aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
author(no author) <(no author)@138bc75d-0d04-0410-961f-82ee72b054a4>2004-04-20 22:59:34 +0000
committer(no author) <(no author)@138bc75d-0d04-0410-961f-82ee72b054a4>2004-04-20 22:59:34 +0000
commit627d7bdfdca723de0f8e7c20c825d395f03cfe53 (patch)
treeba73e617e78f6f848a0e78ae80ff58e81186399a
parent86248a4b2696dd0f45ceabfd239e870ba0d36c89 (diff)
This commit was manufactured by cvs2svn to create tagapple/gcc-1741
'apple-gcc-1741'. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/tags/apple-gcc-1741@80931 138bc75d-0d04-0410-961f-82ee72b054a4
-rw-r--r--CHANGES.Apple265
-rw-r--r--GNUmakefile88
-rw-r--r--README.Apple463
-rw-r--r--boehm-gc/alpha_mach_dep.S87
-rw-r--r--boehm-gc/sparc_mach_dep.S67
-rwxr-xr-xbuild_gcc338
-rw-r--r--gcc/ChangeLog.apple-ppc331
-rw-r--r--gcc/Makefile.in114
-rw-r--r--gcc/ada/5qsystem.ads236
-rw-r--r--gcc/ada/5xcrtl.ads159
-rw-r--r--gcc/ada/5zstchop.adb255
-rw-r--r--gcc/ada/Makefile.in21
-rw-r--r--gcc/ada/config-lang.in47
-rw-r--r--gcc/ada/s-stchop.adb273
-rw-r--r--gcc/ada/s-stchop.ads74
-rw-r--r--gcc/alias.c85
-rw-r--r--gcc/basic-block.h21
-rw-r--r--gcc/bb-reorder.c1023
-rw-r--r--gcc/builtin-types.def7
-rw-r--r--gcc/builtins.c34
-rw-r--r--gcc/builtins.def6
-rw-r--r--gcc/c-common.c509
-rw-r--r--gcc/c-common.h131
-rw-r--r--gcc/c-convert.c12
-rw-r--r--gcc/c-cppbuiltin.c26
-rw-r--r--gcc/c-decl.c722
-rw-r--r--gcc/c-dmp-tree.c520
-rw-r--r--gcc/c-idebug.c57
-rw-r--r--gcc/c-lang.c22
-rw-r--r--gcc/c-lex.c126
-rw-r--r--gcc/c-objc-common.c15
-rw-r--r--gcc/c-opts.c202
-rw-r--r--gcc/c-parse.in12
-rw-r--r--gcc/c-pch.c34
-rw-r--r--gcc/c-pragma.c18
-rw-r--r--gcc/c-pragma.h4
-rw-r--r--gcc/c-tree.h19
-rw-r--r--gcc/c-typeck.c201
-rw-r--r--gcc/c.opt103
-rw-r--r--gcc/calls.c99
-rw-r--r--gcc/cfgbuild.c8
-rw-r--r--gcc/cfgcleanup.c80
-rw-r--r--gcc/cfghooks.c5
-rw-r--r--gcc/cfglayout.c72
-rw-r--r--gcc/cfglayout.h3
-rw-r--r--gcc/cfgloop.h2
-rw-r--r--gcc/cfgloopanal.c17
-rw-r--r--gcc/cfgrtl.c137
-rw-r--r--gcc/cgraphunit.c2
-rw-r--r--gcc/combine.c54
-rw-r--r--gcc/common.opt70
-rw-r--r--gcc/config.in3
-rw-r--r--gcc/config/darwin-c.c225
-rw-r--r--gcc/config/darwin-protos.h35
-rw-r--r--gcc/config/darwin.c475
-rw-r--r--gcc/config/darwin.h340
-rw-r--r--gcc/config/h8300/t-rtems7
-rw-r--r--gcc/config/host-linux.c137
-rw-r--r--gcc/config/host-solaris.c79
-rw-r--r--gcc/config/i386/darwin.h55
-rw-r--r--gcc/config/i386/i386.c70
-rw-r--r--gcc/config/i386/i386.h14
-rw-r--r--gcc/config/i386/t-djgpp2
-rw-r--r--gcc/config/ia64/t-hpux43
-rw-r--r--gcc/config/mips/t-mips21
-rw-r--r--gcc/config/rs6000/altivec.h26
-rw-r--r--gcc/config/rs6000/builtin.ops297
-rw-r--r--gcc/config/rs6000/darwin-fpsave.asm69
-rw-r--r--gcc/config/rs6000/darwin-vecsave.asm133
-rw-r--r--gcc/config/rs6000/darwin-worldsave.asm233
-rw-r--r--gcc/config/rs6000/darwin.h124
-rwxr-xr-xgcc/config/rs6000/ops-to-gp620
-rw-r--r--gcc/config/rs6000/rs6000-c.c119
-rw-r--r--gcc/config/rs6000/rs6000-protos.h13
-rw-r--r--gcc/config/rs6000/rs6000.c928
-rw-r--r--gcc/config/rs6000/rs6000.h60
-rw-r--r--gcc/config/rs6000/rs6000.md263
-rw-r--r--gcc/config/rs6000/sysv4.h7
-rw-r--r--gcc/config/rs6000/t-darwin8
-rw-r--r--gcc/config/rs6000/t-rs60001
-rw-r--r--gcc/config/rs6000/t-rtems86
-rw-r--r--gcc/config/rs6000/vec.h4515
-rw-r--r--gcc/config/rs6000/vec.ops1025
-rw-r--r--gcc/config/t-darwin2
-rw-r--r--gcc/config/t-slibgcc-darwin3
-rw-r--r--gcc/config/x-linux4
-rw-r--r--gcc/config/x-solaris4
-rwxr-xr-xgcc/configure146
-rw-r--r--gcc/configure.ac3
-rw-r--r--gcc/coretypes.h2
-rw-r--r--gcc/cp/ChangeLog.apple-ppc5
-rw-r--r--gcc/cp/Make-lang.in38
-rw-r--r--gcc/cp/call.c73
-rw-r--r--gcc/cp/class.c205
-rw-r--r--gcc/cp/cp-dmp-tree.c1326
-rw-r--r--gcc/cp/cp-idebug.c463
-rw-r--r--gcc/cp/cp-lang.c63
-rw-r--r--gcc/cp/cp-root.h4
-rw-r--r--gcc/cp/cp-tree.h55
-rw-r--r--gcc/cp/decl.c234
-rw-r--r--gcc/cp/decl2.c102
-rw-r--r--gcc/cp/g++spec.c11
-rw-r--r--gcc/cp/init.c10
-rw-r--r--gcc/cp/lang-specs.h5
-rw-r--r--gcc/cp/lex.c62
-rw-r--r--gcc/cp/lex.h15
-rw-r--r--gcc/cp/mangle.c29
-rw-r--r--gcc/cp/method.c8
-rw-r--r--gcc/cp/optimize.c194
-rw-r--r--gcc/cp/pt.c6
-rw-r--r--gcc/cp/rtti.c9
-rw-r--r--gcc/cp/tree.c12
-rw-r--r--gcc/cp/typeck.c283
-rw-r--r--gcc/cp/typeck2.c10
-rw-r--r--gcc/cppcharset.c5
-rw-r--r--gcc/cpperror.c27
-rw-r--r--gcc/cpphash.h32
-rw-r--r--gcc/cppinit.c25
-rw-r--r--gcc/cpplib.c92
-rw-r--r--gcc/cpplib.h109
-rw-r--r--gcc/cpppch.c59
-rw-r--r--gcc/cse.c73
-rw-r--r--gcc/dbxout.c149
-rw-r--r--gcc/debug.c3
-rw-r--r--gcc/debug.h7
-rw-r--r--gcc/defaults.h11
-rw-r--r--gcc/diagnostic.c29
-rw-r--r--gcc/dmp-tree.c3695
-rw-r--r--gcc/dmp-tree.h116
-rw-r--r--gcc/doc/cppopts.texi14
-rw-r--r--gcc/doc/extend.texi72
-rw-r--r--gcc/doc/gcc.texi4
-rw-r--r--gcc/doc/include/sourcecode.texi35
-rw-r--r--gcc/doc/invoke.texi608
-rw-r--r--gcc/doc/rtl.texi10
-rw-r--r--gcc/doc/tm.texi31
-rw-r--r--gcc/doloop.c887
-rw-r--r--gcc/dwarf2out.c159
-rw-r--r--gcc/expmed.c11
-rw-r--r--gcc/expr.c9
-rw-r--r--gcc/f/Make-lang.in4
-rw-r--r--gcc/f/com.c31
-rw-r--r--gcc/final.c79
-rw-r--r--gcc/flags.h72
-rw-r--r--gcc/fold-const.c44
-rw-r--r--gcc/function.c19
-rw-r--r--gcc/function.h3
-rw-r--r--gcc/gcc.c1073
-rw-r--r--gcc/gcc.h6
-rw-r--r--gcc/gcse.c71
-rw-r--r--gcc/gengtype.c38
-rw-r--r--gcc/ginclude/stdarg.h7
-rw-r--r--gcc/ginclude/varargs.h8
-rw-r--r--gcc/global.c64
-rw-r--r--gcc/hooks.c16
-rw-r--r--gcc/hooks.h4
-rw-r--r--gcc/idebug.c639
-rw-r--r--gcc/ifcvt.c34
-rw-r--r--gcc/java/Make-lang.in4
-rw-r--r--gcc/java/lang.c31
-rw-r--r--gcc/langhooks-def.h26
-rw-r--r--gcc/langhooks.c33
-rw-r--r--gcc/langhooks.h17
-rw-r--r--gcc/libgcc2.c8
-rw-r--r--gcc/loop-doloop.c552
-rw-r--r--gcc/loop-iv.c4
-rw-r--r--gcc/loop.c99
-rw-r--r--gcc/loop.h5
-rw-r--r--gcc/mkinstalldirs0
-rwxr-xr-xgcc/move-if-change0
-rw-r--r--gcc/objc/Make-lang.in32
-rw-r--r--gcc/objc/config-lang.in6
-rw-r--r--gcc/objc/objc-act.c136
-rw-r--r--gcc/objc/objc-act.h3
-rw-r--r--gcc/objc/objc-dmp-tree.c285
-rw-r--r--gcc/objc/objc-idebug.c72
-rw-r--r--gcc/objc/objc-lang.c4
-rw-r--r--gcc/objc/objc-root.h4
-rw-r--r--gcc/objcp/.cvsignore4
-rw-r--r--gcc/objcp/Make-lang.in222
-rw-r--r--gcc/objcp/config-lang.in43
-rw-r--r--gcc/objcp/lang-specs.h59
-rw-r--r--gcc/objcp/objcp-decl.c306
-rw-r--r--gcc/objcp/objcp-decl.h100
-rw-r--r--gcc/objcp/objcp-root.h4
-rw-r--r--gcc/opts.c635
-rw-r--r--gcc/output.h14
-rw-r--r--gcc/params.def16
-rw-r--r--gcc/passes.c44
-rw-r--r--gcc/predict.c8
-rw-r--r--gcc/print-rtl.c10
-rw-r--r--gcc/print-tree.c8
-rw-r--r--gcc/ra-build.c6
-rw-r--r--gcc/regrename.c17
-rw-r--r--gcc/reload.c36
-rw-r--r--gcc/rtl.c6
-rw-r--r--gcc/rtl.h24
-rw-r--r--gcc/sched-rgn.c23
-rw-r--r--gcc/simplify-rtx.c6
-rw-r--r--gcc/stor-layout.c81
-rw-r--r--gcc/stringpool.c1
-rw-r--r--gcc/target-def.h11
-rw-r--r--gcc/target.h19
-rw-r--r--gcc/testsuite/UNTESTABLE57
-rw-r--r--gcc/testsuite/ada/acats/support/f340a000.a149
-rw-r--r--gcc/testsuite/ada/acats/support/f340a001.a75
-rw-r--r--gcc/testsuite/ada/acats/support/f341a00.a216
-rw-r--r--gcc/testsuite/ada/acats/support/f390a00.a94
-rw-r--r--gcc/testsuite/ada/acats/support/f392a00.a200
-rw-r--r--gcc/testsuite/ada/acats/support/f392c00.a267
-rw-r--r--gcc/testsuite/ada/acats/support/f392d00.a103
-rw-r--r--gcc/testsuite/ada/acats/support/f393a00.a245
-rw-r--r--gcc/testsuite/ada/acats/support/f393b00.a101
-rw-r--r--gcc/testsuite/ada/acats/support/f3a2a00.a81
-rw-r--r--gcc/testsuite/ada/acats/support/f460a00.a90
-rw-r--r--gcc/testsuite/ada/acats/support/f730a000.a107
-rw-r--r--gcc/testsuite/ada/acats/support/f730a001.a76
-rw-r--r--gcc/testsuite/ada/acats/support/f731a00.a66
-rw-r--r--gcc/testsuite/ada/acats/support/f940a00.a97
-rw-r--r--gcc/testsuite/ada/acats/support/f954a00.a134
-rw-r--r--gcc/testsuite/ada/acats/support/fa11a00.a73
-rw-r--r--gcc/testsuite/ada/acats/support/fa11b00.a110
-rw-r--r--gcc/testsuite/ada/acats/support/fa11c00.a112
-rw-r--r--gcc/testsuite/ada/acats/support/fa11d00.a78
-rw-r--r--gcc/testsuite/ada/acats/support/fa13a00.a171
-rw-r--r--gcc/testsuite/ada/acats/support/fa13b00.a106
-rw-r--r--gcc/testsuite/ada/acats/support/fa21a00.a127
-rw-r--r--gcc/testsuite/ada/acats/support/fb20a00.a101
-rw-r--r--gcc/testsuite/ada/acats/support/fb40a00.a81
-rw-r--r--gcc/testsuite/ada/acats/support/fc50a00.a92
-rw-r--r--gcc/testsuite/ada/acats/support/fc51a00.a99
-rw-r--r--gcc/testsuite/ada/acats/support/fc51b00.a62
-rw-r--r--gcc/testsuite/ada/acats/support/fc51c00.a112
-rw-r--r--gcc/testsuite/ada/acats/support/fc51d00.a82
-rw-r--r--gcc/testsuite/ada/acats/support/fc54a00.a132
-rw-r--r--gcc/testsuite/ada/acats/support/fc70a00.a117
-rw-r--r--gcc/testsuite/ada/acats/support/fc70b00.a133
-rw-r--r--gcc/testsuite/ada/acats/support/fc70c00.a100
-rw-r--r--gcc/testsuite/ada/acats/support/fd72a00.a84
-rw-r--r--gcc/testsuite/ada/acats/support/fdb0a00.a144
-rw-r--r--gcc/testsuite/ada/acats/support/fdd2a00.a149
-rw-r--r--gcc/testsuite/ada/acats/support/fxa5a00.a121
-rw-r--r--gcc/testsuite/ada/acats/support/fxaca00.a144
-rw-r--r--gcc/testsuite/ada/acats/support/fxacb00.a107
-rw-r--r--gcc/testsuite/ada/acats/support/fxacc00.a115
-rw-r--r--gcc/testsuite/ada/acats/support/fxc6a00.a162
-rw-r--r--gcc/testsuite/ada/acats/support/fxe2a00.a90
-rw-r--r--gcc/testsuite/ada/acats/support/fxf2a00.a96
-rw-r--r--gcc/testsuite/ada/acats/support/fxf3a00.a330
-rw-r--r--gcc/testsuite/ada/acats/support/impdef.a371
-rw-r--r--gcc/testsuite/ada/acats/support/impdefd.a69
-rw-r--r--gcc/testsuite/ada/acats/support/impdefe.a58
-rw-r--r--gcc/testsuite/ada/acats/support/impdefg.a83
-rw-r--r--gcc/testsuite/ada/acats/support/impdefh.a102
-rw-r--r--gcc/testsuite/ada/acats/support/widechr.a294
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c330001.a354
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c330002.a326
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c332001.a226
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c340001.a470
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c340a01.a165
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c340a02.a221
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c341a01.a117
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c341a02.a145
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c341a03.a140
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c341a04.a141
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c352001.a270
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c354002.a335
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c354003.a211
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c360002.a268
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c371001.a388
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c371002.a364
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c371003.a474
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c380001.a128
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c380002.a72
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c380003.a223
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c380004.a385
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c3900010.a147
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c390002.a165
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c390003.a419
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c390004.a404
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c3900050.a157
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c3900051.a137
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c3900052.a138
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c3900060.a159
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c3900061.a138
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c3900062.a137
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c390007.a374
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c390010.a216
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c390011.a250
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c390a010.a127
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c390a020.a90
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c390a021.a133
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c390a030.a188
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c391001.a329
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c391002.a493
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c392002.a349
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c392003.a453
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c392004.a189
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c392005.a367
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c392008.a401
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c392010.a512
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c392011.a299
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c392013.a179
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c392014.a225
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c392a01.a265
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c392c05.a164
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c392c07.a190
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c392d01.a324
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c392d02.a185
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c392d03.a248
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c393001.a407
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c393007.a157
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c393008.a204
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c393009.a170
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c393010.a306
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c393011.a220
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c393012.a221
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c393a02.a213
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c393a03.a242
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c393a05.a166
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c393a06.a201
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c393b12.a131
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c393b13.a105
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c393b14.a147
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c3a0001.a138
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c3a0002.a142
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c3a0003.a144
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c3a0004.a115
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c3a0005.a147
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c3a0006.a163
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c3a0007.a234
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c3a0008.a150
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c3a0009.a219
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c3a0010.a158
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c3a0011.a186
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c3a00120.a83
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c3a00121.a76
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c3a0013.a347
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c3a0014.a453
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c3a0015.a267
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c3a1001.a315
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c3a1002.a251
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c3a2001.a460
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c3a2002.a295
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c3a2003.a329
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c3a2a01.a367
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c3a2a02.a396
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c410001.a303
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c420001.a110
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c431001.a464
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c432001.a512
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c432002.a764
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c432003.a594
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c432004.a319
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c433001.a302
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c450001.a434
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c452001.a707
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c455001.a164
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c460001.a300
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c460002.a330
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c460004.a335
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c460005.a260
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c460006.a378
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c460007.a239
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c460008.a286
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c460009.a467
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c460010.a354
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c460011.a210
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c460012.a93
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c460a01.a408
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c460a02.a413
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c490001.a215
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c490002.a239
-rw-r--r--gcc/testsuite/ada/acats/tests/c4/c490003.a215
-rw-r--r--gcc/testsuite/ada/acats/tests/c5/c540001.a410
-rw-r--r--gcc/testsuite/ada/acats/tests/c6/c631001.a134
-rw-r--r--gcc/testsuite/ada/acats/tests/c6/c640001.a334
-rw-r--r--gcc/testsuite/ada/acats/tests/c6/c641001.a281
-rw-r--r--gcc/testsuite/ada/acats/tests/c6/c650001.a412
-rw-r--r--gcc/testsuite/ada/acats/tests/c7/c730001.a437
-rw-r--r--gcc/testsuite/ada/acats/tests/c7/c730002.a383
-rw-r--r--gcc/testsuite/ada/acats/tests/c7/c730003.a283
-rw-r--r--gcc/testsuite/ada/acats/tests/c7/c730004.a327
-rw-r--r--gcc/testsuite/ada/acats/tests/c7/c730a01.a176
-rw-r--r--gcc/testsuite/ada/acats/tests/c7/c730a02.a252
-rw-r--r--gcc/testsuite/ada/acats/tests/c7/c731001.a407
-rw-r--r--gcc/testsuite/ada/acats/tests/c7/c760001.a390
-rw-r--r--gcc/testsuite/ada/acats/tests/c7/c760002.a489
-rw-r--r--gcc/testsuite/ada/acats/tests/c7/c760007.a247
-rw-r--r--gcc/testsuite/ada/acats/tests/c7/c760009.a533
-rw-r--r--gcc/testsuite/ada/acats/tests/c7/c760010.a418
-rw-r--r--gcc/testsuite/ada/acats/tests/c7/c760011.a291
-rw-r--r--gcc/testsuite/ada/acats/tests/c7/c760012.a256
-rw-r--r--gcc/testsuite/ada/acats/tests/c7/c760013.a108
-rw-r--r--gcc/testsuite/ada/acats/tests/c7/c761001.a117
-rw-r--r--gcc/testsuite/ada/acats/tests/c7/c761002.a245
-rw-r--r--gcc/testsuite/ada/acats/tests/c7/c761003.a447
-rw-r--r--gcc/testsuite/ada/acats/tests/c7/c761004.a305
-rw-r--r--gcc/testsuite/ada/acats/tests/c7/c761005.a288
-rw-r--r--gcc/testsuite/ada/acats/tests/c7/c761006.a425
-rw-r--r--gcc/testsuite/ada/acats/tests/c7/c761007.a419
-rw-r--r--gcc/testsuite/ada/acats/tests/c7/c761010.a447
-rw-r--r--gcc/testsuite/ada/acats/tests/c7/c761011.a410
-rw-r--r--gcc/testsuite/ada/acats/tests/c7/c761012.a151
-rw-r--r--gcc/testsuite/ada/acats/tests/c8/c840001.a257
-rw-r--r--gcc/testsuite/ada/acats/tests/c8/c854001.a277
-rw-r--r--gcc/testsuite/ada/acats/tests/c8/c854002.a185
-rw-r--r--gcc/testsuite/ada/acats/tests/c8/c854003.a64
-rw-r--r--gcc/testsuite/ada/acats/tests/c9/c910001.a224
-rw-r--r--gcc/testsuite/ada/acats/tests/c9/c910002.a143
-rw-r--r--gcc/testsuite/ada/acats/tests/c9/c910003.a185
-rw-r--r--gcc/testsuite/ada/acats/tests/c9/c930001.a153
-rw-r--r--gcc/testsuite/ada/acats/tests/c9/c940001.a212
-rw-r--r--gcc/testsuite/ada/acats/tests/c9/c940002.a309
-rw-r--r--gcc/testsuite/ada/acats/tests/c9/c940004.a416
-rw-r--r--gcc/testsuite/ada/acats/tests/c9/c940005.a370
-rw-r--r--gcc/testsuite/ada/acats/tests/c9/c940006.a223
-rw-r--r--gcc/testsuite/ada/acats/tests/c9/c940007.a427
-rw-r--r--gcc/testsuite/ada/acats/tests/c9/c940010.a269
-rw-r--r--gcc/testsuite/ada/acats/tests/c9/c940011.a175
-rw-r--r--gcc/testsuite/ada/acats/tests/c9/c940012.a174
-rw-r--r--gcc/testsuite/ada/acats/tests/c9/c940013.a379
-rw-r--r--gcc/testsuite/ada/acats/tests/c9/c940014.a177
-rw-r--r--gcc/testsuite/ada/acats/tests/c9/c940015.a149
-rw-r--r--gcc/testsuite/ada/acats/tests/c9/c940016.a211
-rw-r--r--gcc/testsuite/ada/acats/tests/c9/c940a03.a350
-rw-r--r--gcc/testsuite/ada/acats/tests/c9/c951001.a192
-rw-r--r--gcc/testsuite/ada/acats/tests/c9/c951002.a334
-rw-r--r--gcc/testsuite/ada/acats/tests/c9/c953001.a188
-rw-r--r--gcc/testsuite/ada/acats/tests/c9/c953002.a242
-rw-r--r--gcc/testsuite/ada/acats/tests/c9/c953003.a189
-rw-r--r--gcc/testsuite/ada/acats/tests/c9/c954001.a273
-rw-r--r--gcc/testsuite/ada/acats/tests/c9/c954010.a286
-rw-r--r--gcc/testsuite/ada/acats/tests/c9/c954011.a384
-rw-r--r--gcc/testsuite/ada/acats/tests/c9/c954012.a496
-rw-r--r--gcc/testsuite/ada/acats/tests/c9/c954013.a521
-rw-r--r--gcc/testsuite/ada/acats/tests/c9/c954014.a485
-rw-r--r--gcc/testsuite/ada/acats/tests/c9/c954015.a549
-rw-r--r--gcc/testsuite/ada/acats/tests/c9/c954016.a182
-rw-r--r--gcc/testsuite/ada/acats/tests/c9/c954017.a184
-rw-r--r--gcc/testsuite/ada/acats/tests/c9/c954018.a227
-rw-r--r--gcc/testsuite/ada/acats/tests/c9/c954019.a314
-rw-r--r--gcc/testsuite/ada/acats/tests/c9/c954020.a422
-rw-r--r--gcc/testsuite/ada/acats/tests/c9/c954021.a524
-rw-r--r--gcc/testsuite/ada/acats/tests/c9/c954022.a351
-rw-r--r--gcc/testsuite/ada/acats/tests/c9/c954023.a558
-rw-r--r--gcc/testsuite/ada/acats/tests/c9/c954024.a380
-rw-r--r--gcc/testsuite/ada/acats/tests/c9/c954025.a237
-rw-r--r--gcc/testsuite/ada/acats/tests/c9/c954026.a269
-rw-r--r--gcc/testsuite/ada/acats/tests/c9/c954a01.a262
-rw-r--r--gcc/testsuite/ada/acats/tests/c9/c954a02.a259
-rw-r--r--gcc/testsuite/ada/acats/tests/c9/c954a03.a322
-rw-r--r--gcc/testsuite/ada/acats/tests/c9/c960001.a164
-rw-r--r--gcc/testsuite/ada/acats/tests/c9/c960002.a171
-rw-r--r--gcc/testsuite/ada/acats/tests/c9/c960004.a206
-rw-r--r--gcc/testsuite/ada/acats/tests/c9/c974001.a152
-rw-r--r--gcc/testsuite/ada/acats/tests/c9/c974002.a209
-rw-r--r--gcc/testsuite/ada/acats/tests/c9/c974003.a249
-rw-r--r--gcc/testsuite/ada/acats/tests/c9/c974004.a273
-rw-r--r--gcc/testsuite/ada/acats/tests/c9/c974005.a259
-rw-r--r--gcc/testsuite/ada/acats/tests/c9/c974006.a197
-rw-r--r--gcc/testsuite/ada/acats/tests/c9/c974007.a205
-rw-r--r--gcc/testsuite/ada/acats/tests/c9/c974008.a229
-rw-r--r--gcc/testsuite/ada/acats/tests/c9/c974009.a206
-rw-r--r--gcc/testsuite/ada/acats/tests/c9/c974010.a209
-rw-r--r--gcc/testsuite/ada/acats/tests/c9/c974011.a275
-rw-r--r--gcc/testsuite/ada/acats/tests/c9/c974012.a165
-rw-r--r--gcc/testsuite/ada/acats/tests/c9/c974013.a167
-rw-r--r--gcc/testsuite/ada/acats/tests/c9/c974014.a132
-rw-r--r--gcc/testsuite/ada/acats/tests/c9/c980001.a303
-rw-r--r--gcc/testsuite/ada/acats/tests/c9/c980002.a165
-rw-r--r--gcc/testsuite/ada/acats/tests/c9/c980003.a294
-rw-r--r--gcc/testsuite/ada/acats/tests/ca/ca11001.a276
-rw-r--r--gcc/testsuite/ada/acats/tests/ca/ca11002.a238
-rw-r--r--gcc/testsuite/ada/acats/tests/ca/ca11003.a290
-rw-r--r--gcc/testsuite/ada/acats/tests/ca/ca110040.a90
-rw-r--r--gcc/testsuite/ada/acats/tests/ca/ca110041.a118
-rw-r--r--gcc/testsuite/ada/acats/tests/ca/ca110050.a99
-rw-r--r--gcc/testsuite/ada/acats/tests/ca/ca11006.a211
-rw-r--r--gcc/testsuite/ada/acats/tests/ca/ca11007.a228
-rw-r--r--gcc/testsuite/ada/acats/tests/ca/ca11008.a216
-rw-r--r--gcc/testsuite/ada/acats/tests/ca/ca11009.a246
-rw-r--r--gcc/testsuite/ada/acats/tests/ca/ca11010.a254
-rw-r--r--gcc/testsuite/ada/acats/tests/ca/ca11011.a271
-rw-r--r--gcc/testsuite/ada/acats/tests/ca/ca11012.a259
-rw-r--r--gcc/testsuite/ada/acats/tests/ca/ca11013.a201
-rw-r--r--gcc/testsuite/ada/acats/tests/ca/ca11014.a302
-rw-r--r--gcc/testsuite/ada/acats/tests/ca/ca11015.a312
-rw-r--r--gcc/testsuite/ada/acats/tests/ca/ca11016.a321
-rw-r--r--gcc/testsuite/ada/acats/tests/ca/ca11017.a246
-rw-r--r--gcc/testsuite/ada/acats/tests/ca/ca11018.a366
-rw-r--r--gcc/testsuite/ada/acats/tests/ca/ca11019.a306
-rw-r--r--gcc/testsuite/ada/acats/tests/ca/ca11020.a238
-rw-r--r--gcc/testsuite/ada/acats/tests/ca/ca11021.a245
-rw-r--r--gcc/testsuite/ada/acats/tests/ca/ca11022.a242
-rw-r--r--gcc/testsuite/ada/acats/tests/ca/ca11a01.a228
-rw-r--r--gcc/testsuite/ada/acats/tests/ca/ca11a02.a156
-rw-r--r--gcc/testsuite/ada/acats/tests/ca/ca11b01.a208
-rw-r--r--gcc/testsuite/ada/acats/tests/ca/ca11b02.a169
-rw-r--r--gcc/testsuite/ada/acats/tests/ca/ca11c01.a170
-rw-r--r--gcc/testsuite/ada/acats/tests/ca/ca11c02.a158
-rw-r--r--gcc/testsuite/ada/acats/tests/ca/ca11c03.a186
-rw-r--r--gcc/testsuite/ada/acats/tests/ca/ca11d010.a119
-rw-r--r--gcc/testsuite/ada/acats/tests/ca/ca11d011.a79
-rw-r--r--gcc/testsuite/ada/acats/tests/ca/ca11d012.a73
-rw-r--r--gcc/testsuite/ada/acats/tests/ca/ca11d02.a393
-rw-r--r--gcc/testsuite/ada/acats/tests/ca/ca11d03.a174
-rw-r--r--gcc/testsuite/ada/acats/tests/ca/ca13001.a370
-rw-r--r--gcc/testsuite/ada/acats/tests/ca/ca13002.a259
-rw-r--r--gcc/testsuite/ada/acats/tests/ca/ca13003.a256
-rw-r--r--gcc/testsuite/ada/acats/tests/ca/ca13a01.a320
-rw-r--r--gcc/testsuite/ada/acats/tests/ca/ca13a02.a301
-rw-r--r--gcc/testsuite/ada/acats/tests/ca/ca140230.a62
-rw-r--r--gcc/testsuite/ada/acats/tests/ca/ca140231.a59
-rw-r--r--gcc/testsuite/ada/acats/tests/ca/ca140233.a68
-rw-r--r--gcc/testsuite/ada/acats/tests/ca/ca140280.a77
-rw-r--r--gcc/testsuite/ada/acats/tests/ca/ca140281.a67
-rw-r--r--gcc/testsuite/ada/acats/tests/ca/ca140282.a64
-rw-r--r--gcc/testsuite/ada/acats/tests/ca/ca15003.a161
-rw-r--r--gcc/testsuite/ada/acats/tests/ca/ca200020.a70
-rw-r--r--gcc/testsuite/ada/acats/tests/ca/ca200021.a66
-rw-r--r--gcc/testsuite/ada/acats/tests/ca/ca21001.a152
-rw-r--r--gcc/testsuite/ada/acats/tests/cb/cb10002.a128
-rw-r--r--gcc/testsuite/ada/acats/tests/cb/cb20001.a228
-rw-r--r--gcc/testsuite/ada/acats/tests/cb/cb20003.a286
-rw-r--r--gcc/testsuite/ada/acats/tests/cb/cb20004.a203
-rw-r--r--gcc/testsuite/ada/acats/tests/cb/cb20005.a210
-rw-r--r--gcc/testsuite/ada/acats/tests/cb/cb20006.a217
-rw-r--r--gcc/testsuite/ada/acats/tests/cb/cb20007.a196
-rw-r--r--gcc/testsuite/ada/acats/tests/cb/cb20a02.a155
-rw-r--r--gcc/testsuite/ada/acats/tests/cb/cb40005.a339
-rw-r--r--gcc/testsuite/ada/acats/tests/cb/cb40a01.a135
-rw-r--r--gcc/testsuite/ada/acats/tests/cb/cb40a020.a95
-rw-r--r--gcc/testsuite/ada/acats/tests/cb/cb40a030.a105
-rw-r--r--gcc/testsuite/ada/acats/tests/cb/cb40a04.a119
-rw-r--r--gcc/testsuite/ada/acats/tests/cb/cb41001.a213
-rw-r--r--gcc/testsuite/ada/acats/tests/cb/cb41002.a283
-rw-r--r--gcc/testsuite/ada/acats/tests/cb/cb41003.a358
-rw-r--r--gcc/testsuite/ada/acats/tests/cb/cb41004.a316
-rw-r--r--gcc/testsuite/ada/acats/tests/cc/cc30001.a219
-rw-r--r--gcc/testsuite/ada/acats/tests/cc/cc30002.a349
-rw-r--r--gcc/testsuite/ada/acats/tests/cc/cc40001.a403
-rw-r--r--gcc/testsuite/ada/acats/tests/cc/cc50001.a257
-rw-r--r--gcc/testsuite/ada/acats/tests/cc/cc50a01.a313
-rw-r--r--gcc/testsuite/ada/acats/tests/cc/cc50a02.a227
-rw-r--r--gcc/testsuite/ada/acats/tests/cc/cc51001.a186
-rw-r--r--gcc/testsuite/ada/acats/tests/cc/cc51002.a198
-rw-r--r--gcc/testsuite/ada/acats/tests/cc/cc51003.a187
-rw-r--r--gcc/testsuite/ada/acats/tests/cc/cc51004.a181
-rw-r--r--gcc/testsuite/ada/acats/tests/cc/cc51006.a224
-rw-r--r--gcc/testsuite/ada/acats/tests/cc/cc51007.a305
-rw-r--r--gcc/testsuite/ada/acats/tests/cc/cc51008.a124
-rw-r--r--gcc/testsuite/ada/acats/tests/cc/cc51a01.a193
-rw-r--r--gcc/testsuite/ada/acats/tests/cc/cc51b03.a258
-rw-r--r--gcc/testsuite/ada/acats/tests/cc/cc51d01.a262
-rw-r--r--gcc/testsuite/ada/acats/tests/cc/cc51d02.a244
-rw-r--r--gcc/testsuite/ada/acats/tests/cc/cc54001.a184
-rw-r--r--gcc/testsuite/ada/acats/tests/cc/cc54002.a223
-rw-r--r--gcc/testsuite/ada/acats/tests/cc/cc54003.a234
-rw-r--r--gcc/testsuite/ada/acats/tests/cc/cc54004.a295
-rw-r--r--gcc/testsuite/ada/acats/tests/cc/cc70001.a309
-rw-r--r--gcc/testsuite/ada/acats/tests/cc/cc70002.a241
-rw-r--r--gcc/testsuite/ada/acats/tests/cc/cc70003.a212
-rw-r--r--gcc/testsuite/ada/acats/tests/cc/cc70a01.a208
-rw-r--r--gcc/testsuite/ada/acats/tests/cc/cc70a02.a193
-rw-r--r--gcc/testsuite/ada/acats/tests/cc/cc70b01.a170
-rw-r--r--gcc/testsuite/ada/acats/tests/cc/cc70b02.a222
-rw-r--r--gcc/testsuite/ada/acats/tests/cc/cc70c01.a187
-rw-r--r--gcc/testsuite/ada/acats/tests/cc/cc70c02.a192
-rw-r--r--gcc/testsuite/ada/acats/tests/cd/cd10001.a300
-rw-r--r--gcc/testsuite/ada/acats/tests/cd/cd10002.a1198
-rw-r--r--gcc/testsuite/ada/acats/tests/cd/cd20001.a275
-rw-r--r--gcc/testsuite/ada/acats/tests/cd/cd30001.a284
-rw-r--r--gcc/testsuite/ada/acats/tests/cd/cd30002.a207
-rw-r--r--gcc/testsuite/ada/acats/tests/cd/cd30003.a227
-rw-r--r--gcc/testsuite/ada/acats/tests/cd/cd30004.a215
-rw-r--r--gcc/testsuite/ada/acats/tests/cd/cd33001.a139
-rw-r--r--gcc/testsuite/ada/acats/tests/cd/cd33002.a140
-rw-r--r--gcc/testsuite/ada/acats/tests/cd/cd40001.a181
-rw-r--r--gcc/testsuite/ada/acats/tests/cd/cd70001.a201
-rw-r--r--gcc/testsuite/ada/acats/tests/cd/cd72a01.a165
-rw-r--r--gcc/testsuite/ada/acats/tests/cd/cd72a02.a225
-rw-r--r--gcc/testsuite/ada/acats/tests/cd/cd90001.a233
-rw-r--r--gcc/testsuite/ada/acats/tests/cd/cd92001.a229
-rw-r--r--gcc/testsuite/ada/acats/tests/cd/cdb0a01.a305
-rw-r--r--gcc/testsuite/ada/acats/tests/cd/cdb0a02.a329
-rw-r--r--gcc/testsuite/ada/acats/tests/cd/cdd1001.a94
-rw-r--r--gcc/testsuite/ada/acats/tests/cd/cdd2001.a203
-rw-r--r--gcc/testsuite/ada/acats/tests/cd/cdd2a01.a379
-rw-r--r--gcc/testsuite/ada/acats/tests/cd/cdd2a02.a345
-rw-r--r--gcc/testsuite/ada/acats/tests/cd/cdd2a03.a325
-rw-r--r--gcc/testsuite/ada/acats/tests/cd/cde0001.a324
-rw-r--r--gcc/testsuite/ada/acats/tests/cxa/cxa3001.a507
-rw-r--r--gcc/testsuite/ada/acats/tests/cxa/cxa3002.a318
-rw-r--r--gcc/testsuite/ada/acats/tests/cxa/cxa3003.a243
-rw-r--r--gcc/testsuite/ada/acats/tests/cxa/cxa3004.a235
-rw-r--r--gcc/testsuite/ada/acats/tests/cxa/cxa4001.a218
-rw-r--r--gcc/testsuite/ada/acats/tests/cxa/cxa4002.a182
-rw-r--r--gcc/testsuite/ada/acats/tests/cxa/cxa4003.a326
-rw-r--r--gcc/testsuite/ada/acats/tests/cxa/cxa4004.a431
-rw-r--r--gcc/testsuite/ada/acats/tests/cxa/cxa4005.a683
-rw-r--r--gcc/testsuite/ada/acats/tests/cxa/cxa4006.a319
-rw-r--r--gcc/testsuite/ada/acats/tests/cxa/cxa4007.a334
-rw-r--r--gcc/testsuite/ada/acats/tests/cxa/cxa4008.a662
-rw-r--r--gcc/testsuite/ada/acats/tests/cxa/cxa4009.a619
-rw-r--r--gcc/testsuite/ada/acats/tests/cxa/cxa4010.a275
-rw-r--r--gcc/testsuite/ada/acats/tests/cxa/cxa4011.a376
-rw-r--r--gcc/testsuite/ada/acats/tests/cxa/cxa4012.a305
-rw-r--r--gcc/testsuite/ada/acats/tests/cxa/cxa4013.a203
-rw-r--r--gcc/testsuite/ada/acats/tests/cxa/cxa4014.a359
-rw-r--r--gcc/testsuite/ada/acats/tests/cxa/cxa4015.a580
-rw-r--r--gcc/testsuite/ada/acats/tests/cxa/cxa4016.a685
-rw-r--r--gcc/testsuite/ada/acats/tests/cxa/cxa4017.a337
-rw-r--r--gcc/testsuite/ada/acats/tests/cxa/cxa4018.a379
-rw-r--r--gcc/testsuite/ada/acats/tests/cxa/cxa4019.a1027
-rw-r--r--gcc/testsuite/ada/acats/tests/cxa/cxa4020.a688
-rw-r--r--gcc/testsuite/ada/acats/tests/cxa/cxa4021.a311
-rw-r--r--gcc/testsuite/ada/acats/tests/cxa/cxa4022.a531
-rw-r--r--gcc/testsuite/ada/acats/tests/cxa/cxa4023.a585
-rw-r--r--gcc/testsuite/ada/acats/tests/cxa/cxa4024.a350
-rw-r--r--gcc/testsuite/ada/acats/tests/cxa/cxa4025.a376
-rw-r--r--gcc/testsuite/ada/acats/tests/cxa/cxa4026.a526
-rw-r--r--gcc/testsuite/ada/acats/tests/cxa/cxa4027.a342
-rw-r--r--gcc/testsuite/ada/acats/tests/cxa/cxa4028.a331
-rw-r--r--gcc/testsuite/ada/acats/tests/cxa/cxa4029.a333
-rw-r--r--gcc/testsuite/ada/acats/tests/cxa/cxa4030.a414
-rw-r--r--gcc/testsuite/ada/acats/tests/cxa/cxa4031.a291
-rw-r--r--gcc/testsuite/ada/acats/tests/cxa/cxa4032.a457
-rw-r--r--gcc/testsuite/ada/acats/tests/cxa/cxa4033.a405
-rw-r--r--gcc/testsuite/ada/acats/tests/cxa/cxa4034.a281
-rw-r--r--gcc/testsuite/ada/acats/tests/cxa/cxa5011.a471
-rw-r--r--gcc/testsuite/ada/acats/tests/cxa/cxa5012.a536
-rw-r--r--gcc/testsuite/ada/acats/tests/cxa/cxa5015.a342
-rw-r--r--gcc/testsuite/ada/acats/tests/cxa/cxa5a01.a338
-rw-r--r--gcc/testsuite/ada/acats/tests/cxa/cxa5a02.a328
-rw-r--r--gcc/testsuite/ada/acats/tests/cxa/cxa5a03.a426
-rw-r--r--gcc/testsuite/ada/acats/tests/cxa/cxa5a04.a434
-rw-r--r--gcc/testsuite/ada/acats/tests/cxa/cxa5a05.a338
-rw-r--r--gcc/testsuite/ada/acats/tests/cxa/cxa5a06.a334
-rw-r--r--gcc/testsuite/ada/acats/tests/cxa/cxa5a07.a413
-rw-r--r--gcc/testsuite/ada/acats/tests/cxa/cxa5a08.a474
-rw-r--r--gcc/testsuite/ada/acats/tests/cxa/cxa5a09.a400
-rw-r--r--gcc/testsuite/ada/acats/tests/cxa/cxa5a10.a551
-rw-r--r--gcc/testsuite/ada/acats/tests/cxa/cxa8001.a243
-rw-r--r--gcc/testsuite/ada/acats/tests/cxa/cxa8002.a285
-rw-r--r--gcc/testsuite/ada/acats/tests/cxa/cxa8003.a214
-rw-r--r--gcc/testsuite/ada/acats/tests/cxa/cxa9001.a287
-rw-r--r--gcc/testsuite/ada/acats/tests/cxa/cxa9002.a482
-rw-r--r--gcc/testsuite/ada/acats/tests/cxa/cxaa001.a279
-rw-r--r--gcc/testsuite/ada/acats/tests/cxa/cxaa002.a257
-rw-r--r--gcc/testsuite/ada/acats/tests/cxa/cxaa003.a293
-rw-r--r--gcc/testsuite/ada/acats/tests/cxa/cxaa004.a260
-rw-r--r--gcc/testsuite/ada/acats/tests/cxa/cxaa005.a292
-rw-r--r--gcc/testsuite/ada/acats/tests/cxa/cxaa006.a285
-rw-r--r--gcc/testsuite/ada/acats/tests/cxa/cxaa007.a263
-rw-r--r--gcc/testsuite/ada/acats/tests/cxa/cxaa008.a271
-rw-r--r--gcc/testsuite/ada/acats/tests/cxa/cxaa009.a290
-rw-r--r--gcc/testsuite/ada/acats/tests/cxa/cxaa010.a335
-rw-r--r--gcc/testsuite/ada/acats/tests/cxa/cxaa011.a266
-rw-r--r--gcc/testsuite/ada/acats/tests/cxa/cxaa012.a167
-rw-r--r--gcc/testsuite/ada/acats/tests/cxa/cxaa013.a167
-rw-r--r--gcc/testsuite/ada/acats/tests/cxa/cxaa014.a178
-rw-r--r--gcc/testsuite/ada/acats/tests/cxa/cxaa015.a227
-rw-r--r--gcc/testsuite/ada/acats/tests/cxa/cxaa016.a462
-rw-r--r--gcc/testsuite/ada/acats/tests/cxa/cxaa017.a400
-rw-r--r--gcc/testsuite/ada/acats/tests/cxa/cxaa018.a277
-rw-r--r--gcc/testsuite/ada/acats/tests/cxa/cxaa019.a138
-rw-r--r--gcc/testsuite/ada/acats/tests/cxa/cxab001.a272
-rw-r--r--gcc/testsuite/ada/acats/tests/cxa/cxac001.a292
-rw-r--r--gcc/testsuite/ada/acats/tests/cxa/cxac002.a426
-rw-r--r--gcc/testsuite/ada/acats/tests/cxa/cxac003.a376
-rw-r--r--gcc/testsuite/ada/acats/tests/cxa/cxac004.a310
-rw-r--r--gcc/testsuite/ada/acats/tests/cxa/cxac005.a343
-rw-r--r--gcc/testsuite/ada/acats/tests/cxa/cxaca01.a291
-rw-r--r--gcc/testsuite/ada/acats/tests/cxa/cxaca02.a360
-rw-r--r--gcc/testsuite/ada/acats/tests/cxa/cxacb01.a264
-rw-r--r--gcc/testsuite/ada/acats/tests/cxa/cxacb02.a421
-rw-r--r--gcc/testsuite/ada/acats/tests/cxa/cxacc01.a299
-rw-r--r--gcc/testsuite/ada/acats/tests/cxa/cxaf001.a199
-rw-r--r--gcc/testsuite/ada/acats/tests/cxb/cxb2001.a633
-rw-r--r--gcc/testsuite/ada/acats/tests/cxb/cxb2002.a259
-rw-r--r--gcc/testsuite/ada/acats/tests/cxb/cxb2003.a255
-rw-r--r--gcc/testsuite/ada/acats/tests/cxb/cxb3001.a179
-rw-r--r--gcc/testsuite/ada/acats/tests/cxb/cxb3002.a158
-rw-r--r--gcc/testsuite/ada/acats/tests/cxb/cxb3003.a167
-rw-r--r--gcc/testsuite/ada/acats/tests/cxb/cxb3005.a396
-rw-r--r--gcc/testsuite/ada/acats/tests/cxb/cxb3007.a408
-rw-r--r--gcc/testsuite/ada/acats/tests/cxb/cxb3008.a226
-rw-r--r--gcc/testsuite/ada/acats/tests/cxb/cxb3009.a305
-rw-r--r--gcc/testsuite/ada/acats/tests/cxb/cxb3010.a320
-rw-r--r--gcc/testsuite/ada/acats/tests/cxb/cxb3011.a282
-rw-r--r--gcc/testsuite/ada/acats/tests/cxb/cxb3012.a342
-rw-r--r--gcc/testsuite/ada/acats/tests/cxb/cxb3014.a254
-rw-r--r--gcc/testsuite/ada/acats/tests/cxb/cxb3015.a520
-rw-r--r--gcc/testsuite/ada/acats/tests/cxb/cxb3016.a516
-rw-r--r--gcc/testsuite/ada/acats/tests/cxb/cxb4001.a230
-rw-r--r--gcc/testsuite/ada/acats/tests/cxb/cxb4002.a308
-rw-r--r--gcc/testsuite/ada/acats/tests/cxb/cxb4003.a310
-rw-r--r--gcc/testsuite/ada/acats/tests/cxb/cxb4004.a443
-rw-r--r--gcc/testsuite/ada/acats/tests/cxb/cxb4005.a332
-rw-r--r--gcc/testsuite/ada/acats/tests/cxb/cxb4006.a322
-rw-r--r--gcc/testsuite/ada/acats/tests/cxb/cxb4007.a271
-rw-r--r--gcc/testsuite/ada/acats/tests/cxb/cxb4008.a248
-rw-r--r--gcc/testsuite/ada/acats/tests/cxb/cxb5001.a110
-rw-r--r--gcc/testsuite/ada/acats/tests/cxb/cxb5002.a334
-rw-r--r--gcc/testsuite/ada/acats/tests/cxb/cxb5003.a295
-rw-r--r--gcc/testsuite/ada/acats/tests/cxf/cxf1001.a261
-rw-r--r--gcc/testsuite/ada/acats/tests/cxf/cxf2001.a755
-rw-r--r--gcc/testsuite/ada/acats/tests/cxf/cxf2002.a352
-rw-r--r--gcc/testsuite/ada/acats/tests/cxf/cxf2003.a363
-rw-r--r--gcc/testsuite/ada/acats/tests/cxf/cxf2004.a513
-rw-r--r--gcc/testsuite/ada/acats/tests/cxf/cxf2005.a293
-rw-r--r--gcc/testsuite/ada/acats/tests/cxf/cxf2a01.a448
-rw-r--r--gcc/testsuite/ada/acats/tests/cxf/cxf2a02.a354
-rw-r--r--gcc/testsuite/ada/acats/tests/cxf/cxf3001.a192
-rw-r--r--gcc/testsuite/ada/acats/tests/cxf/cxf3002.a231
-rw-r--r--gcc/testsuite/ada/acats/tests/cxf/cxf3003.a292
-rw-r--r--gcc/testsuite/ada/acats/tests/cxf/cxf3004.a257
-rw-r--r--gcc/testsuite/ada/acats/tests/cxf/cxf3a01.a167
-rw-r--r--gcc/testsuite/ada/acats/tests/cxf/cxf3a02.a267
-rw-r--r--gcc/testsuite/ada/acats/tests/cxf/cxf3a03.a429
-rw-r--r--gcc/testsuite/ada/acats/tests/cxf/cxf3a04.a293
-rw-r--r--gcc/testsuite/ada/acats/tests/cxf/cxf3a05.a266
-rw-r--r--gcc/testsuite/ada/acats/tests/cxf/cxf3a06.a302
-rw-r--r--gcc/testsuite/ada/acats/tests/cxf/cxf3a07.a337
-rw-r--r--gcc/testsuite/ada/acats/tests/cxf/cxf3a08.a289
-rw-r--r--gcc/testsuite/ada/acats/tests/cxg/cxg1001.a276
-rw-r--r--gcc/testsuite/ada/acats/tests/cxg/cxg1002.a198
-rw-r--r--gcc/testsuite/ada/acats/tests/cxg/cxg1003.a478
-rw-r--r--gcc/testsuite/ada/acats/tests/cxg/cxg1004.a360
-rw-r--r--gcc/testsuite/ada/acats/tests/cxg/cxg1005.a393
-rw-r--r--gcc/testsuite/ada/acats/tests/cxg/cxg2001.a322
-rw-r--r--gcc/testsuite/ada/acats/tests/cxg/cxg2002.a468
-rw-r--r--gcc/testsuite/ada/acats/tests/cxg/cxg2003.a701
-rw-r--r--gcc/testsuite/ada/acats/tests/cxg/cxg2004.a499
-rw-r--r--gcc/testsuite/ada/acats/tests/cxg/cxg2005.a204
-rw-r--r--gcc/testsuite/ada/acats/tests/cxg/cxg2006.a281
-rw-r--r--gcc/testsuite/ada/acats/tests/cxg/cxg2007.a291
-rw-r--r--gcc/testsuite/ada/acats/tests/cxg/cxg2008.a948
-rw-r--r--gcc/testsuite/ada/acats/tests/cxg/cxg2009.a421
-rw-r--r--gcc/testsuite/ada/acats/tests/cxg/cxg2010.a892
-rw-r--r--gcc/testsuite/ada/acats/tests/cxg/cxg2011.a490
-rw-r--r--gcc/testsuite/ada/acats/tests/cxg/cxg2012.a438
-rw-r--r--gcc/testsuite/ada/acats/tests/cxg/cxg2013.a367
-rw-r--r--gcc/testsuite/ada/acats/tests/cxg/cxg2014.a399
-rw-r--r--gcc/testsuite/ada/acats/tests/cxg/cxg2015.a686
-rw-r--r--gcc/testsuite/ada/acats/tests/cxg/cxg2016.a482
-rw-r--r--gcc/testsuite/ada/acats/tests/cxg/cxg2017.a296
-rw-r--r--gcc/testsuite/ada/acats/tests/cxg/cxg2018.a355
-rw-r--r--gcc/testsuite/ada/acats/tests/cxg/cxg2019.a338
-rw-r--r--gcc/testsuite/ada/acats/tests/cxg/cxg2020.a351
-rw-r--r--gcc/testsuite/ada/acats/tests/cxg/cxg2021.a386
-rw-r--r--gcc/testsuite/ada/acats/tests/cxg/cxg2022.a309
-rw-r--r--gcc/testsuite/ada/acats/tests/cxg/cxg2023.a351
-rw-r--r--gcc/testsuite/ada/acats/tests/cxg/cxg2024.a191
-rw-r--r--gcc/testsuite/ada/acats/tests/cxh/cxh1001.a349
-rw-r--r--gcc/testsuite/ada/acats/tests/cxh/cxh3001.a243
-rw-r--r--gcc/testsuite/ada/acats/tests/cxh/cxh3002.a343
-rw-r--r--gcc/testsuite/ada/acats/tests/cxh/cxh30030.a54
-rw-r--r--gcc/testsuite/ada/acats/tests/l/la140010.a51
-rw-r--r--gcc/testsuite/ada/acats/tests/l/la140012.a55
-rw-r--r--gcc/testsuite/ada/acats/tests/l/la140020.a60
-rw-r--r--gcc/testsuite/ada/acats/tests/l/la140022.a66
-rw-r--r--gcc/testsuite/ada/acats/tests/l/la140030.a57
-rw-r--r--gcc/testsuite/ada/acats/tests/l/la140031.a66
-rw-r--r--gcc/testsuite/ada/acats/tests/l/la140033.a56
-rw-r--r--gcc/testsuite/ada/acats/tests/l/la140040.a52
-rw-r--r--gcc/testsuite/ada/acats/tests/l/la140042.a53
-rw-r--r--gcc/testsuite/ada/acats/tests/l/la140050.a60
-rw-r--r--gcc/testsuite/ada/acats/tests/l/la140051.a56
-rw-r--r--gcc/testsuite/ada/acats/tests/l/la140053.a60
-rw-r--r--gcc/testsuite/ada/acats/tests/l/la140060.a54
-rw-r--r--gcc/testsuite/ada/acats/tests/l/la140061.a66
-rw-r--r--gcc/testsuite/ada/acats/tests/l/la140063.a70
-rw-r--r--gcc/testsuite/ada/acats/tests/l/la140070.a62
-rw-r--r--gcc/testsuite/ada/acats/tests/l/la140071.a72
-rw-r--r--gcc/testsuite/ada/acats/tests/l/la140073.a63
-rw-r--r--gcc/testsuite/ada/acats/tests/l/la140080.a52
-rw-r--r--gcc/testsuite/ada/acats/tests/l/la140081.a63
-rw-r--r--gcc/testsuite/ada/acats/tests/l/la140083.a61
-rw-r--r--gcc/testsuite/ada/acats/tests/l/la140090.a60
-rw-r--r--gcc/testsuite/ada/acats/tests/l/la140091.a60
-rw-r--r--gcc/testsuite/ada/acats/tests/l/la140093.a59
-rw-r--r--gcc/testsuite/ada/acats/tests/l/la140100.a56
-rw-r--r--gcc/testsuite/ada/acats/tests/l/la140101.a89
-rw-r--r--gcc/testsuite/ada/acats/tests/l/la140103.a58
-rw-r--r--gcc/testsuite/ada/acats/tests/l/la140110.a64
-rw-r--r--gcc/testsuite/ada/acats/tests/l/la140111.a62
-rw-r--r--gcc/testsuite/ada/acats/tests/l/la140113.a59
-rw-r--r--gcc/testsuite/ada/acats/tests/l/la140120.a63
-rw-r--r--gcc/testsuite/ada/acats/tests/l/la140121.a64
-rw-r--r--gcc/testsuite/ada/acats/tests/l/la140123.a59
-rw-r--r--gcc/testsuite/ada/acats/tests/l/la140130.a57
-rw-r--r--gcc/testsuite/ada/acats/tests/l/la140131.a58
-rw-r--r--gcc/testsuite/ada/acats/tests/l/la140133.a58
-rw-r--r--gcc/testsuite/ada/acats/tests/l/la140140.a55
-rw-r--r--gcc/testsuite/ada/acats/tests/l/la140141.a57
-rw-r--r--gcc/testsuite/ada/acats/tests/l/la140143.a64
-rw-r--r--gcc/testsuite/ada/acats/tests/l/la140150.a56
-rw-r--r--gcc/testsuite/ada/acats/tests/l/la140151.a65
-rw-r--r--gcc/testsuite/ada/acats/tests/l/la140153.a61
-rw-r--r--gcc/testsuite/ada/acats/tests/l/la140160.a54
-rw-r--r--gcc/testsuite/ada/acats/tests/l/la140161.a63
-rw-r--r--gcc/testsuite/ada/acats/tests/l/la140163.a67
-rw-r--r--gcc/testsuite/ada/acats/tests/l/la140170.a64
-rw-r--r--gcc/testsuite/ada/acats/tests/l/la140171.a69
-rw-r--r--gcc/testsuite/ada/acats/tests/l/la140173.a75
-rw-r--r--gcc/testsuite/ada/acats/tests/l/la140180.a65
-rw-r--r--gcc/testsuite/ada/acats/tests/l/la140181.a54
-rw-r--r--gcc/testsuite/ada/acats/tests/l/la140183.a60
-rw-r--r--gcc/testsuite/ada/acats/tests/l/la140190.a61
-rw-r--r--gcc/testsuite/ada/acats/tests/l/la140191.a74
-rw-r--r--gcc/testsuite/ada/acats/tests/l/la140193.a64
-rw-r--r--gcc/testsuite/ada/acats/tests/l/la140200.a76
-rw-r--r--gcc/testsuite/ada/acats/tests/l/la140201.a71
-rw-r--r--gcc/testsuite/ada/acats/tests/l/la140203.a71
-rw-r--r--gcc/testsuite/ada/acats/tests/l/la140210.a69
-rw-r--r--gcc/testsuite/ada/acats/tests/l/la140212.a74
-rw-r--r--gcc/testsuite/ada/acats/tests/l/la140220.a64
-rw-r--r--gcc/testsuite/ada/acats/tests/l/la140222.a69
-rw-r--r--gcc/testsuite/ada/acats/tests/l/la140240.a61
-rw-r--r--gcc/testsuite/ada/acats/tests/l/la140241.a55
-rw-r--r--gcc/testsuite/ada/acats/tests/l/la140243.a61
-rw-r--r--gcc/testsuite/ada/acats/tests/l/la140250.a56
-rw-r--r--gcc/testsuite/ada/acats/tests/l/la140252.a59
-rw-r--r--gcc/testsuite/ada/acats/tests/l/la140260.a98
-rw-r--r--gcc/testsuite/ada/acats/tests/l/la140261.a52
-rw-r--r--gcc/testsuite/ada/acats/tests/l/la140263.a57
-rw-r--r--gcc/testsuite/ada/acats/tests/l/la140270.a56
-rw-r--r--gcc/testsuite/ada/acats/tests/l/la140271.a93
-rw-r--r--gcc/testsuite/ada/acats/tests/l/la140273.a58
-rw-r--r--gcc/testsuite/g++.dg/abi/layout2.C2
-rw-r--r--gcc/testsuite/g++.dg/align-test-1.C347
-rw-r--r--gcc/testsuite/g++.dg/altivec-1.C12
-rw-r--r--gcc/testsuite/g++.dg/altivec-2.C15
-rw-r--r--gcc/testsuite/g++.dg/altivec-3.C21
-rw-r--r--gcc/testsuite/g++.dg/altivec-4.C129
-rw-r--r--gcc/testsuite/g++.dg/altivec-5.C19
-rw-r--r--gcc/testsuite/g++.dg/apple-altivec-1.C9
-rw-r--r--gcc/testsuite/g++.dg/charset/asm1.c14
-rw-r--r--gcc/testsuite/g++.dg/charset/asm2.c33
-rw-r--r--gcc/testsuite/g++.dg/charset/asm3.c10
-rw-r--r--gcc/testsuite/g++.dg/charset/asm4.c8
-rw-r--r--gcc/testsuite/g++.dg/charset/attribute1.c10
-rw-r--r--gcc/testsuite/g++.dg/charset/attribute2.c8
-rw-r--r--gcc/testsuite/g++.dg/charset/extern1.cc15
-rw-r--r--gcc/testsuite/g++.dg/charset/extern2.cc5
-rw-r--r--gcc/testsuite/g++.dg/charset/string.c5
-rw-r--r--gcc/testsuite/g++.dg/const-cfstring-1.C26
-rw-r--r--gcc/testsuite/g++.dg/debug/debug8.C29
-rw-r--r--gcc/testsuite/g++.dg/eh/spec7.C35
-rw-r--r--gcc/testsuite/g++.dg/expr/align68k-1.C46
-rw-r--r--gcc/testsuite/g++.dg/expr/align68k-2.C38
-rw-r--r--gcc/testsuite/g++.dg/expr/cast-ptr-1.C15
-rw-r--r--gcc/testsuite/g++.dg/expr/fieldref1.C23
-rw-r--r--gcc/testsuite/g++.dg/ext/anon-struct4.C3
-rw-r--r--gcc/testsuite/g++.dg/ext/attrib14.C13
-rw-r--r--gcc/testsuite/g++.dg/init/ctor3.C6
-rw-r--r--gcc/testsuite/g++.dg/init/ref11.C13
-rw-r--r--gcc/testsuite/g++.dg/init/union1.C5
-rw-r--r--gcc/testsuite/g++.dg/kext1.C11
-rw-r--r--gcc/testsuite/g++.dg/kext2.C13
-rw-r--r--gcc/testsuite/g++.dg/kext3.C18
-rw-r--r--gcc/testsuite/g++.dg/lookup/enum1.C5
-rw-r--r--gcc/testsuite/g++.dg/lookup/struct2.C7
-rw-r--r--gcc/testsuite/g++.dg/opt/eh1.C21
-rw-r--r--gcc/testsuite/g++.dg/overload/ref1.C21
-rw-r--r--gcc/testsuite/g++.dg/parse/builtin2.C5
-rw-r--r--gcc/testsuite/g++.dg/parse/crash14.C20
-rw-r--r--gcc/testsuite/g++.dg/parse/non-dependent3.C17
-rw-r--r--gcc/testsuite/g++.dg/parse/template14.C17
-rw-r--r--gcc/testsuite/g++.dg/pascal-strings-1.C44
-rw-r--r--gcc/testsuite/g++.dg/pascal-strings-2.C43
-rw-r--r--gcc/testsuite/g++.dg/preserve-PPC-CR.C41
-rw-r--r--gcc/testsuite/g++.dg/template/spec12.C18
-rw-r--r--gcc/testsuite/g++.dg/warn/Wunused-7.C12
-rw-r--r--gcc/testsuite/g++.old-deja/g++.pt/static3.C2
-rw-r--r--gcc/testsuite/gcc.apple/Wextra-tokens.c21
-rw-r--r--gcc/testsuite/gcc.apple/Wfour-char-constants-1.c12
-rw-r--r--gcc/testsuite/gcc.apple/Wfour-char-constants-2.c12
-rw-r--r--gcc/testsuite/gcc.apple/Wlong-double.c11
-rw-r--r--gcc/testsuite/gcc.apple/Wmost.c19
-rw-r--r--gcc/testsuite/gcc.apple/align-test-1.c605
-rw-r--r--gcc/testsuite/gcc.apple/align-test-2.c152
-rw-r--r--gcc/testsuite/gcc.apple/align-test-3.c123
-rw-r--r--gcc/testsuite/gcc.apple/align-test-4.c224
-rw-r--r--gcc/testsuite/gcc.apple/align-test-4.h43
-rw-r--r--gcc/testsuite/gcc.apple/align-test-5a.c87
-rw-r--r--gcc/testsuite/gcc.apple/align-test-5b.c87
-rw-r--r--gcc/testsuite/gcc.apple/align-test-5c.c87
-rw-r--r--gcc/testsuite/gcc.apple/altivec-1.c124
-rw-r--r--gcc/testsuite/gcc.apple/altivec-2.c9
-rw-r--r--gcc/testsuite/gcc.apple/applecc.c14
-rw-r--r--gcc/testsuite/gcc.apple/const-cfstring-1.c26
-rw-r--r--gcc/testsuite/gcc.apple/const-cfstring-2.c13
-rw-r--r--gcc/testsuite/gcc.apple/dg.exp (renamed from gcc/testsuite/gcc.dg/debug/dwarf2/dwarf2.exp)20
-rw-r--r--gcc/testsuite/gcc.apple/execute/bitfield-1.c52
-rw-r--r--gcc/testsuite/gcc.apple/execute/execute.exp43
-rw-r--r--gcc/testsuite/gcc.apple/framework1.c12
-rw-r--r--gcc/testsuite/gcc.apple/import.c9
-rw-r--r--gcc/testsuite/gcc.apple/importee.h3
-rw-r--r--gcc/testsuite/gcc.apple/inttypes-1.c21
-rw-r--r--gcc/testsuite/gcc.apple/no-warning.c8
-rw-r--r--gcc/testsuite/gcc.apple/one.framework/Headers/one.h3
-rw-r--r--gcc/testsuite/gcc.apple/pascal-strings-1.c46
-rw-r--r--gcc/testsuite/gcc.apple/pascal-strings-2.c45
-rw-r--r--gcc/testsuite/gcc.apple/preprocess.s16
-rw-r--r--gcc/testsuite/gcc.apple/special/liblongcall.c9
-rw-r--r--gcc/testsuite/gcc.apple/special/longcall-prog.c17
-rw-r--r--gcc/testsuite/gcc.apple/special/longcall.exp69
-rw-r--r--gcc/testsuite/gcc.apple/special/special.exp42
-rw-r--r--gcc/testsuite/gcc.apple/special/zerofill.c5
-rw-r--r--gcc/testsuite/gcc.c-torture/compile/simd-4.x4
-rw-r--r--gcc/testsuite/gcc.c-torture/execute/20040308-1.c21
-rw-r--r--gcc/testsuite/gcc.c-torture/execute/20040309-1.c24
-rw-r--r--gcc/testsuite/gcc.c-torture/execute/20040311-1.c68
-rw-r--r--gcc/testsuite/gcc.c-torture/execute/20040313-1.c17
-rw-r--r--gcc/testsuite/gcc.c-torture/execute/simd-1.x7
-rw-r--r--gcc/testsuite/gcc.c-torture/execute/simd-2.x7
-rw-r--r--gcc/testsuite/gcc.dg/20020416-1.c3
-rw-r--r--gcc/testsuite/gcc.dg/20040305-2.c47
-rw-r--r--gcc/testsuite/gcc.dg/20040309-1.c17
-rw-r--r--gcc/testsuite/gcc.dg/20040310-1.c34
-rw-r--r--gcc/testsuite/gcc.dg/20040311-2.c36
-rw-r--r--gcc/testsuite/gcc.dg/alias-2.c16
-rw-r--r--gcc/testsuite/gcc.dg/altivec-2.c2
-rw-r--r--gcc/testsuite/gcc.dg/altivec-4.c2
-rw-r--r--gcc/testsuite/gcc.dg/altivec-5.c2
-rw-r--r--gcc/testsuite/gcc.dg/builtin-inf-1.c2
-rw-r--r--gcc/testsuite/gcc.dg/builtins-34.c66
-rw-r--r--gcc/testsuite/gcc.dg/c90-dupqual-1.c12
-rw-r--r--gcc/testsuite/gcc.dg/c99-complex-1.c4
-rw-r--r--gcc/testsuite/gcc.dg/c99-dupqual-1.c12
-rw-r--r--gcc/testsuite/gcc.dg/cast-ptr-1.c15
-rw-r--r--gcc/testsuite/gcc.dg/charset/asm1.c14
-rw-r--r--gcc/testsuite/gcc.dg/charset/asm3.c33
-rw-r--r--gcc/testsuite/gcc.dg/charset/asm4.c10
-rw-r--r--gcc/testsuite/gcc.dg/charset/asm5.c8
-rw-r--r--gcc/testsuite/gcc.dg/charset/attribute1.c10
-rw-r--r--gcc/testsuite/gcc.dg/charset/attribute2.c8
-rw-r--r--gcc/testsuite/gcc.dg/charset/string.c5
-rw-r--r--gcc/testsuite/gcc.dg/compat/struct-by-value-21_main.c13
-rw-r--r--gcc/testsuite/gcc.dg/compat/struct-by-value-21_x.c168
-rw-r--r--gcc/testsuite/gcc.dg/compat/struct-by-value-21_y.c86
-rw-r--r--gcc/testsuite/gcc.dg/compat/struct-return-21_main.c13
-rw-r--r--gcc/testsuite/gcc.dg/compat/struct-return-21_x.c112
-rw-r--r--gcc/testsuite/gcc.dg/compat/struct-return-21_y.c65
-rw-r--r--gcc/testsuite/gcc.dg/compat/union-by-value-1_main.c13
-rw-r--r--gcc/testsuite/gcc.dg/compat/union-by-value-1_x.c180
-rw-r--r--gcc/testsuite/gcc.dg/compat/union-by-value-1_y.c92
-rw-r--r--gcc/testsuite/gcc.dg/compat/union-check.h34
-rw-r--r--gcc/testsuite/gcc.dg/compat/union-defs.h15
-rw-r--r--gcc/testsuite/gcc.dg/compat/union-init.h34
-rw-r--r--gcc/testsuite/gcc.dg/compat/union-return-1_main.c13
-rw-r--r--gcc/testsuite/gcc.dg/compat/union-return-1_x.c124
-rw-r--r--gcc/testsuite/gcc.dg/compat/union-return-1_y.c71
-rw-r--r--gcc/testsuite/gcc.dg/const-cfstring-2.c13
-rw-r--r--gcc/testsuite/gcc.dg/cpp/c++98-pedantic.cc11
-rw-r--r--gcc/testsuite/gcc.dg/cpp/c++98.cc11
-rw-r--r--gcc/testsuite/gcc.dg/cpp/endif-pedantic2.c4
-rw-r--r--gcc/testsuite/gcc.dg/cpp/extratokens.c3
-rw-r--r--gcc/testsuite/gcc.dg/cpp/if-2.c2
-rw-r--r--gcc/testsuite/gcc.dg/cpp/include2.c6
-rw-r--r--gcc/testsuite/gcc.dg/cpp/skipping2.c3
-rw-r--r--gcc/testsuite/gcc.dg/cpp/sysmac2.c3
-rw-r--r--gcc/testsuite/gcc.dg/debug/20020220-1.c2
-rw-r--r--gcc/testsuite/gcc.dg/debug/debug-1.c3
-rw-r--r--gcc/testsuite/gcc.dg/debug/debug-2.c3
-rw-r--r--gcc/testsuite/gcc.dg/debug/dwarf2/dwarf-die1.c8
-rw-r--r--gcc/testsuite/gcc.dg/debug/dwarf2/dwarf-die2.c7
-rw-r--r--gcc/testsuite/gcc.dg/debug/dwarf2/dwarf-die3.c11
-rw-r--r--gcc/testsuite/gcc.dg/debug/dwarf2/dwarf-die5.c12
-rw-r--r--gcc/testsuite/gcc.dg/debug/dwarf2/dwarf-die6.c12
-rw-r--r--gcc/testsuite/gcc.dg/debug/dwarf2/dwarf-die7.c14
-rw-r--r--gcc/testsuite/gcc.dg/dg.exp2
-rw-r--r--gcc/testsuite/gcc.dg/format/c90-printf-1.c3
-rw-r--r--gcc/testsuite/gcc.dg/format/c90-scanf-1.c3
-rw-r--r--gcc/testsuite/gcc.dg/format/strfmon-1.c3
-rw-r--r--gcc/testsuite/gcc.dg/gnu89-dupqual-1.c12
-rw-r--r--gcc/testsuite/gcc.dg/pch/apple-altivec-1.c126
-rw-r--r--gcc/testsuite/gcc.dg/pch/apple-altivec-1.hs2
-rw-r--r--gcc/testsuite/gcc.dg/pr14289-1.c12
-rw-r--r--gcc/testsuite/gcc.dg/pr14289-2.c12
-rw-r--r--gcc/testsuite/gcc.dg/pr14289-3.c12
-rw-r--r--gcc/testsuite/gcc.dg/ss/README17
-rw-r--r--gcc/testsuite/gcc.dg/ss/one.c18
-rw-r--r--gcc/testsuite/gcc.dg/ss/one.ssh13
-rw-r--r--gcc/testsuite/gcc.dg/ss/ss-cmd1.c10
-rw-r--r--gcc/testsuite/gcc.dg/ss/ss.exp235
-rw-r--r--gcc/testsuite/gcc.dg/torture/builtin-integral-1.c58
-rw-r--r--gcc/testsuite/gcc.dg/torture/builtin-nonneg-1.c172
-rw-r--r--gcc/testsuite/gcc.dg/typespec-1.c3
-rw-r--r--gcc/testsuite/gcc.dg/va-arg-2.c7
-rw-r--r--gcc/testsuite/gcc.dg/verbose-asm-2.c13
-rw-r--r--gcc/testsuite/gcc.dg/wtr-conversion-1.c3
-rw-r--r--gcc/testsuite/lib/g++.exp8
-rw-r--r--gcc/testsuite/lib/gcc.exp7
-rw-r--r--gcc/testsuite/lib/obj-c++-dg.exp165
-rw-r--r--gcc/testsuite/lib/obj-c++.exp311
-rw-r--r--gcc/testsuite/lib/scanasm.exp6
-rw-r--r--gcc/testsuite/obj-c++.dg/basic.mm24
-rw-r--r--gcc/testsuite/obj-c++.dg/dg.exp (renamed from gcc/testsuite/gcc.dg/charset/charset.exp)36
-rw-r--r--gcc/testsuite/obj-c++.dg/method-1.mm30
-rw-r--r--gcc/testsuite/obj-c++.dg/super-class-1.mm30
-rw-r--r--gcc/testsuite/obj-c++/redo-dg.exp38
-rw-r--r--gcc/testsuite/obj-c++/redo-old-deja.exp63
-rw-r--r--gcc/testsuite/objc.dg/call-super-1.m3
-rw-r--r--gcc/testsuite/objc.dg/category-1.m12
-rw-r--r--gcc/testsuite/objc.dg/const-cfstring-1.m57
-rw-r--r--gcc/testsuite/objc.dg/const-cfstring-2.m26
-rw-r--r--gcc/testsuite/objc.dg/const-str-3.m8
-rw-r--r--gcc/testsuite/objc.dg/dg.exp3
-rw-r--r--gcc/testsuite/objc.dg/encode-1.m13
-rw-r--r--gcc/testsuite/objc.dg/nested-func-1.m1
-rw-r--r--gcc/testsuite/objc.dg/objc.c6
-rw-r--r--gcc/timevar.c85
-rw-r--r--gcc/timevar.def2
-rw-r--r--gcc/toplev.c238
-rw-r--r--gcc/toplev.h2
-rw-r--r--gcc/tree-dump.c26
-rw-r--r--gcc/tree-inline.c15
-rw-r--r--gcc/tree.c116
-rw-r--r--gcc/tree.h113
-rw-r--r--gcc/varasm.c145
-rw-r--r--gcc/version.c17
-rw-r--r--include/demangle.h4
-rw-r--r--libada/configure.ac65
-rw-r--r--libiberty/vasprintf.c3
-rw-r--r--libjava/gnu/java/awt/peer/gtk/GdkGraphicsEnvironment.java87
-rw-r--r--libjava/gnu/java/net/protocol/core/Connection.java172
-rw-r--r--libjava/gnu/java/net/protocol/core/CoreInputStream.java90
-rw-r--r--libjava/gnu/java/net/protocol/core/Handler.java28
-rw-r--r--libjava/gnu/java/net/protocol/core/natCoreInputStream.cc51
-rw-r--r--libjava/gnu/regexp/CharIndexed.java84
-rw-r--r--libjava/gnu/regexp/CharIndexedCharArray.java62
-rw-r--r--libjava/gnu/regexp/CharIndexedInputStream.java149
-rw-r--r--libjava/gnu/regexp/CharIndexedReader.java142
-rw-r--r--libjava/gnu/regexp/CharIndexedString.java64
-rw-r--r--libjava/gnu/regexp/CharIndexedStringBuffer.java62
-rw-r--r--libjava/gnu/regexp/MessagesBundle.properties22
-rw-r--r--libjava/gnu/regexp/MessagesBundle_fr.properties22
-rw-r--r--libjava/gnu/regexp/RE.java1350
-rw-r--r--libjava/gnu/regexp/REException.java182
-rw-r--r--libjava/gnu/regexp/REFilterInputStream.java140
-rw-r--r--libjava/gnu/regexp/REFilterReader.java117
-rw-r--r--libjava/gnu/regexp/REMatch.java263
-rw-r--r--libjava/gnu/regexp/REMatchEnumeration.java135
-rw-r--r--libjava/gnu/regexp/RESyntax.java521
-rw-r--r--libjava/gnu/regexp/REToken.java86
-rw-r--r--libjava/gnu/regexp/RETokenAny.java73
-rw-r--r--libjava/gnu/regexp/RETokenBackRef.java72
-rw-r--r--libjava/gnu/regexp/RETokenChar.java91
-rw-r--r--libjava/gnu/regexp/RETokenEnd.java75
-rw-r--r--libjava/gnu/regexp/RETokenEndSub.java53
-rw-r--r--libjava/gnu/regexp/RETokenLookAhead.java68
-rw-r--r--libjava/gnu/regexp/RETokenOneOf.java130
-rw-r--r--libjava/gnu/regexp/RETokenPOSIX.java144
-rw-r--r--libjava/gnu/regexp/RETokenRange.java69
-rw-r--r--libjava/gnu/regexp/RETokenRepeated.java227
-rw-r--r--libjava/gnu/regexp/RETokenStart.java87
-rw-r--r--libjava/gnu/regexp/RETokenWordBoundary.java104
-rw-r--r--libjava/gnu/regexp/UncheckedRE.java109
-rw-r--r--libjava/java/util/natResourceBundle.cc42
-rw-r--r--libjava/javax/swing/plaf/basic/BasicProgressBarUI.java820
-rw-r--r--libjava/javax/swing/plaf/basic/BasicSeparatorUI.java266
-rw-r--r--libjava/javax/swing/plaf/basic/BasicSliderUI.java2213
-rw-r--r--libstdc++-v3/config/allocator/bitmap_allocator_base.h37
-rw-r--r--libstdc++-v3/config/allocator/malloc_allocator_base.h37
-rw-r--r--libstdc++-v3/config/allocator/mt_allocator_base.h37
-rw-r--r--libstdc++-v3/config/allocator/new_allocator_base.h37
-rw-r--r--libstdc++-v3/config/os/bsd/darwin/ctype_base.h77
-rw-r--r--libstdc++-v3/config/os/bsd/darwin/ctype_inline.h95
-rw-r--r--libstdc++-v3/config/os/bsd/darwin/ctype_noninline.h82
-rw-r--r--libstdc++-v3/config/os/bsd/darwin/os_defines.h161
-rw-r--r--libstdc++-v3/docs/html/ext/ballocator_doc.txt374
-rw-r--r--libstdc++-v3/include/c_std/std_cctype.h21
-rw-r--r--libstdc++-v3/libsupc++/eh_alloc.cc8
-rw-r--r--libstdc++-v3/libsupc++/eh_terminate.cc47
-rw-r--r--libstdc++-v3/libsupc++/new_handler.cc16
-rw-r--r--libstdc++-v3/libsupc++/new_op.cc26
-rw-r--r--libstdc++-v3/libsupc++/new_opnt.cc13
-rw-r--r--libstdc++-v3/libsupc++/pure.cc12
-rw-r--r--libstdc++-v3/src/functexcept.cc6
-rw-r--r--libstdc++-v3/src/ios.cc11
-rw-r--r--libstdc++-v3/testsuite/20_util/allocator/14176.cc42
-rw-r--r--libstdc++-v3/testsuite/22_locale/locale/cons/12658_thread.cc67
-rw-r--r--libstdc++-v3/testsuite/22_locale/money_get/get/char/17.cc71
-rw-r--r--libstdc++-v3/testsuite/22_locale/money_get/get/char/18.cc69
-rw-r--r--libstdc++-v3/testsuite/22_locale/money_get/get/char/19.cc125
-rw-r--r--libstdc++-v3/testsuite/22_locale/money_get/get/wchar_t/17.cc71
-rw-r--r--libstdc++-v3/testsuite/22_locale/money_get/get/wchar_t/18.cc69
-rw-r--r--libstdc++-v3/testsuite/22_locale/money_get/get/wchar_t/19.cc125
-rw-r--r--libstdc++-v3/testsuite/23_containers/deque/modifiers/swap.cc68
-rw-r--r--libstdc++-v3/testsuite/23_containers/list/modifiers/swap.cc67
-rw-r--r--libstdc++-v3/testsuite/23_containers/map/modifiers/swap.cc67
-rw-r--r--libstdc++-v3/testsuite/23_containers/multimap/modifiers/swap.cc67
-rw-r--r--libstdc++-v3/testsuite/23_containers/multiset/modifiers/swap.cc67
-rw-r--r--libstdc++-v3/testsuite/23_containers/set/modifiers/swap.cc67
-rw-r--r--libstdc++-v3/testsuite/23_containers/vector/modifiers/swap.cc67
-rw-r--r--libstdc++-v3/testsuite/26_numerics/cmath/overloads.cc27
-rw-r--r--libstdc++-v3/testsuite/26_numerics/complex/13450.cc75
-rw-r--r--libstdc++-v3/testsuite/26_numerics/complex/pow.cc14
-rw-r--r--libstdc++-v3/testsuite/26_numerics/valarray_subset_assignment.cc88
-rwxr-xr-xltconfig3
-rw-r--r--ltmain.sh30
-rwxr-xr-xmaintainer-scripts/import-prune24
-rwxr-xr-xmaintainer-scripts/local-summary60
-rwxr-xr-xmaintainer-scripts/local-untested9
-rw-r--r--man-pages/README4
-rw-r--r--man-pages/cpp3.1821
-rw-r--r--man-pages/gcc3.15764
-rw-r--r--man-pages/gcov3.1453
-rw-r--r--more-hdrs/assert.h71
-rw-r--r--more-hdrs/float.h98
-rw-r--r--more-hdrs/inttypes.h308
-rw-r--r--more-hdrs/machine/limits.h11
-rw-r--r--more-hdrs/ppc_intrinsics.h939
-rw-r--r--more-hdrs/stdarg.h6
-rw-r--r--more-hdrs/stdbool.h2
-rw-r--r--more-hdrs/stdint.h203
-rw-r--r--more-hdrs/varargs.h6
-rw-r--r--order-files/HOW TO BUILD170
-rw-r--r--order-files/cc1.order1188
-rw-r--r--order-files/cc1obj.order2163
-rw-r--r--order-files/cc1objplus.order952
-rw-r--r--order-files/cc1plus.order1356
-rw-r--r--pbproj/gcc3.pbproj/dpatel.pbxuser208
-rw-r--r--pbproj/gcc3.pbproj/project.pbxproj191
-rw-r--r--pbproj/gcc3.pbproj/spolk.pbxuser370
-rw-r--r--pbproj/gcc3.pbproj/zlaski.pbxuser225
1130 files changed, 50218 insertions, 173773 deletions
diff --git a/CHANGES.Apple b/CHANGES.Apple
new file mode 100644
index 00000000000..96d8c9d1e52
--- /dev/null
+++ b/CHANGES.Apple
@@ -0,0 +1,265 @@
+APPLE LOCAL file maintenance
+
+This files lists all of Apple's local changes, the people responsible
+for them, and their current status.
+
+List owners by email name. Possible statuses:
+ local not accepted/able for FSF GCC, permanently local
+ submit should submit to FSF GCC at some point
+ submitted submitted to FSF GCC, awaiting approval/disapproval
+ accepted in FSF GCC, expected to appear in next import
+ mixed for large patches, parts could go into FSF GCC
+ unknown not known what to do with
+
+Owner Status Name of change
+----- ------ --------------
+shebs local #import not deprecated
+mrs unknown %b/save-temps can clobber input file (radar 2871891)
+dalej unknown 'reg + index' reg case.
+dalej unknown +2 (could be conditionalized)
+dalej unknown , a temporary kludge
+dalej unknown , for now, don't count pseudos
+shebs local -ObjC
+dpatel unknown -Werror
+dpatel unknown -Wextra-tokens
+shebs local -Wfour-char-constants
+dpatel unknown -Wlong-double
+dpatel unknown -Wmost
+shebs unknown -Wnewline-eof
+dpatel local -Wno-#warnings
+zlaski local -Wno-altivec-long-deprecated
+shebs unknown -Wpragma-once
+dpatel local -dependency-file
+austern local -fapple-kext
+shebs unknown -ffppc
+austern unknown -findirect-virtual-calls
+stuart local -fobey-inline
+austern unknown -fterminated-vtables
+dpatel local -header-mapfile
+dpatel local -header-mapfile bandaid for buffer overflows
+shebs local -malign-mac68k
+stuart unknown -mlong-branch
+dalej submit -pg fix
+dpatel local -arch
+austern local 2.95-compatibility stuff
+austern local 2.95-ptmf-compatibility
+dpatel local 2920964
+stuart unknown 8-byte-struct hack
+dalej unknown ?
+shebs unknown Agree with <stdio.h> prototype
+shebs mixed AltiVec
+shebs unknown Altivec related
+shebs local Apple banner
+shebs local Apple version
+shebs submitted C++ EH
+shebs unknown CALL_ON_LOAD/CALL_ON_UNLOAD pragmas
+mrs unknown CALL_ON_MODULE_BIND deprecated
+dalej unknown CCUNS, CCFP, CCEQ patterns
+mrs unknown Constructors return THIS
+mrs unknown EH VALID_FDE_P
+mrs unknown EH runtime
+mrs unknown Enable $ in identifiers in assembly.
+mrs submit FSF candidate
+dalej unknown MEM_OFFSET setting
+zlaski local MW compatibility
+mrs unknown Mach time
+shebs local Macintosh alignment
+shebs submit OS pragma hook
+zlaski submit Objective-C++
+shebs local PPC_INTRINSICS
+zlaski local Pascal strings
+dalej unknown RTX_COST for multiply
+dalej unknown Reduce code size / improve performance
+stuart submit Stripped encodings ('!T_' and '!t_') should match.
+dalej unknown accept hard R12 as target reg
+zlaski submit add + for GNU runtime only
+dalej unknown add mode change case
+mrs unknown alignment
+mrs unknown alloca
+mrs unknown alloca not in std
+austern local apple kext alignment
+austern local apple-kext Radar #2849864
+shebs submit asm flags
+mrs unknown assembly "abort" directive
+dalej unknown avoid out-of-bounds refs
+austern unknown be permissive by default
+dalej unknown better induction variable selection
+zlaski submit bitfield alignment
+zlaski submit bool encoding
+dalej unknown branch cost
+shebs local build machinery
+zlaski submit call super
+stuart unknown callers_lr_already_saved
+austern unknown cc1plus spec
+zlaski unknown check ctype also
+austern unknown coalescing
+dalej unknown code size reduction / performance enhancement
+dalej unknown combine hoisted consts
+dalej unknown compare >= 0, not > 0.
+stuart submit const_data
+zlaski local constant cfstrings
+zlaski submit constant strings
+mrs unknown control opt level.
+austern unknown correct constructor inlining
+shebs local darwin host
+mrs unknown darwin mmap bug workaround
+shebs unknown darwin native
+shebs unknown darwin native (?)
+shebs unknown darwin native, AltiVec
+shebs unknown darwin-specific headers
+shebs unknown darwin_set_section_for_var_p
+dalej unknown dbj
+austern local ddtor double destructor
+shebs local debugging
+mrs unknown declare string functions
+stuart submitted decloning
+stuart submitted decloning structors
+stuart unknown default to ppro
+shebs unknown direct-binding-refs
+shebs accepted disable Dwarf 2 until assembler fixed
+shebs local disable generic AltiVec patterns
+dalej unknown disable strict aliasing; breaks too much existing code.
+dalej unknown disallow (not (SYM))
+dalej unknown div by const
+shebs unknown do not extern fp save/restore
+austern unknown do not forward reference anonymous enum
+dalej unknown do not use float fieldmode
+shebs local documentation
+shebs unknown don't define SAVE_FP_PREFIX and friends
+austern local double destructor
+mrs unknown eh in data segment
+dpatel unknown error-colon
+shebs local fat builds
+shebs local fat builds readability
+mrs unknown fde end extension
+zlaski submit finish file hook
+dalej unknown fix 2857104
+dalej unknown fix 2866661
+zlaski submit fix OBJC codegen
+shebs unknown fix prototypes
+shebs unknown fix redundant add?
+shebs unknown flag translation
+zlaski unknown flag_objc
+dalej unknown for TRUNC_DIV_EXPR
+dalej unknown for now
+mrs submited framework headers
+dalej local fused multiply-add
+mrs unknown gdb only used symbols
+dpatel unknown handle -Wno-system-headers (2910306)
+shebs submit handle ~ in pathnames
+dalej unknown improve performance
+shebs submit include guard for darwin.h
+dalej unknown indirect calls in R12
+stuart local indirect sibcalls
+mrs submit insert assembly ".abort" directive on fatal error
+mrs unknown interrupt signal handler (radar 2941633)
+zlaski submit ivar access
+zlaski local keep tables in sync comment
+mrs unknown keymgr
+austern unknown libcc_kext
+austern unknown libm
+zlaski submit libobjc
+shebs unknown linker flags
+dpatel unknown long double warning
+stuart unknown long-branch
+shebs local maintenance
+shebs unknown make easy_vector_constant globally visible (rs6000-protos.h)
+austern unknown make libstdc++ more fine-grained
+shebs local man pages
+shebs local manual
+zlaski submit method encoding
+shebs unknown more orphaned code
+dalej unknown move '<' case down?
+zlaski submit move is_class_name to stub-objc.c
+dalej unknown move loads out of loops
+zlaski submit move lookup_interface to stub-objc.c
+zlaski submit move lookup_objc_ivar to stub-objc.c
+zlaski submit msg send super
+dalej unknown multiply cost pulled into function
+dalej unknown multiply-add
+zlaski submit mystery binfo
+zlaski submit nested functions
+dpatel submitted new tree dump
+shebs unknown no soft-float multilibs
+stuart local obey inline
+zlaski submit objc bug fix
+zlaski submit objc finish file
+shebs submit objc stret methods
+dalej unknown optimization
+shebs local order files
+mrs unknown parsedir
+shebs unknown pass reload addr by address
+shebs unknown performance enhancement
+shebs unknown performance improvement
+shebs local preprocess .s files
+dalej unknown preserve CR2 for save_world prologues
+austern unknown private extern
+austern unknown private extern Radar 2872481
+zlaski submit protocol qual
+shebs unknown prototypes
+shebs local prune man page
+dalej unknown put this insn after the loop in all cases
+mrs submit radar 2466994 - -no-c++filt
+mrs submit radar 2466994 - pass linker output through c++filt
+dpatel local radar 2866081: Env. variable -O override
+dpatel local radar 2866081: Env. variable override
+mrs unknown radar 2871891 - %b/%B & -save-temps can clobber input file
+dalej unknown recompute PIC register use
+dalej unknown record that float extend is a copy
+dalej unknown reduce code size
+austern unknown reduce emergency buffer size
+dalej submit reenable some lost combines
+shebs unknown remove a stub tweak
+dalej unknown remove invalid delete
+austern unknown remove machopic_output_possible_stub_label
+dalej unknown remove this so combine doesn't generate it
+shebs unknown remove vasprintf prototype
+shebs submit rename for HFS
+shebs local report bugs to Apple
+dalej unknown restoration of inmode/outmode
+dalej unknown rewrite weight computation
+dalej unknown save and restore LR
+dalej unknown separate cl into c,*l; switch and attr's expanded to match
+zlaski unknown separate outputdir
+mrs submit setrlimit
+shebs unknown setting of all callee-saved regs removed
+stuart submit sibcall
+stuart submit sibcall 3007352
+stuart submit sibcall patterns
+shebs unknown size of bool
+dalej unknown special ObjC method use of R12
+shebs unknown static const members
+shebs unknown static structors in __StaticInit section
+stuart submitted structor decloning
+stuart submitted structor thunks
+dalej unknown subtract 1
+shebs local supply missing ctype.h decls
+zlaski submit suppress method inlining
+shebs unknown temporary pragmas
+austern local terminated-vtables
+stuart unknown test for flag_pic deleted deliberately
+shebs unknown testsuite
+shebs local testsuite OS flush bug workaround
+shebs unknown testsuite multiply defined
+stuart unknown thunks
+shebs unknown time formatting
+dalej unknown try destroyed input
+shebs unknown try to improve ggc
+dalej unknown tweak default optimizations
+dpatel unknown unavailable
+dpatel unknown unavailable (Radar 2809697)
+shebs unknown unnecessary test?
+dalej unknown use R12 as register for indirect calls. This improves
+dalej unknown use new pseudo for temp; reusing reg confuses PRE
+dalej unknown use r12 for indirect calls
+dalej unknown volatile pic base reg in leaves
+austern unknown weak definition
+austern unknown weak import
+austern unknown weak_import (Radar 2809704)
+shebs unknown what is this for?
+shebs unknown why is this needed?
+mrs unknown work around Radar 2844245.
+shebs local work around a makeinfo complaint
+shebs unknown world save/restore
+austern unknown write used class statics
+shebs submit zerofill
diff --git a/GNUmakefile b/GNUmakefile
new file mode 100644
index 00000000000..ce0b8336ef0
--- /dev/null
+++ b/GNUmakefile
@@ -0,0 +1,88 @@
+# APPLE LOCAL file build machinery
+# Apple GCC Compiler Makefile for use by buildit.
+#
+# This makefile is intended only for use with B&I buildit. For "normal"
+# builds use the conventional FSF top-level makefile.
+#
+# You can specify TARGETS=ppc (or i386) on the buildit command line to
+# limit the build to just one target. The default is for ppc and i386.
+# The compiler targetted at this host gets built anyway, but not installed
+# unless it's listed in TARGETS.
+
+# Include the set of standard Apple makefile definitions.
+ifndef CoreOSMakefiles
+CoreOSMakefiles = $(MAKEFILEPATH)/CoreOS
+endif
+include $(CoreOSMakefiles)/Standard/Standard.make
+
+# Enable Apple extensions to (gnu)make.
+USE_APPLE_PB_SUPPORT = all
+
+HOSTS = ppc i386 # `arch`
+targets = echo $${TARGETS:-'ppc i386'}
+TARGETS := $(shell $(targets))
+
+RC_ARCHS = $(HOSTS)
+
+SRCROOT = .
+
+SRC = `cd $(SRCROOT) && pwd | sed s,/private,,`
+OBJROOT = $(SRC)/obj
+SYMROOT = $(OBJROOT)/../sym
+DSTROOT = $(OBJROOT)/../dst
+
+PREFIX = /usr
+
+#######################################################################
+
+install: $(OBJROOT) $(SYMROOT) $(DSTROOT)
+ cd $(OBJROOT) && \
+ $(SRC)/build_gcc "$(RC_ARCHS)" "$(TARGETS)" \
+ $(SRC) $(PREFIX) $(DSTROOT) $(SYMROOT)
+
+# installhdrs does nothing, because the headers aren't useful until
+# the compiler is installed.
+installhdrs:
+
+# We build and install in one shell script.
+build:
+
+installsrc:
+ @echo
+ @echo ++++++++++++++++++++++
+ @echo + Installing sources +
+ @echo ++++++++++++++++++++++
+ @echo
+ if [ $(SRCROOT) != . ]; then \
+ $(PAX) -rw . $(SRCROOT); \
+ fi
+ find -d "$(SRCROOT)" \( -type d -a -name CVS -o \
+ -type f -a -name .DS_Store -o \
+ -name \*~ -o -name .\#\* \) \
+ -exec rm -rf {} \;
+
+#######################################################################
+
+clean:
+ @echo
+ @echo ++++++++++++
+ @echo + Cleaning +
+ @echo ++++++++++++
+ @echo
+ @if [ -d $(OBJROOT) -a "$(OBJROOT)" != / ]; then \
+ echo '*** DELETING ' $(OBJROOT); \
+ rm -rf $(OBJROOT); \
+ fi
+ @if [ -d $(SYMROOT) -a "$(SYMROOT)" != / ]; then \
+ echo '*** DELETING ' $(SYMROOT); \
+ rm -rf $(SYMROOT); \
+ fi
+ @if [ -d $(DSTROOT) -a "$(DSTROOT)" != / ]; then \
+ echo '*** DELETING ' $(DSTROOT); \
+ rm -rf $(DSTROOT); \
+ fi
+
+#######################################################################
+
+$(OBJROOT) $(SYMROOT) $(DSTROOT):
+ mkdir -p $@
diff --git a/README.Apple b/README.Apple
new file mode 100644
index 00000000000..c0d5abadd4c
--- /dev/null
+++ b/README.Apple
@@ -0,0 +1,463 @@
+APPLE LOCAL file documentation
+
+This file describes Apple's version of GCC 3.x modified for Darwin /
+Mac OS X. Although Apple's stated policy is to contribute all of its
+GCC work to the FSF GCC mainstream, at any given moment there will be
+changes that are permanently unacceptable for FSF GCC, in need of
+rework before acceptance, or that we simply aren't ready to send in.
+This version of GCC contains all those changes.
+
+In keeping with provision 2a of the GPL, each Apple change is marked
+with a comment saying "APPLE LOCAL", followed by optional words "begin",
+"end", or "file", followed by a short phrase describing the change
+generally ("AltiVec" for instance, if the change is related to AltiVec
+support), followed by an optional date in the form yyyy-mm-dd,
+optionally followed by the initials or email address of the person
+making the change. The words "begin" and "end" indicate that the
+comments delimit a multi-line change, while the word "file" indicates
+that the entire file is an Apple addition. Additional explanatory
+comments should be in a separate comment.
+
+You may also isolate Apple's changes by diffing with the FSF mainline
+sources as of the date mentioned in gcc/version.c; this date is
+updated in the FSF repository daily, and is preserved when we import
+FSF sources into Apple's repository (the tag for the imported source
+is "fsf-cvs").
+
+The primary purpose of this version of GCC is to be the main system
+compiler for Darwin and Mac OS X. However, since additions such as
+PFE precompiled headers and Objective-C++ are of interest on other
+platforms, we have generally conditionalized Mac-specific code so that
+the compiler will build and run elsewhere. You may however run into
+mistakes; please let us know about them and we will
+fix these if possible.
+
+NOTE! It's best to assume that this code has been updated from FSF
+development sources recently, and has received very little testing
+before being imported. There is a good chance that your favorite
+program will not compile or run when compiled with this program. The
+version of the compiler that ships with OS X is the standard for
+correctness; any time something works with that compiler but fails
+with this one is probably a bug, and should be reported to
+darwin-development@lists.apple.com.
+
+PREREQUISITES
+
+Presumably if you're reading this, you've figured out how to get the
+sources. :-) But just to be complete, these sources are available from
+the Darwin repository at opensource.apple.com, CVS module "gcc3". See
+http://www.opensource.apple.com/tools/cvs if this isn't enough info
+yet.
+
+If you want C++ exception handling to work, you will need a modified
+crt1.o. (crt1.o is the bit of code that sets up for execution and
+calls your program's main().) The modified crt1.o is standard in 10.2,
+but 10.1, you will need to set it up yourself.
+
+If you can't get a modified crt1.o from somebody else, you can patch a
+copy of the sources to the "Csu" project and build it yourself. The
+patch is included in this directory, as "csu-patch". The build is
+easy, just say "make" in the Csu directory, and then copy the crt1.o
+to /usr/lib/crt1.o (as usual, it's prudent to keep around a copy of
+the original crt1.o, just in case). You will need to have built the
+"cctools" project as well, in order to get the helper tool "indr"
+(which is expected to be installed as /usr/local/bin/indr).
+
+BUILDING, THE APPLE WAY
+
+To build things the Apple way, just say (in the source directory)
+
+ mkdir -p build/obj build/dst build/sym
+ gnumake install RC_OS=macos RC_ARCHS=ppc TARGETS=ppc \
+ SRCROOT=`pwd` OBJROOT=`pwd`/build/obj \
+ DSTROOT=`pwd`/build/dst SYMROOT=`pwd`/build/sym
+
+This will configure and then do a full bootstrap build, with all the
+results going into the subdirectory build/ that you created. The
+final results will be in the "dest root" directory build/dst, in the
+form of an image of the installed directory structure. The drivers
+and other user-visible tools have a "3" suffixed, so for instance the
+driver is /usr/bin/gcc3, and the demangler is /usr/bin/c++filt3.
+
+To install the results, become root and do
+
+ ditto build/dst /
+
+Various knobs and switches are available, but even so, the Apple
+makefile machinery is mainly designed for mass builds of all the
+projects that make up Darwin and/or Mac OS X, and is thus not as
+flexible as the standard GCC build process.
+
+To build for i386 Darwin, set TARGETS=i386. To build fat, set
+RC_ARCHS='i386 ppc' TARGETS='i386 ppc'. Note that you must have a
+complete set of fat libraries and i386-targeting cctools for this
+all to work.
+
+You can set the four *ROOT variables to point anywhere, but they must
+always be absolute pathnames.
+
+This way of building may or may not work on non-Macs, and if it
+doesn't, you're on your own.
+
+BUILDING, THE FSF WAY
+
+In general, standard GCC procedures work for building this version.
+We recommend that you build in a separate objdir; create a sibling
+to the toplevel source dir, call it whatever you want, cd into it,
+and say "../gcc3/configure". This way you can have more than one
+build using the same set of sources.
+
+If you insist on building in the source directory using "./configure",
+the GNUmakefile that supports the Apple build process (see above) will
+shadow your makefile, and you will need to override this behavior by
+saying "make -f Makefile" (or by moving GNUmakefile out of the way).
+
+For instance:
+
+ mkdir darwin
+ cd darwin
+ ../gcc3/configure --prefix=/tmp/testplace
+ make bootstrap
+ make install
+
+does a full build, plus two generations of self-compilation for
+GCC proper, then an install.
+
+To avoid building every language, use --enable-languages argument to
+configure. For instance, '--enable-languages=objc,c++,objc++' skips
+the Fortran and Java compilers. (The C compiler will always be
+built.)
+
+To build an x86 cross-compiler, add "--target=i386-darwin" to the
+configure line. The x86 compiler works, but to make it useful you
+will need libraries and such from x86 Darwin.
+
+There is a ProjectBuilder (PB) project also, but at the moment it's
+only useful for browsing. We expect to make it useful for building
+eventually. To keep it out of the way until then, it's in
+"pbproj/gcc3.pbproj".
+
+Tools built the FSF way are *not* usually going to be dropin
+replacements for already-installed tools built the Apple way, because
+search paths and other details will be different.
+
+TESTING
+
+This package includes a copy of the test framework of DejaGNU, for
+convenience in running GCC's testsuite. If you've done a make
+from the top, DejaGNU will have been built already; otherwise at
+the top of the objdir say "make all-dejagnu".
+
+Once the DejaGNU is available, you can cd into the gcc objdir and type
+"make check" to run all the tests. This will take several hours. You
+can do things like "make check-gcc" just to run C tests, or "make
+check-g77" for Fortran tests, which take less time.
+
+USING
+
+While this compiler can be used with 10.1, it is aimed at 10.2
+(Jaguar) and later releases. Built correctly, using the "Apple way",
+it can be a dropin replacement for the 10.2 system compiler.
+
+* Compatibility Issues
+
+This section lists areas where this compiler behaves differently
+from other versions of GCC.
+
+Built-in functions are not automatically declared
+
+GCC knows about some functions, such as memcpy, so it can generate
+better code for them. However, 2.95.2 let C++ programs refer to them
+without ever declaring them. The current C++ compiler now does the
+right thing by requiring you to declare all functions.
+
+alloca is a built-in function
+
+Normally only __builtin_alloca is a built-in function, and user
+code #defines alloca as __builtin_alloca. This version of GCC
+also recognizes alloca as built-in, and compiles it into a single
+stack adjustment.
+
+va_arg cannot take chars, shorts, or floats
+
+You can no longer pass "char", "short", or "float" as the second
+argument to va_arg() when using varargs.
+
+#pragma once is silently accepted
+
+GCC handles #pragma once correctly, but the standard compiler warns
+that the pragma is obsolete. This version of GCC is silent by
+default. Use -Wpragma-once to see the warnings again.
+
+#import is silently accepted
+
+GCC handles #import correctly, but the standard compiler warns that
+the directive is obsolete. This version of GCC is silent by default.
+Use -Wimport to see the warnings again.
+
+Extra tokens after #endif and friends are silently accepted
+
+Standard GCC now warns about extra tokens after #endif and other
+preprocessor directives. This version of GCC is silent by default.
+Use -Wextra-tokens to see these warnings.
+
+Files with missing newlines are silently accepted
+
+Standard GCC warns about files that do not end with a newline.
+This seems to be common in Apple headers and sources, so this
+version does not warn. Use -Wnewline-eof to see these warnings.
+
+-fpermissive by default
+
+The C++ compiler is normally strict about adherence to the language
+standard, but the -fpermissive flag is available to convert many
+errors into warnings. Apple's compiler is set to be permissive
+by default. This is temporary as of 1/27/02.
+
+GNU stddef.h not installed
+
+If built the Apple way, GCC's stddef.h is installed as "gnu-stddef.h",
+and so by default you will get the /usr/include/stddef.h that comes
+with Darwin.
+
+libobjc not built
+
+Since GNU libobjc and its headers would mask the system library
+and headers, this version of GCC does not build or install them
+if targeting Darwin.
+
+Objective-C structure returns
+
+When using the NeXT runtime, methods returning structures will work,
+while they will fail when using FSF GCC.
+
+All assembly files are preprocessed
+
+FSF GCC only runs the C preprocessor on files with extension .S, and
+does not run it on files ending in .s. Apple GCC runs the
+preprocessor on .s files also.
+
+Bug reporting address different
+
+If the compiler gets an internal error, it will ask you to report the
+error to Apple, rather than to the FSF.
+
+* Extensions
+
+This section briefly describes Apple's extensions to GCC. Further
+details may be found in the GCC manual (usually).
+
+__APPLE_CC__
+
+The preprocessor symbol __APPLE_CC__ identifies a specific "build
+number" of the compiler. These numbers are finer-grained than the
+generic GCC version numbers, and for gcc3 they range from 1000 up
+(2.95.2 versions are in the 900s).
+
+Framework includes
+
+Headers may be found by pathname in the usual way, or as part of
+"frameworks" which are assemblages of library/headers/resources. For
+instance, #include <IOKit/IOTypes.h> will be found as
+/System/Library/Frameworks/IOKit.framework/Headers/IOTypes.h. The
+-F<pathname> adds <pathname> as a place to search for frameworks; by
+default, the compiler will look in /System/Library/Frameworks,
+/Library/Frameworks, and /Local/Library/Frameworks.
+
+Frameworks may also have subframeworks, and the framework include
+machinery will find headers in subframeworks if the outer framework
+(known as an "umbrella framework) is being included.
+
+Objective-C++
+
+Objective-C++ is C++ extended to understand Objective-C constructs.
+The two object models are separate and "mutually oblivious", so C++
+code generally works unchanged, as well as Objective-C code that
+conforms to C++ restrictions (similar to the restrictions placed on
+plain C code by C++). Objective-C++ files must have the extension .mm
+or .M (but note that .M will conflict with .m files on HFS
+filesystems, so .mm is preferred).
+
+Pascal strings
+
+The flag -fpascal-strings enables the use of "\p" to designate a
+length byte, originally used for C-Pascal interoperation on Macs, but
+now mostly a human-appendix-like compatibility option.
+
+Macintosh alignment
+
+The options -malign-mac68k, -malign-power, and -malign-natural are
+available to control whether the alignment of structure fields
+follows 68K, PowerPC, or "natural" rules. These options are
+useful to applications which need to be binary-compatible with
+very old Mac applications, libraries, or resources. The "natural"
+alignment mode may be useful to applications whose performance is
+sensitive to misaligned data accesses.
+
+In addition, #pragma options align=<option> is available, where
+<option> may be mac68k, native, natural, packed, power, or reset.
+(native == power on a PowerPC.) The pragma effectively pushes the
+alignment onto a stack, while align=reset pops the alignment, thus
+allowing nested pragmas to work. #pragma pack is also available and
+works with the same stack.
+
+private extern symbols
+
+You can declare symbols as "private extern", which means that they
+behave as extern until linking, then they are made private, and are
+not visible outside the library. To declare something as private
+extern, add "__private_extern__" where you might normally say
+"extern".
+
+Coalescing
+
+Using "-fcoalesce", "-fcoalesce-templates" and "-fweak-coalesced"
+flags can reduce the amount of duplicated code. Coalescing and C++
+template coalescing are enabled by default, at least if a
+recent-enough cctools version (10.2 or later) has been installed.
+
+-dynamiclib
+
+You can build shared libraries (aka dylibs) by using -dynamiclib.
+This invokes libtool (not to be confused with GNU libtool) instead of
+ld. See the libtool man page for more detail on options that can be
+passed to libtool.
+
+Linker flags
+
+This version of GCC understands the plethora of linker-related flags,
+such as -framework, -flat_namespace, etc. The functionality should be
+the same as for 2.95.2 and as documented in the linker man page; any
+discrepancies are probably bugs.
+
+AltiVec
+
+The complete AltiVec programming interface, as defined in the PIM, is
+available. Use -faltivec to enable it.
+
+Note that the PIM, section 2.1 mentions that AltiVec data types using
+the 'long' keyword (i.e., vector [un]signed long) are deprecated and
+that the 'int' should be used. The compiler will thus issue a warning
+for these cases. The warning may be suppressed by specifying
+-Wno-altivec-long-deprecated.
+
+-mdynamic-no-pic
+
+The option -mdynamic-no-pic generates code that make references to
+PIC, but is not itself position-independent and thus more efficient.
+This option is suitable for applications but not dylibs.
+
+unavailable attribute
+
+The attribute "unavailable" is available :-) to declare that a
+symbol is not available.
+
+weak_import attribute
+
+The attribute weak_import is available to declare that a symbol
+should be designated as a weak reference.
+
+CALL_ON_LOAD and CALL_ON_UNLOAD pragmas
+
+The pragmas CALL_ON_LOAD and CALL_ON_UNLOAD allow you to declare
+that a given name is the name of a function to be called when
+a module is loaded or unloaded by the system.
+
+IOKit support
+
+There are a number of changes to support the building of IOKit drivers.
+
+The option -findirect-virtual-calls forces all virtual calls to go
+through the vtable, while the option -fterminated-vtables adds a null
+termination to vtables. -fapple-kext turns on all of these, plus any
+future options that may be needed to compile kexts.
+
+There is a library libcc_kext.a that is libgcc.a compiled static and
+including only routines that are allowed in the kernel.
+
+The PowerPC-only option -mlong-branch is available to generate full
+32-bit jumps, since kexts may not be loaded at addresses close to the
+kernel.
+
+Dependency file names
+
+When you use -MD to output dependencies, you can also use
+-dependency-file <name> to write the dependencies into the file named
+<name>. (By default, they go into <inputfilename>.d .)
+
+Fat builds
+
+You can compile for a specific target type by using -arch <archname>.
+Multiple -arch options also work, and result in "fat binaries". -arch
+works with -c, -precomp (to make fat precomps), but not -S or
+-save-temps.
+
+At present, only "i386" and "ppc" may be used as architecture names.
+Note that building for a specific arch will only work if you have
+assembler and libraries for that arch.
+
+-ObjC, -ObjC++
+
+These options set the default language to be Objective-C and
+Objective-C++, respectively. Note that this behavior is slightly
+different from the -x options, because -x affects only the files
+appearing after it on the command line, while -ObjC and -ObjC++ affect
+all input files. Nevertheless, -x is standard and thus preferable.
+(-fobjc works and is equivalent to -ObjC, but it's even more
+deprecated.)
+
+-Wmost
+
+The option -Wmost is equivalent to -Wall -Wno-parentheses. It is
+present for compatibility with some existing Mac OS X projects.
+
+-Wno-#warnings
+
+The option -Wno-#warnings suppresses warnings issued by #warning.
+
+-Wno-altivec-long-deprecated
+
+The option -Wno-altivec-long-deprecated suppresses warnings about
+'int' being preferred to 'long' in AltiVec vector types.
+
+-Werror suppression
+
+The environment variable QA_DISABLE_WERROR, if set (to any value),
+disables the effect of -Werror on the command line; warnings will
+not result in an error.
+
+PB indexing
+
+If the environment variable PB_INDEX_SOCKET_PORT is defined, then the
+compiler will output PB indexing information to that port. The option
+-fdebug-gen-index will do the same port, but sending the information
+to standard output, for debugging indexing.
+
+Header mapfiles
+
+This is the support for a PB feature where actual pathnames for
+headers come from a given file rather than being searched for in the
+various include paths. It's not useful outside of the PB environment.
+
+QA_OVERRIDE_GCC3_OPTIONS environment variable
+
+Allows overriding, adding, or changing options sent to toplev.c. This
+allows you, for example, to override the -O setting that the driver
+sends to the command line. Documentation is in toplev.c.
+
+* Miscellaneous Issues
+
+GCC uses a syntax for rlwinm instructions that is only supported
+by the assembler in 10.1 or later. If you need to run 10.0, and
+can't build cctools-364, then you can try to dig up the workaround;
+versions of gcc3 before December 2001 have it, look for references
+to rlwinm in gcc/config/rs6000/rs6000.md.
+
+TO DO
+
+This section lists specific features that we're still working on.
+
+Make fat building work when the compiler is built the FSF way.
+
+Implement floating point precision control (-ffppc) for i386.
+
diff --git a/boehm-gc/alpha_mach_dep.S b/boehm-gc/alpha_mach_dep.S
deleted file mode 100644
index a6f0b8506f5..00000000000
--- a/boehm-gc/alpha_mach_dep.S
+++ /dev/null
@@ -1,87 +0,0 @@
- # $Id: alpha_mach_dep.S,v 1.1 2003/07/28 03:46:09 jsturm Exp $
- .arch ev6
-
- .text
- .align 4
- .globl GC_push_regs
- .ent GC_push_regs 2
-GC_push_regs:
- ldgp $gp, 0($27)
- lda $sp, -16($sp)
- stq $26, 0($sp)
- .mask 0x04000000, 0
- .frame $sp, 16, $26, 0
-
- # $0 integer result
- # $1-$8 temp regs - not preserved cross calls
- # $9-$15 call saved regs
- # $16-$21 argument regs - not preserved cross calls
- # $22-$28 temp regs - not preserved cross calls
- # $29 global pointer - not preserved cross calls
- # $30 stack pointer
-
-# define call_push(x) \
- mov x, $16; \
- jsr $26, GC_push_one; \
- ldgp $gp, 0($26)
-
- call_push($9)
- call_push($10)
- call_push($11)
- call_push($12)
- call_push($13)
- call_push($14)
- call_push($15)
-
- # $f0-$f1 floating point results
- # $f2-$f9 call saved regs
- # $f10-$f30 temp regs - not preserved cross calls
-
- # Use the most efficient transfer method for this hardware.
- # Bit 1 detects the FIX extension, which includes ftoit.
- amask 2, $0
- bne $0, $use_stack
-
-#undef call_push
-#define call_push(x) \
- ftoit x, $16; \
- jsr $26, GC_push_one; \
- ldgp $gp, 0($26)
-
- call_push($f2)
- call_push($f3)
- call_push($f4)
- call_push($f5)
- call_push($f6)
- call_push($f7)
- call_push($f8)
- call_push($f9)
-
- ldq $26, 0($sp)
- lda $sp, 16($sp)
- ret $31, ($26), 1
-
- .align 4
-$use_stack:
-
-#undef call_push
-#define call_push(x) \
- stt x, 8($sp); \
- ldq $16, 8($sp); \
- jsr $26, GC_push_one; \
- ldgp $gp, 0($26)
-
- call_push($f2)
- call_push($f3)
- call_push($f4)
- call_push($f5)
- call_push($f6)
- call_push($f7)
- call_push($f8)
- call_push($f9)
-
- ldq $26, 0($sp)
- lda $sp, 16($sp)
- ret $31, ($26), 1
-
- .end GC_push_regs
diff --git a/boehm-gc/sparc_mach_dep.S b/boehm-gc/sparc_mach_dep.S
deleted file mode 100644
index 06a0f3b4673..00000000000
--- a/boehm-gc/sparc_mach_dep.S
+++ /dev/null
@@ -1,67 +0,0 @@
-! SPARCompiler 3.0 and later apparently no longer handles
-! asm outside functions. So we need a separate .s file
-! This is only set up for SunOS 5, not SunOS 4.
-! Assumes this is called before the stack contents are
-! examined.
-
- .seg "text"
- .globl GC_save_regs_in_stack
- .globl GC_push_regs
-GC_save_regs_in_stack:
-GC_push_regs:
-#if defined(__arch64__) || defined(__sparcv9)
- save %sp,-128,%sp
- flushw
- ret
- restore %sp,2047+128,%o0
-#else /* 32 bit SPARC */
- ta 0x3 ! ST_FLUSH_WINDOWS
- mov %sp,%o0
- retl
- nop
-#endif /* 32 bit SPARC */
-.GC_save_regs_in_stack_end:
- .size GC_save_regs_in_stack,.GC_save_regs_in_stack_end-GC_save_regs_in_stack
-
-
- .globl GC_clear_stack_inner
-GC_clear_stack_inner:
-#if defined(__arch64__) || defined(__sparcv9)
- mov %sp,%o2 ! Save sp
- add %sp,2047-8,%o3 ! p = sp+bias-8
- add %o1,-2047-192,%sp ! Move sp out of the way,
- ! so that traps still work.
- ! Includes some extra words
- ! so we can be sloppy below.
-loop:
- stx %g0,[%o3] ! *(long *)p = 0
- cmp %o3,%o1
- bgu,pt %xcc, loop ! if (p > limit) goto loop
- add %o3,-8,%o3 ! p -= 8 (delay slot)
- retl
- mov %o2,%sp ! Restore sp., delay slot
-#else /* 32 bit SPARC */
- mov %sp,%o2 ! Save sp
- add %sp,-8,%o3 ! p = sp-8
- clr %g1 ! [g0,g1] = 0
- add %o1,-0x60,%sp ! Move sp out of the way,
- ! so that traps still work.
- ! Includes some extra words
- ! so we can be sloppy below.
-loop:
- std %g0,[%o3] ! *(long long *)p = 0
- cmp %o3,%o1
- bgu loop ! if (p > limit) goto loop
- add %o3,-8,%o3 ! p -= 8 (delay slot)
- retl
- mov %o2,%sp ! Restore sp., delay slot
-#endif /* 32 bit SPARC */
-.GC_clear_stack_inner_end:
- .size GC_clear_stack_inner,.GC_clear_stack_inner_end-GC_clear_stack_inner
-
-
-
-
-
-
-
diff --git a/build_gcc b/build_gcc
new file mode 100755
index 00000000000..f81941f2376
--- /dev/null
+++ b/build_gcc
@@ -0,0 +1,338 @@
+#!/bin/sh
+# APPLE LOCAL file B&I
+
+set -x
+
+# -arch arguments are different than configure arguments. We need to
+# translate them.
+
+TRANSLATE_ARCH="sed -e s/ppc/powerpc/ -e s/i386/i686/"
+
+# Build GCC the "Apple way".
+# Parameters:
+
+# The first parameter is a space-separated list of the architectures
+# the compilers will run on. For instance, "ppc i386". If the
+# current machine isn't in the list, it will (effectively) be added.
+HOSTS=`echo $1 | $TRANSLATE_ARCH `
+
+# The second parameter is a space-separated list of the architectures the
+# compilers will generate code for. If the current machine isn't in
+# the list, a compiler for it will get built anyway, but won't be
+# installed.
+TARGETS=`echo $2 | $TRANSLATE_ARCH`
+
+# The GNU makefile target ('bootstrap' by default).
+BOOTSTRAP=${BOOTSTRAP-bootstrap}
+
+# The B&I build srcript (~rc/bin/buildit) accepts an '-othercflags'
+# command-line flag, and captures the argument to that flag in
+# $RC_NONARCH_CFLAGS (and mysteriously prepends '-pipe' thereto).
+# We will allow this to override the default $CFLAGS and $CXXFLAGS.
+
+CFLAGS=${RC_NONARCH_CFLAGS/-pipe/}
+CFLAGS=${CFLAGS:-"-g -O2"}
+
+# This isn't a parameter; it is the architecture of the current machine.
+BUILD=`arch | $TRANSLATE_ARCH`
+
+# The third parameter is the path to the compiler sources. There should
+# be a shell script named 'configure' in this directory. This script
+# makes a copy...
+ORIG_SRC_DIR="$3"
+
+# The fourth parameter is the location where the compiler will be installed,
+# normally "/usr". You can move it once it's built, so this mostly controls
+# the layout of $DEST_DIR.
+DEST_ROOT="$4"
+
+# The fifth parameter is the place where the compiler will be copied once
+# it's built.
+DEST_DIR="$5"
+
+# The sixth parameter is a directory in which to place information (like
+# unstripped executables and generated source files) helpful in debugging
+# the resulting compiler.
+SYM_DIR="$6"
+
+# The current working directory is where the build will happen.
+# It may already contain a partial result of an interrupted build,
+# in which case this script will continue where it left off.
+DIR=`pwd`
+
+# This isn't a parameter; it's the version of the compiler that we're
+# about to build. It's included in the names of various files and
+# directories in the installed image.
+VERS=`sed -n -e '/version_string/s/.*\"\([^ \"]*\)[ \"].*/\1/p' \
+ < $ORIG_SRC_DIR/gcc/version.c || exit 1`
+
+# This isn't a parameter either, it's the major version of the compiler
+# to be built. It's VERS but only up to the second '.' (if there is one).
+MAJ_VERS=`echo $VERS | sed 's/\([0-9]*\.[0-9]*\)\..*/\1/'`
+
+########################################
+# Run the build.
+
+# Create the source tree we'll actually use to build, deleting
+# tcl since it doesn't actually build properly in a cross environment
+# and we don't really need it.
+SRC_DIR=$DIR/src
+rm -rf $SRC_DIR || exit 1
+mkdir $SRC_DIR || exit 1
+ln -s $ORIG_SRC_DIR/* $SRC_DIR/ || exit 1
+rm -rf $SRC_DIR/tcl $SRC_DIR/expect $SRC_DIR/dejagnu || exit 1
+
+# These are the configure and build flags that are used.
+CONFIGFLAGS="--disable-checking \
+ --prefix=$DEST_ROOT \
+ --mandir=\${prefix}/share/man \
+ --enable-languages=c,objc,c++ --disable-libada \
+ --program-transform-name=/^[cg][^.-]*$/s/$/-$MAJ_VERS/ \
+ --with-gxx-include-dir=\${prefix}/include/gcc/darwin/$MAJ_VERS/c++ \
+ --build=$BUILD-apple-darwin"
+
+# Figure out how many make processes to run.
+SYSCTL=`sysctl -n hw.activecpu`
+
+# hw.activecpu only available in 10.2.6 and later
+if [ -z "$SYSCTL" ]; then
+ SYSCTL=`sysctl -n hw.ncpu`
+fi
+
+# sysctl -n hw.* does not work when invoked via B&I chroot /BuildRoot.
+# Builders can default to 2, since even if they are single processor,
+# nothing else is running on the machine.
+if [ -z "$SYSCTL" ]; then
+ SYSCTL=2
+fi
+# The $LOCAL_MAKEFLAGS variable can be used to override $MAKEFLAGS.
+MAKEFLAGS=${LOCAL_MAKEFLAGS-"-j $SYSCTL"}
+
+# Build the native GCC. Do this even if the user didn't ask for it
+# because it'll be needed for the bootstrap.
+mkdir -p $DIR/obj-$BUILD-$BUILD $DIR/dst-$BUILD-$BUILD || exit 1
+cd $DIR/obj-$BUILD-$BUILD || exit 1
+if [ \! -f $DIR/$BUILD-configured ] ; then
+ $SRC_DIR/configure $CONFIGFLAGS \
+ --host=$BUILD-apple-darwin --target=$BUILD-apple-darwin || exit 1
+ touch $DIR/$BUILD-configured || exit 1
+fi
+make $MAKEFLAGS $BOOTSTRAP CFLAGS="$CFLAGS" CXXFLAGS="$CFLAGS" || exit 1
+make $MAKEFLAGS DESTDIR=$DIR/dst-$BUILD-$BUILD install-gcc install-target \
+ CFLAGS="$CFLAGS" CXXFLAGS="$CFLAGS" || exit 1
+
+# Add the compiler we just built to the path, giving it appropriate names.
+D=$DIR/dst-$BUILD-$BUILD/usr/bin
+ln -f $D/gcc-$MAJ_VERS $D/gcc || exit 1
+ln -f $D/gcc $D/$BUILD-apple-darwin-gcc || exit 1
+PATH=$DIR/dst-$BUILD-$BUILD/usr/bin:$PATH
+
+# The cross-tools' build process expects to find certain programs
+# under names like 'i386-apple-darwin-ar'; so make them.
+# Annoyingly, ranlib changes behaviour depending on what you call it,
+# so we have to use a shell script for indirection, grrr.
+rm -rf $DIR/bin || exit 1
+mkdir $DIR/bin || exit 1
+for prog in ar nm ranlib ; do
+ for t in `echo $TARGETS $HOSTS | sort -u`; do
+ P=$DIR/bin/${t}-apple-darwin-${prog}
+ echo '#!/bin/sh' > $P || exit 1
+ echo 'exec /usr/bin/'${prog}' $*' >> $P || exit 1
+ chmod a+x $P || exit 1
+ done
+done
+PATH=$DIR/bin:$PATH
+
+# Build the cross-compilers, using the compiler we just built.
+for t in $TARGETS ; do
+ if [ $t != $BUILD ] ; then
+ mkdir -p $DIR/obj-$BUILD-$t $DIR/dst-$BUILD-$t || exit 1
+ cd $DIR/obj-$BUILD-$t || exit 1
+ $SRC_DIR/configure $CONFIGFLAGS \
+ --program-prefix=$t-apple-darwin- \
+ --host=$BUILD-apple-darwin --target=$t-apple-darwin || exit 1
+ make $MAKEFLAGS all CFLAGS="$CFLAGS" CXXFLAGS="$CFLAGS" || exit 1
+ make $MAKEFLAGS DESTDIR=$DIR/dst-$BUILD-$t install-gcc install-target \
+ CFLAGS="$CFLAGS" CXXFLAGS="$CFLAGS" || exit 1
+
+ # Add the compiler we just built to the path.
+ PATH=$DIR/dst-$BUILD-$t/usr/bin:$PATH
+ fi
+done
+
+# Rearrange various libraries, for no really good reason.
+for t in $TARGETS ; do
+ DT=$DIR/dst-$BUILD-$t
+ D=`echo $DT/usr/lib/gcc/$t-apple-darwin/$VERS`
+ if [ $t == $BUILD ] ; then
+ mv $DT/usr/lib/libstdc++.a $D || exit 1
+ mv $DT/usr/lib/libsupc++.a $D || exit 1
+ else
+ DD=$DT/usr/${t}-apple-darwin/lib
+ mv $DD/libstdc++.a $D || exit 1
+ mv $DD/libsupc++.a $D || exit 1
+ fi
+ mv $D/static/libgcc.a $D/libgcc_static.a || exit 1
+ mv $D/kext/libgcc.a $D/libcc_kext.a || exit 1
+ rm -r $D/static $D/kext || exit 1
+done
+
+# Build the cross-hosted compilers.
+for h in $HOSTS ; do
+ if [ $h != $BUILD ] ; then
+ for t in $TARGETS ; do
+ mkdir -p $DIR/obj-$h-$t $DIR/dst-$h-$t || exit 1
+ cd $DIR/obj-$h-$t || exit 1
+ if [ $h = $t ] ; then
+ pp=
+ else
+ pp=$t-apple-darwin-
+ fi
+
+ $SRC_DIR/configure $CONFIGFLAGS \
+ --program-prefix=$pp \
+ --host=$h-apple-darwin --target=$t-apple-darwin || exit 1
+ make $MAKEFLAGS all-gcc CFLAGS="$CFLAGS" CXXFLAGS="$CFLAGS" || exit 1
+ make $MAKEFLAGS DESTDIR=$DIR/dst-$h-$t install-gcc \
+ CFLAGS="$CFLAGS" CXXFLAGS="$CFLAGS" || exit 1
+ done
+ fi
+done
+
+########################################
+# Construct the actual destination root, by copying stuff from
+# $DIR/dst-* to $DEST_DIR, with occasional 'lipo' commands.
+
+cd $DEST_DIR || exit 1
+
+# Clean out DEST_DIR in case -noclean was passed to buildit.
+rm -rf * || exit 1
+
+# HTML documentation
+HTMLDIR=/Developer/Documentation/DeveloperTools
+mkdir -p .$HTMLDIR || exit 1
+cp -rp $DIR/obj-$BUILD-$BUILD/gcc/doc/HTML/* .$HTMLDIR/ || exit 1
+
+# Manual pages
+mkdir -p .$DEST_ROOT/share || exit 1
+cp -rp $DIR/dst-$BUILD-$BUILD$DEST_ROOT/share/man .$DEST_ROOT/share/ \
+ || exit 1
+
+# libexec
+LIBEXEC_FILES=` \
+ ls $DIR/dst-$BUILD-$BUILD$DEST_ROOT/libexec/gcc/$BUILD-apple-darwin/$VERS \
+ | grep -v install-tools || exit 1`
+for t in $TARGETS ; do
+ DL=$DEST_ROOT/libexec/gcc/$t-apple-darwin/$VERS
+ mkdir -p .$DL || exit 1
+ for f in $LIBEXEC_FILES ; do
+ lipo -output .$DL/$f -create $DIR/dst-*-$t$DL/$f || exit 1
+ done
+done
+
+# bin
+# The native drivers ('native' is different in different architectures).
+BIN_FILES=`ls $DIR/dst-$BUILD-$BUILD$DEST_ROOT/bin | grep '^[^-]*-[0-9.]*$' \
+ | grep -v gccbug | grep -v gcov || exit 1`
+mkdir .$DEST_ROOT/bin
+for f in $BIN_FILES ; do
+ lipo -output .$DEST_ROOT/bin/$f -create $DIR/dst-*$DEST_ROOT/bin/$f || exit 1
+done
+# gcov, which is special only because it gets built multiple times and lipo
+# will complain if we try to add two architectures into the same output.
+TARG0=`echo $TARGETS | cut -d ' ' -f 1`
+lipo -output .$DEST_ROOT/bin/gcov-$MAJ_VERS -create \
+ $DIR/dst-*-$TARG0$DEST_ROOT/bin/gcov-$MAJ_VERS || exit 1
+# The fully-named drivers, which have the same target on every host.
+for t in $TARGETS ; do
+ lipo -output .$DEST_ROOT/bin/$t-apple-darwin-gcc-$VERS -create \
+ $DIR/dst-*-$t$DEST_ROOT/bin/$t-apple-darwin-gcc-$VERS || exit 1
+done
+
+# lib
+mkdir -p .$DEST_ROOT/lib/gcc || exit 1
+for t in $TARGETS ; do
+ cp -rp $DIR/dst-$BUILD-$t$DEST_ROOT/lib/gcc/$t-apple-darwin \
+ .$DEST_ROOT/lib/gcc || exit 1
+done
+SHARED_LIBS=`ls $DIR/dst-$BUILD-$BUILD$DEST_ROOT/lib | grep '\.dylib$'`
+for l in $SHARED_LIBS ; do
+ F=$DIR/dst-$BUILD-$BUILD$DEST_ROOT/lib/$l
+ if [ \! -L $F ] ; then
+ if [ -f $DIR/dst-$BUILD-*$DEST_ROOT/*-apple-darwin/lib/$l ] ; then
+ lipo -output .$DEST_ROOT/lib/$l -create $F \
+ $DIR/dst-$BUILD-*$DEST_ROOT/*-apple-darwin/lib/$l || exit 1
+ else
+ cp -p $F .$DEST_ROOT/lib/$l || exit 1
+ fi
+ F1=`echo $l \
+ | sed 's/\(\.[0-9]\{1,\}\)\(\.[0-9]\{1,\}\)\{1,\}\.dylib/\1.dylib/'`
+ F0=`echo $l | sed 's/\(\.[0-9]\{1,\}\)\{1,\}\.dylib/.dylib/'`
+ ln -s $l .$DEST_ROOT/lib/$F1 || exit 1
+ for t in $TARGETS ; do
+ ln -s ../../../$F1 .$DEST_ROOT/lib/gcc/$t-apple-darwin/$VERS/$F0 \
+ || exit 1
+ done
+ fi
+done
+
+# FIXME
+# This is a workaround for gcc_select, pending approval of a patch that
+# makes it unnecessary. Radar 3538294.
+mkdir -p .$DEST_ROOT/libexec/gcc/darwin/ppc/$MAJ_VERS
+mkdir -p .$DEST_ROOT/lib/gcc/darwin/$MAJ_VERS
+
+# include
+HEADERPATH=$DEST_ROOT/include/gcc/darwin/$MAJ_VERS
+mkdir -p .$HEADERPATH || exit 1
+cp -rp $DIR/dst-$BUILD-$BUILD$HEADERPATH/c++ \
+ .$HEADERPATH/ || exit 1
+for t in $TARGETS ; do
+ DS=$HEADERPATH/c++
+ [ $t = $BUILD ] || \
+ cp -rp $DIR/dst-$BUILD-$t$DS/$t-apple-darwin .$DS/ || exit 1
+done
+
+# Some headers are installed from more-hdrs/. They all share
+# one common feature: they shouldn't be installed here. Sometimes,
+# they should be part of FSF GCC and installed from there; sometimes,
+# they should be installed by some completely different package; sometimes,
+# they only exist for codewarrior compatibility and codewarrior should provide
+# its own.
+cd $SRC_DIR/more-hdrs
+for h in `echo [^C]*` ; do
+ cp -r $h $DEST_DIR$HEADERPATH/$h || exit 1
+ for t in $TARGETS ; do
+ THEADERPATH=$DEST_DIR$DEST_ROOT/lib/gcc/${t}-apple-darwin/$VERS/include
+ [ -f $THEADERPATH/$h ] || \
+ ln -s ../../../../../include/gcc/darwin/$MAJ_VERS/$h $THEADERPATH/$h || \
+ exit 1
+ done
+done
+
+########################################
+# Save the source files and objects needed for debugging
+
+cd $SYM_DIR || exit 1
+
+# Clean out SYM_DIR in case -noclean was passed to buildit.
+rm -rf * || exit 1
+
+# Save executables and libraries.
+cd $DEST_DIR || exit 1
+find . \( -perm -0111 -or -name \*.a \) -type f -print \
+ | cpio -pdml $SYM_DIR || exit 1
+# Save source files.
+mkdir $SYM_DIR/src || exit 1
+cd $DIR || exit 1
+find obj-* -name \*.\[chy\] -print | cpio -pdml $SYM_DIR/src || exit 1
+
+########################################
+# Strip the executables and libraries
+find $DEST_DIR -perm -0111 \! -name \*.dylib -type f -print \
+ | xargs strip || exit 1
+find $DEST_DIR \( -name \*.a -or -name \*.dylib \) -type f -print \
+ | xargs strip -SX || exit 1
+
+# Done!
+exit 0
diff --git a/gcc/ChangeLog.apple-ppc b/gcc/ChangeLog.apple-ppc
new file mode 100644
index 00000000000..6285b1f9f55
--- /dev/null
+++ b/gcc/ChangeLog.apple-ppc
@@ -0,0 +1,331 @@
+2004-04-20 Geoffrey Keating <geoffk@apple.com>
+
+ * c-cppbuiltin.c (define__GNUC__): Better precision and more
+ error checking for code defining __APPLE_CC__.
+ * testsuite/gcc.apple/applecc.c: New.
+
+2004-04-15 Devang Patel <dpatel@apple.com>
+
+ * config/i386.h: Add static tree nodes for vector types to
+ accomodate tree.h changes due to local Altivec patch.
+
+2004-04-15 Caroline Tice <ctice@apple.com>
+
+ Fix various problems related to hot/cold partitioning (but not all of
+ them yet).
+ * bb-reorder.c (tm_p.h): Add new include statement.
+ (HAVE_return): Define HAVE_return appropriately if not already defined.
+ (find_rarely_executed_basic_blocks_and_crossing_edges): Modify to
+ only mark crossing edges if architecture supports named sections.
+ (fix_crossing_conditional_branches): Add test for HAVE_return before
+ calling gen_return.
+ (fix_crossing_unconditional_branches): Change VOIDmode to Pmode in call
+ to gen_rtl_LABEL_REF.
+ (fix_edges_for_rarely_executed_code): Only "fix" branches and add
+ REG_CROSSING_JUMP notes if the architecture supports named sections.
+ (reorder_basic_blocks): Change (* targetm.cannot_modify_jumps_p ())
+ into (targetm.cannot_modify_jumps_p ()). Modify to only add
+ NOTE_INSN_UNLIKELY_EXECUTED_CODE notes if the architecture supports
+ named sections.
+ * cfglayout.c (fixup_reorder_chain): Modify code that adds
+ NOTE_INSN_UNLIKELY_EXECUTED_CODE and REG_CROSSING_JUMP notes, to only
+ do so if architecture supports named sections.
+ * cfgrtl.c (target.h): Add new include statement.
+ (force_nonfallthru_and_redirect): Modify code that adds
+ NOTE_INSN_UNLIKELY_EXECUTED_CODE and REG_CROSSING_JUMP notes, to only
+ do so if architecture supports named sections.
+ (commit_one_edge_insertion): Likewise.
+ * dbxout.c (dbxout_source_file): Fix bug, when writing out source
+ location debug information, to not change to the wrong section.
+ * defaults.h (NORMAL_TEXT_SECTION_NAME): Remove this definition.
+ (SECTION_FORMAT_STRING): Remove this definition.
+ * final.c (final_scan_insn): Remove unnecessary in_unlikely_text_section
+ test from if statement. Modify code that switches sections to not
+ do so if architecture does not support named sections. Cleaned up
+ if statement.
+ * ifcvt.c (if_convert): Modified test that disables optimization when
+ partitioning, to not disable it if the architecture does not support
+ named sections.
+ * passes.c (rest_of_compilation): Removed flag_exceptions test from
+ code that calls partitioning, as this is already taken care of
+ in decode_options.
+ * predict.c (choose_function_section): Modify to NOT choose hot or
+ cold sections for the function decl if we are doing partitioning
+ optimization (want to leave it up to the hot/cold partitioning
+ optimization, which is more fine-grained).
+ * varasm.c (text_section): Restore code that outputs assembly for
+ the text section to its original code.
+ (unlikely_text_section): Modify to always use named_section for
+ writing out section directive, remove unnecessary ifdef, and
+ use ASM_OUTPUT_LABEL for labelling the start of the
+ cold section.
+ (in_unlikely_text_section): Modify to deal correctly with being in
+ a named section.
+ (function_section): Restore code for generating section directives
+ to its original order.
+ * config/darwin.c (darwin_asm_named_section): Restore code that
+ generates section directive to its original state.
+ * config/i386/darwin.h (ASM_OUTPUT_ALIGN): Add in_unlikely_text_section ()
+ to an if test that tests for in_text_section ().
+ * config/rs6000/darwin.h (NORMAL_TEXT_SECTION_NAME): Remove definition.
+ (SECTION_FORMAT_STRING): Remove definition.
+
+2004-04-10 Paolo Bonzini <bonzini@gnu.org>
+ Richard Henderson <rth@redhat.com>
+
+ PR target/14899
+
+ * c-common.c (vector_types_compatible_p): New function.
+ * c-typeck.c (comptypes): Recurse on vector types,
+ treat a non-opaque type as equivalent to an opaque type.
+ (convert_for_assignment): Use vector_types_compatible_p.
+ (digest_init): Use vector_types_compatible_p to check
+ validness of constant vector initializers; otherwise treat
+ them as scalars
+ * tree.c (make_or_reuse_type): New.
+ (build_common_tree_nodes): Use it.
+ * cp/call.c (standard_conversion): Likewise.
+ * cp/typeck.c (comptypes): Recurse on vector types, do not
+ treat a non-opaque type as equivalent to an opaque type.
+ (convert_for_assignment): Use vector_types_compatible_p.
+
+2004-04-13 Fariborz Jahanian <fjahanian@apple.com>
+
+ * combine.c (combine_instructions):
+ Try insn with each REG_EQUAL note it links back to.
+ (unmentioned_reg_p_1, unmentioned_reg_p): New functions.
+ Brought from tree-ssa branch.
+
+2004-04-09 Dale Johannesen <dalej@apple.com>
+
+ Roll in gcc-1552 enhancement for separate stack temps.
+ Turn on -fstrict-aliasing with -fast.
+ * function.c (assign_stack_local_with_alias): New function.
+ * rtl.h (assign_stack_local_with_alias): Declare it.
+ * config/rs6000/rs6000.c (rs6000_override_options): Turn on strict
+ aliasing with -fast.
+ * config/rs6000/rs6000.md (floatsidf2): Use
+ assign_stack_local_with_alias.
+ (floatunssidf2): Ditto.
+ (fix_truncdfsi2): Ditto.
+
+2004-04-07 Fariborz Jahanian <fjahanian@apple.com>
+
+ Roll in Ziem Laski's Altivec front-end fixes to
+ support MOTOROLA's Altivec syntax.
+ * Makefile.in: Add c-lex.o dependencies.
+ * c-common.c (vector_constructor_from_expr): New function.
+ * c-common.h (vector_constructor_from_expr): Add declaration.
+ * c-lex.c: include target.h, cpphash.h. Add lexer support
+ for new syntax.
+ (c_lex_prepend): new function. (c_lex_peek): new function.
+ * c-pragma.h: add (c_lex_peek, c_lex_prepend) declarations.
+
+2004-04-06 Dale Johannesen <dalej@apple.com>
+
+ Roll in Zdenek Dvorak's rewrite of doloop optimization.
+ * Makefile.in: add loop-doloop.*, remove doloop.*
+ * loop-doloop.c: New.
+ * doloop.c: Remove.
+ * cfgloop.h: Add new function declarations.
+ * cfgloopanal.c: Add get_loop_level.
+ * loop-iv.c: Recognize unexecuted loops.
+ * loop.c: Remove call to old doloop optimization.
+ * loop.h: Remove LOOP_BCT.
+ * passes.c: Ditto. Call new doloop optimization.
+ * config/rs6000/rs6000-protos.h: Remove duplicate declarations.
+ * config/rs6000/rs6000.c: Cosmetic cleanups. Add -freorder-blocks
+ to -fast.
+
+2004-04-02 Ziemowit Laski <zlaski@apple.com>
+
+ Remove APPLE LOCAL AltiVec code whenever possible; merge in
+ AltiVec/VECTOR_TYPE-handling code from mainline.
+
+2004-04-01 Fariborz Jahanian <fjahanian@apple.com>
+
+ * Makefile.in: add $(PARAMS_H) $(TM_P_H) dependencies
+ for sched-rgn.o.
+ * params.def: add definitions for
+ max-sched-region-blocks and max-sched-region-insns.
+ * sched-rgn.c (too_large): change return type to bool.
+ Use the parametrized values of max-sched-region-blocks,
+ max-sched-region-insns for computing upper limits for
+ interblock scheduling.
+ * doc/invoke.texi: Document max-sched-region-blocks,
+ max-sched-region-insns.
+
+2004-04-01 Caroline Tice <ctice@apple.com>
+
+ * basic-block.h (struct edge_def): Add new field, crossing_edge.
+ (struct basic_block_def): Add new field, partition.
+ (UNPARTITIONED, HOT_PARTITION, COLD_PARTITION): New constant macro
+ definitions.
+ (partition_hot_cold_basic_blocks): Add extern function
+ declaration.
+ * bb-reorder.c (function.h, obstack.h, expr.h, regs.h): Add four new
+ include statements.
+ (N_ROUNDS): Increase the maximum number of rounds by 1.
+ (branch_threshold): Add array value for new round.
+ (exec_threshold): Add array value for new round.
+ (push_to_next_round_p): New function.
+ (add_unlikely_executed_notes): New function.
+ (find_rarely_executed_basic_blocks_and_crossing_edges): New function.
+ (mark_bb_for_unlikely_executed_section): New function.
+ (add_labels_and_missing_jumps): New function.
+ (add_reg_crossing_jump_notes): New function.
+ (fix_up_fall_thru_edges): New function.
+ (find_jump_block): New function.
+ (fix_crossing_conditional_branches): New function.
+ (fix_crossing_unconditional_branches): New function.
+ (fix_edges_for_rarely_executed_code): New function.
+ (partition_hot_cold_basic_blocks): New function.
+ (find_traces): Add an extra round for partitioning hot/cold
+ basic blocks.
+ (find_traces_1_round): Add a parameter. Modify to push all cold blocks,
+ and only cold blocks, into the last (extra) round of collecting traces.
+ (better_edge_p): Add a parameter. Modify to favor non-crossing edges
+ over crossing edges.
+ (bb_to_key): Add code to correctly identify cold blocks when
+ doing partitioning.
+ (connect_traces): Modify to connect all the non-cold traces first, then
+ go back and connect up all the cold traces.
+ (reorder_basic_blocks): Add call to add_unlikely_executed_notes.
+ * cfg.c (entry_exit_blocks): Add initialization for partition field in
+ entry and exit blocks.
+ * cfgbuild.c (make_edges): Update current_function_has_computed_jump
+ if we are doing hot/cold partitioning.
+ * cfgcleanup.c (cfglayout.h): Add new include statement.
+ (try_simplify_condjump): Modify to not attempt on blocks with jumps
+ that cross section boundaries.
+ (try_forward_edges): Likewise.
+ (merge_blocks_move_predecessor_nojumps): Likewise.
+ (merge_blocks_move_successor_nojumps): Likewise.
+ (merge_blocks_move): Likewise.
+ (try_crossjump_to_edge): Modify to not attempt after we have done
+ the block partitioning.
+ (try_crossjump_bb): Modify to not attempt on blocks with jumps that
+ cross section boundaries.
+ (try_optimize_cfg): Likewise.
+ * cfghooks.c (tidy_fallthru_edges): Modify to not remove indirect
+ jumps that cross section boundaries.
+ * cfglayout.c (flags.h): Add new include statement.
+ (update_unlikely_executed_notes): New function.
+ (fixup_reorder_chain): Add code so when a new jumping basic block is
+ added, it's UNLIKELY_EXECUTED_CODE and REG_CROSSING_JUMP notes are
+ updated appropriately.
+ (duplicate_insn_chain): Add code to duplicate the new NOTE insn
+ introduced by this optimization.
+ * cfglayout.h (scan_ahead_for_unlikely_executed_note): Add new
+ extern function declaration.
+ * cfgrtl.c (can_delete_note_p): Add NOTE_INSN_UNLIKELY_EXECUTED_CODE to
+ list of notes that can be deleted.
+ (create_basic_block_structure): Add initialization for partition field.
+ (rtl_can_merge_blocks): Modify to test blocks for jumps that cross
+ section boundaries.
+ (try_redirect_by_replacing_jump): Modify to not attempt on jumps that
+ cross section boundaries.
+ (commit_one_edge_insertion): Add code so newly created basic block
+ ends up in correct (hot or cold) section. Modify to disallow
+ insertions before NOTE_INSN_UNLIKELY_EXECUTED_CODE notes.
+ (rtl_verify_flow_info_1): Add code to verify that no fall_thru edge
+ crosses section boundaries.
+ (cfg_layout_can_merge_blocks_p): Modify to test blocks for jumps that
+ cross section boundaries.
+ (force_nonfallthru_and_redirect): Modify to make sure new basic block
+ ends up in correct section, with correct notes attached.
+ * common.opt (freorder-blocks-and-partition): Add new flag for this
+ optimization.
+ * dbxout.c (dbx_function_end): Add code to make sure scope labels at
+ the end of functions are written into the correct (hot or cold)
+ section.
+ (dbx_source_file): Add code so writing debug file information
+ doesn't incorrectly change sections.
+ * defaults.h (NORMAL_TEXT_SECTION_NAME): New constant macro, for use
+ in partitioning hot/cold basic blocks into separate sections.
+ (SECTION_FORMAT_STRING): New constant macro, for linux/i386 hot/cold
+ section partitioning.
+ (HAS_LONG_COND_BRANCH): New constant macro, indicating whether or not
+ conditional branches can span all of memory.
+ (HAS_LONG_UNCOND_BRANCH): New constant macro, indicationg whether or not
+ unconditional branches can span all of memory.
+ * final.c (scan_ahead_for_unlikely_executed_note): New function.
+ (final_scan_insn): Add code to check for NOTE instruction indicating
+ whether basic block belongs in hot or cold section, and to make sure
+ the current basic block is being written to the appropriate section.
+ Also added code to ensure that jump table basic blocks end up in the
+ correct section.
+ * flags.h (flag_reorder_blocks_and_partition): New flag.
+ * ifcvt.c (find_if_case_1): Modify to not attempt if conversion if
+ one of the branches has a jump that crosses between sections.
+ (find_if_case_2): Likewise.
+ (ifcvt): Modify to not attempt to mark loop exit edges after
+ hot/cold partitioning has occurred.
+ * opts.c (decode_options): Code to handle new flag,
+ flag_reorder_blocks_and_partition; also to turn it off if
+ flag_exceptions is on.
+ (common_handle_option): Code to handle new flag,
+ flag_reorder_blocks_and_partition.
+ * output.h (unlikely_text_section): New extern function declaration.
+ (in_unlikely_text_section): New extern function declaration.
+ * passes.c (rest_of_handle_stack_regs): Add
+ flag_reorder_blocks_and_partition as an 'or' condition for calling
+ reorder_basic_blocks.
+ (rest_of_handle_reorder_blocks): Add flag_reorder_blocks_and_partition
+ as an 'or' condition for calling reorder_basic_blocks.
+ (rest_of_compilation): Add call to partition_hot_cold_basic_blocks.
+ * print-rtl.c (print_rtx): Add code for handling new note,
+ NOTE_INSN_UNLIKELY_EXECUTED_CODE
+ * rtl.c (NOTE_INSN_UNLIKELY_EXECUTED_CODE): New note insn (see below).
+ (REG_CROSSING_JUMP): New kind of reg_note, to mark jumps that
+ cross between section boundaries.
+ * rtl.h (NOTE_INSN_UNLIKELY_EXECUTED_CODE): New note instruction,
+ indicating the basic block containing it belongs in the cold section.
+ (REG_CROSSING_JUMP): New type of reg_note, to mark jumps that cross
+ between hot and cold sections.
+ * toplev.c (flag_reorder_blocks_and_partition): Add code to
+ initialize this flag, and to tie it to the command-line option
+ freorder-blocks-and-partition.
+ * varasm.c (cfglayout.h): Add new include statement.
+ (unlikely_section_label_printed): New global variable, used for
+ determining when to output section name labels for cold sections.
+ (in_section): Add in_unlikely_executed_text to enum data structure.
+ (text_section): Modify code to use SECTION_FORMAT_STRING and
+ NORMAL_TEXT_SECTION_NAME macros.
+ (unlikely_text_section): New function.
+ (in_unlikely_text_section): New function.
+ (function_section): Add code to make sure beginning of function is
+ written into correct section (hot or cold).
+ (assemble_start_function): Add code to make sure stuff is written to
+ the correct section.
+ (assemble_zeros): Add in_unlikely_text_section as an 'or' condition
+ to an if statement that was checking 'in_text_section'.
+ (assemble_variable): Add 'in_unlikely_text_section' as an 'or'
+ condition to an if statement that was checking 'in_text_section'.
+ (default_section_type_flags_1): Add check: if in cold section
+ flags = SECTION_CODE.
+ * config/darwin.c (darwin_asm_named_section): Modify to use
+ SECTION_FORMAT_STRING if we are partitioning hot/cold blocks.
+ * config/i386/i386.h (HAS_LONG_COND_BRANCH): Defined this macro
+ specifically for the i386.
+ (HAS_LONG_UNCOND_BRANCH): Defined this macro specifically for the i386.
+ * config/rs6000/darwin.h (UNLIKELY_EXECUTED_TEXT_SECTION_NAME): Change
+ text string to something more informative.
+ (NORMAL_TEXT_SECTION_NAME): Add new definition.
+ (SECTION_FORMAT_STRING): Add new definition.
+ * config/rs6000/rs6000.c (rs6000_assemble_integer): Add
+ '!in_unlikely_text_section' as an 'and' condition to an if statement
+ that was already checking '!in_text_section'.
+ (rs6000_override_options): Turn on flag_reorder_blocks_and_partition
+ with "-fast".
+ * config/rs6000/sysv4.h (HOT_TEXT_SECTION_NAME,NORMAL_TEXT_SECTION_NAME,
+ UNLIKELY_EXECUTED_TEXT_SECTION_NAME,SECTION_FORMAT_STRING): Make
+ sure these are properly defined for linux on ppc.
+ * doc/invoke.texi (freorder-blocks-and-partition): Add documentation
+ for this new flag.
+ * doc/rtl.texi (REG_CROSSING_JUMP): Add documentation for new
+ reg_note.
+ * doc/tm.texi (NORMAL_TEXT_SECTION_NAME, SECTION_FORMAT_STRING,
+ HAS_LONG_COND_BRANCH, HAS_LONG_UNCOND_BRANCH): Add documentation for
+ these new macros.
+
diff --git a/gcc/Makefile.in b/gcc/Makefile.in
index adc538e9a34..99afd4c390c 100644
--- a/gcc/Makefile.in
+++ b/gcc/Makefile.in
@@ -188,6 +188,18 @@ insn-conditions.o-warn = -Wno-error
# Bison-1.75 output often yields (harmless) -Wtraditional warnings
gengtype-yacc.o-warn = -Wno-error
c-parse.o-warn = -Wno-error
+
+# APPLE LOCAL begin unclean apple code
+alloc-pool.o-warn = -Wno-long-double
+ggc-page.o-warn = -Wno-long-double
+darwin-c.o-warn = -Wno-error
+stub-objc.o-warn = -Wno-error
+timevar.o-warn = -Wno-error
+insn-output.o-warn = -Wno-error
+darwin.o-warn = -Wno-error
+insn-emit.o-warn = -Wno-error
+# APPLE LOCAL end unclean apple code
+
# flex output may yield harmless "no previous prototype" warnings
gengtype-lex.o-warn = -Wno-error
# SYSCALLS.c misses prototypes
@@ -508,11 +520,14 @@ INSTALL_LIBGCC = install-libgcc
# Options to use when compiling libgcc2.a.
#
LIBGCC2_DEBUG_CFLAGS = -g
-LIBGCC2_CFLAGS = -O2 $(LIBGCC2_INCLUDES) $(GCC_CFLAGS) $(TARGET_LIBGCC2_CFLAGS) $(LIBGCC2_DEBUG_CFLAGS) $(GTHREAD_FLAGS) -DIN_LIBGCC2 -D__GCC_FLOAT_NOT_NEEDED @inhibit_libc@
+# APPLE LOCAL control opt level. ilr
+LIBGCC2_CFLAGS = $(LIBGCC2_OPT) $(LIBGCC2_INCLUDES) $(GCC_CFLAGS) $(TARGET_LIBGCC2_CFLAGS) $(LIBGCC2_DEBUG_CFLAGS) $(GTHREAD_FLAGS) -DIN_LIBGCC2 -D__GCC_FLOAT_NOT_NEEDED @inhibit_libc@
# Additional options to use when compiling libgcc2.a.
# Some targets override this to -isystem include
LIBGCC2_INCLUDES =
+# APPLE LOCAL control opt level. ilr
+LIBGCC2_OPT = -O2
# Additional target-dependent options for compiling libgcc2.a.
TARGET_LIBGCC2_CFLAGS =
@@ -625,6 +640,24 @@ UNPROTOIZE_INSTALL_NAME := $(shell echo unprotoize|sed '$(program_transform_name
GCOV_INSTALL_NAME := $(shell echo gcov|sed '$(program_transform_name)')
GCCBUG_INSTALL_NAME := $(shell echo gccbug|sed '$(program_transform_name)')
+# APPLE LOCAL begin order files ilr
+# When configure --enable-build_gcc is specified then we know that the
+# makefile was created as a result of using build_gcc. For such builds
+# we want to use the order files in the order-files directory. The
+# makefile will test ORDER_FILES. If it is not null then the appropriate
+# order file is added to the cc1* link.
+#ORDER_FILES = @enable_build_gcc@
+### ORDER FILES ARE CURRENTLY DISABLED. TO ENABLE THEM REMOVE THE LINE ###
+### BELOW AND UNCOMMENT THE LINE ABOVE. ###
+ORDER_FILES =
+ifeq ($(ORDER_FILES),yes)
+CC1_ORDER_FLAGS = `if [ -f $(srcdir)/../order-files/cc1.order ]; then \
+ echo -sectorder __TEXT __text $(srcdir)/../order-files/cc1.order -e start ; fi`
+else
+CC1_ORDER_FLAGS =
+endif
+# APPLE LOCAL end order files ilr
+
# Setup the testing framework, if you have one
EXPECT = `if [ -f $${rootme}/../expect/expect ] ; then \
echo $${rootme}/../expect/expect ; \
@@ -862,6 +895,8 @@ C_AND_OBJC_OBJS = attribs.o c-errors.o c-lex.o c-pragma.o c-decl.o c-typeck.o \
# Language-specific object files for C.
C_OBJS = c-parse.o c-lang.o stub-objc.o $(C_AND_OBJC_OBJS)
+# APPLE LOCAL debugging
+ # c-idebug.o c-dmp-tree.o
# Language-independent object files.
@@ -878,7 +913,7 @@ OBJS-common = \
cfg.o cfganal.o cfgbuild.o cfgcleanup.o cfglayout.o cfgloop.o \
cfgloopanal.o cfgloopmanip.o loop-init.o loop-unswitch.o loop-unroll.o \
cfgrtl.o combine.o conflict.o convert.o coverage.o cse.o cselib.o \
- dbxout.o debug.o df.o diagnostic.o dojump.o doloop.o dominance.o \
+ dbxout.o debug.o df.o diagnostic.o dojump.o dominance.o loop-doloop.o \
dwarf2asm.o dwarf2out.o emit-rtl.o except.o explow.o loop-iv.o \
expmed.o expr.o final.o flow.o fold-const.o function.o gcse.o \
genrtl.o ggc-common.o global.o graph.o gtype-desc.o \
@@ -1152,9 +1187,10 @@ $(SPECS): xgcc$(exeext)
gcc-cross: xgcc$(exeext)
cp xgcc$(exeext) gcc-cross$(exeext)
+# APPLE LOCAL order files ilr
cc1$(exeext): $(C_OBJS) $(BACKEND) $(LIBDEPS)
$(CC) $(ALL_CFLAGS) $(LDFLAGS) -o cc1$(exeext) \
- $(C_OBJS) $(BACKEND) $(LIBS)
+ $(C_OBJS) $(BACKEND) $(LIBS) $(CC1_ORDER_FLAGS)
# Build the version of limits.h that we will install.
xlimits.h: glimits.h limitx.h limity.h
@@ -1186,7 +1222,8 @@ libgcc.mk: config.status Makefile mklibgcc $(LIB2ADD) $(LIB2ADD_ST) xgcc$(exeext
DPBIT_FUNCS='$(DPBIT_FUNCS)' \
TPBIT='$(TPBIT)' \
TPBIT_FUNCS='$(TPBIT_FUNCS)' \
- MULTILIBS=`$(GCC_FOR_TARGET) --print-multi-lib` \
+ APPLE_LOCAL='APPLE LOCAL libcc_kext' \
+ MULTILIBS=".; static;@static@fno-pic kext;@Dmalloc=kern_os_malloc@Dfree=kern_os_free@DLIBCC_KEXT@static@fno-pic@fno-exceptions$(KEXT_EXTRA_FLAGS)" \
EXTRA_MULTILIB_PARTS='$(EXTRA_MULTILIB_PARTS)' \
SHLIB_LINK='$(SHLIB_LINK)' \
SHLIB_INSTALL='$(SHLIB_INSTALL)' \
@@ -1311,6 +1348,8 @@ c-errors.o: c-errors.c $(CONFIG_H) $(SYSTEM_H) coretypes.h $(TM_H) $(TREE_H) \
c-parse.o : c-parse.c $(CONFIG_H) $(SYSTEM_H) coretypes.h $(TM_H) $(TREE_H) \
$(GGC_H) intl.h $(C_TREE_H) input.h flags.h toplev.h output.h $(CPPLIB_H) \
varray.h gt-c-parse.h langhooks.h
+# APPLE LOCAL Objective-C++
+c-parse.o : langhooks.h
srcextra: gcc.srcextra lang.srcextra
@@ -1341,12 +1380,14 @@ c-typeck.o : c-typeck.c $(CONFIG_H) $(SYSTEM_H) coretypes.h $(TM_H) $(TREE_H) $(
c-lang.o : c-lang.c $(CONFIG_H) $(SYSTEM_H) coretypes.h $(TM_H) $(TREE_H) \
$(C_TREE_H) $(C_PRETTY_PRINT_H) $(DIAGNOSTIC_H) \
$(GGC_H) langhooks.h $(LANGHOOKS_DEF_H) $(C_COMMON_H) gtype-c.h
-stub-objc.o : stub-objc.c $(CONFIG_H) $(SYSTEM_H) coretypes.h $(TREE_H) \
- $(GGC_H) $(C_COMMON_H)
+# APPLE LOCAL Objective-C++
+stub-objc.o : stub-objc.c $(CONFIG_H) $(SYSTEM_H) coretypes.h $(TM_H) $(TREE_H)
c-lex.o : c-lex.c $(CONFIG_H) $(SYSTEM_H) coretypes.h $(TM_H) $(TREE_H) \
$(RTL_H) debug.h $(C_TREE_H) $(C_COMMON_H) real.h c-incpath.h cppdefault.h \
c-pragma.h input.h intl.h flags.h toplev.h output.h \
$(CPPLIB_H) $(EXPR_H) $(TM_P_H)
+# APPLE LOCAL AltiVec
+c-lex.o: $(TARGET_H) cpphash.h
c-ppoutput.o : c-ppoutput.c $(CONFIG_H) $(SYSTEM_H) coretypes.h $(TM_H) \
$(C_COMMON_H) $(TREE_H) $(CPPLIB_H) cpphash.h $(TM_P_H) c-pragma.h
c-objc-common.o : c-objc-common.c $(CONFIG_H) $(SYSTEM_H) coretypes.h $(TM_H) $(TREE_H) \
@@ -1881,9 +1922,9 @@ loop.o : loop.c $(CONFIG_H) $(SYSTEM_H) coretypes.h $(TM_H) $(RTL_H) flags.h $(L
insn-config.h $(REGS_H) hard-reg-set.h $(RECOG_H) $(EXPR_H) \
real.h $(PREDICT_H) $(BASIC_BLOCK_H) function.h cfgloop.h \
toplev.h varray.h except.h cselib.h $(OPTABS_H) $(TM_P_H) $(GGC_H)
-doloop.o : doloop.c $(CONFIG_H) $(SYSTEM_H) coretypes.h $(TM_H) $(RTL_H) flags.h \
- $(LOOP_H) $(EXPR_H) hard-reg-set.h $(BASIC_BLOCK_H) $(TM_P_H) toplev.h \
- cfgloop.h
+loop-doloop.o : loop-doloop.c $(CONFIG_H) $(SYSTEM_H) coretypes.h $(TM_H) \
+ $(RTL_H) flags.h $(EXPR_H) hard-reg-set.h $(BASIC_BLOCK_H) $(TM_P_H) \
+ toplev.h cfgloop.h output.h $(PARAMS_H)
unroll.o : unroll.c $(CONFIG_H) $(SYSTEM_H) coretypes.h $(TM_H) $(RTL_H) insn-config.h \
function.h $(INTEGRATE_H) $(REGS_H) $(RECOG_H) flags.h $(EXPR_H) $(LOOP_H) toplev.h \
hard-reg-set.h varray.h $(BASIC_BLOCK_H) $(TM_P_H) $(PREDICT_H) $(PARAMS_H) \
@@ -1995,7 +2036,7 @@ sched-deps.o : sched-deps.c $(CONFIG_H) $(SYSTEM_H) coretypes.h $(TM_H) $(RTL_H)
$(INSN_ATTR_H) toplev.h $(RECOG_H) except.h cselib.h $(PARAMS_H) $(TM_P_H)
sched-rgn.o : sched-rgn.c $(CONFIG_H) $(SYSTEM_H) coretypes.h $(TM_H) $(RTL_H) \
sched-int.h $(BASIC_BLOCK_H) $(REGS_H) hard-reg-set.h flags.h insn-config.h function.h \
- $(INSN_ATTR_H) toplev.h $(RECOG_H) except.h $(TM_P_H) $(TARGET_H)
+ $(INSN_ATTR_H) toplev.h $(RECOG_H) except.h $(PARAMS_H) $(TM_P_H) $(TARGET_H)
sched-ebb.o : sched-ebb.c $(CONFIG_H) $(SYSTEM_H) coretypes.h $(TM_H) $(RTL_H) \
sched-int.h $(BASIC_BLOCK_H) $(REGS_H) hard-reg-set.h flags.h insn-config.h function.h \
$(INSN_ATTR_H) toplev.h $(RECOG_H) except.h $(TM_P_H) $(PARAMS_H)
@@ -2041,6 +2082,23 @@ params.o : params.c $(CONFIG_H) $(SYSTEM_H) coretypes.h $(TM_H) $(PARAMS_H) topl
hooks.o: hooks.c $(CONFIG_H) $(SYSTEM_H) coretypes.h $(TM_H) $(HOOKS_H)
pretty-print.o: $(CONFIG_H) $(SYSTEM_H) pretty-print.c $(PRETTY_PRINT_H)
+# APPLE LOCAL debugging
+# Suppress all warnings explicitly for the idebug builds since there can be
+# many when, and if, -traditional-cpp is used.
+c-idebug.o : c-idebug.c $(CONFIG_H) $(SYSTEM_H) coretypes.h $(TM_H) \
+ $(TREE_H) $(C_TREE_H) $(RTL_H) flags.h idebug.c
+ $(CC) -c $(ALL_CFLAGS) $(ALL_CPPFLAGS) $(INCLUDES) -Wno-traditional -w $(srcdir)/c-idebug.c -o c-idebug.o
+
+# APPLE LOCAL begin new tree dump
+dmp-tree.o : dmp-tree.c $(CONFIG_H) $(SYSTEM_H) $(TREE_H) $(GGC_H) $(C_COMMON_H) \
+ langhooks.h dmp-tree.h $(TM_H) coretypes.h real.h
+c-dmp-tree.o : c-dmp-tree.c $(CONFIG_H) $(SYSTEM_H) $(TREE_H) $(GGC_H) \
+ $(C_TREE_H) dmp-tree.h $(TM_H) coretypes.h
+# Additional dependencies for existing rules for new tree dump
+c-decl.o : dmp-tree.h
+tree.o : dmp-tree.h
+# APPLE LOCAL end new tree dump
+
$(out_object_file): $(out_file) $(CONFIG_H) coretypes.h $(TM_H) $(TREE_H) $(GGC_H) \
$(RTL_H) $(REGS_H) hard-reg-set.h real.h insn-config.h conditions.h \
output.h $(INSN_ATTR_H) $(SYSTEM_H) toplev.h $(TARGET_H) libfuncs.h \
@@ -2848,10 +2906,12 @@ srcinfo: $(INFOFILES)
TEXI_CPP_FILES = cpp.texi fdl.texi cppenv.texi cppopts.texi
+# APPLE LOCAL GPL compliance
TEXI_GCC_FILES = gcc.texi gcc-common.texi frontends.texi standards.texi \
invoke.texi extend.texi md.texi objc.texi gcov.texi trouble.texi \
bugreport.texi service.texi contribute.texi compat.texi funding.texi \
- gnu.texi gpl.texi fdl.texi contrib.texi cppenv.texi cppopts.texi
+ gnu.texi gpl.texi fdl.texi contrib.texi cppenv.texi cppopts.texi \
+ sourcecode.texi
TEXI_GCCINT_FILES = gccint.texi gcc-common.texi contribute.texi makefile.texi \
configterms.texi portability.texi interface.texi passes.texi \
@@ -2868,6 +2928,38 @@ TEXI_CPPINT_FILES = cppinternals.texi
# patterns. To use them, put each of the specific targets with its
# specific dependencies but no build commands.
+# APPLE LOCAL begin html mrs
+htmldir = doc/HTML/gcc-$(version)
+.PHONY: html
+doc: html
+html: $(htmldir)/gcc/index.html $(htmldir)/cpp/index.html
+
+$(htmldir)/cpp/index.html: $(TEXI_CPP_FILES)
+ $(SHELL) ${srcdir}/mkinstalldirs $(htmldir)/cpp
+ $(MAKEINFO) --html -I $(docdir) -I $(docdir)/include \
+ -o $(htmldir)/cpp $(docdir)/cpp.texi
+
+$(htmldir)/gcc/index.html: $(TEXI_GCC_FILES)
+ $(SHELL) ${srcdir}/mkinstalldirs $(htmldir)/gcc
+ $(MAKEINFO) --html -I $(docdir) -I $(docdir)/include \
+ -o $(htmldir)/gcc $(docdir)/gcc.texi
+
+$(htmldir)/gccint/index.html: $(TEXI_GCCINT_FILES)
+ $(SHELL) ${srcdir}/mkinstalldirs $(htmldir)/gccint
+ $(MAKEINFO) --html -I $(docdir) -I $(docdir)/include \
+ -o $(htmldir)/gccint $(docdir)/gccint.texi
+
+$(htmldir)/gccinstall/index.html: $(TEXI_GCCINSTALL_FILES)
+ $(SHELL) ${srcdir}/mkinstalldirs $(htmldir)/gccinstall
+ $(MAKEINFO) --html -I $(docdir) -I $(docdir)/include \
+ -o $(htmldir)/gccinstall $(docdir)/install.texi
+
+$(htmldir)/cppinternals/index.html: $(TEXI_CPPINT_FILES)
+ $(SHELL) ${srcdir}/mkinstalldirs $(htmldir)/cppinternals
+ $(MAKEINFO) --html -I $(docdir) -I $(docdir)/include \
+ -o $(htmldir)/cppinternals $(docdir)/cppinternals.texi
+# APPLE LOCAL end html mrs
+
doc/cpp.info: $(TEXI_CPP_FILES)
doc/gcc.info: $(TEXI_GCC_FILES)
doc/gccint.info: $(TEXI_GCCINT_FILES)
diff --git a/gcc/ada/5qsystem.ads b/gcc/ada/5qsystem.ads
deleted file mode 100644
index 4d17cdacde5..00000000000
--- a/gcc/ada/5qsystem.ads
+++ /dev/null
@@ -1,236 +0,0 @@
-------------------------------------------------------------------------------
--- --
--- GNAT RUN-TIME COMPONENTS --
--- --
--- S Y S T E M --
--- --
--- S p e c --
--- (OpenVMS 64bit GCC_ZCX DEC Threads Version) --
--- --
--- Copyright (C) 2004 Free Software Foundation, Inc. --
--- --
--- This specification is derived from the Ada Reference Manual for use with --
--- GNAT. The copyright notice above, and the license provisions that follow --
--- apply solely to the contents of the part following the private keyword. --
--- --
--- GNAT is free software; you can redistribute it and/or modify it under --
--- terms of the GNU General Public License as published by the Free Soft- --
--- ware Foundation; either version 2, or (at your option) any later ver- --
--- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
--- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
--- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
--- for more details. You should have received a copy of the GNU General --
--- Public License distributed with GNAT; see file COPYING. If not, write --
--- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
--- MA 02111-1307, USA. --
--- --
--- As a special exception, if other files instantiate generics from this --
--- unit, or you link this unit with other files to produce an executable, --
--- this unit does not by itself cause the resulting executable to be --
--- covered by the GNU General Public License. This exception does not --
--- however invalidate any other reasons why the executable file might be --
--- covered by the GNU Public License. --
--- --
--- GNAT was originally developed by the GNAT team at New York University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
--- --
-------------------------------------------------------------------------------
-
-package System is
-pragma Pure (System);
--- Note that we take advantage of the implementation permission to
--- make this unit Pure instead of Preelaborable, see RM 13.7(36)
-
- type Name is (SYSTEM_NAME_GNAT);
- System_Name : constant Name := SYSTEM_NAME_GNAT;
-
- -- System-Dependent Named Numbers
-
- Min_Int : constant := Long_Long_Integer'First;
- Max_Int : constant := Long_Long_Integer'Last;
-
- Max_Binary_Modulus : constant := 2 ** Long_Long_Integer'Size;
- Max_Nonbinary_Modulus : constant := Integer'Last;
-
- Max_Base_Digits : constant := Long_Long_Float'Digits;
- Max_Digits : constant := Long_Long_Float'Digits;
-
- Max_Mantissa : constant := 63;
- Fine_Delta : constant := 2.0 ** (-Max_Mantissa);
-
- Tick : constant := 0.01;
-
- -- Storage-related Declarations
-
- type Address is private;
- Null_Address : constant Address;
-
- Storage_Unit : constant := 8;
- Word_Size : constant := 64;
- Memory_Size : constant := 2 ** 64;
-
- -- Address comparison
-
- function "<" (Left, Right : Address) return Boolean;
- function "<=" (Left, Right : Address) return Boolean;
- function ">" (Left, Right : Address) return Boolean;
- function ">=" (Left, Right : Address) return Boolean;
- function "=" (Left, Right : Address) return Boolean;
-
- pragma Import (Intrinsic, "<");
- pragma Import (Intrinsic, "<=");
- pragma Import (Intrinsic, ">");
- pragma Import (Intrinsic, ">=");
- pragma Import (Intrinsic, "=");
-
- -- Other System-Dependent Declarations
-
- type Bit_Order is (High_Order_First, Low_Order_First);
- Default_Bit_Order : constant Bit_Order := Low_Order_First;
-
- -- Priority-related Declarations (RM D.1)
-
- Max_Priority : constant Positive := 30;
- Max_Interrupt_Priority : constant Positive := 31;
-
- subtype Any_Priority is Integer range 0 .. 31;
- subtype Priority is Any_Priority range 0 .. 30;
- subtype Interrupt_Priority is Any_Priority range 31 .. 31;
-
- Default_Priority : constant Priority := 15;
-
-private
-
- type Address is mod Memory_Size;
- Null_Address : constant Address := 0;
-
- --------------------------------------
- -- System Implementation Parameters --
- --------------------------------------
-
- -- These parameters provide information about the target that is used
- -- by the compiler. They are in the private part of System, where they
- -- can be accessed using the special circuitry in the Targparm unit
- -- whose source should be consulted for more detailed descriptions
- -- of the individual switch values.
-
- AAMP : constant Boolean := False;
- Backend_Divide_Checks : constant Boolean := False;
- Backend_Overflow_Checks : constant Boolean := False;
- Command_Line_Args : constant Boolean := True;
- Configurable_Run_Time : constant Boolean := False;
- Denorm : constant Boolean := False;
- Duration_32_Bits : constant Boolean := False;
- Exit_Status_Supported : constant Boolean := True;
- Fractional_Fixed_Ops : constant Boolean := False;
- Frontend_Layout : constant Boolean := False;
- Functions_Return_By_DSP : constant Boolean := False;
- Machine_Overflows : constant Boolean := False;
- Machine_Rounds : constant Boolean := True;
- OpenVMS : constant Boolean := True;
- Signed_Zeros : constant Boolean := True;
- Stack_Check_Default : constant Boolean := True;
- Stack_Check_Probes : constant Boolean := True;
- Support_64_Bit_Divides : constant Boolean := True;
- Support_Aggregates : constant Boolean := True;
- Support_Composite_Assign : constant Boolean := True;
- Support_Composite_Compare : constant Boolean := True;
- Support_Long_Shifts : constant Boolean := True;
- Suppress_Standard_Library : constant Boolean := False;
- Use_Ada_Main_Program_Name : constant Boolean := False;
- ZCX_By_Default : constant Boolean := True;
- GCC_ZCX_Support : constant Boolean := True;
- Front_End_ZCX_Support : constant Boolean := False;
-
- -- Obsolete entries, to be removed eventually (bootstrap issues!)
-
- High_Integrity_Mode : constant Boolean := False;
- Long_Shifts_Inlined : constant Boolean := False;
-
- --------------------------
- -- Underlying Priorities --
- ---------------------------
-
- -- Important note: this section of the file must come AFTER the
- -- definition of the system implementation parameters to ensure
- -- that the value of these parameters is available for analysis
- -- of the declarations here (using Rtsfind at compile time).
-
- -- The underlying priorities table provides a generalized mechanism
- -- for mapping from Ada priorities to system priorities. In some
- -- cases a 1-1 mapping is not the convenient or optimal choice.
-
- -- For DEC Threads OpenVMS, we use the full range of 31 priorities
- -- in the Ada model, but map them by compression onto the more limited
- -- range of priorities available in OpenVMS.
-
- -- To replace the default values of the Underlying_Priorities mapping,
- -- copy this source file into your build directory, edit the file to
- -- reflect your desired behavior, and recompile with the command:
-
- -- $ gcc -c -O3 -gnatpgn system.ads
-
- -- then recompile the run-time parts that depend on this package:
-
- -- $ gnatmake -a -gnatn -O3 <your application>
-
- -- then force rebuilding your application if you need different options:
-
- -- $ gnatmake -f <your options> <your application>
-
- type Priorities_Mapping is array (Any_Priority) of Integer;
- pragma Suppress_Initialization (Priorities_Mapping);
- -- Suppress initialization in case gnat.adc specifies Normalize_Scalars
-
- Underlying_Priorities : constant Priorities_Mapping :=
-
- (Priority'First => 16,
-
- 1 => 17,
- 2 => 18,
- 3 => 18,
- 4 => 18,
- 5 => 18,
- 6 => 19,
- 7 => 19,
- 8 => 19,
- 9 => 20,
- 10 => 20,
- 11 => 21,
- 12 => 21,
- 13 => 22,
- 14 => 23,
-
- Default_Priority => 24,
-
- 16 => 25,
- 17 => 25,
- 18 => 25,
- 19 => 26,
- 20 => 26,
- 21 => 26,
- 22 => 27,
- 23 => 27,
- 24 => 27,
- 25 => 28,
- 26 => 28,
- 27 => 29,
- 28 => 29,
- 29 => 30,
-
- Priority'Last => 30,
-
- Interrupt_Priority => 31);
-
- ----------------------------
- -- Special VMS Interfaces --
- ----------------------------
-
- procedure Lib_Stop (I : in Integer);
- pragma Interface (C, Lib_Stop);
- pragma Import_Procedure (Lib_Stop, "LIB$STOP", Mechanism => (Value));
- -- Interface to VMS condition handling. Used by RTSfind and pragma
- -- {Import,Export}_Exception. Put here because this is the only
- -- VMS specific package that doesn't drag in tasking.
-
-end System;
diff --git a/gcc/ada/5xcrtl.ads b/gcc/ada/5xcrtl.ads
deleted file mode 100644
index dd3292e384a..00000000000
--- a/gcc/ada/5xcrtl.ads
+++ /dev/null
@@ -1,159 +0,0 @@
-------------------------------------------------------------------------------
--- --
--- GNAT RUN-TIME COMPONENTS --
--- --
--- S Y S T E M . C R T L --
--- --
--- S p e c --
--- --
--- Copyright (C) 2004 Free Software Foundation, Inc. --
--- --
--- GNAT is free software; you can redistribute it and/or modify it under --
--- terms of the GNU General Public License as published by the Free Soft- --
--- ware Foundation; either version 2, or (at your option) any later ver- --
--- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
--- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
--- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
--- for more details. You should have received a copy of the GNU General --
--- Public License distributed with GNAT; see file COPYING. If not, write --
--- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
--- MA 02111-1307, USA. --
--- --
--- As a special exception, if other files instantiate generics from this --
--- unit, or you link this unit with other files to produce an executable, --
--- this unit does not by itself cause the resulting executable to be --
--- covered by the GNU General Public License. This exception does not --
--- however invalidate any other reasons why the executable file might be --
--- covered by the GNU Public License. --
--- --
--- GNAT was originally developed by the GNAT team at New York University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
--- --
-------------------------------------------------------------------------------
-
--- This package provides the low level interface to the C Run Time Library
--- on 64 bit VMS
-
-with System.Parameters;
-package System.CRTL is
-pragma Preelaborate (CRTL);
-
- subtype chars is System.Address;
- -- Pointer to null-terminated array of characters
-
- subtype FILEs is System.Address;
- -- Corresponds to the C type FILE*
-
- subtype int is Integer;
-
- type long is range -(2 ** (System.Parameters.long_bits - 1))
- .. +(2 ** (System.Parameters.long_bits - 1)) - 1;
-
- subtype off_t is Integer;
-
- type size_t is mod 2 ** Standard'Address_Size;
-
- function atoi (A : System.Address) return Integer;
- pragma Import (C, atoi, "decc$atoi");
-
- procedure clearerr (stream : FILEs);
- pragma Import (C, clearerr, "decc$clearerr");
-
- function fclose (stream : FILEs) return int;
- pragma Import (C, fclose, "decc$fclose");
-
- function fdopen (handle : int; mode : chars) return FILEs;
- pragma Import (C, fdopen, "decc$fdopen");
-
- function fflush (stream : FILEs) return int;
- pragma Import (C, fflush, "decc$fflush");
-
- function fgetc (stream : FILEs) return int;
- pragma Import (C, fgetc, "decc$fgetc");
-
- function fgets (strng : chars; n : int; stream : FILEs) return chars;
- pragma Import (C, fgets, "decc$fgets");
-
- function fopen (filename : chars; Mode : chars) return FILEs;
- pragma Import (C, fopen, "decc$fopen");
-
- function fputc (C : int; stream : FILEs) return int;
- pragma Import (C, fputc, "decc$fputc");
-
- function fputs (Strng : chars; Stream : FILEs) return int;
- pragma Import (C, fputs, "decc$fputs");
-
- procedure free (Ptr : System.Address);
- pragma Import (C, free, "decc$free");
-
- function freopen
- (filename : chars;
- mode : chars;
- stream : FILEs)
- return FILEs;
- pragma Import (C, freopen, "decc$freopen");
-
- function fseek
- (stream : FILEs;
- offset : long;
- origin : int)
- return int;
- pragma Import (C, fseek, "decc$fseek");
-
- function ftell (stream : FILEs) return long;
- pragma Import (C, ftell, "decc$ftell");
-
- function getenv (S : String) return System.Address;
- pragma Import (C, getenv, "decc$getenv");
-
- function isatty (handle : int) return int;
- pragma Import (C, isatty, "decc$isatty");
-
- function lseek (fd : int; offset : off_t; direction : int) return off_t;
- pragma Import (C, lseek, "decc$lseek");
-
- function malloc (Size : size_t) return System.Address;
- pragma Import (C, malloc, "decc$_malloc64");
-
- procedure memcpy (S1 : System.Address; S2 : System.Address; N : size_t);
- pragma Import (C, memcpy, "decc$_memcpy64");
-
- procedure memmove (S1 : System.Address; S2 : System.Address; N : size_t);
- pragma Import (C, memmove, "decc$_memmove64");
-
- procedure mktemp (template : chars);
- pragma Import (C, mktemp, "decc$_mktemp64");
-
- function read (fd : int; buffer : chars; nbytes : int) return int;
- pragma Import (C, read, "decc$read");
-
- function realloc
- (Ptr : System.Address; Size : size_t) return System.Address;
- pragma Import (C, realloc, "decc$_realloc64");
-
- procedure rewind (stream : FILEs);
- pragma Import (C, rewind, "decc$rewind");
-
- function setvbuf
- (stream : FILEs;
- buffer : chars;
- mode : int;
- size : size_t)
- return int;
- pragma Import (C, setvbuf, "decc$setvbuf");
-
- procedure tmpnam (string : chars);
- pragma Import (C, tmpnam, "decc$_tmpnam64");
-
- function tmpfile return FILEs;
- pragma Import (C, tmpfile, "decc$tmpfile");
-
- function ungetc (c : int; stream : FILEs) return int;
- pragma Import (C, ungetc, "decc$ungetc");
-
- function unlink (filename : chars) return int;
- pragma Import (C, unlink, "decc$unlink");
-
- function write (fd : int; buffer : chars; nbytes : int) return int;
- pragma Import (C, write, "decc$write");
-end System.CRTL;
diff --git a/gcc/ada/5zstchop.adb b/gcc/ada/5zstchop.adb
deleted file mode 100644
index b19bb56f274..00000000000
--- a/gcc/ada/5zstchop.adb
+++ /dev/null
@@ -1,255 +0,0 @@
-------------------------------------------------------------------------------
--- --
--- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS --
--- --
--- S Y S T E M . S T A C K _ C H E C K I N G . O P E R A T I O N S --
--- --
--- B o d y --
--- --
--- Copyright (C) 1999-2004 Free Software Foundation, Inc. --
--- --
--- GNARL is free software; you can redistribute it and/or modify it under --
--- terms of the GNU General Public License as published by the Free Soft- --
--- ware Foundation; either version 2, or (at your option) any later ver- --
--- sion. GNARL is distributed in the hope that it will be useful, but WITH- --
--- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
--- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
--- for more details. You should have received a copy of the GNU General --
--- Public License distributed with GNARL; see file COPYING. If not, write --
--- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
--- MA 02111-1307, USA. --
--- --
--- As a special exception, if other files instantiate generics from this --
--- unit, or you link this unit with other files to produce an executable, --
--- this unit does not by itself cause the resulting executable to be --
--- covered by the GNU General Public License. This exception does not --
--- however invalidate any other reasons why the executable file might be --
--- covered by the GNU Public License. --
--- --
--- GNARL was developed by the GNARL team at Florida State University. --
--- Extensive contributions were provided by Ada Core Technologies, Inc. --
--- --
-------------------------------------------------------------------------------
-
--- This is the VxWorks version of this package.
--- This file should be kept synchronized with the general implementation
--- provided by s-stchop.adb.
-
-pragma Restrictions (No_Elaboration_Code);
--- We want to guarantee the absence of elaboration code because the
--- binder does not handle references to this package.
-
-with Ada.Exceptions;
-
-with System.Storage_Elements; use System.Storage_Elements;
-with System.Parameters; use System.Parameters;
-with System.Soft_Links;
-with Interfaces.C;
-with System.OS_Interface;
-
-package body System.Stack_Checking.Operations is
-
- -- In order to have stack checking working appropriately on
- -- VxWorks we need to extract the stack size information from the
- -- VxWorks kernel itself. It means that the library for showing
- -- task-related information needs to be linked into the VxWorks
- -- system, when using stack checking. The TaskShow library can be
- -- linked into the VxWorks system by either:
- -- * defining INCLUDE_SHOW_ROUTINES in config.h when using
- -- configuration header files, or
- -- * selecting INCLUDE_TASK_SHOW when using the Tornado project
- -- facility.
-
- function Set_Stack_Info (Stack : access Stack_Access) return Stack_Access;
-
- -- The function Set_Stack_Info is the actual function that updates
- -- the cache containing a pointer to the Stack_Info. It may also
- -- be used for detecting asynchronous abort in combination with
- -- Invalidate_Self_Cache.
-
- -- Set_Stack_Info should do the following things in order:
- -- 1) Get the Stack_Access value for the current task
- -- 2) Set Stack.all to the value obtained in 1)
- -- 3) Optionally Poll to check for asynchronous abort
-
- -- This order is important because if at any time a write to
- -- the stack cache is pending, that write should be followed
- -- by a Poll to prevent loosing signals.
-
- -- Note: This function must be compiled with Polling turned off
-
- -- Note: on systems like VxWorks and OS/2 with real thread-local storage,
- -- Set_Stack_Info should return an access value for such local
- -- storage. In those cases the cache will always be up-to-date.
-
- -- The following constants should be imported from some system-specific
- -- constants package. The constants must be static for performance reasons.
-
- ----------------------------
- -- Invalidate_Stack_Cache --
- ----------------------------
-
- procedure Invalidate_Stack_Cache (Any_Stack : Stack_Access) is
- pragma Warnings (Off, Any_Stack);
- begin
- Cache := Null_Stack;
- end Invalidate_Stack_Cache;
-
- --------------------
- -- Set_Stack_Info --
- --------------------
-
- function Set_Stack_Info
- (Stack : access Stack_Access) return Stack_Access
- is
-
- -- Task descriptor that is handled internally by the VxWorks kernel
- type Task_Descriptor is record
- T_Id : Interfaces.C.int; -- task identifier
- Td_Name : System.Address; -- task name
- Td_Priority : Interfaces.C.int; -- task priority
- Td_Status : Interfaces.C.int; -- task status
- Td_Options : Interfaces.C.int; -- task option bits (see below)
- Td_Entry : System.Address; -- original entry point of task
- Td_Sp : System.Address; -- saved stack pointer
- Td_PStackBase : System.Address; -- the bottom of the stack
- Td_PStackLimit : System.Address; -- the effective end of the stack
- Td_PStackEnd : System.Address; -- the actual end of the stack
- Td_StackSize : Interfaces.C.int; -- size of stack in bytes
- Td_StackCurrent : Interfaces.C.int; -- current stack usage in bytes
- Td_StackHigh : Interfaces.C.int; -- maximum stack usage in bytes
- Td_StackMargin : Interfaces.C.int; -- current stack margin in bytes
- Td_ErrorStatus : Interfaces.C.int; -- most recent task error status
- Td_Delay : Interfaces.C.int; -- delay/timeout ticks
- end record;
-
- -- This VxWorks procedure fills in a specified task descriptor
- -- for a specified task.
- procedure TaskInfoGet (T_Id : System.OS_Interface.t_id;
- Task_Desc : access Task_Descriptor);
- pragma Import (C, TaskInfoGet, "taskInfoGet");
-
- My_Stack : Stack_Access;
- Task_Desc : aliased Task_Descriptor;
-
- begin
- -- The order of steps 1 .. 3 is important, see specification.
-
- -- 1) Get the Stack_Access value for the current task
-
- My_Stack := Soft_Links.Get_Stack_Info.all;
-
- if My_Stack.Base = Null_Address then
-
- -- First invocation. Ask the VxWorks kernel about stack
- -- values.
- TaskInfoGet (System.OS_Interface.taskIdSelf, Task_Desc'Access);
-
- My_Stack.Size := System.Storage_Elements.Storage_Offset
- (Task_Desc.Td_StackSize);
- My_Stack.Base := Task_Desc.Td_PStackBase;
- My_Stack.Limit := Task_Desc.Td_PStackLimit;
-
- end if;
-
- -- 2) Set Stack.all to the value obtained in 1)
-
- Stack.all := My_Stack;
-
- -- 3) Optionally Poll to check for asynchronous abort
-
- if Soft_Links.Check_Abort_Status.all /= 0 then
- raise Standard'Abort_Signal;
- end if;
-
- return My_Stack; -- Never trust the cached value, but return local copy!
- end Set_Stack_Info;
-
- --------------------
- -- Set_Stack_Size --
- --------------------
-
- -- Specify the stack size for the current frame.
-
- procedure Set_Stack_Size
- (Stack_Size : System.Storage_Elements.Storage_Offset)
- is
- My_Stack : Stack_Access;
- Frame_Address : constant System.Address := My_Stack'Address;
-
- begin
- My_Stack := Stack_Check (Frame_Address);
-
- if Stack_Grows_Down then
- My_Stack.Limit := My_Stack.Base - Stack_Size;
- else
- My_Stack.Limit := My_Stack.Base + Stack_Size;
- end if;
- end Set_Stack_Size;
-
- -----------------
- -- Stack_Check --
- -----------------
-
- function Stack_Check
- (Stack_Address : System.Address) return Stack_Access
- is
- type Frame_Marker is null record;
- Marker : Frame_Marker;
- Cached_Stack : constant Stack_Access := Cache;
- Frame_Address : constant System.Address := Marker'Address;
-
- begin
- -- This function first does a "cheap" check which is correct
- -- if it succeeds. In case of failure, the full check is done.
- -- Ideally the cheap check should be done in an optimized manner,
- -- or be inlined.
-
- if (Stack_Grows_Down and then
- (Frame_Address <= Cached_Stack.Base
- and
- Stack_Address > Cached_Stack.Limit))
- or else
- (not Stack_Grows_Down and then
- (Frame_Address >= Cached_Stack.Base
- and
- Stack_Address < Cached_Stack.Limit))
- then
- -- Cached_Stack is valid as it passed the stack check
- return Cached_Stack;
- end if;
-
- Full_Check :
- declare
- My_Stack : constant Stack_Access := Set_Stack_Info (Cache'Access);
- -- At this point Stack.all might already be invalid, so
- -- it is essential to use our local copy of Stack!
-
- begin
- if (Stack_Grows_Down and then
- Stack_Address < My_Stack.Limit)
- or else
- (not Stack_Grows_Down and then
- Stack_Address > My_Stack.Limit)
- then
- Ada.Exceptions.Raise_Exception
- (E => Storage_Error'Identity,
- Message => "stack overflow detected");
- end if;
-
- return My_Stack;
- end Full_Check;
- end Stack_Check;
-
- ------------------------
- -- Update_Stack_Cache --
- ------------------------
-
- procedure Update_Stack_Cache (Stack : Stack_Access) is
- begin
- if not Multi_Processor then
- Cache := Stack;
- end if;
- end Update_Stack_Cache;
-
-end System.Stack_Checking.Operations;
diff --git a/gcc/ada/Makefile.in b/gcc/ada/Makefile.in
index f8df3945c92..ab6b986462d 100644
--- a/gcc/ada/Makefile.in
+++ b/gcc/ada/Makefile.in
@@ -136,7 +136,6 @@ THREADSLIB =
GMEM_LIB =
MISCLIB =
SYMLIB =
-ADDR2LINE_SYMLIB = -laddr2line -lbfd -liberty $(LIBINTL)
SYMDEPS = $(LIBINTL_DEP)
OUTPUT_OPTION = @OUTPUT_OPTION@
@@ -716,7 +715,7 @@ ifeq ($(strip $(filter-out sparc sun solaris%,$(targ))),)
THREADSLIB = -lposix4 -lthread
MISCLIB = -lposix4 -lnsl -lsocket
- SYMLIB = $(ADDR2LINE_SYMLIB)
+ SYMLIB = -laddr2line -lbfd $(LIBINTL)
SO_OPTS = -Wl,-h,
GNATLIB_SHARED = gnatlib-shared-dual
GMEM_LIB = gmemlib
@@ -825,10 +824,8 @@ ifeq ($(strip $(filter-out %86 linux%,$(arch) $(osys))),)
s-parame.adb<5lparame.adb \
system.ads<5lsystem.ads
- TOOLS_TARGET_PAIRS = \
- mlib-tgt.adb<5lml-tgt.adb
-
- SYMLIB = $(ADDR2LINE_SYMLIB)
+ TOOLS_TARGET_PAIRS = mlib-tgt.adb<5lml-tgt.adb
+ SYMLIB = -laddr2line -lbfd -liberty $(LIBINTL)
THREADSLIB = -lpthread
GNATLIB_SHARED = gnatlib-shared-dual
GMEM_LIB = gmemlib
@@ -916,6 +913,8 @@ ifeq ($(strip $(filter-out mips sgi irix%,$(targ))),)
s-traceb.adb<7straceb.adb \
g-soccon.ads<3gsoccon.ads \
system.ads<5fsystem.ads
+
+ THREADSLIB = -lathread
endif
TOOLS_TARGET_PAIRS = mlib-tgt.adb<5gml-tgt.adb
@@ -965,7 +964,7 @@ ifeq ($(strip $(filter-out hppa% hp hpux11%,$(targ))),)
TOOLS_TARGET_PAIRS = mlib-tgt.adb<5hml-tgt.adb
TGT_LIB = /usr/lib/libcl.a
THREADSLIB = -lpthread
- SYMLIB = $(ADDR2LINE_SYMLIB)
+ SYMLIB = -laddr2line -lbfd $(LIBINTL)
GMEM_LIB = gmemlib
soext = .sl
SO_OPTS = -Wl,+h,
@@ -1031,7 +1030,7 @@ ifeq ($(strip $(filter-out ibm aix%,$(manu) $(osys))),)
TOOLS_TARGET_PAIRS = mlib-tgt.adb<5bml-tgt.adb
GMEM_LIB = gmemlib
- SYMLIB = $(ADDR2LINE_SYMLIB)
+ SYMLIB = -laddr2line -lbfd -liberty $(LIBINTL)
endif
@@ -1118,7 +1117,7 @@ ifeq ($(strip $(filter-out alpha% dec osf%,$(targ))),)
TOOLS_TARGET_PAIRS=mlib-tgt.adb<5aml-tgt.adb
GMEM_LIB=gmemlib
- SYMLIB = $(ADDR2LINE_SYMLIB)
+ SYMLIB = -laddr2line -lbfd $(LIBINTL)
THREADSLIB = -lpthread -lmach -lexc -lrt
PREFIX_OBJS = $(PREFIX_REAL_OBJS)
GNATLIB_SHARED = gnatlib-shared-default
@@ -1238,7 +1237,7 @@ ifeq ($(strip $(filter-out cygwin32% mingw32% pe,$(osys))),)
TOOLS_TARGET_PAIRS=mlib-tgt.adb<5wml-tgt.adb
MISCLIB = -lwsock32
- SYMLIB = $(ADDR2LINE_SYMLIB)
+ SYMLIB = -laddr2line -lbfd -liberty $(LIBINTL)
GMEM_LIB = gmemlib
PREFIX_OBJS = $(PREFIX_REAL_OBJS)
EXTRA_GNATTOOLS = ../../gnatdll$(exeext)
@@ -1288,7 +1287,7 @@ ifeq ($(strip $(filter-out %x86_64 linux%,$(arch) $(osys))),)
system.ads<5nsystem.ads
TOOLS_TARGET_PAIRS=mlib-tgt.adb<5lml-tgt.adb
- SYMLIB = $(ADDR2LINE_SYMLIB)
+ SYMLIB = -laddr2line -lbfd -liberty $(LIBINTL)
THREADSLIB=-lpthread
GNATLIB_SHARED=gnatlib-shared-dual
GMEM_LIB = gmemlib
diff --git a/gcc/ada/config-lang.in b/gcc/ada/config-lang.in
deleted file mode 100644
index 2ec47df0ea3..00000000000
--- a/gcc/ada/config-lang.in
+++ /dev/null
@@ -1,47 +0,0 @@
-# Top level configure fragment for GNU Ada (GNAT).
-# Copyright (C) 1994-2003 Free Software Foundation, Inc.
-
-#This file is part of GCC.
-
-#GCC is free software; you can redistribute it and/or modify
-#it under the terms of the GNU General Public License as published by
-#the Free Software Foundation; either version 2, or (at your option)
-#any later version.
-
-#GCC is distributed in the hope that it will be useful,
-#but WITHOUT ANY WARRANTY; without even the implied warranty of
-#MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-#GNU General Public License for more details.
-
-#You should have received a copy of the GNU General Public License
-#along with GCC; see the file COPYING. If not, write to
-#the Free Software Foundation, 59 Temple Place - Suite 330,
-#Boston, MA 02111-1307, USA.
-
-# Configure looks for the existence of this file to auto-config each language.
-# We define several parameters used by configure:
-#
-# language - name of language as it would appear in $(LANGUAGES)
-# boot_language - "yes" if we need to build this language in stage1
-# compilers - value to add to $(COMPILERS)
-# stagestuff - files to add to $(STAGESTUFF)
-
-language="ada"
-boot_language=no
-boot_language_boot_flags='ADAFLAGS="$(BOOT_ADAFLAGS)"'
-
-compilers="gnat1\$(exeext)"
-
-stagestuff="gnatbind\$(exeext) gnat1\$(exeext)"
-
-gtfiles="\$(srcdir)/ada/ada-tree.h \$(srcdir)/ada/gigi.h \$(srcdir)/ada/decl.c \$(srcdir)/ada/trans.c \$(srcdir)/ada/utils.c"
-
-outputs=ada/Makefile
-
-target_libs="target-libada"
-
-# The logic for determining whether there is a bootstrap Ada compiler
-# available needs to be moved from gcc/configure to the toplevel configure,
-# so that target-libada is not built when there is no bootstrap Ada compiler.
-# Until then disable building this language by default.
-build_by_default=no
diff --git a/gcc/ada/s-stchop.adb b/gcc/ada/s-stchop.adb
deleted file mode 100644
index 3a1b1e91a07..00000000000
--- a/gcc/ada/s-stchop.adb
+++ /dev/null
@@ -1,273 +0,0 @@
-------------------------------------------------------------------------------
--- --
--- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS --
--- --
--- S Y S T E M . S T A C K _ C H E C K I N G . O P E R A T I O N S --
--- --
--- B o d y --
--- --
--- Copyright (C) 1999-2004 Free Software Foundation, Inc. --
--- --
--- GNARL is free software; you can redistribute it and/or modify it under --
--- terms of the GNU General Public License as published by the Free Soft- --
--- ware Foundation; either version 2, or (at your option) any later ver- --
--- sion. GNARL is distributed in the hope that it will be useful, but WITH- --
--- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
--- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
--- for more details. You should have received a copy of the GNU General --
--- Public License distributed with GNARL; see file COPYING. If not, write --
--- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
--- MA 02111-1307, USA. --
--- --
--- As a special exception, if other files instantiate generics from this --
--- unit, or you link this unit with other files to produce an executable, --
--- this unit does not by itself cause the resulting executable to be --
--- covered by the GNU General Public License. This exception does not --
--- however invalidate any other reasons why the executable file might be --
--- covered by the GNU Public License. --
--- --
--- GNARL was developed by the GNARL team at Florida State University. --
--- Extensive contributions were provided by Ada Core Technologies, Inc. --
--- --
-------------------------------------------------------------------------------
-
--- This is the general implementation of this package. There is a VxWorks
--- specific version of this package (5zstchop.adb). This file should
--- be kept synchronized with it.
-
-pragma Restrictions (No_Elaboration_Code);
--- We want to guarantee the absence of elaboration code because the
--- binder does not handle references to this package.
-
-with Ada.Exceptions;
-
-with System.Storage_Elements; use System.Storage_Elements;
-with System.Parameters; use System.Parameters;
-with System.Soft_Links;
-with System.CRTL;
-
-package body System.Stack_Checking.Operations is
-
- Kilobyte : constant := 1024;
-
- function Set_Stack_Info (Stack : access Stack_Access) return Stack_Access;
-
- -- The function Set_Stack_Info is the actual function that updates
- -- the cache containing a pointer to the Stack_Info. It may also
- -- be used for detecting asynchronous abort in combination with
- -- Invalidate_Self_Cache.
-
- -- Set_Stack_Info should do the following things in order:
- -- 1) Get the Stack_Access value for the current task
- -- 2) Set Stack.all to the value obtained in 1)
- -- 3) Optionally Poll to check for asynchronous abort
-
- -- This order is important because if at any time a write to
- -- the stack cache is pending, that write should be followed
- -- by a Poll to prevent loosing signals.
-
- -- Note: This function must be compiled with Polling turned off
-
- -- Note: on systems like VxWorks and OS/2 with real thread-local storage,
- -- Set_Stack_Info should return an access value for such local
- -- storage. In those cases the cache will always be up-to-date.
-
- -- The following constants should be imported from some system-specific
- -- constants package. The constants must be static for performance reasons.
-
- ----------------------------
- -- Invalidate_Stack_Cache --
- ----------------------------
-
- procedure Invalidate_Stack_Cache (Any_Stack : Stack_Access) is
- pragma Warnings (Off, Any_Stack);
- begin
- Cache := Null_Stack;
- end Invalidate_Stack_Cache;
-
- --------------------
- -- Set_Stack_Info --
- --------------------
-
- function Set_Stack_Info
- (Stack : access Stack_Access) return Stack_Access
- is
- type Frame_Mark is null record;
- Frame_Location : Frame_Mark;
- Frame_Address : constant Address := Frame_Location'Address;
-
- My_Stack : Stack_Access;
- Limit_Chars : System.Address;
- Limit : Integer;
-
- begin
- -- The order of steps 1 .. 3 is important, see specification.
-
- -- 1) Get the Stack_Access value for the current task
-
- My_Stack := Soft_Links.Get_Stack_Info.all;
-
- if My_Stack.Base = Null_Address then
-
- -- First invocation, initialize based on the assumption that
- -- there are Environment_Stack_Size bytes available beyond
- -- the current frame address.
-
- if My_Stack.Size = 0 then
- My_Stack.Size := Storage_Offset (Default_Env_Stack_Size);
-
- -- When the environment variable GNAT_STACK_LIMIT is set,
- -- set Environment_Stack_Size to that number of kB.
-
- Limit_Chars := System.CRTL.getenv ("GNAT_STACK_LIMIT" & ASCII.NUL);
-
- if Limit_Chars /= Null_Address then
- Limit := System.CRTL.atoi (Limit_Chars);
-
- if Limit >= 0 then
- My_Stack.Size := Storage_Offset (Limit) * Kilobyte;
- end if;
- end if;
- end if;
-
- My_Stack.Base := Frame_Address;
-
- if Stack_Grows_Down then
-
- -- Prevent wrap-around on too big stack sizes
-
- My_Stack.Limit := My_Stack.Base - My_Stack.Size;
-
- if My_Stack.Limit > My_Stack.Base then
- My_Stack.Limit := Address'First;
- end if;
-
- else
- My_Stack.Limit := My_Stack.Base + My_Stack.Size;
-
- -- Prevent wrap-around on too big stack sizes
-
- if My_Stack.Limit < My_Stack.Base then
- My_Stack.Limit := Address'Last;
- end if;
- end if;
- end if;
-
- -- 2) Set Stack.all to the value obtained in 1)
-
- Stack.all := My_Stack;
-
- -- 3) Optionally Poll to check for asynchronous abort
-
- if Soft_Links.Check_Abort_Status.all /= 0 then
- raise Standard'Abort_Signal;
- end if;
-
- return My_Stack; -- Never trust the cached value, but return local copy!
- end Set_Stack_Info;
-
- --------------------
- -- Set_Stack_Size --
- --------------------
-
- -- Specify the stack size for the current frame.
-
- procedure Set_Stack_Size
- (Stack_Size : System.Storage_Elements.Storage_Offset)
- is
- My_Stack : Stack_Access;
- Frame_Address : constant System.Address := My_Stack'Address;
-
- begin
- My_Stack := Stack_Check (Frame_Address);
-
- if Stack_Grows_Down then
- My_Stack.Limit := My_Stack.Base - Stack_Size;
- else
- My_Stack.Limit := My_Stack.Base + Stack_Size;
- end if;
- end Set_Stack_Size;
-
- -----------------
- -- Stack_Check --
- -----------------
-
- function Stack_Check
- (Stack_Address : System.Address) return Stack_Access
- is
- type Frame_Marker is null record;
- Marker : Frame_Marker;
- Cached_Stack : constant Stack_Access := Cache;
- Frame_Address : constant System.Address := Marker'Address;
-
- begin
- -- This function first does a "cheap" check which is correct
- -- if it succeeds. In case of failure, the full check is done.
- -- Ideally the cheap check should be done in an optimized manner,
- -- or be inlined.
-
- if (Stack_Grows_Down and then
- (Frame_Address <= Cached_Stack.Base
- and
- Stack_Address > Cached_Stack.Limit))
- or else
- (not Stack_Grows_Down and then
- (Frame_Address >= Cached_Stack.Base
- and
- Stack_Address < Cached_Stack.Limit))
- then
- -- Cached_Stack is valid as it passed the stack check
- return Cached_Stack;
- end if;
-
- Full_Check :
- declare
- My_Stack : constant Stack_Access := Set_Stack_Info (Cache'Access);
- -- At this point Stack.all might already be invalid, so
- -- it is essential to use our local copy of Stack!
-
- begin
- if (Stack_Grows_Down and then
- (not (Frame_Address <= My_Stack.Base)))
- or else
- (not Stack_Grows_Down and then
- (not (Frame_Address >= My_Stack.Base)))
- then
- -- The returned Base is lower than the stored one,
- -- so assume that the original one wasn't right and use the
- -- current Frame_Address as new one. This allows initializing
- -- Base with the Frame_Address as approximation.
- -- During initialization the Frame_Address will be close to
- -- the stack base anyway: the difference should be compensated
- -- for in the stack reserve.
-
- My_Stack.Base := Frame_Address;
- end if;
-
- if (Stack_Grows_Down and then
- Stack_Address < My_Stack.Limit)
- or else
- (not Stack_Grows_Down and then
- Stack_Address > My_Stack.Limit)
- then
- Ada.Exceptions.Raise_Exception
- (E => Storage_Error'Identity,
- Message => "stack overflow detected");
- end if;
-
- return My_Stack;
- end Full_Check;
- end Stack_Check;
-
- ------------------------
- -- Update_Stack_Cache --
- ------------------------
-
- procedure Update_Stack_Cache (Stack : Stack_Access) is
- begin
- if not Multi_Processor then
- Cache := Stack;
- end if;
- end Update_Stack_Cache;
-
-end System.Stack_Checking.Operations;
diff --git a/gcc/ada/s-stchop.ads b/gcc/ada/s-stchop.ads
deleted file mode 100644
index 10217204d6f..00000000000
--- a/gcc/ada/s-stchop.ads
+++ /dev/null
@@ -1,74 +0,0 @@
-------------------------------------------------------------------------------
--- --
--- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS --
--- --
--- S Y S T E M . S T A C K _ C H E C K I N G . O P E R A T I O N S --
--- --
--- S p e c --
--- --
--- Copyright (C) 1999-2004 Free Software Foundation, Inc. --
--- --
--- GNARL is free software; you can redistribute it and/or modify it under --
--- terms of the GNU General Public License as published by the Free Soft- --
--- ware Foundation; either version 2, or (at your option) any later ver- --
--- sion. GNARL is distributed in the hope that it will be useful, but WITH- --
--- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
--- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
--- for more details. You should have received a copy of the GNU General --
--- Public License distributed with GNARL; see file COPYING. If not, write --
--- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
--- MA 02111-1307, USA. --
--- --
--- As a special exception, if other files instantiate generics from this --
--- unit, or you link this unit with other files to produce an executable, --
--- this unit does not by itself cause the resulting executable to be --
--- covered by the GNU General Public License. This exception does not --
--- however invalidate any other reasons why the executable file might be --
--- covered by the GNU Public License. --
--- --
--- GNARL was developed by the GNARL team at Florida State University. --
--- Extensive contributions were provided by Ada Core Technologies, Inc. --
--- --
-------------------------------------------------------------------------------
-
--- This package provides a implementation of stack checking operations
--- using comparison with stack base and limit.
-
-pragma Restrictions (No_Elaboration_Code);
--- We want to guarantee the absence of elaboration code because the
--- binder does not handle references to this package.
-
-with System.Storage_Elements;
-
-pragma Polling (Off);
--- Turn off polling, we do not want polling to take place during stack
--- checking operations. It causes infinite loops and other problems.
-
-package System.Stack_Checking.Operations is
- procedure Set_Stack_Size
- (Stack_Size : System.Storage_Elements.Storage_Offset);
- -- Specify the stack size for the current task.
-
- procedure Update_Stack_Cache (Stack : Stack_Access);
- -- Set the stack cache for the current task. Note that this is only
- -- for optimization purposes, nothing can be assumed about the
- -- contents of the cache at any time, see Set_Stack_Info.
-
- procedure Invalidate_Stack_Cache (Any_Stack : Stack_Access);
- -- Invalidate cache entries for the task T that owns Any_Stack.
- -- This causes the Set_Stack_Info function to be called during
- -- the next stack check done by T. This can be used to interrupt
- -- task T asynchronously.
- -- Stack_Check should be called in loops for this to work reliably.
-
- function Stack_Check (Stack_Address : System.Address) return Stack_Access;
- -- This version of Stack_Check should not be inlined.
-
-private
-
- Cache : aliased Stack_Access := Null_Stack;
-
- pragma Export (C, Cache, "_gnat_stack_cache");
- pragma Export (C, Stack_Check, "_gnat_stack_check");
-
-end System.Stack_Checking.Operations;
diff --git a/gcc/alias.c b/gcc/alias.c
index d670a7db19e..3bf9e54e7ce 100644
--- a/gcc/alias.c
+++ b/gcc/alias.c
@@ -112,6 +112,11 @@ static bool nonoverlapping_component_refs_p (tree, tree);
static tree decl_for_component_ref (tree);
static rtx adjust_offset_for_component_ref (tree, rtx);
static int nonoverlapping_memrefs_p (rtx, rtx);
+
+/* APPLE LOCAL */
+static int overlapping_memrefs_p (rtx, rtx);
+/* APPLE LOCAL end */
+
static int write_dependence_p (rtx, rtx, int, int);
static int nonlocal_mentioned_p_1 (rtx *, void *);
@@ -2070,6 +2075,65 @@ nonoverlapping_memrefs_p (rtx x, rtx y)
return sizex >= 0 && offsety >= offsetx + sizex;
}
+/* APPLE LOCAL aliasing improvement */
+/* Helper for the following. Return 1 only if we're sure of overlap. */
+
+static int
+overlapping_trees_p (tree exprx, tree expry)
+{
+ /* If no info about either one, can't tell. */
+ if (exprx == 0 || expry == 0)
+ return 0;
+
+ /* Top level code must match. */
+ if (TREE_CODE (exprx) != TREE_CODE (expry))
+ return 0;
+
+ /* Components. */
+ if (TREE_CODE (exprx) == COMPONENT_REF)
+ {
+ /* They must refer to the same field... */
+ if (TREE_OPERAND (exprx, 1) != TREE_OPERAND (expry, 1))
+ return 0;
+ /* ...of the same object. (The object may be null, which
+ will compare as not overlapping.) */
+ return overlapping_trees_p (TREE_OPERAND (exprx, 0),
+ TREE_OPERAND (expry, 0));
+ }
+
+ /* Pointers. */
+ if (TREE_CODE (exprx) == INDIRECT_REF)
+ return overlapping_trees_p (TREE_OPERAND (exprx, 0),
+ TREE_OPERAND (expry, 0));
+
+ if (TREE_CODE (exprx) == VAR_DECL
+ || TREE_CODE (exprx) == PARM_DECL
+ || TREE_CODE (exprx) == CONST_DECL
+ || TREE_CODE (exprx) == FUNCTION_DECL)
+ return exprx == expry;
+
+ return 0;
+}
+
+/* Return 1 if memrefs definitely overlap, 0 otherwise. */
+
+
+static int
+overlapping_memrefs_p (rtx x, rtx y)
+{
+ tree exprx = MEM_EXPR (x), expry = MEM_EXPR (y);
+ rtx offsetx = MEM_OFFSET (x), offsety = MEM_OFFSET (y);
+
+ /* See if offsets collide. Known but different offsets do not
+ overlap. Unknown offsets will if the underlying object is the same. */
+ if (offsetx != 0 && offsety != 0 && !rtx_equal_p (offsetx, offsety))
+ return 0;
+
+ return overlapping_trees_p (exprx, expry);
+}
+/* APPLE LOCAL end aliasing improvement */
+
+
/* True dependence: X is read after store in MEM takes place. */
int
@@ -2120,6 +2184,10 @@ true_dependence (rtx mem, enum machine_mode mem_mode, rtx x,
&& CONSTANT_POOL_ADDRESS_P (base))))
return 0;
+ /* APPLE LOCAL */
+ if (overlapping_memrefs_p (mem, x))
+ return 1;
+
if (! base_alias_check (x_addr, mem_addr, GET_MODE (x), mem_mode))
return 0;
@@ -2187,6 +2255,10 @@ canon_true_dependence (rtx mem, enum machine_mode mem_mode, rtx mem_addr,
x_addr = get_addr (XEXP (x, 0));
+ /* APPLE LOCAL */
+ if (overlapping_memrefs_p (mem, x))
+ return 1;
+
if (! base_alias_check (x_addr, mem_addr, GET_MODE (x), mem_mode))
return 0;
@@ -2233,6 +2305,19 @@ write_dependence_p (rtx mem, rtx x, int writep, int constp)
if (GET_MODE (mem) == BLKmode && GET_CODE (XEXP (mem, 0)) == SCRATCH)
return 1;
+ /* APPLE LOCAL begin make SPEC gcc work with strict aliasing */
+ x_addr = get_addr (XEXP (x, 0));
+ mem_addr = get_addr (XEXP (mem, 0));
+
+ /* If two addresses are "the same" they conflict, even if type
+ checking says they don't. This is a bit too conservative
+ since there's no guarantee identical registers will have the
+ same values in both addresses. This is required to build
+ the (nonstandard) version of gcc found in SPEC. */
+ if (rtx_equal_p (x_addr, mem_addr))
+ return 1;
+ /* APPLE LOCAL end make SPEC gcc work with strict aliasing */
+
if (DIFFERENT_ALIAS_SETS_P (x, mem))
return 0;
diff --git a/gcc/basic-block.h b/gcc/basic-block.h
index 1465d9ed2d6..51363a96701 100644
--- a/gcc/basic-block.h
+++ b/gcc/basic-block.h
@@ -146,6 +146,10 @@ struct edge_def GTY((chain_next ("%h.pred_next")))
int probability; /* biased by REG_BR_PROB_BASE */
gcov_type count; /* Expected number of executions calculated
in profile.c */
+ /* APPLE LOCAL begin hot/cold partitioning */
+ bool crossing_edge; /* Crosses between hot and cold sections, when
+ we do partitioning. */
+ /* APPLE LOCAL end hot/cold partitioning */
};
typedef struct edge_def *edge;
@@ -268,6 +272,12 @@ struct basic_block_def GTY((chain_next ("%h.next_bb"), chain_prev ("%h.prev_bb")
/* Various flags. See BB_* below. */
int flags;
+ /* APPLE LOCAL begin hot/cold partitioning */
+ /* Which section block belongs in, when partitioning basic blocks. */
+ int partition;
+
+ /* APPLE LOCAL end hot/cold partitioning */
+
/* The data used by basic block copying and reordering functions. */
struct reorder_block_def * GTY ((skip (""))) rbi;
@@ -304,6 +314,14 @@ typedef struct reorder_block_def
#define BB_IRREDUCIBLE_LOOP 16
#define BB_SUPERBLOCK 32
+/* APPLE LOCAL begin hot/cold partitioning */
+/* Partitions, to be used when partitioning hot and cold basic blocks into
+ separate sections. */
+#define UNPARTITIONED 0
+#define HOT_PARTITION 1
+#define COLD_PARTITION 2
+/* APPLE LOCAL end hot/cold partitioning */
+
/* Number of basic blocks in the current function. */
extern int n_basic_blocks;
@@ -664,6 +682,9 @@ extern bool control_flow_insn_p (rtx);
/* In bb-reorder.c */
extern void reorder_basic_blocks (void);
+/* APPLE LOCAL begin hot/cold partitioning */
+extern void partition_hot_cold_basic_blocks (void);
+/* APPLE LOCAL end hot/cold partitioning */
/* In cfg.c */
extern void alloc_rbi_pool (void);
diff --git a/gcc/bb-reorder.c b/gcc/bb-reorder.c
index 90ef75cc7d0..55d4cf4933b 100644
--- a/gcc/bb-reorder.c
+++ b/gcc/bb-reorder.c
@@ -77,15 +77,29 @@
#include "cfglayout.h"
#include "fibheap.h"
#include "target.h"
-
-/* The number of rounds. */
-#define N_ROUNDS 4
+/* APPLE LOCAL begin hot/cold partitioning */
+#include "function.h"
+#include "obstack.h"
+#include "expr.h"
+#include "regs.h"
+#include "tm_p.h"
+
+#ifndef HAVE_return
+#define HAVE_return 0
+#define gen_return () NULL_RTX
+#endif
+
+/* The number of rounds. In most cases there will only be 4 rounds, but
+ when partitioning hot and cold basic blocks into separate sections of
+ the .o file there will be an extra round.*/
+#define N_ROUNDS 5
/* Branch thresholds in thousandths (per mille) of the REG_BR_PROB_BASE. */
-static int branch_threshold[N_ROUNDS] = {400, 200, 100, 0};
+static int branch_threshold[N_ROUNDS] = {400, 200, 100, 0, 0};
/* Exec thresholds in thousandths (per mille) of the frequency of bb 0. */
-static int exec_threshold[N_ROUNDS] = {500, 200, 50, 0};
+static int exec_threshold[N_ROUNDS] = {500, 200, 50, 0, 0};
+/* APPLE LOCAL end hot/cold partitioning */
/* If edge frequency is lower than DUPLICATION_THRESHOLD per mille of entry
block the edge destination is not duplicated while connecting traces. */
@@ -145,14 +159,66 @@ gcov_type max_entry_count;
static void find_traces (int *, struct trace *);
static basic_block rotate_loop (edge, struct trace *, int);
static void mark_bb_visited (basic_block, int);
+/* APPLE LOCAL begin hot/cold partitioning */
static void find_traces_1_round (int, int, gcov_type, struct trace *, int *,
- int, fibheap_t *);
+ int, fibheap_t *, int);
static basic_block copy_bb (basic_block, edge, basic_block, int);
static fibheapkey_t bb_to_key (basic_block);
-static bool better_edge_p (basic_block, edge, int, int, int, int);
+static bool better_edge_p (basic_block, edge, int, int, int, int, edge);
+/* APPLE LOCAL end hot/cold partitioning */
static void connect_traces (int, struct trace *);
static bool copy_bb_p (basic_block, int);
static int get_uncond_jump_length (void);
+/* APPLE LOCAL begin hot/cold partitioning */
+static bool push_to_next_round_p (basic_block, int, int, int, gcov_type);
+static void add_unlikely_executed_notes (void);
+static void find_rarely_executed_basic_blocks_and_crossing_edges (edge *,
+ int *,
+ int *);
+static void mark_bb_for_unlikely_executed_section (basic_block);
+static void add_labels_and_missing_jumps (edge *, int);
+static void add_reg_crossing_jump_notes (void);
+static void fix_up_fall_thru_edges (void);
+static void fix_edges_for_rarely_executed_code (edge *, int);
+static void fix_crossing_conditional_branches (void);
+static void fix_crossing_unconditional_branches (void);
+
+/* Check to see if bb should be pushed into the next round of trace
+ collections or not. Reasons for pushing the block forward are 1).
+ If the block is cold, we are doing partitioning, and there will be
+ another round (cold partition blocks are not supposed to be
+ collected into traces until the very last round); or 2). There will
+ be another round, and the basic block is not "hot enough" for the
+ current round of trace collection. */
+
+static bool
+push_to_next_round_p (basic_block bb, int round, int number_of_rounds,
+ int exec_th, gcov_type count_th)
+{
+ bool next_round_is_last;
+ bool there_exists_another_round;
+ bool block_not_hot_enough;
+
+ there_exists_another_round = round < number_of_rounds - 1;
+
+ next_round_is_last = round + 1 == number_of_rounds - 1;
+
+ block_not_hot_enough = (bb->frequency < exec_th
+ || bb->count < count_th
+ || probably_never_executed_bb_p (bb));
+
+ /* When partitioning, save last round for cold blocks only. */
+
+ if (flag_reorder_blocks_and_partition
+ && next_round_is_last
+ && bb->partition != COLD_PARTITION)
+ return false;
+ else if (there_exists_another_round && block_not_hot_enough)
+ return true;
+ else
+ return false;
+}
+/* APPLE LOCAL end hot/cold partitioning */
/* Find the traces for Software Trace Cache. Chain each trace through
RBI()->next. Store the number of traces to N_TRACES and description of
@@ -164,6 +230,18 @@ find_traces (int *n_traces, struct trace *traces)
int i;
edge e;
fibheap_t heap;
+ /* APPLE LOCAL begin hot/cold partitioning */
+ int number_of_rounds;
+
+ /* Add one extra round of trace collection when partitioning hot/cold
+ basic blocks into separate sections. The last round is for all the
+ cold blocks (and ONLY the cold blocks). */
+
+ number_of_rounds = N_ROUNDS - 1;
+ if (flag_reorder_blocks_and_partition)
+ number_of_rounds = N_ROUNDS;
+
+ /* APPLE LOCAL end hot/cold partitioning */
/* Insert entry points of function into heap. */
heap = fibheap_new ();
@@ -173,7 +251,7 @@ find_traces (int *n_traces, struct trace *traces)
{
bbd[e->dest->index].heap = heap;
bbd[e->dest->index].node = fibheap_insert (heap, bb_to_key (e->dest),
- e->dest);
+ e->dest);
if (e->dest->frequency > max_entry_frequency)
max_entry_frequency = e->dest->frequency;
if (e->dest->count > max_entry_count)
@@ -181,7 +259,9 @@ find_traces (int *n_traces, struct trace *traces)
}
/* Find the traces. */
- for (i = 0; i < N_ROUNDS; i++)
+ /* APPLE LOCAL begin hot/cold partitioning */
+ for (i = 0; i < number_of_rounds; i++)
+ /* APPLE LOCAL end hot/cold partitioning */
{
gcov_type count_threshold;
@@ -193,9 +273,12 @@ find_traces (int *n_traces, struct trace *traces)
else
count_threshold = max_entry_count / 1000 * exec_threshold[i];
+ /* APPLE LOCAL begin hot/cold partitioning */
find_traces_1_round (REG_BR_PROB_BASE * branch_threshold[i] / 1000,
max_entry_frequency * exec_threshold[i] / 1000,
- count_threshold, traces, n_traces, i, &heap);
+ count_threshold, traces, n_traces, i, &heap,
+ number_of_rounds);
+ /* APPLE LOCAL end hot/cold partitioning */
}
fibheap_delete (heap);
@@ -354,8 +437,16 @@ mark_bb_visited (basic_block bb, int trace)
static void
find_traces_1_round (int branch_th, int exec_th, gcov_type count_th,
struct trace *traces, int *n_traces, int round,
- fibheap_t *heap)
+ /* APPLE LOCAL begin hot/cold partitioning */
+ fibheap_t *heap, int number_of_rounds)
{
+ /* The following variable refers to the last round in which non-"cold"
+ blocks may be collected into a trace. */
+
+ int last_round = N_ROUNDS - 1;
+
+ /* APPLE LOCAL end hot/cold partitioning */
+
/* Heap for discarded basic blocks which are possible starting points for
the next round. */
fibheap_t new_heap = fibheap_new ();
@@ -374,10 +465,15 @@ find_traces_1_round (int branch_th, int exec_th, gcov_type count_th,
if (dump_file)
fprintf (dump_file, "Getting bb %d\n", bb->index);
- /* If the BB's frequency is too low send BB to the next round. */
- if (round < N_ROUNDS - 1
- && (bb->frequency < exec_th || bb->count < count_th
- || probably_never_executed_bb_p (bb)))
+ /* APPLE LOCAL begin hot/cold partitioning */
+ /* If the BB's frequency is too low send BB to the next round. When
+ partitioning hot/cold blocks into separate sections, make sure all
+ the cold blocks (and ONLY the cold blocks) go into the (extra) final
+ round. */
+
+ if (push_to_next_round_p (bb, round, number_of_rounds, exec_th,
+ count_th))
+ /* APPLE LOCAL end hot/cold partitioning */
{
int key = bb_to_key (bb);
bbd[bb->index].heap = new_heap;
@@ -427,6 +523,14 @@ find_traces_1_round (int branch_th, int exec_th, gcov_type count_th,
&& e->dest->rbi->visited != *n_traces)
continue;
+ /* APPLE LOCAL begin hot/cold partitioning */
+
+ if (e->dest->partition == COLD_PARTITION
+ && round < last_round)
+ continue;
+
+ /* APPLE LOCAL end hot/cold partitioning */
+
prob = e->probability;
freq = EDGE_FREQUENCY (e);
@@ -436,7 +540,13 @@ find_traces_1_round (int branch_th, int exec_th, gcov_type count_th,
|| prob < branch_th || freq < exec_th || e->count < count_th)
continue;
- if (better_edge_p (bb, e, prob, freq, best_prob, best_freq))
+ /* APPLE LOCAL begin hot/cold partitioning */
+ /* If partitioning hot/cold basic blocks, don't consider edges
+ that cross section boundaries. */
+
+ if (better_edge_p (bb, e, prob, freq, best_prob, best_freq,
+ best_edge))
+ /* APPLE LOCAL end hot/cold partitioning */
{
best_edge = e;
best_prob = prob;
@@ -490,7 +600,15 @@ find_traces_1_round (int branch_th, int exec_th, gcov_type count_th,
|| prob < branch_th || freq < exec_th
|| e->count < count_th)
{
- if (round < N_ROUNDS - 1)
+ /* APPLE LOCAL begin hot/cold partitioning */
+ /* When partitioning hot/cold basic blocks, make sure
+ the cold blocks (and only the cold blocks) all get
+ pushed to the last round of trace collection. */
+
+ if (push_to_next_round_p (e->dest, round,
+ number_of_rounds,
+ exec_th, count_th))
+ /* APPLE LOCAL end hot/cold partitioning */
which_heap = new_heap;
}
@@ -588,6 +706,9 @@ find_traces_1_round (int branch_th, int exec_th, gcov_type count_th,
&& !(e->flags & EDGE_COMPLEX)
&& !e->dest->rbi->visited
&& !e->dest->pred->pred_next
+ /* APPLE LOCAL begin hot/cold partitioning */
+ && !e->crossing_edge
+ /* APPLE LOCAL end hot/cold partitioning */
&& e->dest->succ
&& (e->dest->succ->flags & EDGE_CAN_FALLTHRU)
&& !(e->dest->succ->flags & EDGE_COMPLEX)
@@ -707,7 +828,9 @@ bb_to_key (basic_block bb)
int priority = 0;
/* Do not start in probably never executed blocks. */
- if (probably_never_executed_bb_p (bb))
+ /* APPLE LOCAL begin hot/cold partitioning */
+ if (bb->partition == COLD_PARTITION || probably_never_executed_bb_p (bb))
+ /* APPLE LOCAL end hot/cold partitioning */
return BB_FREQ_MAX;
/* Prefer blocks whose predecessor is an end of some trace
@@ -739,7 +862,9 @@ bb_to_key (basic_block bb)
static bool
better_edge_p (basic_block bb, edge e, int prob, int freq, int best_prob,
- int best_freq)
+ /* APPLE LOCAL begin hot/cold partitioning */
+ int best_freq, edge cur_best_edge)
+ /* APPLE LOCAL end hot/cold partitioning */
{
bool is_better_edge;
@@ -769,6 +894,18 @@ better_edge_p (basic_block bb, edge e, int prob, int freq, int best_prob,
is_better_edge = true;
else
is_better_edge = false;
+
+ /* APPLE LOCAL begin hot/cold partitioning */
+ /* If we are doing hot/cold partitioning, make sure that we always favor
+ non-crossing edges over crossing edges. */
+
+ if (!is_better_edge
+ && flag_reorder_blocks_and_partition
+ && cur_best_edge
+ && cur_best_edge->crossing_edge
+ && !e->crossing_edge)
+ is_better_edge = true;
+ /* APPLE LOCAL end hot/cold partitioning */
return is_better_edge;
}
@@ -783,6 +920,11 @@ connect_traces (int n_traces, struct trace *traces)
int last_trace;
int freq_threshold;
gcov_type count_threshold;
+ /* APPLE LOCAL begin hot/cold partitioning */
+ int unconnected_hot_trace_count = 0;
+ bool cold_connected = true;
+ bool *cold_traces;
+ /* APPLE LOCAL end hot/cold partitioning */
freq_threshold = max_entry_frequency * DUPLICATION_THRESHOLD / 1000;
if (max_entry_count < INT_MAX / 1000)
@@ -792,17 +934,68 @@ connect_traces (int n_traces, struct trace *traces)
connected = xcalloc (n_traces, sizeof (bool));
last_trace = -1;
- for (i = 0; i < n_traces; i++)
+
+ /* APPLE LOCAL begin hot/cold partitioning */
+ /* If we are partitioning hot/cold basic blocks, mark the cold
+ traces as already connnected, to remove them from consideration
+ for connection to the hot traces. After the hot traces have all
+ been connected (determined by "unconnected_hot_trace_count"), we
+ will go back and connect the cold traces. */
+
+ cold_traces = xcalloc (n_traces, sizeof (bool));
+
+ if (flag_reorder_blocks_and_partition)
+ for (i = 0; i < n_traces; i++)
+ {
+ if (traces[i].first->partition == COLD_PARTITION)
+ {
+ connected[i] = true;
+ cold_traces[i] = true;
+ cold_connected = false;
+ }
+ else
+ unconnected_hot_trace_count++;
+ }
+
+ for (i = 0; i < n_traces || !cold_connected ; i++)
{
int t = i;
int t2;
edge e, best;
int best_len;
+ /* If we are partitioning hot/cold basic blocks, check to see
+ if all the hot traces have been connected. If so, go back
+ and mark the cold traces as unconnected so we can connect
+ them up too. Re-set "i" to the first (unconnected) cold
+ trace. Use flag "cold_connected" to make sure we don't do
+ this step more than once. */
+
+ if (flag_reorder_blocks_and_partition
+ && (i >= n_traces || unconnected_hot_trace_count <= 0)
+ && !cold_connected)
+ {
+ int j;
+ int first_cold_trace = -1;
+
+ for (j = 0; j < n_traces; j++)
+ if (cold_traces[j])
+ {
+ connected[j] = false;
+ if (first_cold_trace == -1)
+ first_cold_trace = j;
+ }
+ i = t = first_cold_trace;
+ cold_connected = true;
+ }
+
if (connected[t])
continue;
connected[t] = true;
+ if (unconnected_hot_trace_count > 0)
+ unconnected_hot_trace_count--;
+ /* APPLE LOCAL end hot/cold partitioning */
/* Find the predecessor traces. */
for (t2 = t; t2 > 0;)
@@ -832,6 +1025,10 @@ connect_traces (int n_traces, struct trace *traces)
best->src->rbi->next = best->dest;
t2 = bbd[best->src->index].end_of_trace;
connected[t2] = true;
+ /* APPLE LOCAL begin hot/cold partitioning */
+ if (unconnected_hot_trace_count > 0)
+ unconnected_hot_trace_count--;
+ /* APPLE LOCAL end hot/cold partitioning */
if (dump_file)
{
fprintf (dump_file, "Connection: %d %d\n",
@@ -881,6 +1078,10 @@ connect_traces (int n_traces, struct trace *traces)
t = bbd[best->dest->index].start_of_trace;
traces[last_trace].last->rbi->next = traces[t].first;
connected[t] = true;
+ /* APPLE LOCAL begin hot/cold partitioning */
+ if (unconnected_hot_trace_count > 0)
+ unconnected_hot_trace_count--;
+ /* APPLE LOCAL end hot/cold partitioning */
last_trace = t;
}
else
@@ -940,6 +1141,11 @@ connect_traces (int n_traces, struct trace *traces)
}
}
+ /* APPLE LOCAL begin hot/cold partitioning */
+ if (flag_reorder_blocks_and_partition)
+ try_copy = false;
+ /* APPLE LOCAL end hot/cold partitioning */
+
/* Copy tiny blocks always; copy larger blocks only when the
edge is traversed frequently enough. */
if (try_copy
@@ -969,6 +1175,10 @@ connect_traces (int n_traces, struct trace *traces)
t = bbd[next_bb->index].start_of_trace;
traces[last_trace].last->rbi->next = traces[t].first;
connected[t] = true;
+ /* APPLE LOCAL begin hot/cold partitioning */
+ if (unconnected_hot_trace_count > 0)
+ unconnected_hot_trace_count--;
+ /* APPLE LOCAL end hot/cold partitioning */
last_trace = t;
}
else
@@ -1063,6 +1273,715 @@ get_uncond_jump_length (void)
return length;
}
+/* APPLE LOCAL begin hot/cold partitioning */
+static void
+add_unlikely_executed_notes (void)
+{
+ basic_block bb;
+
+ FOR_EACH_BB (bb)
+ if (bb->partition == COLD_PARTITION)
+ mark_bb_for_unlikely_executed_section (bb);
+}
+
+/* Find the basic blocks that are rarely executed and need to be moved to
+ a separate section of the .o file (to cut down on paging and improve
+ cache locality). */
+
+static void
+find_rarely_executed_basic_blocks_and_crossing_edges (edge *crossing_edges,
+ int *n_crossing_edges,
+ int *max_idx)
+{
+ basic_block bb;
+ bool has_hot_blocks;
+ edge e;
+ int i;
+
+ /* Mark which partition (hot/cold) each basic block belongs in. */
+
+ FOR_EACH_BB (bb)
+ {
+ if (probably_never_executed_bb_p (bb))
+ bb->partition = COLD_PARTITION;
+ else
+ {
+ bb->partition = HOT_PARTITION;
+ has_hot_blocks = true;
+ }
+ }
+
+ /* Since all "hot" basic blocks will eventually be scheduled before all
+ cold basic blocks, make *sure* the real function entry block is in
+ the hot partition. */
+
+ if (has_hot_blocks)
+ for (e = ENTRY_BLOCK_PTR->succ; e; e = e->succ_next)
+ if (e->dest->index >= 0)
+ {
+ e->dest->partition = HOT_PARTITION;
+ break;
+ }
+
+ /* Mark every edge that crosses between sections. */
+
+ i = 0;
+ if (targetm.have_named_sections)
+ {
+ FOR_EACH_BB (bb)
+ for (e = bb->succ; e; e = e->succ_next)
+ {
+ if (e->src != ENTRY_BLOCK_PTR
+ && e->dest != EXIT_BLOCK_PTR
+ && e->src->partition != e->dest->partition)
+ {
+ e->crossing_edge = true;
+ if (i == *max_idx)
+ {
+ *max_idx *= 2;
+ crossing_edges = xrealloc (crossing_edges,
+ (*max_idx) * sizeof (edge));
+ }
+ crossing_edges[i++] = e;
+ }
+ else
+ e->crossing_edge = false;
+ }
+
+ }
+ *n_crossing_edges = i;
+}
+
+/* Add NOTE_INSN_UNLIKELY_EXECUTED_CODE to top of basic block. This note
+ is later used to mark the basic block to be put in the
+ unlikely-to-be-executed section of the .o file. */
+
+static void
+mark_bb_for_unlikely_executed_section (basic_block bb)
+{
+ rtx cur_insn;
+ rtx insert_insn = NULL;
+ rtx new_note;
+
+ /* Find first non-note instruction and insert new NOTE before it (as
+ long as new NOTE is not first instruction in basic block). */
+
+ for (cur_insn = BB_HEAD (bb); cur_insn != NEXT_INSN (BB_END (bb));
+ cur_insn = NEXT_INSN (cur_insn))
+ if (GET_CODE (cur_insn) != NOTE
+ && GET_CODE (cur_insn) != CODE_LABEL)
+ {
+ insert_insn = cur_insn;
+ break;
+ }
+
+ /* Insert note and assign basic block number to it. */
+
+ if (insert_insn)
+ {
+ new_note = emit_note_before (NOTE_INSN_UNLIKELY_EXECUTED_CODE,
+ insert_insn);
+ NOTE_BASIC_BLOCK (new_note) = bb;
+ }
+ else
+ {
+ new_note = emit_note_after (NOTE_INSN_UNLIKELY_EXECUTED_CODE,
+ BB_END (bb));
+ NOTE_BASIC_BLOCK (new_note) = bb;
+ }
+}
+
+/* If any destination of a crossing edge does not have a label, add label;
+ Convert any fall-through crossing edges (for blocks that do not contain
+ a jump) to unconditional jumps. */
+
+static void
+add_labels_and_missing_jumps (edge *crossing_edges, int n_crossing_edges)
+{
+ int i;
+ basic_block src;
+ basic_block dest;
+ rtx label;
+ rtx barrier;
+ rtx new_jump;
+
+ for (i=0; i < n_crossing_edges; i++)
+ {
+ if (crossing_edges[i])
+ {
+ src = crossing_edges[i]->src;
+ dest = crossing_edges[i]->dest;
+
+ /* Make sure dest has a label. */
+
+ if (dest && (dest != EXIT_BLOCK_PTR))
+ {
+ label = block_label (dest);
+
+ /* Make sure source block ends with a jump. */
+
+ if (src && (src != ENTRY_BLOCK_PTR))
+ {
+ if (GET_CODE (BB_END (src)) != JUMP_INSN)
+ /* bb just falls through. */
+ {
+ /* make sure there's only one successor */
+ if (src->succ && (src->succ->succ_next == NULL))
+ {
+ /* Find label in dest block. */
+ label = block_label (dest);
+
+ new_jump = emit_jump_insn_after (gen_jump (label),
+ BB_END (src));
+ barrier = emit_barrier_after (new_jump);
+ JUMP_LABEL (new_jump) = label;
+ LABEL_NUSES (label) += 1;
+ src->rbi->footer = unlink_insn_chain (barrier,
+ barrier);
+ /* Mark edge as non-fallthru. */
+ crossing_edges[i]->flags &= ~EDGE_FALLTHRU;
+ }
+ else
+ {
+ /* Basic block has two successors, but
+ doesn't end in a jump; something is wrong
+ here! */
+ abort();
+ }
+ } /* end: 'if (GET_CODE ... ' */
+ } /* end: 'if (src && src->index...' */
+ } /* end: 'if (dest && dest->index...' */
+ } /* end: 'if (crossing_edges[i]...' */
+ } /* end for loop */
+}
+
+/* Find any bb's where the fall-through edge is a crossing edge (note that
+ these bb's must also contain a conditional jump; we've already
+ dealt with fall-through edges for blocks that didn't have a
+ conditional jump in the call to add_labels_and_missing_jumps).
+ Convert the fall-through edge to non-crossing edge by inserting a
+ new bb to fall-through into. The new bb will contain an
+ unconditional jump (crossing edge) to the original fall through
+ destination. */
+
+static void
+fix_up_fall_thru_edges (void)
+{
+ basic_block cur_bb;
+ basic_block new_bb;
+ edge succ1;
+ edge succ2;
+ edge fall_thru;
+ edge cond_jump;
+ edge e;
+ bool cond_jump_crosses;
+ int invert_worked;
+ rtx old_jump;
+ rtx fall_thru_label;
+ rtx barrier;
+
+ FOR_EACH_BB (cur_bb)
+ {
+ fall_thru = NULL;
+ succ1 = cur_bb->succ;
+ if (succ1)
+ succ2 = succ1->succ_next;
+ else
+ succ2 = NULL;
+
+ /* Find the fall-through edge. */
+
+ if (succ1
+ && (succ1->flags & EDGE_FALLTHRU))
+ {
+ fall_thru = succ1;
+ cond_jump = succ2;
+ }
+ else if (succ2
+ && (succ2->flags & EDGE_FALLTHRU))
+ {
+ fall_thru = succ2;
+ cond_jump = succ1;
+ }
+
+ if (fall_thru && (fall_thru->dest != EXIT_BLOCK_PTR))
+ {
+ /* Check to see if the fall-thru edge is a crossing edge. */
+
+ if (fall_thru->crossing_edge)
+ {
+ /* The fall_thru edge crosses; now check the cond jump edge, if
+ it exists. */
+
+ cond_jump_crosses = true;
+ invert_worked = 0;
+ old_jump = BB_END (cur_bb);
+
+ /* Find the jump instruction, if there is one. */
+
+ if (cond_jump)
+ {
+ if (!cond_jump->crossing_edge)
+ cond_jump_crosses = false;
+
+ /* We know the fall-thru edge crosses; if the cond
+ jump edge does NOT cross, and its destination is the
+ next block in the bb order, invert the jump
+ (i.e. fix it so the fall thru does not cross and
+ the cond jump does). */
+
+ if (!cond_jump_crosses
+ && cur_bb->rbi->next == cond_jump->dest)
+ {
+ /* Find label in fall_thru block. We've already added
+ any missing labels, so there must be one. */
+
+ fall_thru_label = block_label (fall_thru->dest);
+
+ if (old_jump && fall_thru_label)
+ invert_worked = invert_jump (old_jump,
+ fall_thru_label,0);
+ if (invert_worked)
+ {
+ fall_thru->flags &= ~EDGE_FALLTHRU;
+ cond_jump->flags |= EDGE_FALLTHRU;
+ update_br_prob_note (cur_bb);
+ e = fall_thru;
+ fall_thru = cond_jump;
+ cond_jump = e;
+ cond_jump->crossing_edge = true;
+ fall_thru->crossing_edge = false;
+ }
+ }
+ }
+
+ if (cond_jump_crosses || !invert_worked)
+ {
+ /* This is the case where both edges out of the basic
+ block are crossing edges. Here we will fix up the
+ fall through edge. The jump edge will be taken care
+ of later. */
+
+ new_bb = force_nonfallthru (fall_thru);
+
+ if (new_bb)
+ {
+ new_bb->rbi->next = cur_bb->rbi->next;
+ cur_bb->rbi->next = new_bb;
+
+ /* Make sure new fall-through bb is in same
+ partition as bb it's falling through from. */
+
+ new_bb->partition = cur_bb->partition;
+ new_bb->succ->crossing_edge = true;
+ }
+
+ /* Add barrier after new jump */
+
+ if (new_bb)
+ {
+ barrier = emit_barrier_after (BB_END (new_bb));
+ new_bb->rbi->footer = unlink_insn_chain (barrier,
+ barrier);
+ }
+ else
+ {
+ barrier = emit_barrier_after (BB_END (cur_bb));
+ cur_bb->rbi->footer = unlink_insn_chain (barrier,
+ barrier);
+ }
+ }
+ }
+ }
+ }
+}
+
+/* This function checks the destination blockof a "crossing jump" to
+ see if it has any crossing predecessors that begin with a code label
+ and end with an unconditional jump. If so, it returns that predecessor
+ block. (This is to avoid creating lots of new basic blocks that all
+ contain unconditional jumps to the same destination). */
+
+static basic_block
+find_jump_block (basic_block jump_dest)
+{
+ basic_block source_bb = NULL;
+ edge e;
+ rtx insn;
+
+ for (e = jump_dest->pred; e; e = e->pred_next)
+ if (e->crossing_edge)
+ {
+ basic_block src = e->src;
+
+ /* Check each predecessor to see if it has a label, and contains
+ only one executable instruction, which is an unconditional jump.
+ If so, we can use it. */
+
+ if (GET_CODE (BB_HEAD (src)) == CODE_LABEL)
+ for (insn = BB_HEAD (src);
+ !INSN_P (insn) && insn != NEXT_INSN (BB_END (src));
+ insn = NEXT_INSN (insn))
+ {
+ if (INSN_P (insn)
+ && insn == BB_END (src)
+ && GET_CODE (insn) == JUMP_INSN
+ && !any_condjump_p (insn))
+ {
+ source_bb = src;
+ break;
+ }
+ }
+
+ if (source_bb)
+ break;
+ }
+
+ return source_bb;
+}
+
+/* Find all BB's with conditional jumps that are crossing edges;
+ insert a new bb and make the conditional jump branch to the new
+ bb instead (make the new bb same color so conditional branch won't
+ be a 'crossing' edge). Insert an unconditional jump from the
+ new bb to the original destination of the conditional jump. */
+
+static void
+fix_crossing_conditional_branches (void)
+{
+ basic_block cur_bb;
+ basic_block new_bb;
+ basic_block last_bb;
+ basic_block dest;
+ basic_block prev_bb;
+ edge succ1;
+ edge succ2;
+ edge crossing_edge;
+ edge new_edge;
+ rtx old_jump;
+ rtx set_src;
+ rtx old_label = NULL_RTX;
+ rtx new_label;
+ rtx new_jump;
+ rtx barrier;
+
+ last_bb = EXIT_BLOCK_PTR->prev_bb;
+
+ FOR_EACH_BB (cur_bb)
+ {
+ crossing_edge = NULL;
+ succ1 = cur_bb->succ;
+ if (succ1)
+ succ2 = succ1->succ_next;
+ else
+ succ2 = NULL;
+
+ /* We already took care of fall-through edges, so only one successor
+ can be a crossing edge. */
+
+ if (succ1 && succ1->crossing_edge)
+ crossing_edge = succ1;
+ else if (succ2 && succ2->crossing_edge)
+ crossing_edge = succ2;
+
+ if (crossing_edge)
+ {
+ old_jump = BB_END (cur_bb);
+
+ /* Check to make sure the jump instruction is a
+ conditional jump. */
+
+ set_src = NULL_RTX;
+
+ if (any_condjump_p (old_jump))
+ {
+ if (GET_CODE (PATTERN (old_jump)) == SET)
+ set_src = SET_SRC (PATTERN (old_jump));
+ else if (GET_CODE (PATTERN (old_jump)) == PARALLEL)
+ {
+ set_src = XVECEXP (PATTERN (old_jump), 0,0);
+ if (GET_CODE (set_src) == SET)
+ set_src = SET_SRC (set_src);
+ else
+ set_src = NULL_RTX;
+ }
+ }
+
+ if (set_src && (GET_CODE (set_src) == IF_THEN_ELSE))
+ {
+ if (GET_CODE (XEXP (set_src, 1)) == PC)
+ old_label = XEXP (set_src, 2);
+ else if (GET_CODE (XEXP (set_src, 2)) == PC)
+ old_label = XEXP (set_src, 1);
+
+ /* Check to see if new bb for jumping to that dest has
+ already been created; if so, use it; if not, create
+ a new one. */
+
+ new_bb = find_jump_block (crossing_edge->dest);
+
+ if (new_bb)
+ new_label = block_label (new_bb);
+ else
+ {
+ /* Create new basic block to be dest for
+ conditional jump. */
+
+ new_bb = create_basic_block (NULL, NULL, last_bb);
+ new_bb->rbi->next = last_bb->rbi->next;
+ last_bb->rbi->next = new_bb;
+ prev_bb = last_bb;
+ last_bb = new_bb;
+
+ /* Update register liveness information. */
+
+ new_bb->global_live_at_start =
+ OBSTACK_ALLOC_REG_SET (&flow_obstack);
+ new_bb->global_live_at_end =
+ OBSTACK_ALLOC_REG_SET (&flow_obstack);
+ COPY_REG_SET (new_bb->global_live_at_end,
+ prev_bb->global_live_at_end);
+ COPY_REG_SET (new_bb->global_live_at_start,
+ prev_bb->global_live_at_end);
+
+ /* Put appropriate instructions in new bb. */
+
+ new_label = gen_label_rtx ();
+ emit_label_before (new_label, BB_HEAD (new_bb));
+ BB_HEAD (new_bb) = new_label;
+
+ if (GET_CODE (old_label) == LABEL_REF)
+ {
+ old_label = JUMP_LABEL (old_jump);
+ new_jump = emit_jump_insn_after (gen_jump
+ (old_label),
+ BB_END (new_bb));
+ }
+ else if (HAVE_return
+ && GET_CODE (old_label) == RETURN)
+ new_jump = emit_jump_insn_after (gen_return (),
+ BB_END (new_bb));
+ else
+ abort ();
+
+ barrier = emit_barrier_after (new_jump);
+ JUMP_LABEL (new_jump) = old_label;
+ new_bb->rbi->footer = unlink_insn_chain (barrier,
+ barrier);
+
+ /* Make sure new bb is in same partition as source
+ of conditional branch. */
+
+ new_bb->partition = cur_bb->partition;
+ }
+
+ /* Make old jump branch to new bb. */
+
+ redirect_jump (old_jump, new_label, 0);
+
+ /* Remove crossing_edge as predecessor of 'dest'. */
+
+ dest = crossing_edge->dest;
+
+ redirect_edge_succ (crossing_edge, new_bb);
+
+ /* Make a new edge from new_bb to old dest; new edge
+ will be a successor for new_bb and a predecessor
+ for 'dest'. */
+
+ if (!new_bb->succ)
+ new_edge = make_edge (new_bb, dest, 0);
+ else
+ new_edge = new_bb->succ;
+
+ crossing_edge->crossing_edge = false;
+ new_edge->crossing_edge = true;
+ }
+ }
+ }
+}
+
+/* Find any unconditional branches that cross between hot and cold
+ sections. Convert them into indirect jumps instead. */
+
+static void
+fix_crossing_unconditional_branches (void)
+{
+ basic_block cur_bb;
+ rtx last_insn;
+ rtx label;
+ rtx label_addr;
+ rtx indirect_jump_sequence;
+ rtx jump_insn = NULL_RTX;
+ rtx new_reg;
+ rtx cur_insn;
+ edge succ;
+
+ FOR_EACH_BB (cur_bb)
+ {
+ last_insn = BB_END (cur_bb);
+ succ = cur_bb->succ;
+
+ /* Check to see if bb ends in a crossing (unconditional) jump. At
+ this point, no crossing jumps should be conditional. */
+
+ if (GET_CODE (last_insn) == JUMP_INSN
+ && succ->crossing_edge)
+ {
+ rtx label2, table;
+
+ if (any_condjump_p (last_insn))
+ abort ();
+
+ /* Make sure the jump is not already an indirect or table jump. */
+
+ else if (!computed_jump_p (last_insn)
+ && !tablejump_p (last_insn, &label2, &table))
+ {
+ /* We have found a "crossing" unconditional branch. Now
+ we must convert it to an indirect jump. First create
+ reference of label, as target for jump. */
+
+ label = JUMP_LABEL (last_insn);
+ label_addr = gen_rtx_LABEL_REF (Pmode, label);
+ LABEL_NUSES (label) += 1;
+
+ /* Get a register to use for the indirect jump. */
+
+ new_reg = gen_reg_rtx (Pmode);
+
+ /* Generate indirect the jump sequence. */
+
+ start_sequence ();
+ emit_move_insn (new_reg, label_addr);
+ emit_indirect_jump (new_reg);
+ indirect_jump_sequence = get_insns ();
+ end_sequence ();
+
+ /* Make sure every instruction in the new jump sequence has
+ its basic block set to be cur_bb. */
+
+ for (cur_insn = indirect_jump_sequence; cur_insn;
+ cur_insn = NEXT_INSN (cur_insn))
+ {
+ BLOCK_FOR_INSN (cur_insn) = cur_bb;
+ if (GET_CODE (cur_insn) == JUMP_INSN)
+ jump_insn = cur_insn;
+ }
+
+ /* Insert the new (indirect) jump sequence immediately before
+ the unconditional jump, then delete the unconditional jump. */
+
+ emit_insn_before (indirect_jump_sequence, last_insn);
+ delete_insn (last_insn);
+
+ /* Make BB_END for cur_bb be the jump instruction (NOT the
+ barrier instruction at the end of the sequence...). */
+
+ BB_END (cur_bb) = jump_insn;
+ }
+ }
+ }
+}
+
+/* Add REG_CROSSING_JUMP note to all crossing jump insns. */
+
+static void
+add_reg_crossing_jump_notes (void)
+{
+ basic_block bb;
+ edge e;
+
+ FOR_EACH_BB (bb)
+ for (e = bb->succ; e; e = e->succ_next)
+ if (e->crossing_edge
+ && GET_CODE (BB_END (e->src)) == JUMP_INSN)
+ REG_NOTES (BB_END (e->src)) = gen_rtx_EXPR_LIST (REG_CROSSING_JUMP,
+ NULL_RTX,
+ REG_NOTES (BB_END
+ (e->src)));
+}
+
+/* Basic blocks containing NOTE_INSN_UNLIKELY_EXECUTED_CODE will be
+ put in a separate section of the .o file, to reduce paging and
+ improve cache performance (hopefully). This can result in bits of
+ code from the same function being widely separated in the .o file.
+ However this is not obvious to the current bb structure. Therefore
+ we must take care to ensure that: 1). There are no fall_thru edges
+ that cross between sections; 2). For those architectures which
+ have "short" conditional branches, all conditional branches that
+ attempt to cross between sections are converted to unconditional
+ branches; and, 3). For those architectures which have "short"
+ unconditional branches, all unconditional branches that attempt
+ to cross between sections are converted to indirect jumps.
+
+ The code for fixing up fall_thru edges that cross between hot and
+ cold basic blocks does so by creating new basic blocks containing
+ unconditional branches to the appropriate label in the "other"
+ section. The new basic block is then put in the same (hot or cold)
+ section as the original conditional branch, and the fall_thru edge
+ is modified to fall into the new basic block instead. By adding
+ this level of indirection we end up with only unconditional branches
+ crossing between hot and cold sections.
+
+ Conditional branches are dealt with by adding a level of indirection.
+ A new basic block is added in the same (hot/cold) section as the
+ conditional branch, and the conditional branch is retargeted to the
+ new basic block. The new basic block contains an unconditional branch
+ to the original target of the conditional branch (in the other section).
+
+ Unconditional branches are dealt with by converting them into
+ indirect jumps. */
+
+static void
+fix_edges_for_rarely_executed_code (edge *crossing_edges,
+ int n_crossing_edges)
+{
+ /* Make sure the source of any crossing edge ends in a jump and the
+ destination of any crossing edge has a label. */
+
+ add_labels_and_missing_jumps (crossing_edges, n_crossing_edges);
+
+ /* Convert all crossing fall_thru edges to non-crossing fall
+ thrus to unconditional jumps (that jump to the original fall
+ thru dest). */
+
+ fix_up_fall_thru_edges ();
+
+ /* Only do the parts necessary for writing separate sections if
+ the target architecture has the ability to write separate sections
+ (i.e. it has named sections). Otherwise, the hot/cold partitioning
+ information will be used when reordering blocks to try to put all
+ the hot blocks together, then all the cold blocks, but no actual
+ section partitioning will be done. */
+
+ if (targetm.have_named_sections)
+ {
+ /* If the architecture does not have conditional branches that can
+ span all of memory, convert crossing conditional branches into
+ crossing unconditional branches. */
+
+ if (!HAS_LONG_COND_BRANCH)
+ fix_crossing_conditional_branches ();
+
+ /* If the architecture does not have unconditional branches that
+ can span all of memory, convert crossing unconditional branches
+ into indirect jumps. Since adding an indirect jump also adds
+ a new register usage, update the register usage information as
+ well. */
+
+ if (!HAS_LONG_UNCOND_BRANCH)
+ {
+ fix_crossing_unconditional_branches ();
+ reg_scan (get_insns(), max_reg_num (), 1);
+ }
+
+ add_reg_crossing_jump_notes ();
+ }
+}
+
+/* APPLE LOCAL end hot/cold partitioning */
+
/* Reorder basic blocks. The main entry point to this file. */
void
@@ -1075,7 +1994,7 @@ reorder_basic_blocks (void)
if (n_basic_blocks <= 1)
return;
- if ((* targetm.cannot_modify_jumps_p) ())
+ if (targetm.cannot_modify_jumps_p ())
return;
timevar_push (TV_REORDER_BLOCKS);
@@ -1111,7 +2030,69 @@ reorder_basic_blocks (void)
if (dump_file)
dump_flow_info (dump_file);
+ /* APPLE LOCAL begin hot/cold partitioning */
+ if (flag_reorder_blocks_and_partition
+ && targetm.have_named_sections)
+ add_unlikely_executed_notes ();
+ /* APPLE LOCAL end hot/cold partitioning */
+
cfg_layout_finalize ();
timevar_pop (TV_REORDER_BLOCKS);
}
+
+/* APPLE LOCAL begin hot/cold partitioning */
+/* This function is the main 'entrance' for the optimization that
+ partitions hot and cold basic blocks into separate sections of the
+ .o file (to improve performance and cache locality). Ideally it
+ would be called after all optimizations that rearrange the CFG have
+ been called. However part of this optimization may introduce new
+ register usage, so it must be called before register allocation has
+ occurred. This means that this optimization is actually called
+ well before the optimization that reorders basic blocks (see function
+ above).
+
+ This optimization checks the feedback information to determine
+ which basic blocks are hot/cold and adds
+ NOTE_INSN_UNLIKELY_EXECUTED_CODE to non-hot basic blocks. The
+ presence or absence of this note is later used for writing out
+ sections in the .o file. This optimization must also modify the
+ CFG to make sure there are no fallthru edges between hot & cold
+ blocks, as those blocks will not necessarily be contiguous in the
+ .o (or assembly) file; and in those cases where the architecture
+ requires it, conditional and unconditional branches that cross
+ between sections are converted into unconditional or indirect
+ jumps, depending on what is appropriate. */
+
+void
+partition_hot_cold_basic_blocks (void)
+{
+ basic_block cur_bb;
+ edge *crossing_edges;
+ int n_crossing_edges;
+ int max_edges = 2 * last_basic_block;
+
+ if (n_basic_blocks <= 1)
+ return;
+
+ crossing_edges = xcalloc (max_edges, sizeof (edge));
+
+ cfg_layout_initialize ();
+
+ FOR_EACH_BB (cur_bb)
+ if (cur_bb->index >= 0
+ && cur_bb->next_bb->index >= 0)
+ cur_bb->rbi->next = cur_bb->next_bb;
+
+ find_rarely_executed_basic_blocks_and_crossing_edges (crossing_edges,
+ &n_crossing_edges,
+ &max_edges);
+
+ if (n_crossing_edges > 0)
+ fix_edges_for_rarely_executed_code (crossing_edges, n_crossing_edges);
+
+ free (crossing_edges);
+
+ cfg_layout_finalize();
+}
+/* APPLE LOCAL end hot/cold partitioning */
diff --git a/gcc/builtin-types.def b/gcc/builtin-types.def
index e65c6a8a160..cfd8b34155f 100644
--- a/gcc/builtin-types.def
+++ b/gcc/builtin-types.def
@@ -297,3 +297,10 @@ DEF_FUNCTION_TYPE_VAR_3 (BT_FN_SSIZE_STRING_SIZE_CONST_STRING_VAR,
DEF_POINTER_TYPE (BT_PTR_FN_VOID_VAR, BT_FN_VOID_VAR)
DEF_FUNCTION_TYPE_3 (BT_FN_PTR_PTR_FN_VOID_VAR_PTR_SIZE,
BT_PTR, BT_PTR_FN_VOID_VAR, BT_PTR, BT_SIZE)
+
+/* APPLE LOCAL begin constant cfstrings */
+/* For simplicity's sake, we will make __builtin___CFStringMakeConstantString
+ return a 'const void *', rather than 'CFStringRef', so that we can avoid
+ having to define 'CFStringRef' as a built-in type. */
+DEF_FUNCTION_TYPE_1 (BT_FN_CONST_PTR_CONST_STRING, BT_CONST_PTR, BT_CONST_STRING)
+/* APPLE LOCAL end constant cfstrings */
diff --git a/gcc/builtins.c b/gcc/builtins.c
index 6b6440f0c58..39f603f4d85 100644
--- a/gcc/builtins.c
+++ b/gcc/builtins.c
@@ -174,6 +174,11 @@ static void simplify_builtin_next_arg (tree);
static void simplify_builtin_va_start (tree);
static tree simplify_builtin_sprintf (tree, int);
+/* APPLE LOCAL begin constant cfstrings */
+/* This is broken, builtins.c should not be referencing something in
+ c-common. */
+extern tree build_cfstring_ascii (tree);
+/* APPLE LOCAL end constant cfstrings */
/* Return the alignment in bits of EXP, a pointer valued expression.
But don't return more than MAX_ALIGN no matter what.
@@ -5752,6 +5757,15 @@ expand_builtin (tree exp, rtx target, rtx subtarget, enum machine_mode mode,
case BUILT_IN_PROFILE_FUNC_EXIT:
return expand_builtin_profile_func (true);
+ /* APPLE LOCAL begin constant cfstrings */
+ case BUILT_IN___CFSTRINGMAKECONSTANTSTRING:
+ /* if __builtin___CFStringMakeConstantString made it intact this far,
+ past the constant folding, it means that the argument is not a
+ constant. This is a no-no. */
+ error ("CFString literal expression not constant");
+ return const0_rtx;
+ /* APPLE LOCAL end constant cfstrings */
+
case BUILT_IN_INIT_TRAMPOLINE:
return expand_builtin_init_trampoline (arglist);
case BUILT_IN_ADJUST_TRAMPOLINE:
@@ -6946,6 +6960,26 @@ fold_builtin_1 (tree exp)
}
break;
+ /* APPLE LOCAL begin constant cfstrings */
+ case BUILT_IN___CFSTRINGMAKECONSTANTSTRING:
+ /* This may only be used in conjunction with '-fconstant-cfstrings'. */
+ if (!flag_constant_cfstrings)
+ {
+ error ("built-in function `%s' requires `-fconstant-cfstrings' flag",
+ IDENTIFIER_POINTER (DECL_NAME (fndecl)));
+ return error_mark_node;
+ }
+ if (validate_arglist (arglist, POINTER_TYPE, VOID_TYPE))
+ {
+ tree offset_node;
+ tree literal = string_constant (TREE_VALUE (arglist), &offset_node);
+
+ if (literal)
+ return build_cfstring_ascii (literal);
+ }
+ break;
+ /* APPLE LOCAL end constant cfstrings */
+
case BUILT_IN_FABS:
case BUILT_IN_FABSF:
case BUILT_IN_FABSL:
diff --git a/gcc/builtins.def b/gcc/builtins.def
index 5141067c11d..4805b1c08df 100644
--- a/gcc/builtins.def
+++ b/gcc/builtins.def
@@ -518,6 +518,12 @@ DEF_LIB_BUILTIN (BUILT_IN_EXIT, "exit", BT_FN_VOID_INT, ATTR_NORETURN_NOT
DEF_GCC_BUILTIN (BUILT_IN_EXPECT, "expect", BT_FN_LONG_LONG_LONG, ATTR_NULL)
DEF_GCC_BUILTIN (BUILT_IN_EXTEND_POINTER, "extend_pointer", BT_FN_WORD_PTR, ATTR_CONST_NOTHROW_LIST)
DEF_GCC_BUILTIN (BUILT_IN_EXTRACT_RETURN_ADDR, "extract_return_addr", BT_FN_PTR_PTR, ATTR_NULL)
+/* APPLE LOCAL begin constant cfstrings */
+DEF_GCC_BUILTIN (BUILT_IN___CFSTRINGMAKECONSTANTSTRING,
+ "__CFStringMakeConstantString",
+ BT_FN_CONST_PTR_CONST_STRING,
+ ATTR_NULL)
+/* APPLE LOCAL end constant cfstrings */
DEF_GCC_BUILTIN (BUILT_IN_FRAME_ADDRESS, "frame_address", BT_FN_PTR_UNSIGNED, ATTR_NULL)
DEF_GCC_BUILTIN (BUILT_IN_FROB_RETURN_ADDR, "frob_return_addr", BT_FN_PTR_PTR, ATTR_NULL)
DEF_EXT_LIB_BUILTIN (BUILT_IN_GETTEXT, "gettext", BT_FN_STRING_CONST_STRING, ATTR_FORMAT_ARG_1)
diff --git a/gcc/c-common.c b/gcc/c-common.c
index d23a5bc5d0e..b91dddab4ea 100644
--- a/gcc/c-common.c
+++ b/gcc/c-common.c
@@ -38,6 +38,8 @@ Software Foundation, 59 Temple Place - Suite 330, Boston, MA
#include "obstack.h"
#include "cpplib.h"
#include "target.h"
+/* APPLE LOCAL Symbol Separation */
+#include "debug.h"
#include "langhooks.h"
#include "tree-inline.h"
#include "c-tree.h"
@@ -449,6 +451,13 @@ int warn_implicit_int;
int warn_nonnull;
+/* BEGIN APPLE LOCAL disable_typechecking_for_spec_flag */
+/* This makes type conflicts a warning, instead of an error,
+ to work around some problems with SPEC. */
+
+int disable_typechecking_for_spec_flag;
+/* END APPLE LOCAL disable_typechecking_for_spec_flag */
+
/* Warn about old-style parameter declaration. */
int warn_old_style_definition;
@@ -601,6 +610,43 @@ int flag_permissive;
int flag_enforce_eh_specs = 1;
+/* APPLE LOCAL begin -findirect-virtual-calls 2001-10-30 sts */
+/* Nonzero if all calls to virtual functions should cause indirection
+ through a vtable. */
+int flag_indirect_virtual_calls;
+/* APPLE LOCAL end -findirect-virtual-calls 2001-10-30 sts */
+
+/* APPLE LOCAL begin terminated-vtables */
+/* Nonzero means append a zero word to vtables. Used by darwin kernel
+ driver dynamic-loader to find the ends of vtables for patching. */
+int flag_terminated_vtables = 0;
+/* APPLE LOCAL end terminated-vtables */
+
+/* APPLE LOCAL begin private extern Radar 2872481 ilr */
+/* Nonzero if -fpreproceessed specified. This is needed by
+ init_reswords() so that it can make __private_extern__ have the
+ same rid code as extern when -fpreprocessed is specified. Normally
+ there is a -D on the command line for this. But if -fpreprocessed
+ was specified then macros aren't expanded. So we fake the token
+ value out using the rid code. */
+int flag_preprocessed = 0;
+/* APPLE LOCAL end private extern Radar 2872481 ilr */
+
+/* APPLE LOCAL begin apple-kext Radar #2849864 ilr */
+/* Nonzero if we're compiling in a gcc2.95-compatibility mode.
+ Implies -fterminated-vtables and -findirect-virtual-calls,
+ only-deleting-destructor support, 2.95 ptmfs, vptr initialisation,
+ constructors-returning-this... */
+int flag_apple_kext = 0;
+/* APPLE LOCAL end apple-kext ilr */
+
+/* APPLE LOCAL begin structor thunks */
+/* Nonzero if we prefer to clone con/de/structors. Alternative is to
+ gen multiple tiny thunk-esque things that call/jump to a unified
+ con/de/structor. This is a classic size/speed tradeoff. */
+int flag_clone_structors = 0;
+/* APPLE LOCAL end structor thunks */
+
/* Nonzero means warn about things that will change when compiling
with an ABI-compliant compiler. */
@@ -696,6 +742,19 @@ void (*lang_expand_function_end) (void);
This is a count, since unevaluated expressions can nest. */
int skip_evaluation;
+/* APPLE LOCAL begin -Wlong-double */
+/* Nonzero means warn about usage of long double. */
+#ifdef CONFIG_DARWIN_H
+int warn_long_double = 1;
+#else
+int warn_long_double = 0;
+#endif
+/* APPLE LOCAL end -Wlong-double */
+
+/* APPLE LOCAL begin constant cfstrings */
+static void create_cfstring_template PARAMS ((void));
+/* APPLE LOCAL end constant cfstrings */
+
/* Information about how a function name is generated. */
struct fname_var_t
{
@@ -771,6 +830,12 @@ static tree handle_no_limit_stack_attribute (tree *, tree, tree, int,
static tree handle_pure_attribute (tree *, tree, tree, int, bool *);
static tree handle_deprecated_attribute (tree *, tree, tree, int,
bool *);
+/* APPLE LOCAL begin unavailable (Radar 2809697) ilr */
+static tree handle_unavailable_attribute (tree *, tree, tree, int, bool *);
+/* APPLE LOCAL end unavailable ilr */
+/* APPLE LOCAL begin weak_import (Radar 2809704) ilr */
+static tree handle_weak_import_attribute (tree *, tree, tree, int, bool *);
+/* APPLE LOCAL end weak_import ilr */
static tree handle_vector_size_attribute (tree *, tree, tree, int,
bool *);
static tree handle_nonnull_attribute (tree *, tree, tree, int, bool *);
@@ -841,6 +906,14 @@ const struct attribute_spec c_common_attribute_table[] =
handle_pure_attribute },
{ "deprecated", 0, 0, false, false, false,
handle_deprecated_attribute },
+ /* APPLE LOCAL begin unavailable (Radar 2809697) ilr */
+ { "unavailable", 0, 0, false, false, false,
+ handle_unavailable_attribute },
+ /* APPLE LOCAL end unavailable ilr */
+ /* APPLE LOCAL begin weak_import (Radar 2809704) ilr */
+ { "weak_import", 0, 0, true, false, false,
+ handle_weak_import_attribute },
+ /* APPLE LOCAL end weak_import ilr */
{ "vector_size", 1, 1, false, true, false,
handle_vector_size_attribute },
{ "visibility", 1, 1, true, false, false,
@@ -1285,6 +1358,16 @@ constant_fits_type_p (tree c, tree type)
return !TREE_OVERFLOW (c);
}
+/* Nonzero if vector types T1 and T2 can be converted to each other
+ without an explicit cast. */
+int
+vector_types_compatible_p (tree t1, tree t2)
+{
+ return targetm.vector_opaque_p (t1)
+ || targetm.vector_opaque_p (t2)
+ || TYPE_MODE (t1) == TYPE_MODE (t2);
+}
+
/* Convert EXPR to TYPE, warning about conversion problems with constants.
Invoke this function on every expression that is converted implicitly,
i.e. because of language rules and not because of an explicit cast. */
@@ -1886,38 +1969,12 @@ c_common_type_for_mode (enum machine_mode mode, int unsignedp)
if (mode == TYPE_MODE (build_pointer_type (integer_type_node)))
return unsignedp ? make_unsigned_type (mode) : make_signed_type (mode);
- switch (mode)
- {
- case V16QImode:
- return unsignedp ? unsigned_V16QI_type_node : V16QI_type_node;
- case V8HImode:
- return unsignedp ? unsigned_V8HI_type_node : V8HI_type_node;
- case V4SImode:
- return unsignedp ? unsigned_V4SI_type_node : V4SI_type_node;
- case V2DImode:
- return unsignedp ? unsigned_V2DI_type_node : V2DI_type_node;
- case V2SImode:
- return unsignedp ? unsigned_V2SI_type_node : V2SI_type_node;
- case V2HImode:
- return unsignedp ? unsigned_V2HI_type_node : V2HI_type_node;
- case V4HImode:
- return unsignedp ? unsigned_V4HI_type_node : V4HI_type_node;
- case V8QImode:
- return unsignedp ? unsigned_V8QI_type_node : V8QI_type_node;
- case V1DImode:
- return unsignedp ? unsigned_V1DI_type_node : V1DI_type_node;
- case V16SFmode:
- return V16SF_type_node;
- case V4SFmode:
- return V4SF_type_node;
- case V2SFmode:
- return V2SF_type_node;
- case V2DFmode:
- return V2DF_type_node;
- case V4DFmode:
- return V4DF_type_node;
- default:
- break;
+ if (VECTOR_MODE_P (mode))
+ {
+ enum machine_mode inner_mode = GET_MODE_INNER (mode);
+ tree inner_type = c_common_type_for_mode (inner_mode, unsignedp);
+ if (inner_type != NULL_TREE)
+ return build_vector_type_for_mode (inner_type, mode);
}
for (t = registered_builtin_types; t; t = TREE_CHAIN (t))
@@ -2267,7 +2324,7 @@ shorten_compare (tree *op0_ptr, tree *op1_ptr, tree *restype_ptr,
TREE_TYPE (primop0));
/* In C, if TYPE is an enumeration, then we need to get its
- min/max values from it's underlying integral type, not the
+ min/max values from its underlying integral type, not the
enumerated type itself. In C++, TYPE_MAX_VALUE and
TYPE_MIN_VALUE have already been set correctly on the
enumeration type. */
@@ -3541,6 +3598,11 @@ c_common_nodes_and_builtins (void)
(*targetm.init_builtins) ();
main_identifier_node = get_identifier ("main");
+
+ /* APPLE LOCAL begin constant cfstrings */
+ if (flag_constant_cfstrings)
+ create_cfstring_template ();
+ /* APPLE LOCAL end constant cfstrings */
}
tree
@@ -5253,6 +5315,97 @@ handle_deprecated_attribute (tree *node, tree name,
return NULL_TREE;
}
+/* APPLE LOCAL begin unavailable (Radar 2809697) ilr */
+/* Handle a "unavailable" attribute; arguments as in
+ struct attribute_spec.handler. */
+
+static tree
+handle_unavailable_attribute (tree *node, tree name,
+ tree args ATTRIBUTE_UNUSED,
+ int flags ATTRIBUTE_UNUSED,
+ bool *no_add_attrs)
+{
+ tree type = NULL_TREE;
+ int warn = 0;
+ const char *what = NULL;
+
+ if (DECL_P (*node))
+ {
+ tree decl = *node;
+ type = TREE_TYPE (decl);
+
+ if (TREE_CODE (decl) == TYPE_DECL
+ || TREE_CODE (decl) == PARM_DECL
+ || TREE_CODE (decl) == VAR_DECL
+ || TREE_CODE (decl) == FUNCTION_DECL
+ || TREE_CODE (decl) == FIELD_DECL)
+ {
+ TREE_DEPRECATED (decl) = 1;
+ TREE_UNAVAILABLE (decl) = 1;
+ }
+ else
+ warn = 1;
+ }
+ else if (TYPE_P (*node))
+ {
+ if (!(flags & (int) ATTR_FLAG_TYPE_IN_PLACE))
+ *node = build_type_copy (*node);
+ TREE_DEPRECATED (*node) = 1;
+ TREE_UNAVAILABLE (*node) = 1;
+ type = *node;
+ }
+ else
+ warn = 1;
+
+ if (warn)
+ {
+ *no_add_attrs = true;
+ if (type && TYPE_NAME (type))
+ {
+ if (TREE_CODE (TYPE_NAME (type)) == IDENTIFIER_NODE)
+ what = IDENTIFIER_POINTER (TYPE_NAME (*node));
+ else if (TREE_CODE (TYPE_NAME (type)) == TYPE_DECL
+ && DECL_NAME (TYPE_NAME (type)))
+ what = IDENTIFIER_POINTER (DECL_NAME (TYPE_NAME (type)));
+ }
+ if (what)
+ warning ("`%s' attribute ignored for `%s'",
+ IDENTIFIER_POINTER (name), what);
+ else
+ warning ("`%s' attribute ignored", IDENTIFIER_POINTER (name));
+ }
+
+ return NULL_TREE;
+}
+/* APPLE LOCAL end unavailable ilr */
+
+/* APPLE LOCAL begin weak_import (Radar 2809704) ilr */
+/* Handle a "weak_import" attribute; arguments as in
+ struct attribute_spec.handler. If FLAGS contains
+ ATTR_FLAG_FUNCTION_DEF then the attribute is on a
+ function definition which is not allowed. Only
+ function prototypes and extern data definitions
+ are allowed. */
+
+static tree
+handle_weak_import_attribute (tree *node, tree name,
+ tree args ATTRIBUTE_UNUSED,
+ int flags ATTRIBUTE_UNUSED,
+ bool *no_add_attrs)
+{
+ /* See FIXME comment in c_common_attribute_table. */
+ if ((flags & (int) ATTR_FLAG_FUNCTION_DEF) == 0 && DECL_EXTERNAL (*node))
+ DECL_WEAK_IMPORT (*node) = 1;
+ else
+ {
+ warning ("`%s' attribute ignored", IDENTIFIER_POINTER (name));
+ *no_add_attrs = true;
+ }
+
+ return NULL_TREE;
+}
+/* APPLE LOCAL end weak_import ilr */
+
/* Keep a list of vector type nodes we created in handle_vector_size_attribute,
to prevent us from duplicating type nodes unnecessarily.
The normal mechanism to prevent duplicates is to use type_hash_canon, but
@@ -5270,19 +5423,24 @@ handle_vector_size_attribute (tree *node, tree name, tree args,
{
unsigned HOST_WIDE_INT vecsize, nunits;
enum machine_mode mode, orig_mode, new_mode;
- tree type = *node, new_type = NULL_TREE;
- tree type_list_node;
+ tree type = *node, new_type, size;
*no_add_attrs = true;
- if (! host_integerp (TREE_VALUE (args), 1))
+ /* Stripping NON_LVALUE_EXPR allows declarations such as
+ typedef short v4si __attribute__((vector_size (4 * sizeof(short)))). */
+ size = TREE_VALUE (args);
+ if (TREE_CODE (size) == NON_LVALUE_EXPR)
+ size = TREE_OPERAND (size, 0);
+
+ if (! host_integerp (size, 1))
{
warning ("`%s' attribute ignored", IDENTIFIER_POINTER (name));
return NULL_TREE;
}
/* Get the vector size (in bytes). */
- vecsize = tree_low_cst (TREE_VALUE (args), 1);
+ vecsize = tree_low_cst (size, 1);
/* We need to provide for vector pointers, vector arrays, and
functions returning vectors. For example:
@@ -5328,73 +5486,13 @@ handle_vector_size_attribute (tree *node, tree name, tree args,
break;
}
- if (new_mode == VOIDmode)
+ if (new_mode == VOIDmode)
{
error ("no vector mode with the size and type specified could be found");
return NULL_TREE;
}
- for (type_list_node = vector_type_node_list; type_list_node;
- type_list_node = TREE_CHAIN (type_list_node))
- {
- tree other_type = TREE_VALUE (type_list_node);
- tree record = TYPE_DEBUG_REPRESENTATION_TYPE (other_type);
- tree fields = TYPE_FIELDS (record);
- tree field_type = TREE_TYPE (fields);
- tree array_type = TREE_TYPE (field_type);
- if (TREE_CODE (fields) != FIELD_DECL
- || TREE_CODE (field_type) != ARRAY_TYPE)
- abort ();
-
- if (TYPE_MODE (other_type) == mode && type == array_type)
- {
- new_type = other_type;
- break;
- }
- }
-
- if (new_type == NULL_TREE)
- {
- tree index, array, rt, list_node;
-
- new_type = (*lang_hooks.types.type_for_mode) (new_mode,
- TREE_UNSIGNED (type));
-
- if (!new_type)
- {
- error ("no vector mode with the size and type specified could be found");
- return NULL_TREE;
- }
-
- new_type = build_type_copy (new_type);
-
- /* If this is a vector, make sure we either have hardware
- support, or we can emulate it. */
- if ((GET_MODE_CLASS (mode) == MODE_VECTOR_INT
- || GET_MODE_CLASS (mode) == MODE_VECTOR_FLOAT)
- && !vector_mode_valid_p (mode))
- {
- error ("unable to emulate '%s'", GET_MODE_NAME (mode));
- return NULL_TREE;
- }
-
- /* Set the debug information here, because this is the only
- place where we know the underlying type for a vector made
- with vector_size. For debugging purposes we pretend a vector
- is an array within a structure. */
- index = build_int_2 (TYPE_VECTOR_SUBPARTS (new_type) - 1, 0);
- array = build_array_type (type, build_index_type (index));
- rt = make_node (RECORD_TYPE);
-
- TYPE_FIELDS (rt) = build_decl (FIELD_DECL, get_identifier ("f"), array);
- DECL_CONTEXT (TYPE_FIELDS (rt)) = rt;
- layout_type (rt);
- TYPE_DEBUG_REPRESENTATION_TYPE (new_type) = rt;
-
- list_node = build_tree_list (NULL, new_type);
- TREE_CHAIN (list_node) = vector_type_node_list;
- vector_type_node_list = list_node;
- }
+ new_type = build_vector_type_for_mode (type, new_mode);
/* Build back pointers if needed. */
*node = reconstruct_complex_type (*node, new_type);
@@ -5746,6 +5844,165 @@ check_function_arguments_recurse (void (*callback)
(*callback) (ctx, param, param_num);
}
+/* APPLE LOCAL begin -Wlong-double dpatel */
+void
+warn_about_long_double (void)
+{
+ /* Nonzero means we already warned about long doubles. */
+ static int warned_about_long_double = 0;
+
+ if (warn_long_double
+ && ! warned_about_long_double
+ /* Oh, the fromage of it all... For hysterical reasons, the
+ preprocessor does not recognize things in the system
+ frameworks as "system headers", which confuses some types
+ of warnings. So instead of hacking the preprocessors in
+ obscure ways, test for and ignore system headers here. */
+ && ! in_system_header
+ && ! strstr (input_filename, "/System/Library/Frameworks/")
+ && ! strstr (input_filename, "/usr/include/"))
+ {
+ warning ("use of `long double' type; its size may change in a future release");
+ warning ("(Long double usage is reported only once for each file.");
+ warning ("To disable this warning, use -Wno-long-double.)");
+ warned_about_long_double = 1;
+ }
+}
+/* APPLE LOCAL end -Wlong-double dpatel */
+
+/* APPLE LOCAL begin constant cfstrings */
+
+static GTY(()) tree cfstring_class_reference = NULL_TREE;
+static GTY(()) tree cfstring_object_template = NULL_TREE;
+
+static void
+create_cfstring_template (void)
+{
+ /* "extern int __CFConstantStringClassReference[];" */
+ cfstring_class_reference = build_decl
+ (VAR_DECL,
+ get_identifier ("__CFConstantStringClassReference"),
+ build_array_type (integer_type_node, 0));
+ DECL_EXTERNAL (cfstring_class_reference) = 1;
+ TREE_PUBLIC (cfstring_class_reference) = 1;
+ TREE_USED (cfstring_class_reference) = 1;
+ DECL_ARTIFICIAL (cfstring_class_reference) = 1;
+ pushdecl (cfstring_class_reference);
+ rest_of_decl_compilation (cfstring_class_reference, 0, 0, 0);
+}
+
+tree
+build_cfstring_ascii (tree str)
+{
+ tree initlist, constructor;
+ int length;
+
+ length = TREE_STRING_LENGTH (str) - 1;
+ if (warn_nonportable_cfstrings)
+ {
+ const char *s = TREE_STRING_POINTER (str);
+ int l = 0;
+
+ for (l = 0; l < length; l++)
+ if (s[l] <= 0 || s[l] >= 127)
+ {
+ warning ("%s in CFString literal",
+ s[l] ? "non-ASCII character" : "embedded NUL");
+ break;
+ }
+ }
+
+ initlist = build_tree_list
+ (NULL_TREE, convert (const_ptr_type_node,
+ copy_node (build_unary_op
+ (ADDR_EXPR,
+ cfstring_class_reference, 0))));
+ initlist = tree_cons (NULL_TREE, convert (const_ptr_type_node,
+ build_int_2 (0x000007c8, 0)), initlist);
+ initlist = tree_cons
+ (NULL_TREE, convert (const_ptr_type_node,
+ copy_node (build_unary_op
+ (ADDR_EXPR, str, 1))), initlist);
+ initlist = tree_cons (NULL_TREE, convert (const_ptr_type_node,
+ build_int_2 (length, 0)), initlist);
+
+ /* Because we're lazy, we'll treat CFStrings (internally) as arrays of pointers.
+ This shouldn't matter, anyway. */
+ cfstring_object_template = build_array_type (const_ptr_type_node, 0);
+ TYPE_ALIGN (cfstring_object_template) = TYPE_ALIGN (const_ptr_type_node);
+ /* NB: We are initializing 'cfstring_object_template' every time, instead of
+ once in create_cfstring_template() above, because the compiler appears
+ to clobber it on occasion. Exercise for the student: eliminate the
+ clobbering. Primary suspect: memory manager. */
+
+ constructor = build (CONSTRUCTOR, cfstring_object_template,
+ NULL_TREE, nreverse (initlist));
+ TREE_CONSTANT (constructor) = 1;
+ TREE_STATIC (constructor) = 1;
+ TREE_READONLY (constructor) = 1;
+
+ /* Fromage: The C++ flavor of 'build_unary_op' expects constructor nodes to have
+ the TREE_HAS_CONSTRUCTOR (...) bit set. However, this file (c-common.c) is built
+ without any knowledge of C++ tree accessors; hence, we shall use the generic
+ accessor that TREE_HAS_CONSTRUCTOR actually maps to! */
+ if (c_dialect_cxx ())
+ TREE_LANG_FLAG_4 (constructor) = 1; /* TREE_HAS_CONSTRUCTOR */
+
+ return build_c_cast (const_ptr_type_node, copy_node
+ (build_unary_op (ADDR_EXPR, constructor, 1)));
+}
+/* APPLE LOCAL end constant cfstrings */
+
+/* APPLE LOCAL begin Symbol Separation */
+/* Call debugger hooks to restore state of debugging symbol generation.
+ This is called at the end of header processing whose symbol repository was
+ available and valid. */
+void
+cb_restore_write_symbols (void)
+{
+ (*debug_hooks->restore_write_symbols) ();
+}
+
+/* Call debugger hooks to clear state of debugging symbol generation.
+ This is called to stop generation of debugging info. for a header whose
+ valid context information is available. */
+void
+cb_clear_write_symbols (const char *filename, unsigned long checksum)
+{
+ (*debug_hooks->clear_write_symbols) (filename, checksum);
+}
+
+/* Call debugger hooks to mark start of symbol repository.
+ Similar to start_source_file. Only difference is that checksum is added
+ with BINCL stabs. */
+void
+cb_start_symbol_repository (unsigned int lineno, const char *filename,
+ unsigned long checksum)
+{
+ (*debug_hooks->start_symbol_repository) (lineno, filename, checksum);
+}
+
+/* Call debugger hoooks to makr end of symbol repository.
+ Identical to end_source_file. */
+void
+cb_end_symbol_repository (unsigned int lineno)
+{
+ (*debug_hooks->end_symbol_repository) (lineno);
+}
+
+/* Decide if hashnode points to a tree used for builtin identifier.
+ This is used during context info writing to avoid collecting information
+ about builtins in cinfo files. */
+int
+cb_is_builtin_identifier (cpp_hashnode *p)
+{
+ if (DECL_BUILT_IN_CLASS (HT_IDENT_TO_GCC_IDENT (HT_NODE (p))))
+ return 1;
+ else
+ return 0;
+}
+/* APPLE LOCAL end Symbol Separation */
+
/* C implementation of lang_hooks.tree_inlining.walk_subtrees. Tracks the
line number from STMT_LINENO and handles DECL_STMT specially. */
@@ -6096,4 +6353,58 @@ c_warn_unused_result (tree *top_p)
}
}
+/* APPLE LOCAL begin AltiVec */
+/* Convert the incoming expression EXPR into a vector constructor of
+ type VECTOR_TYPE, casting the individual vector elements as appropriate. */
+
+tree
+vector_constructor_from_expr (tree expr, tree vector_type)
+{
+ tree list = NULL_TREE, elttype = TREE_TYPE (vector_type);
+ int index, max_index = TYPE_VECTOR_SUBPARTS (vector_type);
+ int all_constant = TREE_CONSTANT (expr);
+ bool cxx = (c_dialect_cxx () != 0); /* Impedance matching. */
+
+ /* If we already have a vector expression, then the user probably
+ wants to convert it to another. */
+ if (TREE_CODE (TREE_TYPE (expr)) == VECTOR_TYPE)
+ return convert (vector_type, expr);
+
+ /* Walk through the compound expression, gathering initializers. */
+ for (index = 0; index < max_index; ++index)
+ {
+ tree elem;
+
+ if (TREE_CODE (expr) == COMPOUND_EXPR)
+ {
+ elem
+ = (cxx ? TREE_OPERAND (expr, 1) : TREE_OPERAND (expr, 0));
+ expr = (cxx ? TREE_OPERAND (expr, 0) : TREE_OPERAND (expr, 1));
+ }
+ else
+ elem = expr;
+
+ while (TREE_CODE (elem) == COMPOUND_EXPR && TREE_CONSTANT (elem))
+ elem = TREE_OPERAND (elem, 1);
+ while (TREE_CODE (elem) == CONVERT_EXPR)
+ elem = TREE_OPERAND (elem, 0);
+
+ list = chainon (list,
+ build_tree_list (NULL_TREE,
+ convert (elttype, elem)));
+ }
+
+ if (cxx)
+ list = nreverse (list);
+
+ list = build_constructor (vector_type, list);
+ if (cxx)
+ TREE_LANG_FLAG_4 (list) = 1; /* TREE_HAS_CONSTRUCTOR */
+ else
+ TREE_CONSTANT (list) = all_constant;
+
+ return list;
+}
+/* APPLE LOCAL end AltiVec */
+
#include "gt-c-common.h"
diff --git a/gcc/c-common.h b/gcc/c-common.h
index d874f8bc711..2c491bd5013 100644
--- a/gcc/c-common.h
+++ b/gcc/c-common.h
@@ -61,6 +61,9 @@ enum rid
/* C extensions */
RID_COMPLEX, RID_THREAD,
+ /* APPLE LOCAL private extern */
+ RID_PRIVATE_EXTERN,
+
/* C++ */
RID_FRIEND, RID_VIRTUAL, RID_EXPLICIT, RID_EXPORT, RID_MUTABLE,
@@ -144,6 +147,8 @@ enum c_tree_index
CTI_WIDEST_UINT_LIT_TYPE,
CTI_CHAR_ARRAY_TYPE,
+ /* APPLE LOCAL Pascal strings 2001-07-05 zll */
+ CTI_PASCAL_STRING_TYPE, /* for Pascal strings */
CTI_WCHAR_ARRAY_TYPE,
CTI_INT_ARRAY_TYPE,
CTI_STRING_TYPE,
@@ -198,6 +203,8 @@ struct c_common_identifier GTY(())
#define truthvalue_false_node c_global_trees[CTI_TRUTHVALUE_FALSE]
#define char_array_type_node c_global_trees[CTI_CHAR_ARRAY_TYPE]
+/* APPLE LOCAL Pascal strings 2001-07-05 zll */
+#define pascal_string_type_node c_global_trees[CTI_PASCAL_STRING_TYPE]
#define wchar_array_type_node c_global_trees[CTI_WCHAR_ARRAY_TYPE]
#define int_array_type_node c_global_trees[CTI_INT_ARRAY_TYPE]
#define string_type_node c_global_trees[CTI_STRING_TYPE]
@@ -374,6 +381,13 @@ extern int flag_replace_objc_classes;
/* Nonzero means don't output line number information. */
+/* APPLE LOCAL begin Symbol Separation */
+/* The directory name where separate debug repository and context
+ available. NULL if Symbol Separation is not used. */
+extern const char *dbg_dir;
+
+/* APPLE LOCAL end Symbol Separation */
+
extern char flag_no_line_commands;
/* Nonzero causes -E output not to be done, but directives such as
@@ -475,6 +489,12 @@ extern int warn_sign_compare;
extern int warn_long_long;
+/* APPLE LOCAL begin -Wlong-double */
+/* Nonzero means warn about usage of long double. */
+
+extern int warn_long_double;
+/* APPLE LOCAL end -Wlong-double */
+
/* Nonzero means warn about deprecated conversion from string constant to
`char *'. */
@@ -527,6 +547,13 @@ extern int warn_format_nonliteral;
extern int warn_format_security;
+/* BEGIN APPLE LOCAL disable_typechecking_for_spec_flag */
+/* This makes type conflicts a warning, instead of an error,
+ to work around some problems with SPEC. */
+
+extern int disable_typechecking_for_spec_flag;
+/* END APPLE LOCAL disable_typechecking_for_spec_flag */
+
/* C/ObjC language option variables. */
@@ -758,6 +785,68 @@ extern int flag_permissive;
extern int flag_enforce_eh_specs;
+/* The version of the C++ ABI in use. The following values are
+ allowed:
+
+ APPLE LOCAL begin 10.2 C++ abi compat mrs
+ -2: 2.95.2 Apple uses for kernel extensions.
+
+ -1: gcc 3.1 20020420. Apple uses for gcc3 compatible 10.2.
+
+ APPLE LOCAL end 10.2 C++ abi compat mrs
+ 0: The version of the ABI believed most conformant with the
+ C++ ABI specification. This ABI may change as bugs are
+ discovered and fixed. Therefore, 0 will not necessarily
+ indicate the same ABI in different versions of G++.
+
+ 1: The version of the ABI first used in G++ 3.2.
+
+ Additional positive integers will be assigned as new versions of
+ the ABI become the default version of the ABI. */
+
+extern int flag_abi_version;
+
+/* APPLE LOCAL begin -findirect-virtual-calls 2001-10-30 sts */
+/* Nonzero if all calls to virtual functions should cause indirection
+ through a vtable. */
+
+extern int flag_indirect_virtual_calls;
+/* APPLE LOCAL end -findirect-virtual-calls 2001-10-30 sts */
+
+/* APPLE LOCAL begin -fterminated-vtables */
+/* Nonzero to terminate vtables with a unique value, currently zero.
+ Used by the darwin kernel to find ends of vtables for patching
+ when loading drivers dynamically. */
+
+extern int flag_terminated_vtables;
+/* APPLE LOCAL end -fterminated-vtables */
+
+/* APPLE LOCAL begin 2.95-compatibility stuff turly */
+/* Nonzero if we're compiling in a gcc2.95-compatibility mode.
+ Implies -fterminated-vtables and -findirect-virtual-calls,
+ only-deleting-destructor support, 2.95 ptmfs, vptr initialisation,
+ constructors-returning-this... */
+
+extern int flag_apple_kext;
+/* APPLE LOCAL end 2.95-compatibility stuff turly */
+
+/* APPLE LOCAL begin structor thunks */
+/* Nonzero if we prefer to clone con/de/structors.
+ Alternative is to gen multiple tiny thunk-esque things that
+ call/jump to a unified con/de/structor. This is a classic
+ size/speed tradeoff. */
+extern int flag_clone_structors;
+/* APPLE LOCAL begin structor thunks */
+
+/* APPLE LOCAL begin private extern Radar 2872481 ilr */
+/* Nonzero if -fpreprocessed specified. This is needed by init_reswords()
+ so that it can make __private_extern__ have the same rid code as extern
+ when -fpreprocessed is specified. Normally there is a -D on the command
+ line for this. But if -fpreprocessed was specified then macros aren't
+ expanded. So we fake the token value out using the rid code. */
+extern int flag_preprocessed;
+/* APPLE LOCAL end private extern Radar 2872481 ilr */
+
/* Nonzero means warn about things that will change when compiling
with an ABI-compliant compiler. */
@@ -1199,6 +1288,8 @@ extern tree finish_label_address_expr (tree);
different implementations. Used in c-common.c. */
extern tree lookup_label (tree);
+extern int vector_types_compatible_p (tree t1, tree t2);
+
extern rtx c_expand_expr (tree, rtx, enum machine_mode, int, rtx *);
extern int c_safe_from_p (rtx, tree);
@@ -1229,6 +1320,40 @@ extern void dump_time_statistics (void);
extern bool c_dump_tree (void *, tree);
+/* APPLE LOCAL begin Objective-C++ */
+/* The following have been moved here from c-tree.h, since they're needed
+ in the ObjC++ world, too. */
+extern tree lookup_interface (tree);
+extern tree is_class_name (tree);
+extern tree is_id (tree);
+extern void objc_check_decl (tree);
+extern int objc_comptypes (tree, tree, int);
+extern tree objc_message_selector (void);
+extern int recognize_objc_keyword (void);
+extern tree lookup_objc_ivar (tree);
+/* APPLE LOCAL end Objective-C++ */
+
+/* APPLE LOCAL -Wlong-double */
+extern void warn_about_long_double (void);
+
+/* APPLE LOCAL begin constant cfstrings */
+extern tree build_cfstring_ascii (tree);
+/* APPLE LOCAL end constant cfstrings */
+
+/* APPLE LOCAL begin Symbol Separation */
+extern void dbg_ss_init (void);
+extern void c_common_write_context (void);
+extern void cb_clear_write_symbols (const char *, unsigned long);
+extern void cb_restore_write_symbols (void);
+extern void cb_start_symbol_repository (unsigned int,
+ const char *,
+ unsigned long);
+extern void cb_end_symbol_repository (unsigned int);
+extern int c_valid_cinfo (cpp_reader *,
+ const char *);
+extern int cb_is_builtin_identifier (cpp_hashnode *);
+/* APPLE LOCAL end Symbol Separation */
+
extern int c_gimplify_expr (tree *, tree *, tree *);
extern tree c_walk_subtrees (tree*, int*, walk_tree_fn, void*, void*);
extern int c_tree_chain_matters_p (tree);
@@ -1265,6 +1390,12 @@ extern tree lookup_objc_ivar (tree);
extern void *get_current_scope (void);
extern void objc_mark_locals_volatile (void *);
+/* APPLE LOCAL begin AltiVec */
+/* The following function will convert expressions into
+ vector initializers. */
+extern tree vector_constructor_from_expr (tree, tree);
+/* APPLE LOCAL end AltiVec */
+
/* In c-ppoutput.c */
extern void init_pp_output (FILE *);
extern void preprocess_file (cpp_reader *);
diff --git a/gcc/c-convert.c b/gcc/c-convert.c
index 20d2e466fe3..39eb63ecd4e 100644
--- a/gcc/c-convert.c
+++ b/gcc/c-convert.c
@@ -33,6 +33,9 @@ Software Foundation, 59 Temple Place - Suite 330, Boston, MA
#include "flags.h"
#include "convert.h"
#include "c-common.h"
+/* APPLE LOCAL begin IMA aggregate types */
+#include "c-tree.h"
+/* APPLE LOCAL end IMA aggregate types */
#include "langhooks.h"
#include "toplev.h"
@@ -114,6 +117,15 @@ convert (tree type, tree expr)
return fold (convert_to_complex (type, e));
if (code == VECTOR_TYPE)
return fold (convert_to_vector (type, e));
+ /* APPLE LOCAL begin IMA aggregate types */
+ if (code == RECORD_TYPE || code == ENUMERAL_TYPE || code == UNION_TYPE)
+ {
+ tree t2 = TREE_TYPE (expr);
+ if (code == TREE_CODE (t2)
+ && !same_translation_unit_p (type, t2) && tagged_types_tu_compatible_p (type, t2, 0))
+ return e;
+ }
+ /* APPLE LOCAL end IMA aggregate types */
error ("conversion to non-scalar type requested");
return error_mark_node;
diff --git a/gcc/c-cppbuiltin.c b/gcc/c-cppbuiltin.c
index 8573b8c5a46..f8ea6b266e9 100644
--- a/gcc/c-cppbuiltin.c
+++ b/gcc/c-cppbuiltin.c
@@ -289,6 +289,32 @@ define__GNUC__ (void)
if (*v && *v != ' ' && *v != '-')
abort ();
+
+ /* APPLE LOCAL begin Apple version */
+ {
+ /* This chunk of code defines __APPLE_CC__ from the version
+ string. It expects to see a substring of the version string of
+ the form "build NNNN)", where each N is a digit, and the first
+ N is nonzero (there can be 4 or 5 digits). It will abort() if
+ these conditions are not met, since that usually means that
+ someone's broken the version string. */
+ const char *vt;
+
+ vt = strstr (version_string, "build ");
+ if (vt == NULL)
+ abort ();
+ vt += strlen ("build ");
+ if (! ISDIGIT (*vt))
+ abort ();
+ for (q = vt; *q != 0 && ISDIGIT (*q); q++)
+ ;
+ if (q == vt || *q != ')')
+ abort ();
+ if ((q - vt != 4 && q - vt != 5) || *vt == '0')
+ abort ();
+ builtin_define_with_value_n ("__APPLE_CC__", vt, q - vt);
+ }
+ /* APPLE LOCAL end Apple version */
}
/* Hook that registers front end and target-specific built-ins. */
diff --git a/gcc/c-decl.c b/gcc/c-decl.c
index 21c5939c916..05962f543a9 100644
--- a/gcc/c-decl.c
+++ b/gcc/c-decl.c
@@ -60,6 +60,12 @@ Software Foundation, 59 Temple Place - Suite 330, Boston, MA
#include "except.h"
#include "langhooks-def.h"
+/* APPLE LOCAL begin new tree dump */
+#include "dmp-tree.h"
+extern int c_dump_tree_p (FILE *, const char *, tree, int);
+extern lang_dump_tree_p_t c_prev_lang_dump_tree_p;
+/* APPLE LOCAL end new tree dump */
+
/* In grokdeclarator, distinguish syntactic contexts of declarators. */
enum decl_context
{ NORMAL, /* Ordinary declaration */
@@ -327,15 +333,33 @@ static void clone_underlying_type (tree);
static bool flexible_array_type_p (tree);
static hashval_t link_hash_hash (const void *);
static int link_hash_eq (const void *, const void *);
+/* APPLE LOCAL loop transpose */
+static void loop_transpose (tree);
+static tree perform_loop_transpose (tree *, int *, void *);
+static tree tree_contains_1 (tree *, int *, void *);
+static bool tree_contains (tree, tree);
+static tree should_transpose_for_loops_1 (tree *, int *, void *);
+static bool should_transpose_for_loops (tree, tree, tree, tree*);
+static tree find_tree_with_code_1 (tree *, int *, void *);
+static tree find_tree_with_code (tree, enum tree_code);
+static tree find_pointer (tree);
+
/* States indicating how grokdeclarator() should handle declspecs marked
with __attribute__((deprecated)). An object declared as
__attribute__((deprecated)) suppresses warnings of uses of other
deprecated items. */
+/* APPLE LOCAL begin unavailable */
+/* Also add an __attribute__((unavailable)). An object declared as
+ __attribute__((unavailable)) suppresses any reports of being
+ declared with unavailable or deprecated items. */
+/* APPLE LOCAL end unavailable */
enum deprecated_states {
DEPRECATED_NORMAL,
DEPRECATED_SUPPRESS
+ /* APPLE LOCAL unavailable */
+ , DEPRECATED_UNAVAILABLE_SUPPRESS
};
static enum deprecated_states deprecated_state = DEPRECATED_NORMAL;
@@ -1004,6 +1028,14 @@ diagnose_mismatched_decls (tree newdecl, tree olddecl,
}
else
{
+ /* BEGIN APPLE LOCAL disable_typechecking_for_spec_flag */
+ if (disable_typechecking_for_spec_flag)
+ {
+ warning ("%Jconflicting types for `%D'", newdecl, newdecl);
+ warning ("%Jprevious declaration of `%D'", olddecl, olddecl);
+ return 0;
+ }
+ /* END APPLE LOCAL disable_typechecking_for_spec_flag */
error ("%Jconflicting types for '%D'", newdecl, newdecl);
diagnose_arglist_conflict (newdecl, olddecl, newtype, oldtype);
locate_old_decl (olddecl, error);
@@ -1457,6 +1489,7 @@ merge_decls (tree newdecl, tree olddecl, tree newtype, tree oldtype)
DECL_INITIAL (newdecl) = DECL_INITIAL (olddecl);
DECL_STRUCT_FUNCTION (newdecl) = DECL_STRUCT_FUNCTION (olddecl);
DECL_SAVED_TREE (newdecl) = DECL_SAVED_TREE (olddecl);
+ DECL_ESTIMATED_INSNS (newdecl) = DECL_ESTIMATED_INSNS (olddecl);
DECL_ARGUMENTS (newdecl) = DECL_ARGUMENTS (olddecl);
/* Set DECL_INLINE on the declaration if we've got a body
@@ -1478,16 +1511,20 @@ merge_decls (tree newdecl, tree olddecl, tree newtype, tree oldtype)
}
}
+ /* APPLE LOCAL begin peserve invisible flag for gap */
/* Copy most of the decl-specific fields of NEWDECL into OLDDECL.
- But preserve OLDDECL's DECL_UID. */
+ But preserve OLDDECL's DECL_UID and C_DECL_INVISIBLE. */
{
unsigned olddecl_uid = DECL_UID (olddecl);
+ unsigned olddecl_c_decl_invisible = C_DECL_INVISIBLE (olddecl);
memcpy ((char *) olddecl + sizeof (struct tree_common),
(char *) newdecl + sizeof (struct tree_common),
sizeof (struct tree_decl) - sizeof (struct tree_common));
DECL_UID (olddecl) = olddecl_uid;
+ C_DECL_INVISIBLE (olddecl) = olddecl_c_decl_invisible;
}
+ /* APPLE LOCAL end peserve invisible flag for gap */
/* If OLDDECL had its DECL_RTL instantiated, re-invoke make_decl_rtl
so that encode_section_info has a chance to look at the new decl
@@ -1723,8 +1760,17 @@ pushdecl (tree x)
tree ext = any_external_decl (name);
if (ext)
{
+ /* APPLE LOCAL begin peserve invisible flag for gap */
+ unsigned old_decl_external = DECL_EXTERNAL(ext);
if (duplicate_decls (x, ext))
+ {
x = copy_node (ext);
+ /* invisible declaration must remain external in case current decl
+ is public static. Otherwise, we get duplicate definition. */
+ if (C_DECL_INVISIBLE (ext) && TREE_CODE (ext) == VAR_DECL)
+ DECL_EXTERNAL(ext) = old_decl_external;
+ }
+ /* APPLE LOCAL end peserve invisible flag for gap */
}
else
record_external_decl (x);
@@ -2233,6 +2279,15 @@ c_init_decl_processing (void)
make_fname_decl = c_make_fname_decl;
start_fname_decls ();
+ /* APPLE LOCAL begin new tree dump */
+#if 0
+ /* MERGE FIXME: 3468690 */
+ /* For condensed tree dumps with debugger. */
+ c_prev_lang_dump_tree_p = set_dump_tree_p (c_dump_tree_p);
+ SET_MAX_DMP_TREE_CODE(LAST_C_TREE_CODE);
+#endif
+ /* APPLE LOCAL end new tree dump */
+
first_builtin_decl = global_scope->names;
last_builtin_decl = global_scope->names_last;
}
@@ -2316,6 +2371,7 @@ builtin_function (const char *name, tree type, int function_code,
return decl;
}
+
/* Called when a declaration is seen that contains no names to declare.
If its type is a reference to a structure, union or enum inherited
@@ -2505,8 +2561,37 @@ start_decl (tree declarator, tree declspecs, int initialized, tree attributes)
/* An object declared as __attribute__((deprecated)) suppresses
warnings of uses of other deprecated items. */
+
+ /* APPLE LOCAL begin unavailable */
+ /* An object declared as __attribute__((unavailable)) suppresses
+ any reports of being declared with unavailable or deprecated
+ items. An object declared as __attribute__((deprecated))
+ suppresses warnings of uses of other deprecated items. */
+#ifdef A_LESS_INEFFICENT_WAY /* which I really don't want to do! */
if (lookup_attribute ("deprecated", attributes))
deprecated_state = DEPRECATED_SUPPRESS;
+ else if (lookup_attribute ("unavailable", attributes))
+ deprecated_state = DEPRECATED_UNAVAILABLE_SUPPRESS;
+#else /* a more efficient way doing what lookup_attribute would do */
+ tree a;
+
+ for (a = attributes; a; a = TREE_CHAIN (a))
+ {
+ tree name = TREE_PURPOSE (a);
+ if (TREE_CODE (name) == IDENTIFIER_NODE)
+ if (is_attribute_p ("deprecated", name))
+ {
+ deprecated_state = DEPRECATED_SUPPRESS;
+ break;
+ }
+ if (is_attribute_p ("unavailable", name))
+ {
+ deprecated_state = DEPRECATED_UNAVAILABLE_SUPPRESS;
+ break;
+ }
+ }
+#endif
+ /* APPLE LOCAL end unavailable */
decl = grokdeclarator (declarator, declspecs,
NORMAL, initialized, NULL);
@@ -3343,13 +3428,26 @@ grokdeclarator (tree declarator, tree declspecs,
{
tree id = TREE_VALUE (spec);
- /* If the entire declaration is itself tagged as deprecated then
- suppress reports of deprecated items. */
+ /* APPLE LOCAL begin unavailable */
+ /* If the entire declaration is itself tagged as unavailable then
+ suppress reports of unavailable/deprecated items. If the
+ entire declaration is tagged as only deprecated we still
+ report unavailable uses. */
if (id && TREE_DEPRECATED (id))
{
- if (deprecated_state != DEPRECATED_SUPPRESS)
- warn_deprecated_use (id);
+ if (TREE_UNAVAILABLE (id))
+ {
+ if (deprecated_state != DEPRECATED_UNAVAILABLE_SUPPRESS)
+ warn_unavailable_use (id);
+ }
+ else
+ {
+ if (deprecated_state != DEPRECATED_SUPPRESS
+ && deprecated_state != DEPRECATED_UNAVAILABLE_SUPPRESS)
+ warn_deprecated_use (id);
+ }
}
+ /* APPLE LOCAL end unavailable */
if (id == ridpointers[(int) RID_INT])
explicit_int = 1;
@@ -3478,6 +3576,8 @@ grokdeclarator (tree declarator, tree declspecs,
{
specbits &= ~(1 << (int) RID_LONG);
type = long_double_type_node;
+ /* APPLE LOCAL -Wlong-double dpatel */
+ warn_about_long_double ();
}
/* Check all other uses of type modifiers. */
@@ -3662,6 +3762,8 @@ grokdeclarator (tree declarator, tree declspecs,
| 1 << (int) RID_STATIC
| 1 << (int) RID_EXTERN)) == (1 << (int) RID_THREAD))
nclasses++;
+ /* APPLE LOCAL private extern */
+ if (specbits & 1 << (int) RID_PRIVATE_EXTERN) nclasses++;
/* Warn about storage classes that are invalid for certain
kinds of declarations (parameters, typenames, etc.). */
@@ -4366,6 +4468,13 @@ grokdeclarator (tree declarator, tree declspecs,
if (defaulted_int)
C_FUNCTION_IMPLICIT_INT (decl) = 1;
+ /* APPLE LOCAL begin private extern */
+ DECL_VISIBILITY (decl)
+ = ((specbits & (1 << (int) RID_PRIVATE_EXTERN)) != 0)
+ ? VISIBILITY_HIDDEN
+ : VISIBILITY_DEFAULT;
+ /* APPLE LOCAL end private extern */
+
/* Record presence of `inline', if it is reasonable. */
if (MAIN_NAME_P (declarator))
{
@@ -4398,7 +4507,9 @@ grokdeclarator (tree declarator, tree declspecs,
{
/* It's a variable. */
/* An uninitialized decl with `extern' is a reference. */
- int extern_ref = !initialized && (specbits & (1 << (int) RID_EXTERN));
+ /* APPLE LOCAL private extern */
+ int extern_ref = !initialized && (specbits & ((1 << (int) RID_EXTERN)
+ | (1 << (int) RID_PRIVATE_EXTERN)));
/* Move type qualifiers down to element of an array. */
if (TREE_CODE (type) == ARRAY_TYPE && type_quals)
@@ -4437,6 +4548,12 @@ grokdeclarator (tree declarator, tree declspecs,
DECL_EXTERNAL (decl) = extern_ref;
+ /* APPLE LOCAL private extern */
+ DECL_VISIBILITY (decl)
+ = ((specbits & (1 << (int) RID_PRIVATE_EXTERN)) != 0)
+ ? VISIBILITY_HIDDEN
+ : VISIBILITY_DEFAULT;
+
/* At file scope, the presence of a `static' or `register' storage
class specifier, or the absence of all storage class specifiers
makes this declaration a definition (perhaps tentative). Also,
@@ -5434,7 +5551,9 @@ start_function (tree declspecs, tree declarator, tree attributes)
return 0;
}
- decl_attributes (&decl1, attributes, 0);
+ /* APPLE LOCAL begin weak_import (Radar 2809704) ilr */
+ decl_attributes (&decl1, attributes, (int)ATTR_FLAG_FUNCTION_DEF);
+ /* APPLE LOCAL end weak_import ilr */
if (DECL_DECLARED_INLINE_P (decl1)
&& DECL_UNINLINABLE (decl1)
@@ -6143,6 +6262,13 @@ finish_function (void)
&& current_function_returns_null)
warning ("this function may return with or without a value");
+ /* APPLE LOCAL begin loop transposition */
+ /* Perform loop tranformations before doing inlining, but do not
+ do it if syntax only is requested. */
+ if (!flag_syntax_only && flag_loop_transpose)
+ loop_transpose(fndecl);
+ /* APPLE LOCAL end loop transposition */
+
/* Store the end of the function, so that we get good line number
info for the epilogue. */
cfun->function_end_locus = input_location;
@@ -6632,6 +6758,13 @@ merge_translation_unit_decls (void)
if (! global_decl)
continue;
+ /* APPLE LOCAL begin */
+ /* For global VARs, make sure DECL_RTL is set; it must be propagated
+ to all the copies, or aliasing won't work. */
+ if (TREE_CODE (global_decl) == VAR_DECL && !DECL_RTL_SET_P (global_decl))
+ make_decl_rtl (global_decl, 0);
+ /* APPLE LOCAL end */
+
/* Print any appropriate error messages, and partially merge
the decls. */
(void) duplicate_decls (decl, global_decl);
@@ -6698,4 +6831,579 @@ c_reset_state (void)
pushdecl (copy_node (link));
}
+/* APPLE LOCAL begin loop transposition (currently unsafe) */
+/* This pass on trees is to transpose loops so that memory systems will
+ not be overtaxed.
+ So it changes:
+ for(i=0;i<size0;i++)
+ for(j=0;j<size1;j++)
+ a = a + pointer[j][i];
+ into
+ for(j=0;j<size1;j++)
+ for(i=0;i<size0;i++)
+ a = a + pointer[j][i];
+
+ and
+ for(i=0;i<size0;i++)
+ {
+ for(j=0;j<size1;j++)
+ {
+ a = a + pointer[j][i];
+ }
+ pointer[i][i] = b * pointer[i][i];
+ }
+ into
+ for(j=0;j<size1;j++)
+ {
+ for(i=0;i<size0;i++)
+ {
+ a = a + pointer[j][i];
+ }
+ }
+ for(j=0;j<size1;j++)
+ {
+ pointer[i][i] = b * pointer[i][i];
+ }
+
+ Note this is experimental because it does not always get it right,
+ but works on SPEC 2000 and the bootstrap of gcc.
+ Here is a case it miscompiles:
+
+ struct {
+ double unew[1782225];
+ } COMMON;
+
+ double swimneg_1()
+ {
+ double ucheck = 0;
+ int i, j;
+ for(i = 1; i <= 1334;i++) {
+ for(j = 1;j <= 1334;j++) {
+ ucheck += COMMON.unew[(i-1) + 1335*(j-1) ];
+ }
+ COMMON.unew[i + 1335*(i)] *= 2;
+ }
+ return ucheck;
+ }
+
+ The loops are incorrectly transposed because it does not know
+ that the modification of
+ COMMON.unew_[icheck_ + 1335*icheck_] (in the outer loop)
+ needs to be done right after the inner loop. */
+
+static tree
+find_tree_with_code_1 (tree *tp, int *walk_subtrees ATTRIBUTE_UNUSED,
+ void *data)
+{
+ if (*tp == NULL_TREE)
+ return NULL_TREE;
+ if (TREE_CODE (*tp) == *((enum tree_code *)data))
+ return *tp;
+ return NULL_TREE;
+}
+
+static tree find_tree_with_code (tree body, enum tree_code code)
+{
+ enum tree_code temp = code;
+ return walk_tree_without_duplicates (&body, find_tree_with_code_1, (void *)&temp);
+}
+
+static tree
+find_pointer (tree t)
+{
+ tree temp2 = find_tree_with_code (t, ARRAY_REF);
+ if (temp2)
+ return TREE_OPERAND (temp2, 0);
+ temp2 = find_tree_with_code (t, INDIRECT_REF);
+ if (temp2)
+ {
+ temp2 = TREE_OPERAND (temp2, 0);
+ if (TREE_CODE (temp2) == PLUS_EXPR)
+ {
+ temp2 = TREE_OPERAND (temp2, 0);
+ if (TREE_CODE (temp2) == PARM_DECL || TREE_CODE (temp2) == VAR_DECL)
+ return temp2;
+ return find_pointer (temp2);
+ }
+ }
+ return NULL_TREE;
+}
+
+typedef struct should_transpose_for_loops_t
+{
+ tree inner_var;
+ tree outer_var;
+ bool doit;
+ tree already_modified;
+} should_transpose_for_loops_t;
+
+/* If the transposition should be done, set data->doit to true and
+ return NULL. If it should not, set data->doit to false and
+ return *tp. */
+
+static tree
+should_transpose_for_loops_1 (tree *tp, int *walk_subtrees, void *data)
+{
+ tree assignment_to = *tp;
+ should_transpose_for_loops_t *temp = (should_transpose_for_loops_t*)data;
+ tree inner_var = temp->inner_var;
+ tree outer_var = temp->outer_var;
+ if (*tp == NULL_TREE)
+ return NULL_TREE;
+ /* We cannot do the transposition if any of these are in the loop. */
+ if (TREE_CODE (*tp) == LABEL_DECL || TREE_CODE (*tp) == GOTO_STMT
+ || TREE_CODE (*tp) == FOR_STMT || TREE_CODE (*tp) == DO_STMT
+ || TREE_CODE (*tp) == WHILE_STMT || TREE_CODE (*tp) == IF_STMT
+ || TREE_CODE (*tp) == BREAK_STMT || TREE_CODE (*tp) == CONTINUE_STMT
+ || TREE_CODE (*tp) == RETURN_EXPR)
+ {
+ temp->doit = false;
+ return *tp;
+ }
+ if (TREE_CODE (assignment_to) == MODIFY_EXPR)
+ {
+ tree temp1;
+ tree temp2 = find_pointer (TREE_OPERAND (assignment_to, 0));
+ /* We cannot do the transposition because the pointer temp2 is modified
+ with a value dependent on itself.
+ (Note this could be better if it is only dependent on a non-forward
+ loop dependent). */
+ if (temp2 != NULL_TREE
+ && tree_contains (TREE_OPERAND (assignment_to, 1), temp2))
+ {
+ temp->doit = false;
+ return *tp;
+ }
+ for (temp1 = temp->already_modified;
+ temp1 != NULL_TREE;
+ temp1 = TREE_CHAIN (temp1))
+ {
+ tree temp3 = TREE_VALUE(temp1);
+ tree temp4 = TREE_OPERAND (assignment_to, 1);
+ /* We cannot do the transposition because the pointer temp3 is
+ modified with a value dependent on itself or already has
+ been modified. */
+ if (tree_contains (temp4, temp3)
+ || (temp2 != NULL_TREE && temp3 == temp2))
+ {
+ temp->doit = false;
+ return *tp;
+ }
+ }
+ /* If it is non-null, add temp2 to the list of already modified
+ pointers. */
+ if(temp2 != NULL_TREE)
+ temp->already_modified =
+ tree_cons(NULL_TREE, temp2, temp->already_modified);
+ }
+ /* Check for pointer[inner][outer], pointer[inner*outersize+outer] and
+ array[inner][outer]. */
+ if ((TREE_CODE (assignment_to) == INDIRECT_REF
+ && TREE_CODE (TREE_OPERAND (assignment_to, 0)) == PLUS_EXPR)
+ || (TREE_CODE (assignment_to) == ARRAY_REF
+ && TREE_CODE (TREE_OPERAND (assignment_to, 1)) == PLUS_EXPR))
+ {
+ tree plus1_expr_assignment = TREE_OPERAND (assignment_to,
+ TREE_CODE (assignment_to) == ARRAY_REF ? 1 : 0);
+ tree side0 = TREE_OPERAND (plus1_expr_assignment, 0);
+ tree side1 = TREE_OPERAND (plus1_expr_assignment, 1);
+ STRIP_NOPS (side0);
+ STRIP_NOPS (side1);
+ /* This handles a[inner][outer]. */
+ if ((TREE_CODE (side0) == INDIRECT_REF
+ && tree_contains (side0, inner_var)
+ && !tree_contains (side0, outer_var)
+ && tree_contains (side1, outer_var)
+ && !tree_contains (side1, inner_var))
+ || (TREE_CODE (side1) == INDIRECT_REF
+ && tree_contains (side1, inner_var)
+ && !tree_contains (side1, outer_var)
+ && tree_contains (side0, outer_var)
+ && !tree_contains (side0, inner_var)))
+ {
+ *walk_subtrees = 0; /* already walked them */
+ temp->doit = true;
+ return NULL_TREE;
+ }
+ else
+ {
+ tree side = NULL_TREE;
+ /* Handle array[inner*size+outer+offset] and pointer[inner*size+outer]
+ (FIXME need to handle array[inner*size+outer]
+ (and pointer[inner*size+outer+offset]?) )*/
+ if (tree_contains (side0, inner_var)
+ && tree_contains (side0, outer_var))
+ side = side0;
+ else if (tree_contains (side1, inner_var)
+ && tree_contains (side1, outer_var))
+ side = side1;
+ if (side && (TREE_CODE (side) == MULT_EXPR))
+ {
+ tree temp0 = TREE_OPERAND (side, 0);
+ tree temp1 = TREE_OPERAND (side, 1);
+ STRIP_NOPS (temp0);
+ STRIP_NOPS (temp1);
+ if (tree_contains (temp0, inner_var)
+ && tree_contains (temp0, outer_var))
+ side = temp0;
+ else if (tree_contains (temp1, inner_var)
+ && tree_contains (temp1, outer_var))
+ side = temp1;
+ else
+ side = NULL_TREE;
+ }
+ if (side && (TREE_CODE (side) == PLUS_EXPR))
+ {
+ tree side10 = TREE_OPERAND (side, 0);
+ tree side11 = TREE_OPERAND (side, 1);
+ STRIP_NOPS (side10);
+ STRIP_NOPS (side11);
+ if ((TREE_CODE (side10) == MULT_EXPR
+ && tree_contains (side10, inner_var)
+ && !tree_contains (side10, outer_var)
+ && tree_contains (side11, outer_var)
+ && !tree_contains (side11, inner_var))
+ || (TREE_CODE (side11) == MULT_EXPR
+ && tree_contains (side11, inner_var)
+ && !tree_contains (side11, outer_var)
+ && tree_contains (side10, outer_var)
+ && !tree_contains (side10, inner_var)))
+ {
+ *walk_subtrees = 0; /* already walked them */
+ temp->doit = true;
+ return NULL;
+ }
+ else
+ {
+ temp->doit = false;
+ return *tp;
+ }
+ }
+ }
+ }
+ /* We cannot do the transposition if there is an assignment to the
+ outer_var or inner_var. */
+ if (TREE_CODE (assignment_to) == MODIFY_EXPR)
+ {
+ tree side1 = TREE_OPERAND (assignment_to, 1);
+ STRIP_NOPS (side1);
+ if (side1 == outer_var || side1 == inner_var)
+ {
+ temp->doit = false;
+ return *tp;
+ }
+ }
+ return NULL_TREE;
+}
+
+/* Return true if the loops should be interchanged based on body, inner
+ variable and outer variable, and also set already_modified to the pointers
+ that are modified during the loop. */
+
+static bool
+should_transpose_for_loops (tree body, tree inner_var, tree outer_var,
+ tree *already_modified)
+{
+ should_transpose_for_loops_t temp;
+ temp.inner_var = inner_var;
+ temp.outer_var = outer_var;
+ temp.already_modified = *already_modified;
+ temp.doit = false;
+ if (walk_tree (&body, should_transpose_for_loops_1, &temp, NULL))
+ return false;
+ *already_modified = temp.already_modified;
+ return temp.doit;
+}
+
+static tree
+tree_contains_1 (tree *tp, int *walk_subtrees ATTRIBUTE_UNUSED, void *data)
+{
+ if (*tp == data)
+ return data;
+ return NULL_TREE;
+}
+
+static bool
+tree_contains (tree body, tree x)
+{
+ return walk_tree_without_duplicates (&body, tree_contains_1, (void *)x)
+ != NULL_TREE;
+}
+
+/* Look for two nested loops and transpose them if this is a good idea.
+ Currently limited to FOR statements in C. */
+
+static tree
+perform_loop_transpose (tree *tp, int *walk_subtrees,
+ void *data ATTRIBUTE_UNUSED)
+{
+ tree already_modified = NULL_TREE;
+ if (*tp == NULL_TREE)
+ return NULL_TREE;
+ if (TREE_CODE (*tp) == FOR_STMT)
+ {
+ tree outer_loop = *tp;
+ tree inner_loop = TREE_OPERAND (outer_loop, 3);
+ tree before_inner_loop = NULL_TREE;
+ tree right_before_inner_loop = NULL_TREE;
+ /* If the loops contains a call or an if statement or is empty,
+ do not do the transposition. */
+ if (inner_loop == NULL_TREE
+ || find_tree_with_code (inner_loop, CALL_EXPR) != NULL_TREE
+ || find_tree_with_code (inner_loop, IF_STMT) != NULL_TREE)
+ return NULL_TREE;
+ /* A compound stmt after the outer for loop. */
+ if (TREE_CODE (inner_loop) == COMPOUND_STMT
+ && TREE_OPERAND (inner_loop, 0) != NULL_TREE
+ && TREE_CODE (TREE_OPERAND (inner_loop, 0)) == SCOPE_STMT)
+ {
+ tree previous = NULL_TREE;
+ before_inner_loop = TREE_OPERAND (inner_loop, 0);
+
+ /* If the outer loop contains variable definitions, do not
+ do the transposition. FIXME: if the only definition is
+ the inner loop variable we could do it. */
+ if (TREE_OPERAND (before_inner_loop, 0) != NULL_TREE)
+ return NULL_TREE;
+
+ /* Find the inner loop if there is any.
+ FIXME: will not work if the inner loop is another compound loop. */
+ for (inner_loop = before_inner_loop;
+ inner_loop != NULL_TREE && TREE_CODE (inner_loop) != FOR_STMT;
+ inner_loop = TREE_CHAIN (inner_loop))
+ previous = inner_loop;
+
+ /* If there is no inner loop do not do anything. */
+ if (inner_loop == NULL_TREE)
+ return NULL_TREE;
+
+ /* If the inner_loop is equal to the start of the compound
+ statement set the start to NULL. */
+ if (inner_loop == before_inner_loop)
+ before_inner_loop = NULL_TREE;
+
+ right_before_inner_loop = previous;
+ }
+ /* We found the inner loop. */
+ if (inner_loop != NULL_TREE && TREE_CODE (inner_loop) == FOR_STMT)
+ {
+ tree outer_init = TREE_OPERAND (outer_loop, 0);
+ tree inner_init = TREE_OPERAND (inner_loop, 0);
+ /* FIXME: does not handle C99/C++ style for init statements */
+ if (outer_init != NULL_TREE && inner_init != NULL_TREE
+ && TREE_CODE (outer_init) == EXPR_STMT
+ && TREE_CODE (inner_init) == EXPR_STMT)
+ {
+ tree outer_init_expr = TREE_OPERAND (outer_init, 0);
+ tree inner_init_expr = TREE_OPERAND (inner_init, 0);
+ if (outer_init_expr != NULL_TREE && inner_init_expr != NULL_TREE
+ && TREE_CODE (inner_init_expr) == MODIFY_EXPR
+ && TREE_CODE (outer_init_expr) == MODIFY_EXPR)
+ {
+ tree outer_var = TREE_OPERAND (outer_init_expr, 0);
+ tree inner_var = TREE_OPERAND (inner_init_expr, 0);
+ /* The inner_var should be independent of outer_var */
+ if (!tree_contains (TREE_OPERAND (inner_init_expr, 1),
+ outer_var)
+ && !tree_contains (TREE_OPERAND (inner_loop, 1),
+ outer_var)
+ && !tree_contains (TREE_OPERAND (inner_loop, 2),
+ outer_var)
+ /* The outer loop variable should be independent of
+ inner_var also. */
+ && !tree_contains (TREE_OPERAND (outer_loop, 1),
+ inner_var)
+ && !tree_contains (TREE_OPERAND (outer_loop, 2),
+ inner_var))
+ {
+ tree inner_loop_body = TREE_OPERAND (inner_loop, 3);
+ if (should_transpose_for_loops (inner_loop_body,
+ inner_var, outer_var, &already_modified))
+ {
+ tree newouter;
+ tree newinner;
+ /* Is the outter loop's body a compound statement? */
+ if (TREE_CODE (TREE_OPERAND (outer_loop, 3))
+ == COMPOUND_STMT)
+ {
+ tree after_loop = TREE_CHAIN (inner_loop);
+ tree find;
+ tree allloops_stmt;
+ tree outloopafter;
+ tree outloopbefore;
+ allloops_stmt = build_stmt (COMPOUND_STMT,
+ NULL_TREE);
+ outloopbefore = build_stmt (FOR_STMT, outer_init,
+ TREE_OPERAND (outer_loop, 1),
+ TREE_OPERAND (outer_loop, 2),
+ NULL_TREE);
+ /* Use copies of the loop test
+ expression (TREE_OPERAND #1) for
+ these, lest the tree-profiler mix the
+ execution counts of two different
+ loops. */
+ outloopafter = build_stmt (FOR_STMT, outer_init,
+ copy_node (TREE_OPERAND (outer_loop, 1)),
+ TREE_OPERAND (outer_loop, 2),
+ NULL_TREE);
+ newinner = build_stmt (FOR_STMT, outer_init,
+ copy_node (TREE_OPERAND (outer_loop, 1)),
+ TREE_OPERAND (outer_loop, 2),
+ inner_loop_body);
+ newouter = build_stmt (FOR_STMT, inner_init,
+ TREE_OPERAND (inner_loop, 1),
+ TREE_OPERAND (inner_loop, 2),
+ newinner);
+ /* This new compound statement has no scope. */
+ COMPOUND_STMT_NO_SCOPE (allloops_stmt) = 1;
+ /* Move to the next statement in the chain of
+ before_inner_loop if it is a scope statement */
+ if (before_inner_loop != NULL_TREE
+ && TREE_CODE (before_inner_loop)
+ == SCOPE_STMT)
+ {
+ if (right_before_inner_loop != NULL_TREE)
+ TREE_CHAIN (right_before_inner_loop)
+ = NULL_TREE;
+ before_inner_loop
+ = TREE_CHAIN (before_inner_loop);
+ }
+ /* Are there statements before the inner loop? */
+ if (before_inner_loop != NULL_TREE)
+ {
+ tree beforeloopbody
+ = build_stmt (COMPOUND_STMT, NULL_TREE);
+ COMPOUND_STMT_NO_SCOPE (beforeloopbody) = 1;
+ beforeloopbody
+ = build_stmt (COMPOUND_STMT, NULL_TREE);
+ COMPOUND_BODY (beforeloopbody)
+ = before_inner_loop;
+ FOR_BODY (outloopbefore) = beforeloopbody;
+ /* If the outer loop body depends on the inner
+ variable we can't do the transposition. */
+ if (tree_contains (outloopbefore, inner_var))
+ return NULL_TREE;
+
+ for (find = already_modified;
+ find != NULL_TREE;
+ find = TREE_CHAIN (find))
+ {
+ tree temp3 = TREE_VALUE(find);
+ if (tree_contains(outloopbefore, temp3))
+ /* We cannot do the transposition
+ because there is a reference to
+ something modified in the outer loop. */
+ return NULL_TREE;
+ }
+ /* If the new before loop body is independent
+ of the outer variable, remove the loop
+ and make the body the first statement in
+ the chain of all the statements. */
+ if (!tree_contains (beforeloopbody,
+ outer_var))
+ {
+ COMPOUND_BODY (allloops_stmt)
+ = beforeloopbody;
+ TREE_CHAIN (beforeloopbody) = newouter;
+ }
+ else
+ {
+ COMPOUND_BODY (allloops_stmt)
+ = outloopbefore;
+ TREE_CHAIN (outloopbefore) = newouter;
+ }
+ }
+ else
+ {
+ COMPOUND_BODY (allloops_stmt) = newouter;
+ outloopbefore = NULL_TREE;
+ }
+ if (after_loop != NULL_TREE
+ && TREE_CHAIN (after_loop) == NULL_TREE)
+ {
+ if (TREE_CODE (after_loop) != SCOPE_STMT)
+ FOR_BODY (outloopafter) = after_loop;
+ else
+ outloopafter = NULL_TREE;
+ }
+ else
+ {
+ tree afterloopbody
+ = build_stmt (COMPOUND_STMT, NULL_TREE);
+ tree temp5;
+ COMPOUND_STMT_NO_SCOPE (afterloopbody) = 1;
+ COMPOUND_BODY (afterloopbody) = after_loop;
+ FOR_BODY (outloopafter) = afterloopbody;
+ for (temp5 = after_loop;
+ temp5 != NULL_TREE;
+ temp5 = TREE_CHAIN (temp5))
+ if (TREE_CODE (TREE_CHAIN (temp5))
+ == SCOPE_STMT)
+ TREE_CHAIN (temp5) = NULL_TREE;
+ /* If the outer loop body depends on the inner
+ variable, we cannot do the transposition. */
+ if (tree_contains (afterloopbody, inner_var))
+ return NULL_TREE;
+ /* FIXME: need to check for the afterloopbody
+ containing a pointer that gets modified
+ before the inner loop has a chance to
+ read it. */
+ for (find = already_modified;
+ find != NULL_TREE;
+ find = TREE_CHAIN (find))
+ {
+ tree temp3 = TREE_VALUE(find);
+ /* If something references something that
+ is stored into we cannot do the
+ transposition. */
+ if (tree_contains(afterloopbody, temp3))
+ return NULL_TREE;
+ }
+ /* If the stuff after the inner_loop is not
+ dependent on the loop variable pull it
+ out of the loop. */
+ if (!tree_contains (afterloopbody, outer_var))
+ outloopafter = afterloopbody;
+ }
+ TREE_CHAIN (newouter) = outloopafter;
+ if (outloopafter == NULL_TREE
+ && outloopbefore == NULL_TREE)
+ allloops_stmt = newouter;
+ TREE_CHAIN (allloops_stmt)
+ = TREE_CHAIN (outer_loop);
+ *walk_subtrees = 0;
+ *tp = allloops_stmt;
+ return NULL_TREE;
+ }
+ /* Do the transposition. */
+ newinner = build_stmt (FOR_STMT, outer_init,
+ TREE_OPERAND (outer_loop, 1),
+ TREE_OPERAND (outer_loop, 2),
+ inner_loop_body);
+ newouter = build_stmt (FOR_STMT, inner_init,
+ TREE_OPERAND (inner_loop, 1),
+ TREE_OPERAND (inner_loop, 2),
+ newinner);
+ TREE_CHAIN (newouter) = TREE_CHAIN (outer_loop);
+ *tp = newouter;
+ *walk_subtrees = 0;
+ }
+ }
+ }
+ }
+ }
+ }
+ return NULL_TREE;
+}
+
+/* The main entry point for the transposition. */
+void
+loop_transpose (tree fn)
+{
+ /*timevar_push (TV_LOOP_TRANSPOSE);*/
+ walk_tree (&DECL_SAVED_TREE (fn), perform_loop_transpose, NULL, NULL);
+ /*timevar_pop (TV_LOOP_TRANSPOSE);*/
+}
+/* APPLE LOCAL end loop transposition */
+
#include "gt-c-decl.h"
diff --git a/gcc/c-dmp-tree.c b/gcc/c-dmp-tree.c
new file mode 100644
index 00000000000..ef1d1e8723b
--- /dev/null
+++ b/gcc/c-dmp-tree.c
@@ -0,0 +1,520 @@
+/* APPLE LOCAL new tree dump */
+/* Common condensed tree display routines specific for C.
+ Copyright (C) 2001 Free Software Foundation, Inc.
+ Contributed by Ira L. Ruben (ira@apple.com)
+
+This file is part of GNU CC.
+
+GNU CC is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2, or (at your option)
+any later version.
+
+GNU CC is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+GNU General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with GNU CC; see the file COPYING. If not, write to
+the Free Software Foundation, 59 Temple Place - Suite 330,
+Boston, MA 02111-1307, USA. */
+
+#include "config.h"
+
+#include "system.h"
+#include "coretypes.h"
+#include "tm.h"
+#include "tree.h"
+#include "c-common.h"
+#include <string.h>
+#include <ctype.h>
+
+#define DMP_TREE
+#include "dmp-tree.h"
+
+int c_dump_tree_p (FILE *, const char *, tree, int);
+lang_dump_tree_p_t c_prev_lang_dump_tree_p = NULL;
+
+#define DEFTREECODE(SYM, NAME, TYPE, LENGTH) \
+static void print_ ## SYM (FILE *file, const char *annotation, tree node, int indent);
+#include "c-common.def"
+#undef DEFTREECODE
+
+/*-------------------------------------------------------------------*/
+
+/* If CP_DMP_TREE is defined then this file is being #include'ed from
+ cp/cp-dmp-tree.c. It needs to handle both C and C++ nodes. The C++
+ nodes are handled from cp/cp-dmp-tree.c and it use c-dmp-tree.c to
+ handle the C nodes. */
+
+#ifndef CP_DMP_TREE
+#include "c-tree.h"
+
+/* Called twice for dmp_tree() for an IDENTIFIER_NODE. The first call
+ is after the common info for the node is generated but before
+ displaying the identifier (before_id==0) which is always assumed
+ to be the last thing on the line.
+
+ The second call is done after the id is displayed (before_id!=0).
+ This is for displaying any language-specific node information that
+ should be preceded by an indent_to() call or a recursive call to
+ dump_tree() for nodes which are language specific operands to a
+ IDENTIFIER_NODE. */
+
+void
+c_dump_identifier (file, node, indent, after_id)
+ FILE *file;
+ tree node;
+ int indent;
+ int after_id;
+{
+ if (!after_id)
+ {
+ if (C_IS_RESERVED_WORD (node))
+ {
+ tree rid = ridpointers[C_RID_CODE (node)];
+ fprintf (file, " rid=");
+ fprintf (file, HOST_PTR_PRINTF, HOST_PTR_PRINTF_VALUE((void *)rid));
+ fprintf (file, "(%s)", IDENTIFIER_POINTER (rid));
+ }
+ if (IDENTIFIER_LABEL_VALUE (node))
+ {
+ fprintf (file, " lbl=");
+ fprintf (file, HOST_PTR_PRINTF, IDENTIFIER_LABEL_VALUE (node));
+ }
+ }
+ else
+ {
+ dump_tree (file, "(lbl)", IDENTIFIER_LABEL_VALUE (node), indent + INDENT);
+ }
+}
+
+/* Called twice for dmp_tree() for a ..._DECL node. The first call
+ after the common info for the node is generated but before
+ displaying the identifer (before_id==0) which is always assumed
+ to be the last thing on the line.
+
+ The second call is done after the id is displayed (before_id!=0).
+ This is for displaying any language-specific node information that
+ should be preceded by an indent_to() call or a recursive call to
+ dump_tree() for nodes which are language specific operands to a
+ a ..._DECL node. */
+
+void
+c_dump_decl (file, node, indent, after_id)
+ FILE *file ATTRIBUTE_UNUSED;
+ tree node ATTRIBUTE_UNUSED;
+ int indent ATTRIBUTE_UNUSED;
+ int after_id ATTRIBUTE_UNUSED;
+{
+}
+
+/* Called twice for dmp_tree() for a ..._TYPE node. The first call
+ after the common info for the node is generated but before
+ displaying the identifier (before_id==0) which is always assumed
+ to be the last thing on the line.
+
+ The second call is done after the id is displayed (before_id!=0).
+ This is for displaying any language-specific node information that
+ should be preceded by an indent_to() call or a recursive call to
+ dump_tree() for nodes which are language specific operands to a
+ a ..._TYPE node. */
+
+void
+c_dump_type (file, node, indent, after_id)
+ FILE *file ATTRIBUTE_UNUSED;
+ tree node ATTRIBUTE_UNUSED;
+ int indent ATTRIBUTE_UNUSED;
+ int after_id ATTRIBUTE_UNUSED;
+{
+}
+
+/* Normally a blank line is inserted before each statement node (a
+ statement node is determined by calling statement_code_p()). This
+ makes the display easier to read by keeping each statement grouped
+ like a paragraph. There may, however, be some kinds of statements
+ where a blank line isn't desired (e.g., a begin SCOPE_STMT in C).
+ Thus dump_lang_blank_line() is called to ask if a particular
+ statement should be preceded by a blank line dependent upon the
+ node that preceded it.
+
+ dump_lang_blank_line_p() is called for each statement passing the
+ previous node (not necessarily a statement) and current node (a
+ statement node by definition). It should return 1 if a blank
+ line is to be inserted and 0 otherwise. */
+
+int
+c_dump_blank_line_p (previous_node, current_node)
+ tree previous_node;
+ tree current_node;
+{
+ return (TREE_CODE (current_node) != SCOPE_STMT
+ && !(TREE_CODE (previous_node) == SCOPE_STMT
+ && SCOPE_BEGIN_P (previous_node)));
+}
+
+/* This is called for each node to display file and/or line number
+ information for those nodes that have such information. If it
+ is displayed the function should return 1. If not, 0.
+
+ The function generally does not have to handle ..._DECL nodes
+ unless there some special handling is reequired. They are
+ handled by print_lineno() (dump_lang_lineno_p()'s caller).
+ It is defined to not repeat the filename if it does not
+ change from what's in dump_tree_state.curr_file and then
+ it only displays the basename (using lbasename()). The
+ format of the display is " line=nbr(basename)" where the
+ leading space is included as usual in these displays and
+ the parenthesized basename omitted if not needed or is
+ the same as before. */
+
+int
+c_dump_lineno_p (file, node)
+ FILE *file ATTRIBUTE_UNUSED;
+ tree node ATTRIBUTE_UNUSED;
+{
+ return 0;
+}
+
+/* Called only by tree-dump.c when doing a full compilation tree dump
+ under one of the -fdmp-xxxx options. This makes tree_dump.c, which
+ is common to all languages, independent of dmp_tree, which currently
+ only supports the c languages. */
+int
+c_dmp_tree3 (file, node, flags)
+ FILE *file;
+ tree node;
+ int flags;
+{
+ dmp_tree3 (file, node, flags);
+ return 1;
+}
+
+#endif /* !CP_DMP_TREE */
+
+/*-------------------------------------------------------------------*/
+
+static void
+print_SIZEOF_EXPR (file, annotation, node, indent)
+ FILE *file ATTRIBUTE_UNUSED;
+ const char *annotation ATTRIBUTE_UNUSED;
+ tree node ATTRIBUTE_UNUSED;
+ int indent ATTRIBUTE_UNUSED;
+{
+ print_operands (file, node, indent, TRUE, NULL);
+}
+
+static void
+print_ARROW_EXPR (file, annotation, node, indent)
+ FILE *file ATTRIBUTE_UNUSED;
+ const char *annotation ATTRIBUTE_UNUSED;
+ tree node ATTRIBUTE_UNUSED;
+ int indent ATTRIBUTE_UNUSED;
+{
+ print_operands (file, node, indent, TRUE, NULL);
+}
+
+static void
+print_ALIGNOF_EXPR (file, annotation, node, indent)
+ FILE *file ATTRIBUTE_UNUSED;
+ const char *annotation ATTRIBUTE_UNUSED;
+ tree node ATTRIBUTE_UNUSED;
+ int indent ATTRIBUTE_UNUSED;
+{
+ print_operands (file, node, indent, TRUE, NULL);
+}
+
+static void
+print_EXPR_STMT (file, annotation, node, indent)
+ FILE *file;
+ const char *annotation ATTRIBUTE_UNUSED;
+ tree node;
+ int indent;
+{
+ print_operands (file, node, indent, TRUE, NULL);
+}
+
+static void
+print_COMPOUND_STMT (file, annotation, node, indent)
+ FILE *file;
+ const char *annotation ATTRIBUTE_UNUSED;
+ tree node;
+ int indent;
+{
+ print_operands (file, node, indent, FALSE, NULL);
+
+ for (node = COMPOUND_BODY (node); node; node = TREE_CHAIN (node))
+ {
+ if (TREE_CODE (node) == SCOPE_STMT && SCOPE_END_P (node) && indent >= INDENT)
+ indent -= INDENT;
+
+ dump_tree (file, NULL, node, indent + INDENT);
+
+ if (TREE_CODE (node) == SCOPE_STMT && SCOPE_BEGIN_P (node))
+ indent += INDENT;
+ }
+}
+
+static void
+print_DECL_STMT (file, annotation, node, indent)
+ FILE *file;
+ const char *annotation ATTRIBUTE_UNUSED;
+ tree node;
+ int indent;
+{
+ tree type;
+
+ fprintf (file, " %s=", tree_code_name[(int) TREE_CODE (DECL_STMT_DECL (node))]);
+ fprintf (file, HOST_PTR_PRINTF, HOST_PTR_PRINTF_VALUE (DECL_STMT_DECL (node)));
+
+ type = TREE_TYPE (DECL_STMT_DECL (node));
+ if (type && TREE_CODE_CLASS (TREE_CODE (type)) == 't')
+ {
+ if (TYPE_NAME (type))
+ {
+ if (TREE_CODE (TYPE_NAME (type)) == IDENTIFIER_NODE)
+ fprintf (file, " {%s}", IDENTIFIER_POINTER (TYPE_NAME (type)));
+ else if (TREE_CODE (TYPE_NAME (type)) == TYPE_DECL
+ && DECL_NAME (TYPE_NAME (type)))
+ fprintf (file, " {%s}",
+ IDENTIFIER_POINTER (DECL_NAME (TYPE_NAME (type))));
+ }
+ else
+ fprintf (file, " {%s}", tree_code_name[(int) TREE_CODE (type)]);
+ }
+
+ if (DECL_NAME ( DECL_STMT_DECL (node)))
+ fprintf (file, " %s", IDENTIFIER_POINTER (DECL_NAME ( DECL_STMT_DECL (node))));
+
+ if (!node_seen (DECL_STMT_DECL (node), FALSE)
+ || TREE_CODE (DECL_STMT_DECL (node)) != VAR_DECL)
+ dump_tree (file, NULL, DECL_STMT_DECL (node), indent + INDENT);
+}
+
+static void
+print_IF_STMT (file, annotation, node, indent)
+ FILE *file;
+ const char *annotation ATTRIBUTE_UNUSED;
+ tree node;
+ int indent;
+{
+ print_operands (file, node, indent, TRUE, "(if)", "(then)", "(else)", NULL);
+}
+
+static void
+print_FOR_STMT (file, annotation, node, indent)
+ FILE *file;
+ const char *annotation ATTRIBUTE_UNUSED;
+ tree node;
+ int indent;
+{
+ if (NEW_FOR_SCOPE_P (node))
+ fputs (" new-scope", file);
+
+ print_operands (file, node, indent, TRUE, "(init)", "(cond)",
+ "(expr)", "(body)", NULL);
+}
+
+static void
+print_WHILE_STMT (file, annotation, node, indent)
+ FILE *file;
+ const char *annotation ATTRIBUTE_UNUSED;
+ tree node;
+ int indent;
+{
+ print_operands (file, node, indent, TRUE, "(cond)", "(body)", NULL);
+}
+
+static void
+print_DO_STMT (file, annotation, node, indent)
+ FILE *file;
+ const char *annotation ATTRIBUTE_UNUSED;
+ tree node;
+ int indent;
+{
+ print_operands (file, node, indent, TRUE, "(cond)", "(body)", NULL);
+}
+
+static void
+print_RETURN_STMT (file, annotation, node, indent)
+ FILE *file;
+ const char *annotation ATTRIBUTE_UNUSED;
+ tree node;
+ int indent;
+{
+ print_operands (file, node, indent, TRUE, NULL);
+}
+
+static void
+print_BREAK_STMT (file, annotation, node, indent)
+ FILE *file;
+ const char *annotation ATTRIBUTE_UNUSED;
+ tree node;
+ int indent;
+{
+ print_operands (file, node, indent, TRUE, NULL);
+}
+
+static void
+print_CONTINUE_STMT (file, annotation, node, indent)
+ FILE *file;
+ const char *annotation ATTRIBUTE_UNUSED;
+ tree node;
+ int indent;
+{
+ print_operands (file, node, indent, TRUE, NULL);
+}
+
+static void
+print_SWITCH_STMT (file, annotation, node, indent)
+ FILE *file;
+ const char *annotation ATTRIBUTE_UNUSED;
+ tree node;
+ int indent;
+{
+ print_operands (file, node, indent, TRUE, "(cond)", "(body)", NULL);
+}
+
+static void
+print_GOTO_STMT (file, annotation, node, indent)
+ FILE *file;
+ const char *annotation ATTRIBUTE_UNUSED;
+ tree node;
+ int indent;
+{
+ print_operands (file, node, indent, TRUE, NULL);
+}
+
+static void
+print_LABEL_STMT (file, annotation, node, indent)
+ FILE *file;
+ const char *annotation ATTRIBUTE_UNUSED;
+ tree node;
+ int indent;
+{
+ print_operands (file, node, indent, TRUE, NULL);
+}
+
+static void
+print_ASM_STMT (file, annotation, node, indent)
+ FILE *file;
+ const char *annotation ATTRIBUTE_UNUSED;
+ tree node;
+ int indent;
+{
+ if (ASM_VOLATILE_P (node))
+ fputs (" volatile", file);
+
+ print_operands (file, node, indent, TRUE, "(cv-qual)", "(string)",
+ "(outputs)", "(inputs)", "(clobbers)", NULL);
+}
+
+static void
+print_SCOPE_STMT (file, annotation, node, indent)
+ FILE *file;
+ const char *annotation ATTRIBUTE_UNUSED;
+ tree node;
+ int indent;
+{
+ if (SCOPE_BEGIN_P (node))
+ fputs (" BEGIN", file);
+ if (SCOPE_END_P (node))
+ fputs (" END", file);
+ if (SCOPE_NULLIFIED_P (node))
+ fputs (" no-vars", file);
+ if (SCOPE_NO_CLEANUPS_P (node))
+ fputs (" no-cleanups", file);
+ if (SCOPE_PARTIAL_P (node))
+ fputs (" partial", file);
+ fprintf (file, " block=");
+ fprintf (file, HOST_PTR_PRINTF,
+ HOST_PTR_PRINTF_VALUE (SCOPE_STMT_BLOCK (node)));
+
+ if (SCOPE_BEGIN_P (node) || !node_seen (SCOPE_STMT_BLOCK (node), FALSE))
+ dump_tree (file, NULL, SCOPE_STMT_BLOCK (node), indent + INDENT);
+
+ (void)node_seen (node, TRUE);
+
+ for (node = TREE_CHAIN (node); node; node = TREE_CHAIN (node))
+ dump_tree (file, annotation, node, indent + INDENT);
+}
+
+static void
+print_FILE_STMT (file, annotation, node, indent)
+ FILE *file;
+ const char *annotation ATTRIBUTE_UNUSED;
+ tree node;
+ int indent;
+{
+ print_operands (file, node, indent, TRUE, NULL);
+}
+
+static void
+print_CASE_LABEL (file, annotation, node, indent)
+ FILE *file;
+ const char *annotation ATTRIBUTE_UNUSED;
+ tree node;
+ int indent;
+{
+ print_operands (file, node, indent, TRUE, "(lo)", "(hi)", "(lbl)", NULL);
+}
+
+static void
+print_STMT_EXPR (file, annotation, node, indent)
+ FILE *file;
+ const char *annotation ATTRIBUTE_UNUSED;
+ tree node;
+ int indent;
+{
+ print_operands (file, node, indent, TRUE, NULL);
+}
+
+static void
+print_COMPOUND_LITERAL_EXPR (file, annotation, node, indent)
+ FILE *file;
+ const char *annotation ATTRIBUTE_UNUSED;
+ tree node;
+ int indent;
+{
+ print_operands (file, node, indent, TRUE, NULL);
+}
+
+static void
+print_CLEANUP_STMT (file, annotation, node, indent)
+ FILE *file;
+ const char *annotation ATTRIBUTE_UNUSED;
+ tree node;
+ int indent;
+{
+ print_operands (file, node, indent, TRUE, "(decl)", "(expr)", NULL);
+}
+
+/*-------------------------------------------------------------------*/
+
+/* Return 1 if tree node is a C++ specific tree node from cp-tree.def
+ or a tree node specific to whatever cp_prev_lang_dump_tree_p
+ calls. Otherwise return 0.
+*/
+
+int
+c_dump_tree_p (file, annotation, node, indent)
+ FILE *file;
+ const char *annotation ATTRIBUTE_UNUSED;
+ tree node;
+ int indent;
+{
+ switch (TREE_CODE (node))
+ {
+# define DEFTREECODE(SYM, NAME, TYPE, LENGTH) \
+ case SYM: print_ ## SYM (file, annotation, node, indent); break;
+# include "c-common.def"
+# undef DEFTREECODE
+ default:
+ return c_prev_lang_dump_tree_p (file, annotation, node, indent);
+ }
+
+ return 1;
+}
+
+
diff --git a/gcc/c-idebug.c b/gcc/c-idebug.c
new file mode 100644
index 00000000000..7b10fc29a0a
--- /dev/null
+++ b/gcc/c-idebug.c
@@ -0,0 +1,57 @@
+/* APPLE LOCAL file debugging */
+/* C-specific tree accessors defined as functions for use in a debugger.
+ Copyright (C) 2001 Free Software Foundation, Inc.
+ Contributed by Ira L. Ruben (ira@apple.com)
+
+This file is part of GNU CC.
+
+GNU CC is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2, or (at your option)
+any later version.
+
+GNU CC is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+GNU General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with GNU CC; see the file COPYING. If not, write to
+the Free Software Foundation, 59 Temple Place - Suite 330,
+Boston, MA 02111-1307, USA. */
+
+/* What we do here is to instantiate each macro as a function *BY
+ THE SAME NAME*. Depends on the macro not being expanded when
+ it is surrounded by parens.
+
+ Note that this file includes idebug.c so that only debugging
+ macros for c-tree.h are actually defined here. For C only
+ this file is included in the link while for C only idebug.c
+ is built and included in the link. */
+
+#include "idebug.c"
+
+#ifdef ENABLE_IDEBUG
+
+#include "c-tree.h"
+
+/* Macros from c-tree.h */
+
+fn_1( IDENTIFIER_GLOBAL_VALUE, tree, tree )
+fn_1( IDENTIFIER_LOCAL_VALUE, tree, tree )
+fn_1( IDENTIFIER_LABEL_VALUE, tree, tree )
+fn_1( IDENTIFIER_LIMBO_VALUE, tree, tree )
+fn_1( IDENTIFIER_IMPLICIT_DECL, tree, tree )
+fn_1( IDENTIFIER_ERROR_LOCUS, tree, tree )
+fn_1( C_TYPE_FIELDS_READONLY, int, tree )
+fn_1( C_TYPE_FIELDS_VOLATILE, int, tree )
+fn_1( C_TYPE_BEING_DEFINED, int, tree )
+fn_1( C_IS_RESERVED_WORD, int, tree )
+fn_1( C_TYPE_VARIABLE_SIZE, int, tree )
+fn_1( C_DECL_VARIABLE_SIZE, int, tree )
+fn_2( C_SET_EXP_ORIGINAL_CODE, int, tree, tree )
+fn_1( C_TYPEDEF_EXPLICITLY_SIGNED, int, tree )
+fn_1( C_DECL_ANTICIPATED, int, tree )
+fn_1( TYPE_ACTUAL_ARG_TYPES, tree, tree )
+
+#endif /* ENABLE_IDEBUG */
diff --git a/gcc/c-lang.c b/gcc/c-lang.c
index ec3bde3f1fb..934511b97d3 100644
--- a/gcc/c-lang.c
+++ b/gcc/c-lang.c
@@ -46,6 +46,10 @@ enum c_language_kind c_language = clk_c;
#define LANG_HOOKS_INIT c_objc_common_init
#undef LANG_HOOKS_FINISH
#define LANG_HOOKS_FINISH c_common_finish
+/* APPLE LOCAL begin Objective-C++ */
+#undef LANG_HOOKS_FINISH_FILE
+#define LANG_HOOKS_FINISH_FILE c_objc_common_finish_file
+/* APPLE LOCAL end Objective-C++ */
#undef LANG_HOOKS_INIT_OPTIONS
#define LANG_HOOKS_INIT_OPTIONS c_common_init_options
#undef LANG_HOOKS_INITIALIZE_DIAGNOSTICS
@@ -143,6 +147,24 @@ enum c_language_kind c_language = clk_c;
#undef LANG_HOOKS_REGISTER_BUILTIN_TYPE
#define LANG_HOOKS_REGISTER_BUILTIN_TYPE c_register_builtin_type
+/* APPLE LOCAL begin new tree dump */
+#if 0
+/* MERGE FIXME 3468690 */
+#undef LANG_HOOKS_DUMP_DECL
+#define LANG_HOOKS_DUMP_DECL c_dump_decl
+#undef LANG_HOOKS_DUMP_TYPE
+#define LANG_HOOKS_DUMP_TYPE c_dump_type
+#undef LANG_HOOKS_DUMP_IDENTIFIER
+#define LANG_HOOKS_DUMP_IDENTIFIER c_dump_identifier
+#undef LANG_HOOKS_DUMP_BLANK_LINE_P
+#define LANG_HOOKS_DUMP_BLANK_LINE_P c_dump_blank_line_p
+#undef LANG_HOOKS_DUMP_LINENO_P
+#define LANG_HOOKS_DUMP_LINENO_P c_dump_lineno_p
+#undef LANG_HOOKS_DMP_TREE3
+#define LANG_HOOKS_DMP_TREE3 c_dmp_tree3
+#endif
+/* APPLE LOCAL end new tree dump */
+
#undef LANG_HOOKS_WRITE_GLOBALS
#define LANG_HOOKS_WRITE_GLOBALS c_write_global_declarations
diff --git a/gcc/c-lex.c b/gcc/c-lex.c
index 3986b2771bb..db2533d961e 100644
--- a/gcc/c-lex.c
+++ b/gcc/c-lex.c
@@ -41,6 +41,10 @@ Software Foundation, 59 Temple Place - Suite 330, Boston, MA
#include "tm_p.h"
#include "splay-tree.h"
#include "debug.h"
+/* APPLE LOCAL begin AltiVec */
+#include "target.h"
+#include "cpphash.h"
+/* APPLE LOCAL end AltiVec */
/* We may keep statistics about how long which files took to compile. */
static int header_time, body_time;
@@ -106,6 +110,24 @@ init_c_lex (void)
cb->define = cb_define;
cb->undef = cb_undef;
}
+
+ /* APPLE LOCAL begin Symbol Separation */
+ /* Set up call back routines. These routines are used when separate symbol
+ repositories are used. */
+ if (write_symbols != NO_DEBUG)
+ {
+ cb->restore_write_symbols = cb_restore_write_symbols;
+ cb->clear_write_symbols = cb_clear_write_symbols;
+ cb->is_builtin_identifier = cb_is_builtin_identifier;
+ cb->start_symbol_repository = cb_start_symbol_repository;
+ cb->end_symbol_repository = cb_end_symbol_repository;
+ if (flag_grepository)
+ {
+ cpp_options *options = cpp_get_options (parse_in);
+ options->use_ss = 1;
+ }
+ }
+ /* APPLE LOCAL end Symbol Separation */
}
struct c_fileinfo *
@@ -298,19 +320,72 @@ cb_undef (cpp_reader *pfile ATTRIBUTE_UNUSED, source_location loc,
(const char *) NODE_NAME (node));
}
+/* APPLE LOCAL begin AltiVec */
+/* We need a small circular buffer for lookaheads (and lookbacks). */
+
+#define C_LEX_BUFCAPACITY 16
+#define C_LEX_OFFS_BOUND(OFFS) \
+ ((OFFS) >= 0 \
+ ? (OFFS) % C_LEX_BUFCAPACITY \
+ : (OFFS) + C_LEX_BUFCAPACITY)
+
+static int c_lex_buf_beg = 0, c_lex_buf_end = 0;
+static const cpp_token *c_lex_buf[C_LEX_BUFCAPACITY];
+
static inline const cpp_token *
-get_nonpadding_token (void)
+get_nonpadding_token (int from_buffer)
{
const cpp_token *tok;
+
timevar_push (TV_CPP);
- do
- tok = cpp_get_token (parse_in);
- while (tok->type == CPP_PADDING);
+ if (from_buffer && c_lex_buf_beg != c_lex_buf_end)
+ {
+ tok = c_lex_buf[c_lex_buf_beg++];
+ c_lex_buf_beg = C_LEX_OFFS_BOUND (c_lex_buf_beg);
+ }
+ else
+ {
+ do
+ tok = cpp_get_token (parse_in);
+ while (tok->type == CPP_PADDING);
+ c_lex_buf[c_lex_buf_end++] = tok;
+ c_lex_buf_end = C_LEX_OFFS_BOUND (c_lex_buf_end);
+ if (from_buffer)
+ c_lex_buf_beg = c_lex_buf_end;
+ }
timevar_pop (TV_CPP);
+ return tok;
+}
+
+const cpp_token *
+c_lex_peek (int offset)
+{
+ const cpp_token *tok;
+
+ if (offset >= 0)
+ {
+ while (C_LEX_OFFS_BOUND (c_lex_buf_end - c_lex_buf_beg) < offset + 1)
+ get_nonpadding_token (0);
+ tok = c_lex_buf[C_LEX_OFFS_BOUND (c_lex_buf_beg + offset)];
+ }
+ else
+ tok = c_lex_buf[C_LEX_OFFS_BOUND (c_lex_buf_end + offset)];
return tok;
}
+void
+c_lex_prepend (const cpp_token *tok_array, int size)
+{
+ while (size--)
+ {
+ --c_lex_buf_beg;
+ c_lex_buf_beg = C_LEX_OFFS_BOUND (c_lex_buf_beg);
+ c_lex_buf[c_lex_buf_beg] = &tok_array[size];
+ }
+}
+/* APPLE LOCAL end AltiVec */
+
int
c_lex_with_flags (tree *value, unsigned char *cpp_flags)
{
@@ -319,12 +394,24 @@ c_lex_with_flags (tree *value, unsigned char *cpp_flags)
static bool no_more_pch;
retry:
- tok = get_nonpadding_token ();
+ tok = get_nonpadding_token (1);
retry_after_at:
switch (tok->type)
{
case CPP_NAME:
+ /* APPLE LOCAL begin AltiVec */
+ /* Conditional macros are expanded whenever a call-back predicate
+ says they should be. */
+ if ((tok->val.node->flags & NODE_DISABLED)
+ && (*targetm.expand_macro_p) (tok))
+ {
+ c_lex_prepend (tok->val.node->value.macro->exp.tokens,
+ tok->val.node->value.macro->count);
+ goto retry;
+ }
+ /* APPLE LOCAL end AltiVec */
+
*value = HT_IDENT_TO_GCC_IDENT (HT_NODE (tok->val.node));
break;
@@ -356,7 +443,8 @@ c_lex_with_flags (tree *value, unsigned char *cpp_flags)
case CPP_ATSIGN:
/* An @ may give the next token special significance in Objective-C. */
atloc = input_location;
- tok = get_nonpadding_token ();
+ /* APPLE LOCAL AltiVec */
+ tok = get_nonpadding_token (1);
if (c_dialect_objc ())
{
tree val;
@@ -659,11 +747,13 @@ lex_string (const cpp_token *tok, tree *valp, bool objc_string)
if (tok->type == CPP_WSTRING)
wide = true;
- tok = get_nonpadding_token ();
+ /* APPLE LOCAL AltiVec */
+ tok = get_nonpadding_token (1);
if (c_dialect_objc () && tok->type == CPP_ATSIGN)
{
objc_string = true;
- tok = get_nonpadding_token ();
+ /* APPLE LOCAL AltiVec */
+ tok = get_nonpadding_token (1);
}
if (tok->type == CPP_STRING || tok->type == CPP_WSTRING)
{
@@ -677,11 +767,13 @@ lex_string (const cpp_token *tok, tree *valp, bool objc_string)
wide = true;
obstack_grow (&str_ob, &tok->val.str, sizeof (cpp_string));
- tok = get_nonpadding_token ();
+ /* APPLE LOCAL ALtiVec */
+ tok = get_nonpadding_token (1);
if (c_dialect_objc () && tok->type == CPP_ATSIGN)
{
objc_string = true;
- tok = get_nonpadding_token ();
+ /* APPLE LOCAL AltiVec */
+ tok = get_nonpadding_token (1);
}
}
while (tok->type == CPP_STRING || tok->type == CPP_WSTRING);
@@ -755,3 +847,17 @@ lex_charconst (const cpp_token *token)
TREE_TYPE (value) = type;
return value;
}
+
+/* APPLE LOCAL begin Symbol Separation */
+
+/* Write context information in .cinfo file.
+ Use PCH routines directly. But set and restore cinfo_state before using them. */
+void
+c_common_write_context (void)
+{
+ /* MERGE FIXME: This used to say 'lineno', not '0', but now we don't
+ have a 'lineno' variable (and it was probably always wrong). */
+ (*debug_hooks->end_symbol_repository) (0);
+ cpp_write_symbol_deps (parse_in);
+}
+/* APPLE LOCAL end Symbol Separation */
diff --git a/gcc/c-objc-common.c b/gcc/c-objc-common.c
index c2c1eeefdf5..562a60cdbfe 100644
--- a/gcc/c-objc-common.c
+++ b/gcc/c-objc-common.c
@@ -62,8 +62,9 @@ c_disregard_inline_limits (tree fn)
if (lookup_attribute ("always_inline", DECL_ATTRIBUTES (fn)) != NULL)
return 1;
+ /* APPLE LOCAL obey inline */
return (!flag_really_no_inline && DECL_DECLARED_INLINE_P (fn)
- && DECL_EXTERNAL (fn));
+ && (DECL_EXTERNAL (fn) || flag_obey_inline));
}
int
@@ -182,6 +183,13 @@ c_objc_common_init (void)
mesg_implicit_function_declaration = 0;
}
+/* APPLE LOCAL gdb only used symbols */
+#ifdef DBX_ONLY_USED_SYMBOLS
+ /* By default we want to use -gused for C and Objective-C. */
+ if (flag_debug_only_used_symbols == -1)
+ flag_debug_only_used_symbols = 1;
+#endif
+
return true;
}
@@ -232,6 +240,11 @@ finish_cdtor (tree body)
void
c_objc_common_finish_file (void)
{
+ /* APPLE LOCAL Symbol Separation */
+ /* Write context information. */
+ if (dbg_dir)
+ c_common_write_context ();
+
if (pch_file)
c_common_write_pch ();
diff --git a/gcc/c-opts.c b/gcc/c-opts.c
index 4c0c1fc4423..09859a437c6 100644
--- a/gcc/c-opts.c
+++ b/gcc/c-opts.c
@@ -58,6 +58,10 @@ static cpp_options *cpp_opts;
/* Input filename. */
static const char *this_input_filename;
+/* APPLE LOCAL begin read-from-stdin */
+static const char *stdin_filename;
+/* APPLE LOCAL end read-from-stdin */
+
/* Filename and stream for preprocessed output. */
static const char *out_fname;
static FILE *out_stream;
@@ -83,6 +87,10 @@ static const char *sysroot = TARGET_SYSTEM_ROOT;
/* Zero disables all standard directories for headers. */
static bool std_inc = true;
+/* APPLE LOCAL begin Symbol Separation */
+const char *dbg_dir;
+/* APPLE LOCAL end Symbol Separation */
+
/* Zero disables the C++-specific standard directories for headers. */
static bool std_cxx_inc = true;
@@ -222,6 +230,13 @@ c_common_init_options (unsigned int argc, const char **argv ATTRIBUTE_UNUSED)
before passing on command-line options to cpplib. */
cpp_opts->warn_dollars = 0;
+#ifdef WARN_FOUR_CHAR_CONSTANTS
+ /* APPLE LOCAL begin -Wfour-char-constants */
+ /* Warn about 4-char constants everywhere except on Macs. */
+ cpp_opts->warn_four_char_constants = WARN_FOUR_CHAR_CONSTANTS;
+ /* APPLE LOCAL end -Wfour-char-constants */
+#endif
+
flag_const_strings = c_dialect_cxx ();
flag_exceptions = c_dialect_cxx ();
warn_pointer_arith = c_dialect_cxx ();
@@ -262,9 +277,18 @@ c_common_handle_option (size_t scode, const char *arg, int value)
break;
case OPT__output_pch_:
+ /* APPLE LOCAL Symbol Separation */
+ cpp_opts->making_pch = value;
pch_file = arg;
break;
+ /* APPLE LOCAL begin Symbol Separation */
+ case OPT_fsave_repository_:
+ dbg_dir = arg;
+ cpp_opts->making_ss = value;
+ break;
+ /* APPLE LOCAL end Symbol Separation */
+
case OPT_A:
defer_opt (code, arg);
break;
@@ -348,6 +372,12 @@ c_common_handle_option (size_t scode, const char *arg, int value)
flag_no_line_commands = 1;
break;
+ /* APPLE LOCAL begin -Wno-#warnings */
+ case OPT_W_warnings:
+ cpp_opts->no_pound_warnings = !value;
+ break;
+ /* APPLE LOCAL end -Wno-#warnings */
+
case OPT_fworking_directory:
flag_working_directory = value;
break;
@@ -361,12 +391,17 @@ c_common_handle_option (size_t scode, const char *arg, int value)
break;
case OPT_Wall:
+ /* APPLE LOCAL -Wmost */
+ case OPT_Wmost:
set_Wunused (value);
set_Wformat (value);
set_Wimplicit (value);
warn_char_subscripts = value;
warn_missing_braces = value;
- warn_parentheses = value;
+ /* APPLE LOCAL begin -Wmost dpatel */
+ if (code != OPT_Wmost)
+ warn_parentheses = value;
+ /* APPLE LOCAL end -Wmost dpatel */
warn_return_type = value;
warn_sequence_point = value; /* Was C only. */
if (c_dialect_cxx ())
@@ -449,8 +484,22 @@ c_common_handle_option (size_t scode, const char *arg, int value)
break;
case OPT_Werror:
- cpp_opts->warnings_are_errors = value;
+ /* APPLE LOCAL begin -Werror 2002-21-01 dpatel */
+ if (getenv ("QA_DISABLE_WERROR"))
+ {
+ warning ("-Werror ignored because QA_DISABLE_WERROR is set.");
+ warning ("Warnings will not be treated as errors.");
+ }
+ else
+ cpp_opts->warnings_are_errors = value;
+ /* APPLE LOCAL end -Werror 2002-21-01 dpatel */
+ break;
+
+ /* APPLE LOCAL begin -Wextra-tokens */
+ case OPT_Wextra_tokens:
+ cpp_opts->warn_extra_tokens = value;
break;
+ /* APPLE LOCAL end -Wextra-tokens */
case OPT_Werror_implicit_function_declaration:
mesg_implicit_function_declaration = 2;
@@ -488,6 +537,18 @@ c_common_handle_option (size_t scode, const char *arg, int value)
warn_format_zero_length = value;
break;
+ /* APPLE LOCAL begin -Wfour-char-constants */
+ case OPT_Wfour_char_constants:
+ cpp_opts->warn_four_char_constants = value;
+ break;
+ /* APPLE LOCAL end -Wfour-char-constants */
+
+ /* APPLE LOCAL begin constant cfstrings */
+ case OPT_Wnonportable_cfstrings:
+ warn_nonportable_cfstrings = value;
+ break;
+ /* APPLE LOCAL end constant cfstrings */
+
case OPT_Winit_self:
warn_init_self = value;
break;
@@ -508,6 +569,18 @@ c_common_handle_option (size_t scode, const char *arg, int value)
/* Silently ignore for now. */
break;
+ /* APPLE LOCAL begin -Wlong-double */
+ case OPT_Wlong_double:
+ warn_long_double = value;
+ break;
+ /* APPLE LOCAL end -Wlong-double */
+
+ /* APPLE LOCAL begin Symbol Separation */
+ case OPT_Winvalid_sr:
+ cpp_opts->warn_invalid_sr = value;
+ break;
+ /* APPLE LOCAL end Symbol Separation */
+
case OPT_Winvalid_offsetof:
warn_invalid_offsetof = value;
break;
@@ -551,6 +624,12 @@ c_common_handle_option (size_t scode, const char *arg, int value)
warn_nested_externs = value;
break;
+ /* APPLE LOCAL begin -Wnewline-eof */
+ case OPT_Wnewline_eof:
+ cpp_opts->warn_newline_at_eof = value;
+ break;
+ /* APPLE LOCAL end -Wnewline-eof */
+
case OPT_Wnon_template_friend:
warn_nontemplate_friend = value;
break;
@@ -676,6 +755,11 @@ c_common_handle_option (size_t scode, const char *arg, int value)
set_std_cxx98 (true);
break;
+ /* APPLE LOCAL begin fat builds */
+ case OPT_arch:
+ break;
+ /* APPLE LOCAL end fat builds */
+
case OPT_d:
handle_OPT_d (arg);
break;
@@ -712,6 +796,14 @@ c_common_handle_option (size_t scode, const char *arg, int value)
flag_access_control = value;
break;
+ /* APPLE LOCAL begin -fapple-kext */
+ case OPT_fapple_kext:
+ flag_apple_kext = value;
+ flag_indirect_virtual_calls = 1;
+ flag_terminated_vtables = 1;
+ break;
+ /* APPLE LOCAL end -fapple-kext */
+
case OPT_fasm:
flag_no_asm = !value;
break;
@@ -727,6 +819,13 @@ c_common_handle_option (size_t scode, const char *arg, int value)
disable_builtin_function (arg);
break;
+ /* BEGIN APPLE LOCAL disable_typechecking_for_spec_flag */
+ case OPT_fdisable_typechecking_for_spec:
+ disable_typechecking_for_spec_flag = value;
+ break;
+ /* END APPLE LOCAL disable_typechecking_for_spec_flag */
+
+
case OPT_fdollars_in_identifiers:
cpp_opts->dollars_in_ident = value;
break;
@@ -772,6 +871,12 @@ c_common_handle_option (size_t scode, const char *arg, int value)
flag_signed_char = !value;
break;
+ /* APPLE LOCAL begin structor decloning */
+ case OPT_fclone_structors:
+ flag_clone_structors = value;
+ break;
+ /* APPLE LOCAL end structor decloning */
+
case OPT_fcheck_new:
flag_check_new = value;
break;
@@ -784,6 +889,12 @@ c_common_handle_option (size_t scode, const char *arg, int value)
flag_const_strings = value;
break;
+ /* APPLE LOCAL begin constant cfstrings */
+ case OPT_fconstant_cfstrings:
+ flag_constant_cfstrings = value;
+ break;
+ /* APPLE LOCAL end constant cfstrings */
+
case OPT_fconstant_string_class_:
constant_string_class_name = arg;
break;
@@ -836,6 +947,12 @@ c_common_handle_option (size_t scode, const char *arg, int value)
flag_implicit_templates = value;
break;
+ /* APPLE LOCAL begin -findirect-virtual-calls */
+ case OPT_findirect_virtual_calls:
+ flag_indirect_virtual_calls = value;
+ break;
+ /* APPLE LOCAL end -findirect-virtual-calls */
+
case OPT_fms_extensions:
flag_ms_extensions = value;
break;
@@ -868,12 +985,21 @@ c_common_handle_option (size_t scode, const char *arg, int value)
cpp_opts->restore_pch_deps = value;
break;
+ /* APPLE LOCAL BEGIN pch distcc mrs */
+ case OPT_fpch_preprocess:
+ flag_pch_preprocess = value;
+ cpp_opts->pch_preprocess = value;
+ break;
+ /* APPLE LOCAL END pch distcc mrs */
+
case OPT_fpermissive:
flag_permissive = value;
break;
case OPT_fpreprocessed:
cpp_opts->preprocessed = value;
+ /* APPLE LOCAL private extern Radar 2872481 ilr */
+ flag_preprocessed = value;
break;
case OPT_freplace_objc_classes:
@@ -908,6 +1034,12 @@ c_common_handle_option (size_t scode, const char *arg, int value)
cpp_opts->narrow_charset = arg;
break;
+ /* APPLE LOCAL begin -fterminated-vtables */
+ case OPT_fterminated_vtables:
+ flag_terminated_vtables = value;
+ break;
+ /* APPLE LOCAL end -fterminated-vtables */
+
case OPT_fwide_exec_charset_:
cpp_opts->wide_charset = arg;
break;
@@ -936,6 +1068,18 @@ c_common_handle_option (size_t scode, const char *arg, int value)
flag_gen_declaration = 1;
break;
+ /* APPLE LOCAL begin -header-mapfile */
+ case OPT_header_mapfile:
+ if (cpp_opts->header_map != NULL)
+ error ("more than one `-header-mapfile' option specified; "
+ "only one is allowed");
+#if 0
+ else
+ cpp_opts->header_map = hmap_load_header_map (arg);
+#endif
+ break;
+ /* APPLE LOCAL end -header-mapfile */
+
case OPT_idirafter:
add_path (xstrdup (arg), AFTER, 0);
break;
@@ -1000,6 +1144,11 @@ c_common_handle_option (size_t scode, const char *arg, int value)
cpp_opts->warn_endif_labels = 1;
break;
+ /* APPLE LOCAL begin -precomp-trustfile */
+ case OPT_precomp_trustfile:
+ break;
+ /* APPLE LOCAL end -precomp-trustfile */
+
case OPT_print_objc_runtime_info:
print_struct_values = 1;
break;
@@ -1054,6 +1203,13 @@ c_common_handle_option (size_t scode, const char *arg, int value)
case OPT_v:
verbose = true;
break;
+
+ /* APPLE LOCAL begin -fast, -fastf, -fastcp option */
+ case OPT_fast:
+ case OPT_fastcp:
+ case OPT_fastf:
+ break;
+ /* APPLE LOCAL end -fast, -fastf, -fastcp option */
}
return result;
@@ -1070,6 +1226,10 @@ c_common_post_options (const char **pfilename)
{
in_fnames = xmalloc (sizeof (in_fnames[0]));
in_fnames[0] = "";
+ /* APPLE LOCAL begin read-from-stdin */
+ if (stdin_filename != NULL)
+ set_stdin_option(parse_in, stdin_filename);
+ /* APPLE LOCAL end read-from-stdin */
}
else if (strcmp (in_fnames[0], "-") == 0)
in_fnames[0] = "";
@@ -1193,6 +1353,18 @@ c_common_init (void)
if (flag_preprocess_only)
{
+ /* APPLE LOCAL BEGIN pch distcc mrs */
+ if (flag_pch_preprocess)
+ {
+ struct cpp_callbacks *cb;
+ cb = cpp_get_callbacks (parse_in);
+
+ /* In this case, we want the pch file to be read in. */
+ cb->valid_pch = c_common_valid_pch;
+ cb->read_pch = c_common_read_pch;
+ }
+ /* APPLE LOCAL END pch distcc mrs */
+
finish_options ();
preprocess_file (parse_in);
return false;
@@ -1235,13 +1407,29 @@ c_common_parse_file (int set_yydebug ATTRIBUTE_UNUSED)
}
finish_options ();
if (file_index == 0)
- pch_init();
+ /* APPLE LOCAL begin Symbol Separation */
+ {
+ pch_init();
+
+ /* Initialize Symbol Sepration. Create .cinfo file and save
+ current cpp state. */
+ dbg_dir = cpp_symbol_separation_init (parse_in, dbg_dir,
+ input_filename);
+ if (dbg_dir)
+ (*debug_hooks->start_symbol_repository)
+ /* MERGE FIXME: This used to have 'lineno' rather than '0',
+ but that variable no longer exists and was almost certainly
+ wrong to use in the first place. */
+ (0, input_filename, cpp_get_stabs_checksum ());
+ }
+ /* APPLE LOCAL end Symbol Separation */
c_parse_file ();
file_index++;
} while (file_index < num_in_fnames);
- finish_file ();
+ /* APPLE LOCAL Objective-C++ */
+ (*lang_hooks.finish_file) ();
}
/* Common finish hook for the C, ObjC and C++ front ends. */
@@ -1514,7 +1702,11 @@ cb_dir_change (cpp_reader *pfile ATTRIBUTE_UNUSED, const char *dir)
static void
set_std_c89 (int c94, int iso)
{
- cpp_set_lang (parse_in, c94 ? CLK_STDC94: iso ? CLK_STDC89: CLK_GNUC89);
+ /* APPLE LOCAL begin 3191171 */
+ /* Do not override CLK_ASM if set */
+ if (cpp_opts->lang != CLK_ASM)
+ /* APPLE LOCAL end 3191171 */
+ cpp_set_lang (parse_in, c94 ? CLK_STDC94: iso ? CLK_STDC89: CLK_GNUC89);
flag_iso = iso;
flag_no_asm = iso;
flag_no_gnu_keywords = iso;
diff --git a/gcc/c-parse.in b/gcc/c-parse.in
index b8637e6b1d3..d6a44c75ded 100644
--- a/gcc/c-parse.in
+++ b/gcc/c-parse.in
@@ -50,6 +50,8 @@ Software Foundation, 59 Temple Place - Suite 330, Boston, MA
#include "output.h"
#include "toplev.h"
#include "ggc.h"
+/* APPLE LOCAL Objective-C++ */
+#include "langhooks.h"
@@ifobjc
#include "objc-act.h"
@@ -3339,6 +3341,8 @@ static const struct resword reswords[] =
{ "__inline", RID_INLINE, 0 },
{ "__inline__", RID_INLINE, 0 },
{ "__label__", RID_LABEL, 0 },
+ /* APPLE LOCAL private extern */
+ { "__private_extern__", RID_PRIVATE_EXTERN, 0 },
{ "__ptrbase", RID_PTRBASE, 0 },
{ "__ptrbase__", RID_PTRBASE, 0 },
{ "__ptrextent", RID_PTREXTENT, 0 },
@@ -3426,9 +3430,11 @@ static const struct resword reswords[] =
};
#define N_reswords (sizeof reswords / sizeof (struct resword))
+/* APPLE LOCAL keep tables in sync comment */
/* Table mapping from RID_* constants to yacc token numbers.
Unfortunately we have to have entries for all the keywords in all
- three languages. */
+ three languages (AND THEY MUST BE KEPT IN PARALLEL - see also
+ cp/lex.c). */
static const short rid_to_yy[RID_MAX] =
{
/* RID_STATIC */ STATIC,
@@ -3448,6 +3454,8 @@ static const short rid_to_yy[RID_MAX] =
/* C extensions */
/* RID_COMPLEX */ TYPESPEC,
/* RID_THREAD */ SCSPEC,
+ /* APPLE LOCAL private extern */
+ /* RID_PRIVATE_EXTERN */ SCSPEC,
/* C++ */
/* RID_FRIEND */ 0,
@@ -3569,7 +3577,7 @@ init_reswords (void)
if (!c_dialect_objc ())
mask |= D_OBJC;
-
+
ridpointers = ggc_calloc ((int) RID_MAX, sizeof (tree));
for (i = 0; i < N_reswords; i++)
{
diff --git a/gcc/c-pch.c b/gcc/c-pch.c
index 157061f9177..c586f49674a 100644
--- a/gcc/c-pch.c
+++ b/gcc/c-pch.c
@@ -35,6 +35,11 @@ Boston, MA 02111-1307, USA. */
#include "hosthooks.h"
#include "target.h"
+/* APPLE LOCAL BEGIN pch distcc mrs */
+#include "flags.h"
+#include "cpphash.h"
+/* APPLE LOCAL END pch distcc mrs */
+
/* This structure is read very early when validating the PCH, and
might be read for a PCH which is for a completely different compiler
for a different operating system. Thus, it should really only contain
@@ -355,6 +360,25 @@ c_common_read_pch (cpp_reader *pfile, const char *name,
unsigned long written;
struct save_macro_data *smd;
+ /* APPLE LOCAL BEGIN pch distcc mrs */
+#if 0
+ /* MERGE FIXME: There is no 'print', and no 'outf'. */
+ if (flag_pch_preprocess
+ && flag_preprocess_only)
+ {
+ fprintf (pfile->print.outf, "#include_pch \"%s\"\n", name);
+ pfile->print.line++;
+ pfile->print.printed = 0;
+ }
+
+ if (! flag_preprocess_only)
+ /* Before we wrote the file, we started a source file, so we have to start
+ one here to match. */
+ /* MERGE FIXME: And there's no 'lineno'. */
+ (*debug_hooks->start_source_file) (lineno, orig_name);
+ /* APPLE LOCAL END pch distcc mrs */
+#endif
+
f = fdopen (fd, "rb");
if (f == NULL)
{
@@ -376,9 +400,13 @@ c_common_read_pch (cpp_reader *pfile, const char *name,
long size = h.asm_size - written;
if (size > 16384)
size = 16384;
- if (fread (buf, size, 1, f) != 1
- || fwrite (buf, size, 1, asm_out_file) != 1)
- cpp_errno (pfile, CPP_DL_ERROR, "reading");
+ /* APPLE LOCAL BEGIN pch distcc mrs */
+ if (fread (buf, size, 1, f) != 1)
+ cpp_errno (pfile, CPP_DL_ERROR, "reading");
+ else if (!flag_preprocess_only
+ && fwrite (buf, size, 1, asm_out_file) != 1)
+ cpp_errno (pfile, CPP_DL_ERROR, "writing");
+ /* APPLE LOCAL END pch distcc mrs */
written += size;
}
free (buf);
diff --git a/gcc/c-pragma.c b/gcc/c-pragma.c
index aa85deea6f3..46956395077 100644
--- a/gcc/c-pragma.c
+++ b/gcc/c-pragma.c
@@ -48,6 +48,9 @@ typedef struct align_stack GTY(())
static GTY(()) struct align_stack * alignment_stack;
+/* APPLE LOCAL Macintosh alignment */
+/* Cut out all of this so the compiler doesn't complain. */
+#if 0
#ifdef HANDLE_PRAGMA_PACK
static void handle_pragma_pack (cpp_reader *);
@@ -253,6 +256,8 @@ handle_pragma_pack (cpp_reader *dummy ATTRIBUTE_UNUSED)
}
}
#endif /* HANDLE_PRAGMA_PACK */
+/* APPLE LOCAL Macintosh alignment */
+#endif /* 0 */
static GTY(()) tree pending_weaks;
@@ -491,9 +496,16 @@ c_register_pragma (const char *space, const char *name,
void
init_pragma (void)
{
+/* APPLE LOCAL begin Macintosh alignment 2002-1-22 ff */
+#if 0
+/* We disable the handling of pragma pack here because it is handled
+ in config/darwin-c.c. */
+/* APPLE LOCAL end Macintosh alignment 2002-1-22 ff */
#ifdef HANDLE_PRAGMA_PACK
c_register_pragma (0, "pack", handle_pragma_pack);
#endif
+/* APPLE LOCAL Macintosh alignment 2002-1-22 ff */
+#endif /* 0 */
#ifdef HANDLE_PRAGMA_WEAK
c_register_pragma (0, "weak", handle_pragma_weak);
#endif
@@ -507,6 +519,12 @@ init_pragma (void)
c_register_pragma (0, "extern_prefix", handle_pragma_extern_prefix);
#endif
+ /* APPLE LOCAL begin OS pragma hook */
+ /* Allow registration of OS-specific but arch-independent pragmas. */
+#ifdef REGISTER_OS_PRAGMAS
+ REGISTER_OS_PRAGMAS (parse_in);
+#endif
+ /* APPLE LOCAL end OS pragma hook */
#ifdef REGISTER_TARGET_PRAGMAS
REGISTER_TARGET_PRAGMAS ();
#endif
diff --git a/gcc/c-pragma.h b/gcc/c-pragma.h
index 397b02d6840..7f1265f2725 100644
--- a/gcc/c-pragma.h
+++ b/gcc/c-pragma.h
@@ -55,6 +55,10 @@ extern tree maybe_apply_renaming_pragma (tree, tree);
extern void add_to_renaming_pragma_list (tree, tree);
extern int c_lex (tree *);
+/* APPLE LOCAL begin AltiVec */
+extern const struct cpp_token *c_lex_peek (int);
+extern void c_lex_prepend (const struct cpp_token *, int);
+/* APPLE LOCAL end AltiVec */
extern int c_lex_with_flags (tree *, unsigned char *);
/* If true, then lex strings into the execution character set.
diff --git a/gcc/c-tree.h b/gcc/c-tree.h
index 5eda48e7513..c67620eb2b8 100644
--- a/gcc/c-tree.h
+++ b/gcc/c-tree.h
@@ -40,6 +40,9 @@ struct lang_identifier GTY(())
tree symbol_value;
tree tag_value;
tree label_value;
+ /* APPLE LOCAL objc speedup dpatel */
+ /* For Objective-C Only */
+ tree interface_value;
};
/* The resulting tree type. */
@@ -246,6 +249,8 @@ extern void merge_translation_unit_decls (void);
extern int c_disregard_inline_limits (tree);
extern int c_cannot_inline_tree_fn (tree *);
extern bool c_objc_common_init (void);
+/* APPLE LOCAL Objective-C++ */
+extern void finish_file (void);
extern bool c_missing_noreturn_ok_p (tree);
extern tree c_objc_common_truthvalue_conversion (tree expr);
extern void c_objc_common_finish_file (void);
@@ -259,6 +264,16 @@ extern bool c_warn_unused_global_decl (tree);
#define c_sizeof_nowarn(T) c_sizeof_or_alignof_type (T, SIZEOF_EXPR, 0)
+/* APPLE LOCAL begin new tree dump */
+/* in c-dmp-tree.c */
+extern void c_dump_identifier PARAMS ((FILE *, tree, int, int));
+extern void c_dump_decl PARAMS ((FILE *, tree, int, int));
+extern void c_dump_type PARAMS ((FILE *, tree, int, int));
+extern int c_dump_blank_line_p PARAMS ((tree, tree));
+extern int c_dump_lineno_p PARAMS ((FILE *, tree));
+extern int c_dmp_tree3 PARAMS ((FILE *, tree, int));
+/* APPLE LOCAL end new tree dump */
+
/* in c-typeck.c */
/* For use with comptypes. */
@@ -266,6 +281,10 @@ enum {
COMPARE_STRICT = 0
};
+/* APPLE LOCAL begin IMA aggregate types */
+extern int same_translation_unit_p (tree, tree);
+extern int tagged_types_tu_compatible_p (tree, tree, int);
+/* APPLE LOCAL end IMA aggregate types */
extern tree require_complete_type (tree);
extern int comptypes (tree, tree, int);
extern tree c_size_in_bytes (tree);
diff --git a/gcc/c-typeck.c b/gcc/c-typeck.c
index 7dd495b7e59..273f699affb 100644
--- a/gcc/c-typeck.c
+++ b/gcc/c-typeck.c
@@ -51,8 +51,6 @@ Software Foundation, 59 Temple Place - Suite 330, Boston, MA
static int missing_braces_mentioned;
static tree qualify_type (tree, tree);
-static int same_translation_unit_p (tree, tree);
-static int tagged_types_tu_compatible_p (tree, tree, int);
static int comp_target_types (tree, tree, int);
static int function_types_compatible_p (tree, tree, int);
static int type_lists_compatible_p (tree, tree, int);
@@ -576,9 +574,14 @@ comptypes (tree type1, tree type2, int flags)
break;
case VECTOR_TYPE:
- /* The target might allow certain vector types to be compatible. */
- val = (*targetm.vector_opaque_p) (t1)
- || (*targetm.vector_opaque_p) (t2);
+ /* This is a comparison of types. If both of them are opaque,
+ the types are identical as long as their size is equal; else
+ check if the underlying types are identical as well. */
+ val = TYPE_VECTOR_SUBPARTS (t1) == TYPE_VECTOR_SUBPARTS (t2)
+ && (targetm.vector_opaque_p (t1)
+ ? targetm.vector_opaque_p (t2)
+ : !targetm.vector_opaque_p (t2)
+ && comptypes (TREE_TYPE (t1), TREE_TYPE (t2), 0));
break;
default:
@@ -617,7 +620,7 @@ comp_target_types (tree ttl, tree ttr, int reflexive)
If the CONTEXT chain ends in a null, that type's context is still
being parsed, so if two types have context chains ending in null,
they're in the same translation unit. */
-static int
+int
same_translation_unit_p (tree t1, tree t2)
{
while (t1 && TREE_CODE (t1) != TRANSLATION_UNIT_DECL)
@@ -632,7 +635,7 @@ same_translation_unit_p (tree t1, tree t2)
while (t2 && TREE_CODE (t2) != TRANSLATION_UNIT_DECL)
switch (TREE_CODE_CLASS (TREE_CODE (t2)))
{
- case 'd': t2 = DECL_CONTEXT (t1); break;
+ case 'd': t2 = DECL_CONTEXT (t2); break;
case 't': t2 = TYPE_CONTEXT (t2); break;
case 'b': t2 = BLOCK_SUPERCONTEXT (t2); break;
default: abort ();
@@ -650,6 +653,10 @@ struct tagged_tu_seen {
const struct tagged_tu_seen * next;
tree t1;
tree t2;
+/* APPLE LOCAL begin IMA speed up */
+ int isEnum;
+ int enumMatched;
+/* APPLE LOCAL end IMA speed up */
};
/* Can they be compatible with each other? We choose to break the
@@ -663,7 +670,7 @@ static const struct tagged_tu_seen * tagged_tu_seen_base;
units are being compiled. See C99 6.2.7 paragraph 1 for the exact
rules. */
-static int
+int
tagged_types_tu_compatible_p (tree t1, tree t2, int flags)
{
tree s1, s2;
@@ -698,45 +705,74 @@ tagged_types_tu_compatible_p (tree t1, tree t2, int flags)
const struct tagged_tu_seen * tts_i;
for (tts_i = tagged_tu_seen_base; tts_i != NULL; tts_i = tts_i->next)
if (tts_i->t1 == t1 && tts_i->t2 == t2)
- return 1;
+/* APPLE LOCAL begin IMA speed up */
+ return tts_i->isEnum ? tts_i->enumMatched : 1;
+/* APPLE LOCAL end IMA speed up */
}
switch (TREE_CODE (t1))
{
case ENUMERAL_TYPE:
{
-
- /* Speed up the case where the type values are in the same order. */
- tree tv1 = TYPE_VALUES (t1);
- tree tv2 = TYPE_VALUES (t2);
-
- if (tv1 == tv2)
- return 1;
-
+ struct tagged_tu_seen *tts;
+/* APPLE LOCAL begin IMA speed up */
+ int res;
+ bool done;
+ /* Speed up the case where the type values are in the same order. */
+ tree tv1 = TYPE_VALUES (t1);
+ tree tv2 = TYPE_VALUES (t2);
+
+ if (tv1 == tv2)
+ return 1;
+
+ res = 0;
+ done = false;
for (;tv1 && tv2; tv1 = TREE_CHAIN (tv1), tv2 = TREE_CHAIN (tv2))
{
if (TREE_PURPOSE (tv1) != TREE_PURPOSE (tv2))
break;
if (simple_cst_equal (TREE_VALUE (tv1), TREE_VALUE (tv2)) != 1)
- return 0;
+ {
+ res = 0;
+ done = true;
+ break;
+ }
}
-
- if (tv1 == NULL_TREE && tv2 == NULL_TREE)
- return 1;
- if (tv1 == NULL_TREE || tv2 == NULL_TREE)
- return 0;
-
- if (list_length (TYPE_VALUES (t1)) != list_length (TYPE_VALUES (t2)))
- return 0;
-
- for (s1 = TYPE_VALUES (t1); s1; s1 = TREE_CHAIN (s1))
+
+ if (!done)
+ {
+ if (tv1 == NULL_TREE && tv2 == NULL_TREE)
+ res = 1, done = true;
+ else if (tv1 == NULL_TREE || tv2 == NULL_TREE)
+ res = 0, done = true;
+ }
+
+ if (!done && list_length (TYPE_VALUES (t1)) == list_length (TYPE_VALUES (t2)))
+ {
+ res = 1;
+ for (s1 = TYPE_VALUES (t1); s1; s1 = TREE_CHAIN (s1))
{
s2 = purpose_member (TREE_PURPOSE (s1), TYPE_VALUES (t2));
if (s2 == NULL
|| simple_cst_equal (TREE_VALUE (s1), TREE_VALUE (s2)) != 1)
- return 0;
+ {
+ res = 0;
+ break;
+ }
}
- return 1;
+ }
+ if (tagged_tu_seen_base)
+ {
+ tts = xmalloc(sizeof (struct tagged_tu_seen));
+ tts->next = tagged_tu_seen_base;
+ tts->t1 = t1;
+ tts->t2 = t2;
+ tts->isEnum = 1;
+ tts->enumMatched = res;
+ tagged_tu_seen_base = tts;
+ }
+ return res;
+/* APPLE LOCAL end IMA speed up */
}
case UNION_TYPE:
@@ -748,10 +784,14 @@ tagged_types_tu_compatible_p (tree t1, tree t2, int flags)
{
bool ok = false;
struct tagged_tu_seen tts;
+ const struct tagged_tu_seen * tts_i;
tts.next = tagged_tu_seen_base;
tts.t1 = t1;
tts.t2 = t2;
+/* APPLE LOCAL begin IMA speed up */
+ tts.isEnum = 0;
+/* APPLE LOCAL end IMA speed up */
tagged_tu_seen_base = &tts;
if (DECL_NAME (s1) != NULL)
@@ -773,6 +813,15 @@ tagged_types_tu_compatible_p (tree t1, tree t2, int flags)
ok = true;
break;
}
+ tts_i = tagged_tu_seen_base;
+/* APPLE LOCAL begin IMA speed up */
+ while (tts_i->isEnum)
+ {
+ const struct tagged_tu_seen* p = tts_i->next;
+ free((struct tagged_tu_seen*)tts_i);
+ tts_i = p;
+ }
+/* APPLE LOCAL end IMA speed up */
tagged_tu_seen_base = tts.next;
if (! ok)
return 0;
@@ -783,12 +832,16 @@ tagged_types_tu_compatible_p (tree t1, tree t2, int flags)
case RECORD_TYPE:
{
struct tagged_tu_seen tts;
+ const struct tagged_tu_seen * tts_i;
tts.next = tagged_tu_seen_base;
tts.t1 = t1;
tts.t2 = t2;
+/* APPLE LOCAL begin IMA speed up */
+ tts.isEnum = 0;
+/* APPLE LOCAL end IMA speed up */
tagged_tu_seen_base = &tts;
-
+
for (s1 = TYPE_FIELDS (t1), s2 = TYPE_FIELDS (t2);
s1 && s2;
s1 = TREE_CHAIN (s1), s2 = TREE_CHAIN (s2))
@@ -798,6 +851,7 @@ tagged_types_tu_compatible_p (tree t1, tree t2, int flags)
|| DECL_NAME (s1) != DECL_NAME (s2))
break;
result = comptypes (TREE_TYPE (s1), TREE_TYPE (s2), flags);
+
if (result == 0)
break;
if (result == 2)
@@ -808,6 +862,16 @@ tagged_types_tu_compatible_p (tree t1, tree t2, int flags)
DECL_FIELD_BIT_OFFSET (s2)) != 1)
break;
}
+
+ tts_i = tagged_tu_seen_base;
+/* APPLE LOCAL begin IMA speed up */
+ while (tts_i->isEnum)
+ {
+ const struct tagged_tu_seen* p = tts_i->next;
+ free((struct tagged_tu_seen*)tts_i);
+ tts_i = p;
+ }
+/* APPLE LOCAL end IMA speed up */
tagged_tu_seen_base = tts.next;
if (s1 && s2)
return 0;
@@ -2832,24 +2896,29 @@ internal_build_compound_expr (tree list, int first_p)
rest = internal_build_compound_expr (TREE_CHAIN (list), FALSE);
- if (! TREE_SIDE_EFFECTS (TREE_VALUE (list)))
+ /* APPLE LOCAL begin AltiVec */
+ if (!targetm.cast_expr_as_vector_init)
{
- /* The left-hand operand of a comma expression is like an expression
- statement: with -Wextra or -Wunused, we should warn if it doesn't have
- any side-effects, unless it was explicitly cast to (void). */
- if (warn_unused_value
- && ! (TREE_CODE (TREE_VALUE (list)) == CONVERT_EXPR
- && VOID_TYPE_P (TREE_TYPE (TREE_VALUE (list)))))
- warning ("left-hand operand of comma expression has no effect");
- }
-
- /* With -Wunused, we should also warn if the left-hand operand does have
- side-effects, but computes a value which is not used. For example, in
- `foo() + bar(), baz()' the result of the `+' operator is not used,
- so we should issue a warning. */
- else if (warn_unused_value)
- warn_if_unused_value (TREE_VALUE (list));
+ if (! TREE_SIDE_EFFECTS (TREE_VALUE (list)))
+ {
+ /* The left-hand operand of a comma expression is like an expression
+ statement: with -Wextra or -Wunused, we should warn if it doesn't have
+ any side-effects, unless it was explicitly cast to (void). */
+ if (warn_unused_value
+ && ! (TREE_CODE (TREE_VALUE (list)) == CONVERT_EXPR
+ && VOID_TYPE_P (TREE_TYPE (TREE_VALUE (list)))))
+ warning ("left-hand operand of comma expression has no effect");
+ }
+ /* With -Wunused, we should also warn if the left-hand operand does have
+ side-effects, but computes a value which is not used. For example, in
+ `foo() + bar(), baz()' the result of the `+' operator is not used,
+ so we should issue a warning. */
+ else if (warn_unused_value)
+ warn_if_unused_value (TREE_VALUE (list));
+ }
+ /* APPLE LOCAL end AltiVec */
+
return build (COMPOUND_EXPR, TREE_TYPE (rest), TREE_VALUE (list), rest);
}
@@ -2863,6 +2932,13 @@ build_c_cast (tree type, tree expr)
if (type == error_mark_node || expr == error_mark_node)
return error_mark_node;
+ /* APPLE LOCAL begin AltiVec */
+ /* If we are casting to a vector type, treat the expression as a vector
+ initializer if this target supports it. */
+ if (TREE_CODE (type) == VECTOR_TYPE && targetm.cast_expr_as_vector_init)
+ return vector_constructor_from_expr (expr, type);
+ /* APPLE LOCAL end AltiVec */
+
/* The ObjC front-end uses TYPE_MAIN_VARIANT to tie together types differing
only in <protocol> qualifications. But when constructing cast expressions,
the protocols do matter and must be kept around. */
@@ -3045,6 +3121,13 @@ build_c_cast (tree type, tree expr)
/* Replace a nonvolatile const static variable with its value. */
if (optimize && TREE_CODE (value) == VAR_DECL)
value = decl_constant_value (value);
+ /* APPLE LOCAL begin don't sign-extend pointers cast to integers */
+ if (TREE_CODE (type) == INTEGER_TYPE
+ && TREE_CODE (otype) == POINTER_TYPE
+ && TYPE_PRECISION (type) > TYPE_PRECISION (otype)
+ && TREE_UNSIGNED (type))
+ value = convert (c_common_type_for_size (POINTER_SIZE, 1), value);
+ /* APPLE LOCAL end don't sign-extend pointers cast to integers */
value = convert (type, value);
/* Ignore any integer overflow caused by the cast. */
@@ -3259,9 +3342,8 @@ convert_for_assignment (tree type, tree rhs, const char *errtype,
return rhs;
}
/* Some types can interconvert without explicit casts. */
- else if (codel == VECTOR_TYPE && coder == VECTOR_TYPE
- && ((*targetm.vector_opaque_p) (type)
- || (*targetm.vector_opaque_p) (rhstype)))
+ else if (codel == VECTOR_TYPE
+ && vector_types_compatible_p (type, TREE_TYPE (rhs)))
return convert (type, rhs);
/* Arithmetic types all interconvert, and enum is treated like int. */
else if ((codel == INTEGER_TYPE || codel == REAL_TYPE
@@ -3869,13 +3951,21 @@ digest_init (tree type, tree init, int require_constant)
if ((TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (inside_init)))
!= char_type_node)
+ /* APPLE LOCAL begin Pascal strings 2001-07-05 zll */
+ && (TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (inside_init)))
+ != unsigned_char_type_node)
+ /* APPLE LOCAL end Pascal strings 2001-07-05 zll */
&& TYPE_PRECISION (typ1) == TYPE_PRECISION (char_type_node))
{
error_init ("char-array initialized from wide string");
return error_mark_node;
}
- if ((TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (inside_init)))
- == char_type_node)
+ /* APPLE LOCAL begin Pascal strings 2001-07-05 zll */
+ if (((TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (inside_init)))
+ == char_type_node)
+ || (TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (inside_init)))
+ == unsigned_char_type_node))
+ /* APPLE LOCAL end Pascal strings 2001-07-05 zll */
&& TYPE_PRECISION (typ1) != TYPE_PRECISION (char_type_node))
{
error_init ("int-array initialized from non-wide string");
@@ -3906,11 +3996,11 @@ digest_init (tree type, tree init, int require_constant)
vector constructor is not constant (e.g. {1,2,3,foo()}) then punt
below and handle as a constructor. */
if (code == VECTOR_TYPE
- && comptypes (TREE_TYPE (inside_init), type, COMPARE_STRICT)
+ && vector_types_compatible_p (TREE_TYPE (inside_init), type)
&& TREE_CONSTANT (inside_init))
{
if (TREE_CODE (inside_init) == VECTOR_CST
- && comptypes (TYPE_MAIN_VARIANT (TREE_TYPE (inside_init)),
+ && comptypes (TYPE_MAIN_VARIANT (TREE_TYPE (inside_init)),
TYPE_MAIN_VARIANT (type),
COMPARE_STRICT))
return inside_init;
@@ -4011,7 +4101,8 @@ digest_init (tree type, tree init, int require_constant)
/* Handle scalar types, including conversions. */
if (code == INTEGER_TYPE || code == REAL_TYPE || code == POINTER_TYPE
- || code == ENUMERAL_TYPE || code == BOOLEAN_TYPE || code == COMPLEX_TYPE)
+ || code == ENUMERAL_TYPE || code == BOOLEAN_TYPE || code == COMPLEX_TYPE
+ || code == VECTOR_TYPE)
{
/* Note that convert_for_assignment calls default_conversion
for arrays and functions. We must not call it in the
diff --git a/gcc/c.opt b/gcc/c.opt
index 4855ee2b03e..e69a0795986 100644
--- a/gcc/c.opt
+++ b/gcc/c.opt
@@ -149,6 +149,11 @@ U
C ObjC C++ ObjC++ Joined Separate
-U<macro> Undefine <macro>
+; APPLE LOCAL -Wno-#warnings
+W#warnings
+C ObjC C++ ObjC++
+Enable #warning
+
Wabi
C++ ObjC++
@@ -212,6 +217,11 @@ Werror-implicit-function-declaration
C ObjC RejectNegative
Make implicit function declarations an error
+; APPLE LOCAL -Wextra-tokens
+Wextra-tokens
+C Objc C++ ObjC++
+Warn about extra tokens at the end of prepreprocessor directives
+
Wfloat-equal
C ObjC C++ ObjC++
Warn if testing floating point numbers for equality
@@ -242,6 +252,11 @@ C ObjC
Wformat=
C ObjC C++ ObjC++ Joined
+; APPLE LOCAL -Wfour-char-constants
+Wfour-char-constants
+C ObjC C++ ObjC++
+Warn about multicharacter constants containing exactly four characters
+
Winit-self
C ObjC C++ ObjC++
Warn about variables which are initialized to themselves.
@@ -269,6 +284,16 @@ Winvalid-pch
C ObjC C++ ObjC++
Warn about PCH files that are found but not used
+; APPLE LOCAL Symbol Separation
+Winvalid-sr
+C ObjC C++ ObjC++
+Warn about symbol files that are found but not used
+
+; APPLE LOCAL -Wlong-double
+Wlong-double
+C ObjC C++ ObjC++
+Warn about \"long double\"
+
Wlong-long
C ObjC C++ ObjC++
Do not warn about using \"long long\" when -pedantic
@@ -293,6 +318,11 @@ Wmissing-prototypes
C ObjC
Warn about global functions without prototypes
+; APPLE LOCAL -Wmost
+Wmost
+C ObjC C++ ObjC++
+Like -Wall but without -Wparentheses
+
Wmultichar
C ObjC C++ ObjC++
Warn about use of multi-character character constants
@@ -301,6 +331,11 @@ Wnested-externs
C ObjC
Warn about \"extern\" declarations not at file scope
+; APPLE LOCAL -Wnewline-eof
+Wnewline-eof
+C ObjC C++ ObjC++
+Warn about files missing a newline at the end of the file
+
Wnon-template-friend
C++ ObjC++
Warn when non-templatized friend functions are declared within a template
@@ -312,6 +347,11 @@ Warn about non-virtual destructors
Wnonnull
C ObjC
+; APPLE LOCAL constant cfstrings
+Wnonportable-cfstrings
+ObjC ObjC++
+Warn about non-ASCII characters or NULs in CFString literals
+
Wold-style-cast
C++ ObjC++
Warn if a C-style cast is used in a program
@@ -415,6 +455,11 @@ ansi
C ObjC C++ ObjC++
A synonym for -std=c89. In a future version of GCC it will become synonymous with -std=c99 instead
+; APPLE LOCAL fat builds
+arch
+C ObjC C++ ObjC++ Separate
+The architecture to build for.
+
d
C ObjC C++ ObjC++ Joined
; Documented in common.opt. FIXME - what about -dI, -dD, -dN and -dD?
@@ -430,10 +475,28 @@ falt-external-templates
C++ ObjC++
Change when template instances are emitted
+; APPLE LOCAL -fapple-kext
+fapple-kext
+C++
+Used for building Darwin kernel extensions
+
fasm
C ObjC C++ ObjC++
Recognize the \"asm\" keyword
+; APPLE LOCAL fast, fastf, fastcp
+fast
+C
+Used for c optimization
+
+fastcp
+C++
+Used when C++ specific optimization is needed
+
+fastf
+C
+Used when c is generated from NAG fortran
+
fbuiltin
C ObjC C++ ObjC++
Recognize built-in functions
@@ -445,6 +508,11 @@ fcheck-new
C++ ObjC++
Check the return value of new
+; APPLE LOCAL structor decloning
+fclone-structors
+C++ ObjC++
+Factor out certain duplicate code in constructors and destructors
+
fcond-mismatch
C ObjC C++ ObjC++
Allow the arguments of the '?' operator to have different types
@@ -457,6 +525,11 @@ fconst-strings
C++ ObjC++
Make string literals \"const char[]\" not \"char[]\"
+; APPLE LOCAL constant cfstrings
+fconstant-cfstrings
+C ObjC C++ ObjC++
+Enable __builtin__CFStringMakeConstantString
+
fconstant-string-class=
ObjC ObjC++ Joined
-fconst-string-class=<name> Use class <name> for constant strings
@@ -465,6 +538,10 @@ fdefault-inline
C++ ObjC++
Inline member functions by default
+fdisable-typechecking-for-spec
+C C++
+Make crossfile type mismatches warnings not errors (for SPEC)
+
fdollars-in-identifiers
C ObjC C++ ObjC++
Permit '$' as an identifier character
@@ -542,6 +619,11 @@ fimplicit-templates
C++ ObjC++
Emit implicit instantiations of templates
+; APPLE LOCAL -findirect-virtual-calls
+findirect-virtual-calls
+C++ ObjC++
+Always use the vtable to make direct calls to virtual functions
+
flabels-ok
C++ ObjC++
@@ -584,6 +666,11 @@ Enable optional diagnostics
fpch-deps
C ObjC C++ ObjC++
+; APPLE LOCAL pch distcc mrs
+fpch-preprocess
+C ObjC C++ ObjC++
+Enable PCH processing even when -E or -save-temps is used
+
fpermissive
C++ ObjC++
Downgrade conformance errors to warnings
@@ -604,6 +691,11 @@ frtti
C++ ObjC++
Generate run time type descriptor information
+; APPLE LOCAL Symbol Separation
+fsave-repository=
+C ObjC C++ ObjC++ Joined Separate
+Creates separate symbol repository
+
fshort-double
C ObjC C++ ObjC++
Use the same size for double as for float
@@ -645,6 +737,11 @@ ftemplate-depth-
C++ ObjC++ Joined RejectNegative UInteger
-ftemplate-depth-<number> Specify maximum template instantiation depth
+; APPLE LOCAL -fterminated-vtables
+fterminated-vtables
+C++ ObjC++
+Put zero word at the end of every vtable
+
fthis-is-variable
C++ ObjC++
@@ -692,6 +789,11 @@ gen-decls
ObjC ObjC++
Dump declarations to a .decl file
+; APPLE LOCAL -header-mapfile
+header-mapfile
+C ObjC C++ ObjC++ Separate
+
+
idirafter
C ObjC C++ ObjC++ Joined Separate
-idirafter <dir> Add <dir> to the end of the system include path
@@ -704,6 +806,7 @@ include
C ObjC C++ ObjC++ Joined Separate
-include <file> Include the contents of <file> before other files
+
iprefix
C ObjC C++ ObjC++ Joined Separate
-iprefix <path> Specify <path> as a prefix for next two options
diff --git a/gcc/calls.c b/gcc/calls.c
index d83b353c0ee..6e83def3756 100644
--- a/gcc/calls.c
+++ b/gcc/calls.c
@@ -381,7 +381,14 @@ emit_call_1 (rtx funexp, tree fntree, tree fndecl ATTRIBUTE_UNUSED,
and we don't want to load it into a register as an optimization,
because prepare_call_address already did it if it should be done. */
if (GET_CODE (funexp) != SYMBOL_REF)
+/* APPLE LOCAL use R12 as register for indirect calls. This improves
+ codegen (computation of value will be into R12) and makes
+ indirect sibcalls possible by ensuring a volatile reg is used. */
+#ifdef MAGIC_INDIRECT_CALL_REG
+ funexp = gen_rtx_REG (SImode, MAGIC_INDIRECT_CALL_REG);
+#else
funexp = memory_address (FUNCTION_MODE, funexp);
+#endif
#if defined (HAVE_sibcall_pop) && defined (HAVE_sibcall_value_pop)
if ((ecf_flags & ECF_SIBCALL)
@@ -1256,8 +1263,8 @@ initialize_argument_information (int num_actuals ATTRIBUTE_UNUSED,
/* Compute the stack-size of this argument. */
if (args[i].reg == 0 || args[i].partial != 0
- || reg_parm_stack_space > 0
- || args[i].pass_on_stack)
+ || reg_parm_stack_space > 0
+ || args[i].pass_on_stack)
locate_and_pad_parm (mode, type,
#ifdef STACK_PARMS_IN_REG_PARM_AREA
1,
@@ -2014,12 +2021,18 @@ expand_call (tree exp, rtx target, int ignore)
tree actparms = TREE_OPERAND (exp, 1);
/* RTX for the function to be called. */
rtx funexp;
+ /* APPLE LOCAL use r12 for indirect calls */
+ /* A single rtx to be shared among multiple chains for indirect sibcalls */
+ rtx funexp_keep = NULL_RTX;
/* Sequence of insns to perform a normal "call". */
rtx normal_call_insns = NULL_RTX;
/* Sequence of insns to perform a tail "call". */
rtx tail_call_insns = NULL_RTX;
/* Data type of the function. */
tree funtype;
+ /* APPLE LOCAL objc stret methods */
+ /* Return type of the function. */
+ tree saved_return_type;
tree type_arg_types;
/* Declaration of the function being called,
or 0 if the function is computed (not known by name). */
@@ -2124,6 +2137,9 @@ expand_call (tree exp, rtx target, int ignore)
if (TREE_NOTHROW (exp))
flags |= ECF_NOTHROW;
+ /* See if we can find a DECL-node for the actual function.
+ As a result, decide whether this is a call to an integrable function. */
+
/* See if we can find a DECL-node for the actual function, and get the
function attributes (flags) from the function decl or type node. */
fndecl = get_callee_fndecl (exp);
@@ -2238,6 +2254,16 @@ expand_call (tree exp, rtx target, int ignore)
abort ();
funtype = TREE_TYPE (funtype);
+ /* APPLE LOCAL objc stret methods */
+ /* Set the return type of the function to the type of the call expression,
+ in case that's different from the function declaration.
+ (This is the case when calling _objc_msgSend_stret, for example,
+ which is declared to return id, but actually returns a struct.)
+ But save the original return type first, so it can be restored later
+ in case it's needed. */
+ saved_return_type = TREE_TYPE (funtype);
+ TREE_TYPE (funtype) = TREE_TYPE (exp);
+
/* Munge the tree to split complex arguments into their imaginary
and real parts. */
if (SPLIT_COMPLEX_ARGS)
@@ -2396,6 +2422,20 @@ expand_call (tree exp, rtx target, int ignore)
It does not seem worth the effort since few optimizable
sibling calls will return a structure. */
|| structure_value_addr != NULL_RTX
+/* APPLE LOCAL begin indirect sibcalls */
+#ifndef MAGIC_INDIRECT_CALL_REG
+/* The register holding the address is now always R12, so
+ we can consider indirect calls as sibcall candidates on ppc. */
+ /* If the register holding the address is a callee saved
+ register, then we lose. We have no way to prevent that,
+ so we only allow calls to named functions. */
+ /* ??? This could be done by having the insn constraints
+ use a register class that is all call-clobbered. Any
+ reload insns generated to fix things up would appear
+ before the sibcall_epilogue. */
+ || fndecl == NULL_TREE
+#endif
+/* APPLE LOCAL end indirect sibcalls */
/* Check whether the target is able to optimize the call
into a sibcall. */
|| !(*targetm.function_ok_for_sibcall) (fndecl, exp)
@@ -2490,6 +2530,14 @@ expand_call (tree exp, rtx target, int ignore)
function_call_count++;
+ /* APPLE LOCAL indirect sibcalls */
+ /* Do this before creating the chains, to avoid a branch within them.
+ The paired chains both branch to the same label, but only one
+ chain has a definition of that label, because of the way the
+ infrastructure works. */
+ if ( !fndecl )
+ funexp_keep = rtx_for_function_call (fndecl, addr);
+
/* We want to make two insn chains; one for a sibling call, the other
for a normal call. We will select one of the two chains after
initial RTL generation is complete. */
@@ -2812,7 +2860,11 @@ expand_call (tree exp, rtx target, int ignore)
be deferred during the evaluation of the arguments. */
NO_DEFER_POP;
- funexp = rtx_for_function_call (fndecl, addr);
+ /* APPLE LOCAL indirect sibcalls */
+ if ( !fndecl )
+ funexp = funexp_keep;
+ else
+ funexp = rtx_for_function_call (fndecl, addr);
/* Figure out the register where the value, if any, will come back. */
valreg = 0;
@@ -2950,6 +3002,24 @@ expand_call (tree exp, rtx target, int ignore)
next_arg_reg = FUNCTION_ARG (args_so_far, VOIDmode,
void_type_node, 1);
+ /* APPLE LOCAL begin indirect calls in R12 */
+#ifdef MAGIC_INDIRECT_CALL_REG
+ /* For indirect calls, put the callee address in R12. This is necessary
+ for ObjC methods. This could be handled by patterns in rs6000.md,
+ as in 2.95, but it is better to put this copy in the RTL so the
+ optimizer can see it, and sometimes get rid of it, and the scheduler
+ can move it around. Right now none of these good things seems to
+ happen, but this should be fixable. (But note FSF won't like
+ putting it here.) */
+ if (!fndecl)
+ {
+ rtx magic_reg = gen_rtx_REG (SImode, MAGIC_INDIRECT_CALL_REG);
+ emit_move_insn (magic_reg, funexp);
+ use_reg (&call_fusage, magic_reg);
+ }
+#endif
+ /* APPLE LOCAL end indirect calls in R12 */
+
/* All arguments and registers used for the call must be set up by
now! */
@@ -2963,6 +3033,11 @@ expand_call (tree exp, rtx target, int ignore)
next_arg_reg, valreg, old_inhibit_defer_pop, call_fusage,
flags, & args_so_far);
+ /* APPLE LOCAL objc stret methods */
+ /* Restore the function's original return type
+ in case it's needed later on. */
+ TREE_TYPE (funtype) = saved_return_type;
+
/* If call is cse'able, make appropriate pair of reg-notes around it.
Test valreg so we don't crash; may safely ignore `const'
if return type is void. Disable for PARALLEL return values, because
@@ -3323,6 +3398,24 @@ expand_call (tree exp, rtx target, int ignore)
abort ();
}
+ /* APPLE LOCAL begin sibcall 3007352 */
+ /* GCC for PPC on Darwin has always rounded 'current_function_args_size' up to a multiple of 16.
+ CodeWarrior doesn't.
+ A father() that passes, say, 40 bytes of parameters to daughter() will have eight bytes of
+ padding if compiled with GCC, and zero bytes of padding if compiled with CW.
+ If a GCC-compiled daughter() in turn sibcalls to granddaughter() with, say, 44 bytes of parameters,
+ GCC will generate a store of that extra parameter into padding of the father() parameter area.
+ Alas, if father() was compild by CW, father() will not have the parameter area padding,
+ and something in the father() stackframe will be stomped.
+ Parameter areas are guaranteed to be a minimum of 32 bytes. See Radar 3007352. */
+ if ( ( ! sibcall_failure)
+ && args_size.constant > 32
+ && args_size.constant > cfun->unrounded_args_size)
+ {
+ sibcall_failure = 1;
+ }
+ /* APPLE LOCAL end sibcall 3007352 */
+
/* If something prevents making this a sibling call,
zero out the sequence. */
if (sibcall_failure)
diff --git a/gcc/cfgbuild.c b/gcc/cfgbuild.c
index 601fcd44cee..f44b764c55a 100644
--- a/gcc/cfgbuild.c
+++ b/gcc/cfgbuild.c
@@ -271,6 +271,14 @@ make_edges (rtx label_value_list, basic_block min, basic_block max, int update_p
/* Assume no computed jump; revise as we create edges. */
current_function_has_computed_jump = 0;
+ /* APPLE LOCAL begin hot/cold partitioning */
+ /* If we are partitioning hot and cold basic blocks into separate
+ sections, we cannot assume there is no computed jump. */
+
+ if (flag_reorder_blocks_and_partition)
+ current_function_has_computed_jump = 1;
+ /* APPLE LOCAL end hot/cold partitioning */
+
/* Heavy use of computed goto in machine-generated code can lead to
nearly fully-connected CFGs. In that case we spend a significant
amount of time searching the edge lists for duplicates. */
diff --git a/gcc/cfgcleanup.c b/gcc/cfgcleanup.c
index e5d775cf497..33f41fef3a2 100644
--- a/gcc/cfgcleanup.c
+++ b/gcc/cfgcleanup.c
@@ -50,6 +50,9 @@ Software Foundation, 59 Temple Place - Suite 330, Boston, MA
#include "target.h"
#include "regs.h"
#include "expr.h"
+/* APPLE LOCAL begin hot/cold partitioning */
+#include "cfglayout.h"
+/* APPLE LOCAL end hot/cold partitioning */
/* cleanup_cfg maintains following flags for each basic block. */
@@ -150,6 +153,17 @@ try_simplify_condjump (basic_block cbranch_block)
return false;
jump_dest_block = jump_block->succ->dest;
+ /* APPLE LOCAL begin hot/cold partitioning */
+ /* If we are partitioning hot/cold basic blocks, we don't want to
+ mess up unconditional or indirect jumps that cross between hot
+ and cold sections. */
+
+ if (flag_reorder_blocks_and_partition
+ && (jump_block->partition != jump_dest_block->partition
+ || cbranch_jump_edge->crossing_edge))
+ return false;
+ /* APPLE LOCAL end hot/cold partitioning */
+
/* The conditional branch must target the block after the
unconditional branch. */
cbranch_dest_block = cbranch_jump_edge->dest;
@@ -428,6 +442,16 @@ try_forward_edges (int mode, basic_block b)
bool changed = false;
edge e, next, *threaded_edges = NULL;
+ /* APPLE LOCAL begin hot/cold partitioning */
+ /* If we are partitioning hot/cold basic blocks, we don't want to
+ mess up unconditional or indirect jumps that cross between hot
+ and cold sections. */
+
+ if (flag_reorder_blocks_and_partition
+ && find_reg_note (BB_END (b), REG_CROSSING_JUMP, NULL_RTX))
+ return false;
+ /* APPLE LOCAL end hot/cold partitioning */
+
for (e = b->succ; e; e = next)
{
basic_block target, first;
@@ -675,6 +699,17 @@ merge_blocks_move_predecessor_nojumps (basic_block a, basic_block b)
{
rtx barrier;
+ /* APPLE LOCAL begin hot/cold partitioning */
+ /* If we are partitioning hot/cold basic blocks, we don't want to
+ mess up unconditional or indirect jumps that cross between hot
+ and cold sections. */
+
+ if (flag_reorder_blocks_and_partition
+ && (a->partition != b->partition
+ || find_reg_note (BB_END (a), REG_CROSSING_JUMP, NULL_RTX)))
+ return;
+ /* APPLE LOCAL end hot/cold partitioning */
+
barrier = next_nonnote_insn (BB_END (a));
if (GET_CODE (barrier) != BARRIER)
abort ();
@@ -718,6 +753,17 @@ merge_blocks_move_successor_nojumps (basic_block a, basic_block b)
rtx barrier, real_b_end;
rtx label, table;
+ /* APPLE LOCAL begin hot/cold partitioning */
+ /* If we are partitioning hot/cold basic blocks, we don't want to
+ mess up unconditional or indirect jumps that cross between hot
+ and cold sections. */
+
+ if (flag_reorder_blocks_and_partition
+ && (find_reg_note (BB_END (a), REG_CROSSING_JUMP, NULL_RTX)
+ || a->partition != b->partition))
+ return;
+ /* APPLE LOCAL end hot/cold partitioning */
+
real_b_end = BB_END (b);
/* If there is a jump table following block B temporarily add the jump table
@@ -782,6 +828,18 @@ merge_blocks_move (edge e, basic_block b, basic_block c, int mode)
&& tail_recursion_label_p (BB_HEAD (c)))
return NULL;
+ /* APPLE LOCAL begin hot/cold partitioning */
+ /* If we are partitioning hot/cold basic blocks, we don't want to
+ mess up unconditional or indirect jumps that cross between hot
+ and cold sections. */
+
+ if (flag_reorder_blocks_and_partition
+ && (find_reg_note (BB_END (b), REG_CROSSING_JUMP, NULL_RTX)
+ || find_reg_note (BB_END (c), REG_CROSSING_JUMP, NULL_RTX)
+ || b->partition != c->partition))
+ return NULL;
+ /* APPLE LOCAL end hot/cold partitioning */
+
/* If B has a fallthru edge to C, no need to move anything. */
if (e->flags & EDGE_FALLTHRU)
{
@@ -1453,6 +1511,14 @@ try_crossjump_to_edge (int mode, edge e1, edge e2)
rtx newpos1, newpos2;
edge s;
+ /* APPLE LOCAL begin hot/cold partitioning */
+ /* If we have partitioned hot/cold basic blocks, it is a bad idea
+ to try this optimization. */
+
+ if (flag_reorder_blocks_and_partition && no_new_pseudos)
+ return false;
+ /* APPLE LOCAL end hot/cold partitioning */
+
newpos1 = newpos2 = NULL_RTX;
/* Search backward through forwarder blocks. We don't need to worry
@@ -1641,6 +1707,17 @@ try_crossjump_bb (int mode, basic_block bb)
if (!bb->pred || !bb->pred->pred_next)
return false;
+ /* APPLE LOCAL begin hot/cold partitioning */
+ /* If we are partitioning hot/cold basic blocks, we don't want to
+ mess up unconditional or indirect jumps that cross between hot
+ and cold sections. */
+
+ if (flag_reorder_blocks_and_partition
+ && (bb->pred->src->partition != bb->pred->pred_next->src->partition
+ || bb->pred->crossing_edge))
+ return false;
+ /* APPLE LOCAL end hot/cold partitioning */
+
/* It is always cheapest to redirect a block that ends in a branch to
a block that falls through into BB, as that adds no branches to the
program. We'll try that combination first. */
@@ -1897,6 +1974,9 @@ try_optimize_cfg (int mode)
&& ! b->succ->succ_next
&& b->succ->dest != EXIT_BLOCK_PTR
&& onlyjump_p (BB_END (b))
+ /* APPLE LOCAL begin hot/cold partitioning */
+ && !find_reg_note (BB_END (b), REG_CROSSING_JUMP, NULL_RTX)
+ /* APPLE LOCAL end hot/cold partitioning */
&& try_redirect_by_replacing_jump (b->succ, b->succ->dest,
(mode & CLEANUP_CFGLAYOUT) != 0))
{
diff --git a/gcc/cfghooks.c b/gcc/cfghooks.c
index ac37d3adb16..a91e0484964 100644
--- a/gcc/cfghooks.c
+++ b/gcc/cfghooks.c
@@ -630,7 +630,10 @@ tidy_fallthru_edges (void)
if ((s = b->succ) != NULL
&& ! (s->flags & EDGE_COMPLEX)
&& s->succ_next == NULL
- && s->dest == c)
+ /* APPLE LOCAL begin hot/cold partitioning */
+ && s->dest == c
+ && !find_reg_note (BB_END (b), REG_CROSSING_JUMP, NULL_RTX))
+ /* APPLE LOCAL end hot/cold partitioning */
tidy_fallthru_edge (s);
}
}
diff --git a/gcc/cfglayout.c b/gcc/cfglayout.c
index 73012c28dd5..6748104fa04 100644
--- a/gcc/cfglayout.c
+++ b/gcc/cfglayout.c
@@ -35,6 +35,9 @@ Software Foundation, 59 Temple Place - Suite 330, Boston, MA
#include "target.h"
#include "ggc.h"
#include "alloc-pool.h"
+/* APPLE LOCAL begin hot/cold partitioning */
+#include "flags.h"
+/* APPLE LOCAL end hot/cold partitioning */
/* The contents of the current function definition are allocated
in this obstack, and all are freed at the end of the function. */
@@ -55,6 +58,9 @@ void verify_insn_chain (void);
static void fixup_fallthru_exit_predecessor (void);
static rtx duplicate_insn_chain (rtx, rtx);
static tree insn_scope (rtx);
+/* APPLE LOCAL begin hot/cold partitioning */
+static void update_unlikely_executed_notes (basic_block);
+/* APPLE LOCAL end hot/cold partitioning */
rtx
unlink_insn_chain (rtx first, rtx last)
@@ -643,6 +649,9 @@ fixup_reorder_chain (void)
edge e_fall, e_taken, e;
rtx bb_end_insn;
basic_block nb;
+ /* APPLE LOCAL begin hot/cold partitioning */
+ basic_block old_bb;
+ /* APPLE LOCAL end hot/cold partitioning */
if (bb->succ == NULL)
continue;
@@ -719,6 +728,13 @@ fixup_reorder_chain (void)
}
}
+ /* APPLE LOCAL end hot/cold partitioning */
+ /* If the "jumping" edge is a crossing edge, and the fall
+ through edge is non-crossing, leave things as they are. */
+ else if (e_taken->crossing_edge && !e_fall->crossing_edge)
+ continue;
+ /* APPLE LOCAL begin hot/cold partitioning */
+
/* Otherwise we can try to invert the jump. This will
basically never fail, however, keep up the pretense. */
else if (invert_jump (bb_end_insn,
@@ -776,7 +792,37 @@ fixup_reorder_chain (void)
nb->rbi->next = bb->rbi->next;
bb->rbi->next = nb;
/* Don't process this new block. */
- bb = nb;
+ /* APPLE LOCAL begin hot/cold partitioning */
+ old_bb = bb;
+ bb = nb;
+
+ /* Make sure new bb is tagged for correct section (same as
+ fall-thru source). */
+ e_fall->src->partition = bb->pred->src->partition;
+ if (flag_reorder_blocks_and_partition
+ && targetm.have_named_sections)
+ {
+ if (bb->pred->src->partition == COLD_PARTITION)
+ {
+ rtx new_note;
+ rtx note = BB_HEAD (e_fall->src);
+
+ while (!INSN_P (note)
+ && note != BB_END (e_fall->src))
+ note = NEXT_INSN (note);
+
+ new_note = emit_note_before
+ (NOTE_INSN_UNLIKELY_EXECUTED_CODE,
+ note);
+ NOTE_BASIC_BLOCK (new_note) = bb;
+ }
+ if (GET_CODE (BB_END (bb)) == JUMP_INSN
+ && !any_condjump_p (BB_END (bb))
+ && bb->succ->crossing_edge )
+ REG_NOTES (BB_END (bb)) = gen_rtx_EXPR_LIST
+ (REG_CROSSING_JUMP, NULL_RTX, REG_NOTES (BB_END (bb)));
+ }
+ /* APPLE LOCAL end hot/cold partitioning */
}
}
@@ -811,6 +857,10 @@ fixup_reorder_chain (void)
bb->index = index;
BASIC_BLOCK (index) = bb;
+ /* APPLE LOCAL begin hot/cold partitioning */
+ update_unlikely_executed_notes (bb);
+ /* APPLE LOCAL end hot/cold partitioning */
+
bb->prev_bb = prev_bb;
prev_bb->next_bb = bb;
}
@@ -827,6 +877,23 @@ fixup_reorder_chain (void)
force_nonfallthru (e);
}
}
+/* APPLE LOCAL begin hot/cold partitioning */
+
+/* Update the basic block number information in any
+ NOTE_INSN_UNLIKELY_EXECUTED_CODE notes within the basic block. */
+
+static void
+update_unlikely_executed_notes (basic_block bb)
+{
+ rtx cur_insn;
+
+ for (cur_insn = BB_HEAD (bb); cur_insn != BB_END (bb);
+ cur_insn = NEXT_INSN (cur_insn))
+ if (GET_CODE (cur_insn) == NOTE
+ && NOTE_LINE_NUMBER (cur_insn) == NOTE_INSN_UNLIKELY_EXECUTED_CODE)
+ NOTE_BASIC_BLOCK (cur_insn) = bb;
+}
+/* APPLE LOCAL end hot/cold partitioning */
/* Perform sanity checks on the insn chain.
1. Check that next/prev pointers are consistent in both the forward and
@@ -993,6 +1060,9 @@ duplicate_insn_chain (rtx from, rtx to)
abort ();
break;
case NOTE_INSN_REPEATED_LINE_NUMBER:
+ /* APPLE LOCAL begin hot/cold partitioning */
+ case NOTE_INSN_UNLIKELY_EXECUTED_CODE:
+ /* APPLE LOCAL end hot/cold partitioning */
emit_note_copy (insn);
break;
diff --git a/gcc/cfglayout.h b/gcc/cfglayout.h
index ad73e713e9a..159144c2b55 100644
--- a/gcc/cfglayout.h
+++ b/gcc/cfglayout.h
@@ -27,3 +27,6 @@ extern void reemit_insn_block_notes (void);
extern bool can_copy_bbs_p (basic_block *, unsigned);
extern void copy_bbs (basic_block *, unsigned, basic_block *,
edge *, unsigned, edge *, struct loop *);
+/* APPLE LOCAL begin hot/cold partitioning */
+extern bool scan_ahead_for_unlikely_executed_note (rtx);
+/* APPLE LOCAL end hot/cold partitioning */
diff --git a/gcc/cfgloop.h b/gcc/cfgloop.h
index e79d39afef1..d9c758408f2 100644
--- a/gcc/cfgloop.h
+++ b/gcc/cfgloop.h
@@ -248,6 +248,7 @@ extern bool flow_bb_inside_loop_p (const struct loop *, const basic_block);
extern struct loop * find_common_loop (struct loop *, struct loop *);
extern int num_loop_insns (struct loop *);
extern int average_num_loop_insns (struct loop *);
+extern unsigned get_loop_level (const struct loop *);
/* Loops & cfg manipulation. */
extern basic_block *get_loop_body (const struct loop *);
@@ -418,3 +419,4 @@ enum
};
extern void unroll_and_peel_loops (struct loops *, int);
+extern void doloop_optimize_loops (struct loops *);
diff --git a/gcc/cfgloopanal.c b/gcc/cfgloopanal.c
index 9b3ffa0c8ae..0af62ef8bfd 100644
--- a/gcc/cfgloopanal.c
+++ b/gcc/cfgloopanal.c
@@ -457,3 +457,20 @@ expected_loop_iterations (const struct loop *loop)
return (freq_latch + freq_in - 1) / freq_in;
}
}
+
+/* Returns the maximum level of nesting of subloops of LOOP. */
+
+unsigned
+get_loop_level (const struct loop *loop)
+{
+ const struct loop *ploop;
+ unsigned mx = 0, l;
+
+ for (ploop = loop->inner; ploop; ploop = ploop->next)
+ {
+ l = get_loop_level (ploop);
+ if (l >= mx)
+ mx = l + 1;
+ }
+ return mx;
+}
diff --git a/gcc/cfgrtl.c b/gcc/cfgrtl.c
index 341167dd684..45cf6e5b4f3 100644
--- a/gcc/cfgrtl.c
+++ b/gcc/cfgrtl.c
@@ -56,6 +56,7 @@ Software Foundation, 59 Temple Place - Suite 330, Boston, MA
#include "insn-config.h"
#include "cfglayout.h"
#include "expr.h"
+#include "target.h"
/* Stubs in case we don't have a return insn. */
#ifndef HAVE_return
@@ -99,6 +100,9 @@ can_delete_note_p (rtx note)
{
return (NOTE_LINE_NUMBER (note) == NOTE_INSN_DELETED
|| NOTE_LINE_NUMBER (note) == NOTE_INSN_BASIC_BLOCK
+ /* APPLE LOCAL begin hot/cold partitioning */
+ || NOTE_LINE_NUMBER (note) == NOTE_INSN_UNLIKELY_EXECUTED_CODE
+ /* APPLE LOCAL end hot/cold partitioning */
|| NOTE_LINE_NUMBER (note) == NOTE_INSN_PREDICTION);
}
@@ -318,6 +322,9 @@ create_basic_block_structure (rtx head, rtx end, rtx bb_note, basic_block after)
link_block (bb, after);
BASIC_BLOCK (bb->index) = bb;
update_bb_for_insn (bb);
+ /* APPLE LOCAL begin hot/cold partitioning */
+ bb->partition = UNPARTITIONED;
+ /* APPLE LOCAL end hot/cold partitioning */
/* Tag the block so that we know it has been used when considering
other basic block notes. */
@@ -613,11 +620,28 @@ rtl_merge_blocks (basic_block a, basic_block b)
static bool
rtl_can_merge_blocks (basic_block a,basic_block b)
{
+ /* APPLE LOCAL begin hot/cold partitioning */
+ bool partitions_ok = true;
+
+ /* If we are partitioning hot/cold basic blocks, we don't want to
+ mess up unconditional or indirect jumps that cross between hot
+ and cold sections. */
+
+ if (flag_reorder_blocks_and_partition
+ && (find_reg_note (BB_END (a), REG_CROSSING_JUMP, NULL_RTX)
+ || find_reg_note (BB_END (b), REG_CROSSING_JUMP, NULL_RTX)
+ || a->partition != b->partition))
+ partitions_ok = false;
+ /* APPLE LOCAL end hot/cold partitioning */
+
/* There must be exactly one edge in between the blocks. */
return (a->succ && !a->succ->succ_next && a->succ->dest == b
&& !b->pred->pred_next && a != b
/* Must be simple edge. */
&& !(a->succ->flags & EDGE_COMPLEX)
+ /* APPLE LOCAL begin hot/cold partitioning */
+ && partitions_ok
+ /* APPLE LOCAL end hot/cold partitioning */
&& a->next_bb == b
&& a != ENTRY_BLOCK_PTR && b != EXIT_BLOCK_PTR
/* If the jump insn has side effects,
@@ -658,6 +682,16 @@ try_redirect_by_replacing_jump (edge e, basic_block target, bool in_cfglayout)
rtx set;
int fallthru = 0;
+ /* APPLE LOCAL begin hot/cold partitioning */
+ /* If we are partitioning hot/cold basic blocks, we don't want to
+ mess up unconditional or indirect jumps that cross between hot
+ and cold sections. */
+
+ if (flag_reorder_blocks_and_partition
+ && find_reg_note (insn, REG_CROSSING_JUMP, NULL_RTX))
+ return false;
+ /* APPLE LOCAL end hot/cold partitioning */
+
/* Verify that all targets will be TARGET. */
for (tmp = src->succ; tmp; tmp = tmp->succ_next)
if (tmp->dest != target && tmp != e)
@@ -1063,6 +1097,36 @@ force_nonfallthru_and_redirect (edge e, basic_block target)
target->global_live_at_start);
}
+ /* APPLE LOCAL begin hot/cold partitioning */
+ /* Make sure new block ends up in correct hot/cold section. */
+
+ jump_block->partition = e->src->partition;
+ if (flag_reorder_blocks_and_partition
+ && targetm.have_named_sections)
+ {
+ if (e->src->partition == COLD_PARTITION)
+ {
+ rtx bb_note, new_note;
+ for (bb_note = BB_HEAD (jump_block);
+ bb_note && bb_note != NEXT_INSN (BB_END (jump_block));
+ bb_note = NEXT_INSN (bb_note))
+ if (GET_CODE (bb_note) == NOTE
+ && NOTE_LINE_NUMBER (bb_note) == NOTE_INSN_BASIC_BLOCK)
+ break;
+ new_note = emit_note_after (NOTE_INSN_UNLIKELY_EXECUTED_CODE,
+ bb_note);
+ NOTE_BASIC_BLOCK (new_note) = jump_block;
+ jump_block->partition = COLD_PARTITION;
+ }
+ if (GET_CODE (BB_END (jump_block)) == JUMP_INSN
+ && !any_condjump_p (BB_END (jump_block))
+ && jump_block->succ->crossing_edge )
+ REG_NOTES (BB_END (jump_block)) = gen_rtx_EXPR_LIST
+ (REG_CROSSING_JUMP, NULL_RTX,
+ REG_NOTES (BB_END (jump_block)));
+ }
+ /* APPLE LOCAL end hot/cold partitioning */
+
/* Wire edge in. */
new_edge = make_edge (e->src, jump_block, EDGE_FALLTHRU);
new_edge->probability = e->probability;
@@ -1477,6 +1541,12 @@ commit_one_edge_insertion (edge e, int watch_calls)
tmp = NEXT_INSN (tmp);
if (NOTE_INSN_BASIC_BLOCK_P (tmp))
tmp = NEXT_INSN (tmp);
+ /* APPLE LOCAL begin hot/cold partitioning */
+ if (tmp
+ && GET_CODE (tmp) == NOTE
+ && NOTE_LINE_NUMBER (tmp) == NOTE_INSN_UNLIKELY_EXECUTED_CODE)
+ tmp = NEXT_INSN (tmp);
+ /* APPLE LOCAL end hot/cold partitioning */
if (tmp == BB_HEAD (bb))
before = tmp;
else if (tmp)
@@ -1519,6 +1589,41 @@ commit_one_edge_insertion (edge e, int watch_calls)
{
bb = split_edge (e);
after = BB_END (bb);
+
+ /* APPLE LOCAL begin hot/cold partitioning */
+ /* If we are partitioning hot/cold basic blocks, we must make sure
+ that the new basic block ends up in the correct section. */
+
+ bb->partition = e->src->partition;
+ if (flag_reorder_blocks_and_partition
+ && targetm.have_named_sections
+ && e->src != ENTRY_BLOCK_PTR
+ && e->src->partition == COLD_PARTITION)
+ {
+ rtx bb_note, new_note, cur_insn;
+
+ bb_note = NULL_RTX;
+ for (cur_insn = BB_HEAD (bb); cur_insn != NEXT_INSN (BB_END (bb));
+ cur_insn = NEXT_INSN (cur_insn))
+ if (GET_CODE (cur_insn) == NOTE
+ && NOTE_LINE_NUMBER (cur_insn) == NOTE_INSN_BASIC_BLOCK)
+ {
+ bb_note = cur_insn;
+ break;
+ }
+
+ new_note = emit_note_after (NOTE_INSN_UNLIKELY_EXECUTED_CODE,
+ bb_note);
+ NOTE_BASIC_BLOCK (new_note) = bb;
+ if (GET_CODE (BB_END (bb)) == JUMP_INSN
+ && !any_condjump_p (BB_END (bb))
+ && bb->succ->crossing_edge )
+ REG_NOTES (BB_END (bb)) = gen_rtx_EXPR_LIST
+ (REG_CROSSING_JUMP, NULL_RTX, REG_NOTES (BB_END (bb)));
+ if (after == bb_note)
+ after = new_note;
+ }
+ /* APPLE LOCAL end hot/cold partitioning */
}
}
@@ -1788,6 +1893,9 @@ update_br_prob_note (basic_block bb)
- tails of basic blocks (ensure that boundary is necessary)
- scans body of the basic block for JUMP_INSN, CODE_LABEL
and NOTE_INSN_BASIC_BLOCK
+ ** APPLE LOCAL begin hot/cold partitioning **
+ - verify that no fall_thru edge crosses hot/cold partition boundaries
+ ** APPLE LOCAL end hot/cold partitioning **
In future it can be extended check a lot of other stuff as well
(reachability of basic blocks, life information, etc. etc.). */
@@ -1875,7 +1983,17 @@ rtl_verify_flow_info_1 (void)
for (e = bb->succ; e; e = e->succ_next)
{
if (e->flags & EDGE_FALLTHRU)
- n_fallthru++, fallthru = e;
+ /* APPLE LOCAL begin hot/cold partitioning */
+ {
+ n_fallthru++, fallthru = e;
+ if (e->crossing_edge)
+ {
+ error ("Fallthru edge crosses section boundary (bb %i)",
+ e->src->index);
+ err = 1;
+ }
+ }
+ /* APPLE LOCAL end hot/cold partitioning */
if ((e->flags & ~(EDGE_DFS_BACK
| EDGE_CAN_FALLTHRU
@@ -2547,11 +2665,28 @@ cfg_layout_delete_block (basic_block bb)
static bool
cfg_layout_can_merge_blocks_p (basic_block a, basic_block b)
{
+ /* APPLE LOCAL begin hot/cold partitioning */
+ bool partitions_ok = true;
+
+ /* If we are partitioning hot/cold basic blocks, we don't want to
+ mess up unconditional or indirect jumps that cross between hot
+ and cold sections. */
+
+ if (flag_reorder_blocks_and_partition
+ && (find_reg_note (BB_END (a), REG_CROSSING_JUMP, NULL_RTX)
+ || find_reg_note (BB_END (b), REG_CROSSING_JUMP, NULL_RTX)
+ || a->partition != b->partition))
+ partitions_ok = false;
+ /* APPLE LOCAL end hot/cold partitioning */
+
/* There must be exactly one edge in between the blocks. */
return (a->succ && !a->succ->succ_next && a->succ->dest == b
&& !b->pred->pred_next && a != b
/* Must be simple edge. */
&& !(a->succ->flags & EDGE_COMPLEX)
+ /* APPLE LOCAL begin hot/cold partitioning */
+ && partitions_ok
+ /* APPLE LOCAL end hot/cold partitioning */
&& a != ENTRY_BLOCK_PTR && b != EXIT_BLOCK_PTR
/* If the jump insn has side effects,
we can't kill the edge. */
diff --git a/gcc/cgraphunit.c b/gcc/cgraphunit.c
index aef6a14845c..c9aadc126cc 100644
--- a/gcc/cgraphunit.c
+++ b/gcc/cgraphunit.c
@@ -615,6 +615,8 @@ cgraph_analyze_function (struct cgraph_node *node)
cgraph_create_edges (node, DECL_SAVED_TREE (decl));
node->local.inlinable = tree_inlinable_function_p (decl);
+ if (!DECL_ESTIMATED_INSNS (decl))
+ DECL_ESTIMATED_INSNS (decl) = estimate_num_insns (DECL_SAVED_TREE (decl));
node->local.self_insns = estimate_num_insns (DECL_SAVED_TREE (decl));
if (node->local.inlinable)
node->local.disregard_inline_limits
diff --git a/gcc/combine.c b/gcc/combine.c
index 5b0b6ac01ce..bb946fb47f8 100644
--- a/gcc/combine.c
+++ b/gcc/combine.c
@@ -407,6 +407,8 @@ static int insn_cuid (rtx);
static void record_promoted_value (rtx, rtx);
static rtx reversed_comparison (rtx, enum machine_mode, rtx, rtx);
static enum rtx_code combine_reversed_comparison_code (rtx);
+static int unmentioned_reg_p_1 (rtx *, void *);
+static bool unmentioned_reg_p (rtx, rtx);
/* Substitute NEWVAL, an rtx expression, into INTO, a place in some
insn. The substitution can be undone by undo_all. If INTO is already
@@ -720,6 +722,31 @@ combine_instructions (rtx f, unsigned int nregs)
&new_direct_jump_p)) != 0)
goto retry;
+ /* Try this insn with each REG_EQUAL note it links back to. */
+ for (links = LOG_LINKS (insn); links; links = XEXP (links, 1))
+ {
+ rtx set, note;
+ rtx temp = XEXP (links, 0);
+ if ((set = single_set (temp)) != 0
+ && (note = find_reg_equal_equiv_note (temp)) != 0
+ && GET_CODE (XEXP (note, 0)) != EXPR_LIST
+ /* Avoid using a register that may already been marked
+ dead by an earlier instruction. */
+ && ! unmentioned_reg_p (XEXP (note, 0), SET_SRC (set)))
+ {
+ /* Temporarily replace the set's source with the
+ contents of the REG_EQUAL note. The insn will
+ be deleted or recognized by try_combine. */
+ rtx orig = SET_SRC (set);
+ SET_SRC (set) = XEXP (note, 0);
+ next = try_combine (insn, temp, NULL_RTX,
+ &new_direct_jump_p);
+ if (next)
+ goto retry;
+ SET_SRC (set) = orig;
+ }
+ }
+
if (GET_CODE (insn) != NOTE)
record_dead_and_set_regs (insn);
@@ -12982,6 +13009,33 @@ distribute_links (rtx links)
}
}
+/* Subroutine of unmentioned_reg_p and callback from for_each_rtx.
+ Check whether the expression pointer to by LOC is a register or
+ memory, and if so return 1 if it isn't mentioned in the rtx EXPR.
+ Otherwise return zero. */
+
+static int
+unmentioned_reg_p_1 (rtx *loc, void *expr)
+{
+ rtx x = *loc;
+
+ if (x != NULL_RTX
+ && (GET_CODE (x) == REG || GET_CODE (x) == MEM)
+ && ! reg_mentioned_p (x, (rtx) expr))
+ return 1;
+ return 0;
+}
+
+/* Check for any register or memory mentioned in EQUIV that is not
+ mentioned in EXPR. This is used to restrict EQUIV to "specializations"
+ of EXPR where some registers may have been replaced by constants. */
+
+static bool
+unmentioned_reg_p (rtx equiv, rtx expr)
+{
+ return for_each_rtx (&equiv, unmentioned_reg_p_1, expr);
+}
+
/* Compute INSN_CUID for INSN, which is an insn made by combine. */
static int
diff --git a/gcc/common.opt b/gcc/common.opt
index 325ad1e4511..668e0683283 100644
--- a/gcc/common.opt
+++ b/gcc/common.opt
@@ -152,6 +152,12 @@ Wunused-variable
Common
Warn when a variable is unused
+; APPLE LOCAL begin fat builds
+arch
+Common Separate
+
+; APPLE LOCAL end fat builds
+
aux-info
Common Separate
-aux-info <file> Emit declaration information into <file>
@@ -210,6 +216,10 @@ Align the start of loops
falign-loops=
Common RejectNegative Joined UInteger
+faltivec
+Common
+Temporary, perhaps, to get NaG Fortran to work
+
fargument-alias
Common
Specify that arguments may alias each other and globals
@@ -262,6 +272,16 @@ fcaller-saves
Common
Save registers around function calls
+; APPLE LOCAL begin coalescing turly
+fcoalesce
+Common
+Coalesce duplicate C++ functions and data
+
+fcoalesce-templates
+Common
+Coalesce duplicate C++ templates
+; APPLE LOCAL end coalescing turly
+
fcommon
Common
Do not put uninitialized globals in the common section
@@ -330,6 +350,12 @@ fexpensive-optimizations
Common
Perform a number of minor, expensive optimizations
+; APPLE LOCAL begin coalescing turly
+fexport-coalesced
+Common
+EXPERIMENTAL: Export coalesced symbols from dylibs
+; APPLE LOCAL end coalescing turly
+
ffast-math
Common
@@ -438,6 +464,10 @@ floop-optimize
Common
Perform loop optimizations
+floop-transpose
+Common
+Interchange loops to improve cache locality
+
fmath-errno
Common
Set errno after built-in math functions
@@ -482,6 +512,12 @@ fnon-call-exceptions
Common
Support synchronous non-call exceptions
+; APPLE LOCAL begin -fobey-inline
+fobey-inline
+Common
+Obey 'inline' keyword and always inline, regardless of size
+; APPLE LOCAL end -fobey-inline
+
fold-unroll-loops
Common
Perform loop unrolling when iteration count is known
@@ -506,6 +542,12 @@ fpack-struct
Common
Pack structure members together without holes
+; APPLE LOCAL begin Pascal strings 2001-07-05 zll
+fpascal-strings
+Common
+Allow Pascal-style string literals
+; APPLE LOCAL end Pascal strings 2001-07-05 zll
+
fpcc-struct-return
Common
Return small aggregates in memory, not registers
@@ -530,6 +572,12 @@ fpie
Common
Generate position-independent code for executables if possible
+; APPLE LOCAL begin -ffppc 2001-08-01 sts
+fppc
+Common
+Perform floating-point precision-control pass
+; APPLE LOCAL end -ffppc 2001-08-01 sts
+
fprefetch-loop-arrays
Common
Generate prefetch instructions, if available, for arrays in loops
@@ -581,6 +629,10 @@ freorder-blocks
Common
Reorder basic blocks to improve code placement
+freorder-blocks-and-partition
+Common
+Reorder basic blocks and partition into hot and cold sections
+
freorder-functions
Common
Reorder functions to improve code placement
@@ -803,6 +855,12 @@ fvpt
Common
Use expression value profiles in optimizations
+; APPLE LOCAL begin coalescing turly
+fweak-coalesced
+Common
+Use the OS X 10.2 'weak_definitions' attribute when coalescing
+; APPLE LOCAL end coalescing turly
+
fweb
Common
Construct webs and split unrelated uses of single variable
@@ -851,6 +909,12 @@ gxcoff+
Common JoinedOrMissing
Generate debug information in extended XCOFF format
+; APPLE LOCAL begin -header-mapfile
+header-mapfile
+Common Separate
+
+; APPLE LOCAL end -header-mapfile
+
m
Common Joined
@@ -870,6 +934,12 @@ pedantic-errors
Common
Like -pedantic but issue them as errors
+; APPLE LOCAL begin -precomp-trustfile
+precomp-trustfile
+Common Separate
+
+; APPLE LOCAL end -precomp-trustfile
+
quiet
Common
Do not display functions compiled or elapsed time
diff --git a/gcc/config.in b/gcc/config.in
index 24a38dce80d..f8a65dbfeed 100644
--- a/gcc/config.in
+++ b/gcc/config.in
@@ -325,6 +325,9 @@
/* Define if your compiler supports the \`long long' type. */
#undef HAVE_LONG_LONG
+/* Define to 1 if you have the <mach/mach_time.h> header file. */
+#undef HAVE_MACH_MACH_TIME_H
+
/* Define to 1 if you have the <malloc.h> header file. */
#undef HAVE_MALLOC_H
diff --git a/gcc/config/darwin-c.c b/gcc/config/darwin-c.c
index a4c6d8bd1da..365ad2bb1c9 100644
--- a/gcc/config/darwin-c.c
+++ b/gcc/config/darwin-c.c
@@ -34,37 +34,74 @@ Boston, MA 02111-1307, USA. */
/* Pragmas. */
#define BAD(msgid) do { warning (msgid); return; } while (0)
+#define BAD2(msgid, arg) do { warning (msgid, arg); return; } while (0)
static bool using_frameworks = false;
+/* APPLE LOCAL CALL_ON_LOAD/CALL_ON_UNLOAD pragmas 20020202 turly */
+static void directive_with_named_function (const char *, void (*sec_f)(void));
+
/* Maintain a small stack of alignments. This is similar to pragma
pack's stack, but simpler. */
-static void push_field_alignment (int);
+/* APPLE LOCAL begin Macintosh alignment 2001-12-17 ff */
+static void push_field_alignment (int, int, int);
+/* APPLE LOCAL end Macintosh alignment 2001-12-17 ff */
static void pop_field_alignment (void);
static const char *find_subframework_file (const char *, const char *);
static void add_system_framework_path (char *);
static const char *find_subframework_header (cpp_reader *pfile, const char *header);
+/* APPLE LOCAL begin Macintosh alignment 2002-1-22 ff */
+/* There are four alignment modes supported on the Apple Macintosh
+ platform: power, mac68k, natural, and packed. These modes are
+ identified as follows:
+ if maximum_field_alignment != 0
+ mode = packed
+ else if TARGET_ALIGN_NATURAL
+ mode = natural
+ else if TARGET_ALIGN_MAC68K
+ mode
+ else
+ mode = power
+ These modes are saved on the alignment stack by saving the values
+ of maximum_field_alignment, TARGET_ALIGN_MAC68K, and
+ TARGET_ALIGN_NATURAL. */
typedef struct align_stack
{
int alignment;
+ unsigned long mac68k;
+ unsigned long natural;
struct align_stack * prev;
} align_stack;
+/* APPLE LOCAL end Macintosh alignment 2002-1-22 ff */
static struct align_stack * field_align_stack = NULL;
+/* APPLE LOCAL begin Macintosh alignment 2001-12-17 ff */
static void
-push_field_alignment (int bit_alignment)
+push_field_alignment (int bit_alignment,
+ int mac68k_alignment, int natural_alignment)
{
align_stack *entry = (align_stack *) xmalloc (sizeof (align_stack));
entry->alignment = maximum_field_alignment;
+ entry->mac68k = TARGET_ALIGN_MAC68K;
+ entry->natural = TARGET_ALIGN_NATURAL;
entry->prev = field_align_stack;
field_align_stack = entry;
maximum_field_alignment = bit_alignment;
+ if (mac68k_alignment)
+ rs6000_alignment_flags |= MASK_ALIGN_MAC68K;
+ else
+ rs6000_alignment_flags &= ~MASK_ALIGN_MAC68K;
+ if (natural_alignment)
+ rs6000_alignment_flags |= MASK_ALIGN_NATURAL;
+ else
+ rs6000_alignment_flags &= ~MASK_ALIGN_NATURAL;
}
+/* APPLE LOCAL end Macintosh alignment 2001-12-17 ff */
static void
pop_field_alignment (void)
@@ -74,6 +111,16 @@ pop_field_alignment (void)
align_stack *entry = field_align_stack;
maximum_field_alignment = entry->alignment;
+/* APPLE LOCAL begin Macintosh alignment 2001-12-17 ff */
+ if (entry->mac68k)
+ rs6000_alignment_flags |= MASK_ALIGN_MAC68K;
+ else
+ rs6000_alignment_flags &= ~MASK_ALIGN_MAC68K;
+ if (entry->natural)
+ rs6000_alignment_flags |= MASK_ALIGN_NATURAL;
+ else
+ rs6000_alignment_flags &= ~MASK_ALIGN_NATURAL;
+/* APPLE LOCAL end Macintosh alignment 2001-12-17 ff */
field_align_stack = entry->prev;
free (entry);
}
@@ -111,15 +158,85 @@ darwin_pragma_options (cpp_reader *pfile ATTRIBUTE_UNUSED)
warning ("junk at end of '#pragma options'");
arg = IDENTIFIER_POINTER (t);
+/* APPLE LOCAL begin Macintosh alignment 2002-1-22 ff */
if (!strcmp (arg, "mac68k"))
- push_field_alignment (16);
+ push_field_alignment (0, 1, 0);
+ else if (!strcmp (arg, "native")) /* equivalent to power on PowerPC */
+ push_field_alignment (0, 0, 0);
+ else if (!strcmp (arg, "natural"))
+ push_field_alignment (0, 0, 1);
+ else if (!strcmp (arg, "packed"))
+ push_field_alignment (8, 0, 0);
else if (!strcmp (arg, "power"))
- push_field_alignment (0);
+ push_field_alignment (0, 0, 0);
else if (!strcmp (arg, "reset"))
pop_field_alignment ();
else
- warning ("malformed '#pragma options align={mac68k|power|reset}', ignoring");
+ warning ("malformed '#pragma options align={mac68k|power|natural|reset}', ignoring");
+/* APPLE LOCAL end Macintosh alignment 2002-1-22 ff */
+}
+
+/* APPLE LOCAL begin Macintosh alignment 2002-1-22 ff */
+/* #pragma pack ()
+ #pragma pack (N)
+
+ We have a problem handling the semantics of these directives since,
+ to play well with the Macintosh alignment directives, we want the
+ usual pack(N) form to do a push of the previous alignment state.
+ Do we want pack() to do another push or a pop? */
+
+void
+darwin_pragma_pack (pfile)
+ cpp_reader *pfile ATTRIBUTE_UNUSED;
+{
+ tree x;
+ int align = -1;
+ enum cpp_ttype token;
+ enum { set, push, pop } action;
+
+ if (c_lex (&x) != CPP_OPEN_PAREN)
+ BAD ("missing '(' after '#pragma pack' - ignored");
+ token = c_lex (&x);
+ if (token == CPP_CLOSE_PAREN)
+ {
+ action = pop; /* or "set" ??? */
+ align = 0;
+ }
+ else if (token == CPP_NUMBER)
+ {
+ align = TREE_INT_CST_LOW (x);
+ action = push;
+ if (c_lex (&x) != CPP_CLOSE_PAREN)
+ BAD ("malformed '#pragma pack' - ignored");
+ }
+ else
+ BAD ("malformed '#pragma pack' - ignored");
+
+ if (c_lex (&x) != CPP_EOF)
+ warning ("junk at end of '#pragma pack'");
+
+ switch (align)
+ {
+ case 0:
+ case 1:
+ case 2:
+ case 4:
+ case 8:
+ case 16:
+ align *= BITS_PER_UNIT;
+ break;
+ default:
+ BAD2 ("alignment must be a small power of two, not %d", align);
+ }
+
+ switch (action)
+ {
+ case pop: pop_field_alignment (); break;
+ case push: push_field_alignment (align, 0, 0); break;
+ case set: break;
+ }
}
+/* APPLE LOCAL end Macintosh alignment 2002-1-22 ff */
/* #pragma unused ([var {, var}*]) */
@@ -464,3 +581,101 @@ find_subframework_header (cpp_reader *pfile, const char *header)
}
struct target_c_incpath_s target_c_incpath = C_INCPATH_INIT;
+
+/* APPLE LOCAL begin CALL_ON_LOAD/CALL_ON_UNLOAD pragmas 20020202 turly */
+extern void mod_init_section (void), mod_term_section (void);
+/* Grab the function name from the pragma line and output it to the
+ assembly output file with the parameter DIRECTIVE. Called by the
+ pragma CALL_ON_LOAD and CALL_ON_UNLOAD handlers below.
+ So: "#pragma CALL_ON_LOAD foo" will output ".mod_init_func _foo". */
+
+static void directive_with_named_function (
+ const char *pragma_name,
+ void (*section_function) (void))
+{
+ tree decl;
+ int tok;
+
+ tok = c_lex (&decl);
+ if (tok == CPP_NAME && decl)
+ {
+ extern FILE *asm_out_file;
+
+ section_function ();
+ fprintf (asm_out_file, "\t.long _%s\n", IDENTIFIER_POINTER (decl));
+
+ if (c_lex (&decl) != CPP_EOF)
+ warning ("junk at end of #pragma %s <function_name>\n", pragma_name);
+ }
+ else
+ warning ("function name expected after #pragma %s\n", pragma_name);
+}
+void
+darwin_pragma_call_on_load (pfile)
+ cpp_reader *pfile ATTRIBUTE_UNUSED;
+{
+ directive_with_named_function ("CALL_ON_LOAD", mod_init_section);
+}
+void
+darwin_pragma_call_on_unload (pfile)
+ cpp_reader *pfile ATTRIBUTE_UNUSED;
+{
+ directive_with_named_function ("CALL_ON_UNLOAD", mod_term_section);
+}
+/* APPLE LOCAL end CALL_ON_LOAD/CALL_ON_UNLOAD pragmas 20020202 turly */
+
+/* APPLE LOCAL begin CALL_ON_MODULE_BIND deprecated 2002-4-10 ff */
+void
+darwin_pragma_call_on_module_bind (pfile)
+ cpp_reader *pfile ATTRIBUTE_UNUSED;
+{
+ warning ("#pragma CALL_ON_MODULE_BIND is no longer supported, ignoring. "
+ "Use CALL_ON_LOAD instead.");
+}
+/* APPLE LOCAL end CALL_ON_MODULE_BIND deprecated 2002-4-10 ff */
+
+/* APPLE LOCAL begin temporary pragmas 2001-07-05 sts */
+/* These need to live only long enough to get their uses flushed out
+ of the system. */
+void
+darwin_pragma_cc_no_mach_text_sections (pfile)
+ cpp_reader *pfile ATTRIBUTE_UNUSED;
+{
+ warning ("#pragma CC_NO_MACH_TEXT_SECTIONS is no longer supported, ignoring");
+}
+
+void
+darwin_pragma_cc_opt_off (pfile)
+ cpp_reader *pfile ATTRIBUTE_UNUSED;
+{
+ warning ("#pragma CC_OPT_OFF is no longer supported, ignoring");
+}
+
+void
+darwin_pragma_cc_opt_on (pfile)
+ cpp_reader *pfile ATTRIBUTE_UNUSED;
+{
+ warning ("#pragma CC_OPT_ON is no longer supported, ignoring");
+}
+
+void
+darwin_pragma_cc_opt_restore (pfile)
+ cpp_reader *pfile ATTRIBUTE_UNUSED;
+{
+ warning ("#pragma CC_OPT_RESTORE is no longer supported, ignoring");
+}
+
+void
+darwin_pragma_cc_writable_strings (pfile)
+ cpp_reader *pfile ATTRIBUTE_UNUSED;
+{
+ warning ("#pragma CC_WRITABLE_STRINGS is no longer supported, ignoring");
+}
+
+void
+darwin_pragma_cc_non_writable_strings (pfile)
+ cpp_reader *pfile ATTRIBUTE_UNUSED;
+{
+ warning ("#pragma CC_NON_WRITABLE_STRINGS is no longer supported, ignoring");
+}
+/* APPLE LOCAL end temporary pragmas 2001-07-05 sts */
diff --git a/gcc/config/darwin-protos.h b/gcc/config/darwin-protos.h
index 28660339488..21426971c23 100644
--- a/gcc/config/darwin-protos.h
+++ b/gcc/config/darwin-protos.h
@@ -25,6 +25,8 @@ extern void machopic_validate_stub_or_non_lazy_ptr (const char *, int);
extern const char *machopic_function_base_name (void);
extern void machopic_output_function_base_name (FILE *);
extern const char *machopic_stub_name (const char*);
+/* APPLE LOCAL coalescing */
+extern int machopic_var_referred_to_p (const char*);
extern void machopic_picsymbol_stub_section (void);
extern void machopic_picsymbol_stub1_section (void);
@@ -75,6 +77,34 @@ extern void darwin_pragma_ignore (struct cpp_reader *);
extern void darwin_pragma_options (struct cpp_reader *);
extern void darwin_pragma_unused (struct cpp_reader *);
+/* APPLE LOCAL begin Macintosh alignment 2002-1-22 ff */
+extern void darwin_pragma_pack (struct cpp_reader *);
+/* APPLE LOCAL end Macintosh alignment 2002-1-22 ff */
+/* APPLE LOCAL begin CALL_ON_LOAD/CALL_ON_UNLOAD pragmas 20020202 turly */
+extern void darwin_pragma_call_on_load (struct cpp_reader *);
+extern void darwin_pragma_call_on_unload (struct cpp_reader *);
+/* APPLE LOCAL end CALL_ON_LOAD/CALL_ON_UNLOAD pragmas 20020202 turly */
+/* APPLE LOCAL begin CALL_ON_MODULE_BIND deprecated 2002-4-10 ff */
+extern void darwin_pragma_call_on_module_bind (struct cpp_reader *);
+/* APPLE LOCAL end CALL_ON_MODULE_BIND deprecated 2002-4-10 ff */
+/* APPLE LOCAL begin temporary pragmas 2001-07-05 sts */
+extern void darwin_pragma_cc_no_mach_text_sections (struct cpp_reader *);
+extern void darwin_pragma_cc_opt_off (struct cpp_reader *);
+extern void darwin_pragma_cc_opt_on (struct cpp_reader *);
+extern void darwin_pragma_cc_opt_restore (struct cpp_reader *);
+extern void darwin_pragma_cc_writable_strings (struct cpp_reader *);
+extern void darwin_pragma_cc_non_writable_strings (struct cpp_reader *);
+/* APPLE LOCAL end temporary pragmas 2001-07-05 sts */
+
+/* APPLE LOCAL begin coalescing */
+extern void darwin_asm_named_section (const char *, unsigned int);
+extern unsigned int darwin_section_type_flags (tree, const char *, int);
+extern int darwin_set_section_for_var_p (tree, int, int);
+/* APPLE LOCAL end coalescing */
+
+/* APPLE LOCAL double destructor */
+extern tree darwin_handle_odd_attribute (tree *, tree, tree, int, bool *);
+
extern void darwin_file_end (void);
/* Expanded by EXTRA_SECTION_FUNCTIONS into varasm.o. */
@@ -108,6 +138,8 @@ extern void objc_class_names_section (void);
extern void objc_meth_var_names_section (void);
extern void objc_meth_var_types_section (void);
extern void objc_cls_refs_section (void);
+/* APPLE LOCAL constant cfstrings */
+extern void cfstring_constant_object_section (void);
extern void machopic_lazy_symbol_ptr_section (void);
extern void machopic_nl_symbol_ptr_section (void);
extern void machopic_symbol_stub_section (void);
@@ -119,3 +151,6 @@ extern void darwin_globalize_label (FILE *, const char *);
extern void darwin_assemble_visibility (tree, int);
extern void darwin_asm_output_dwarf_delta (FILE *, int, const char *,
const char *);
+/* APPLE LOCAL C++ EH */
+extern void darwin_non_lazy_pcrel (FILE *file, rtx addr);
+
diff --git a/gcc/config/darwin.c b/gcc/config/darwin.c
index 858d150d45e..cc213a49388 100644
--- a/gcc/config/darwin.c
+++ b/gcc/config/darwin.c
@@ -46,7 +46,57 @@ Boston, MA 02111-1307, USA. */
static int machopic_data_defined_p (const char *);
static void update_non_lazy_ptrs (const char *);
static void update_stubs (const char *);
-static const char *machopic_non_lazy_ptr_name (const char*);
+const char *machopic_non_lazy_ptr_name (const char*);
+
+/* APPLE LOCAL prototypes */
+static tree machopic_non_lazy_ptr_list_entry PARAMS ((const char*, int));
+static tree machopic_stub_list_entry PARAMS ((const char *));
+
+/* APPLE LOCAL begin coalescing */
+void
+make_decl_coalesced (decl, private_extern_p)
+ tree decl;
+ int private_extern_p; /* 0 for global, 1 for private extern */
+{
+ int no_toc_p = 1; /* Don't add to table of contents */
+#if 0
+ const char *decl_name = IDENTIFIER_POINTER (DECL_ASSEMBLER_NAME (decl));
+#endif
+ static const char *const names[4] = {
+ "__TEXT,__textcoal,coalesced",
+ "__TEXT,__textcoal_nt,coalesced,no_toc",
+ "__DATA,__datacoal,coalesced",
+ "__DATA,__datacoal_nt,coalesced,no_toc",
+ };
+ const char *sec;
+ int idx;
+
+ /* Do nothing if coalescing is disabled. */
+ if (!COALESCING_ENABLED_P())
+ return;
+
+ /* We *do* need to mark these *INTERNAL* functions coalesced: though
+ these pseudo-functions themselves will never appear, their cloned
+ descendants need to be marked coalesced too. */
+#if 0
+ /* Don't touch anything with " *INTERNAL" in its name. */
+ if (strstr (decl_name, " *INTERNAL") != NULL)
+ return;
+#endif
+
+ DECL_COALESCED (decl) = 1;
+ if (private_extern_p)
+ DECL_VISIBILITY (decl) = VISIBILITY_HIDDEN;
+ TREE_PUBLIC (decl) = 1;
+
+ idx = 0;
+ if (TREE_CODE (decl) != FUNCTION_DECL)
+ idx = 2;
+ sec = names[idx + (no_toc_p ? 1 : 0)];
+
+ DECL_SECTION_NAME (decl) = build_string (strlen (sec), sec);
+}
+/* APPLE LOCAL end coalescing */
int
name_needs_quotes (const char *name)
@@ -187,6 +237,14 @@ machopic_ident_defined_p (tree ident)
static int
machopic_data_defined_p (const char *name)
{
+ /* APPLE LOCAL BEGIN fix-and-continue mrs */
+#ifndef TARGET_INDIRECT_ALL_DATA
+#define TARGET_INDIRECT_ALL_DATA 0
+#endif
+ if (TARGET_INDIRECT_ALL_DATA)
+ return 0;
+ /* APPLE LOCAL END fix-and-continue mrs */
+
switch (machopic_classify_ident (get_identifier (name)))
{
case MACHOPIC_DEFINED_DATA:
@@ -264,18 +322,19 @@ static GTY(()) tree machopic_non_lazy_pointers;
either by finding it in our list of pointer names, or by generating
a new one. */
-static const char *
-machopic_non_lazy_ptr_name (const char *name)
+/* APPLE LOCAL weak import */
+/* machopic_non_lazy_ptr_list_entry separated from machopic_non_lazy_ptr_name */
+static tree
+machopic_non_lazy_ptr_list_entry (const char *name, int create_p)
{
- const char *temp_name;
- tree temp, ident = get_identifier (name);
-
+ tree temp, ident = (create_p) ? get_identifier (name) : NULL;
+
for (temp = machopic_non_lazy_pointers;
temp != NULL_TREE;
temp = TREE_CHAIN (temp))
{
if (ident == TREE_VALUE (temp))
- return IDENTIFIER_POINTER (TREE_PURPOSE (temp));
+ return temp;
}
name = darwin_strip_name_encoding (name);
@@ -287,14 +346,14 @@ machopic_non_lazy_ptr_name (const char *name)
{
if (TREE_VALUE (temp))
{
- temp_name = IDENTIFIER_POINTER (TREE_VALUE (temp));
+ const char *temp_name = IDENTIFIER_POINTER (TREE_VALUE (temp));
temp_name = darwin_strip_name_encoding (temp_name);
if (strcmp (name, temp_name) == 0)
- return IDENTIFIER_POINTER (TREE_PURPOSE (temp));
+ return temp;
}
}
- {
+ if (create_p) {
char *buffer;
int namelen = strlen (name);
int bufferlen = 0;
@@ -325,17 +384,41 @@ machopic_non_lazy_ptr_name (const char *name)
TREE_USED (machopic_non_lazy_pointers) = 0;
- return IDENTIFIER_POINTER (ptr_name);
+ return machopic_non_lazy_pointers;
}
+
+ return NULL;
}
+/* APPLE LOCAL begin coalescing */
+/* Was the variable NAME ever referenced? */
+int
+machopic_var_referred_to_p (name)
+ const char *name;
+{
+ return (machopic_non_lazy_ptr_list_entry (name, /*create:*/ 0) != NULL);
+}
+/* APPLE LOCAL end coalescing */
+
+/* APPLE LOCAL begin weak import */
+const char *
+machopic_non_lazy_ptr_name (name)
+ const char *name;
+{
+ return IDENTIFIER_POINTER (TREE_PURPOSE
+ (machopic_non_lazy_ptr_list_entry (name, /*create:*/ 1)));
+}
+/* APPLE LOCAL end weak import */
+
static GTY(()) tree machopic_stubs;
/* Return the name of the stub corresponding to the given name,
generating a new stub name if necessary. */
-const char *
-machopic_stub_name (const char *name)
+/* APPLE LOCAL begin weak import */
+/* machopic_stub_list_entry separated from machopic_stub_name */
+static tree
+machopic_stub_list_entry (const char *name)
{
tree temp, ident = get_identifier (name);
const char *tname;
@@ -345,16 +428,22 @@ machopic_stub_name (const char *name)
temp = TREE_CHAIN (temp))
{
if (ident == TREE_VALUE (temp))
- return IDENTIFIER_POINTER (TREE_PURPOSE (temp));
+ return temp;
tname = IDENTIFIER_POINTER (TREE_VALUE (temp));
if (strcmp (name, tname) == 0)
- return IDENTIFIER_POINTER (TREE_PURPOSE (temp));
+ return temp;
+
+ /* APPLE LOCAL Stripped encodings ('!T_' and '!t_') should match. */
+ if (name [0] == '!' && tname[0] == '!'
+ && strcmp (name + 4, tname + 4) == 0)
+ return temp;
+
/* A library call name might not be section-encoded yet, so try
it against a stripped name. */
if (name[0] != '!'
&& tname[0] == '!'
&& strcmp (name, tname + 4) == 0)
- return IDENTIFIER_POINTER (TREE_PURPOSE (temp));
+ return temp;
}
name = darwin_strip_name_encoding (name);
@@ -406,10 +495,18 @@ machopic_stub_name (const char *name)
machopic_stubs = tree_cons (ptr_name, ident, machopic_stubs);
TREE_USED (machopic_stubs) = 0;
- return IDENTIFIER_POINTER (ptr_name);
+ return machopic_stubs;
}
}
+const char *
+machopic_stub_name (name)
+ const char *name;
+{
+ return IDENTIFIER_POINTER (TREE_PURPOSE (machopic_stub_list_entry (name)));
+}
+/* APPLE LOCAL end weak import */
+
void
machopic_validate_stub_or_non_lazy_ptr (const char *name, int validate_stub)
{
@@ -448,6 +545,8 @@ machopic_indirect_data_reference (rtx orig, rtx reg)
if (GET_CODE (orig) == SYMBOL_REF)
{
const char *name = XSTR (orig, 0);
+ /* APPLE LOCAL weak import */
+ tree sym;
int defined = machopic_data_defined_p (name);
if (defined && MACHO_DYNAMIC_NO_PIC_P)
@@ -499,8 +598,14 @@ machopic_indirect_data_reference (rtx orig, rtx reg)
return orig;
}
+ /* APPLE LOCAL weak import */
+ sym = machopic_non_lazy_ptr_list_entry (name, /*create:*/ 1);
+ IDENTIFIER_WEAK_IMPORT (TREE_PURPOSE (sym)) =
+ IDENTIFIER_WEAK_IMPORT (TREE_VALUE (sym)) =
+ SYMBOL_REF_WEAK_IMPORT (orig);
+
ptr_ref = gen_rtx_SYMBOL_REF (Pmode,
- machopic_non_lazy_ptr_name (name));
+ IDENTIFIER_POINTER (TREE_PURPOSE (sym)));
ptr_ref = gen_rtx_MEM (Pmode, ptr_ref);
RTX_UNCHANGING_P (ptr_ref) = 1;
@@ -585,9 +690,14 @@ machopic_indirect_call_target (rtx target)
if (!machopic_name_defined_p (name))
{
- const char *stub_name = machopic_stub_name (name);
-
- XEXP (target, 0) = gen_rtx_SYMBOL_REF (mode, stub_name);
+ /* APPLE LOCAL weak import */
+ tree stub = machopic_stub_list_entry (name);
+ IDENTIFIER_WEAK_IMPORT (TREE_PURPOSE (stub)) =
+ IDENTIFIER_WEAK_IMPORT (TREE_VALUE (stub)) =
+ SYMBOL_REF_WEAK_IMPORT (XEXP (target, 0));
+
+ XEXP (target, 0) = gen_rtx_SYMBOL_REF (mode,
+ IDENTIFIER_POINTER (TREE_PURPOSE (stub)));
RTX_UNCHANGING_P (target) = 1;
}
}
@@ -855,6 +965,43 @@ machopic_legitimize_pic_address (rtx orig, enum machine_mode mode, rtx reg)
if (RTX_UNCHANGING_P (base) && RTX_UNCHANGING_P (orig))
RTX_UNCHANGING_P (pic_ref) = 1;
+ /* APPLE LOCAL begin gen ADD */
+#ifdef MASK_80387
+ {
+ rtx mem, other;
+
+ if (GET_CODE (orig) == MEM) {
+ mem = orig; other = base;
+ /* Swap the kids only if there is only one MEM, and it's on the right. */
+ if (GET_CODE (base) != MEM) {
+ XEXP (pic_ref, 0) = orig;
+ XEXP (pic_ref, 1) = base;
+ }
+ }
+ else if (GET_CODE (base) == MEM) {
+ mem = base; other = orig;
+ } else
+ mem = other = NULL_RTX;
+
+ /* Both kids are MEMs. */
+ if (other && GET_CODE (other) == MEM)
+ other = force_reg (GET_MODE (other), other);
+
+ /* The x86 can't post-index a MEM; emit an ADD instruction to handle this. */
+ if (mem && GET_CODE (mem) == MEM) {
+ if ( ! reload_in_progress) {
+ rtx set = gen_rtx_SET (VOIDmode, reg, pic_ref);
+ rtx clobber_cc = gen_rtx_CLOBBER (VOIDmode, gen_rtx_REG (CCmode, FLAGS_REG));
+ pic_ref = gen_rtx_PARALLEL (VOIDmode, gen_rtvec (2, set, clobber_cc));
+ emit_insn (pic_ref);
+ pic_ref = reg;
+ is_complex = 0;
+ }
+ }
+ }
+#endif
+ /* APPLE LOCAL end gen ADD */
+
if (reg && is_complex)
{
emit_move_insn (reg, pic_ref);
@@ -871,7 +1018,12 @@ machopic_legitimize_pic_address (rtx orig, enum machine_mode mode, rtx reg)
else if (GET_CODE (orig) == MEM
&& GET_CODE (XEXP (orig, 0)) == SYMBOL_REF)
{
- rtx addr = machopic_legitimize_pic_address (XEXP (orig, 0), Pmode, reg);
+ /* APPLE LOCAL use new pseudo for temp; reusing reg confuses PRE */
+ rtx tempreg = reg;
+ rtx addr;
+ if ( !no_new_pseudos )
+ tempreg = gen_reg_rtx (Pmode);
+ addr = machopic_legitimize_pic_address (XEXP (orig, 0), Pmode, tempreg);
addr = gen_rtx_MEM (GET_MODE (orig), addr);
RTX_UNCHANGING_P (addr) = RTX_UNCHANGING_P (orig);
@@ -916,6 +1068,14 @@ machopic_finish (FILE *asm_out_file)
else
stub[0] = '_', strcpy (stub + 1, stub_name);
+ /* APPLE LOCAL weak import */
+ if ( IDENTIFIER_WEAK_IMPORT (TREE_VALUE (temp)))
+ {
+ fprintf (asm_out_file, "\t.weak_reference ");
+ assemble_name (asm_out_file, sym_name);
+ fprintf (asm_out_file, "\n");
+ }
+
machopic_output_stub (asm_out_file, sym, stub);
}
@@ -929,7 +1089,11 @@ machopic_finish (FILE *asm_out_file)
if (! TREE_USED (temp))
continue;
- if (machopic_ident_defined_p (TREE_VALUE (temp)))
+ /* APPLE LOCAL fix-and-continue mrs */
+ if (! TARGET_INDIRECT_ALL_DATA
+ && (machopic_ident_defined_p (TREE_VALUE (temp))
+ /* APPLE LOCAL private extern */
+ || (sym_name[0] == '!' && sym_name[2] == 'p')))
{
data_section ();
assemble_align (GET_MODE_ALIGNMENT (Pmode));
@@ -940,6 +1104,17 @@ machopic_finish (FILE *asm_out_file)
}
else
{
+ /* APPLE LOCAL fix-and-continue mrs */
+ rtx init = const0_rtx;
+
+ /* APPLE LOCAL weak import */
+ if ( IDENTIFIER_WEAK_IMPORT (TREE_VALUE (temp)))
+ {
+ fprintf (asm_out_file, "\t.weak_reference ");
+ assemble_name (asm_out_file, sym_name);
+ fprintf (asm_out_file, "\n");
+ }
+
machopic_nl_symbol_ptr_section ();
assemble_name (asm_out_file, lazy_name);
fprintf (asm_out_file, ":\n");
@@ -948,8 +1123,14 @@ machopic_finish (FILE *asm_out_file)
assemble_name (asm_out_file, sym_name);
fprintf (asm_out_file, "\n");
- assemble_integer (const0_rtx, GET_MODE_SIZE (Pmode),
+ /* APPLE LOCAL BEGIN fix-and-continue mrs */
+ if (sym_name[3] == 's'
+ && machopic_ident_defined_p (TREE_VALUE (temp)))
+ init = gen_rtx_SYMBOL_REF (Pmode, sym_name);
+
+ assemble_integer (init, GET_MODE_SIZE (Pmode),
GET_MODE_ALIGNMENT (Pmode), 1);
+ /* APPLE LOCAL END fix-and-continue mrs */
}
}
}
@@ -1004,11 +1185,28 @@ darwin_encode_section_info (tree decl, rtx rtl, int first ATTRIBUTE_UNUSED)
if ((TREE_CODE (decl) == FUNCTION_DECL
|| TREE_CODE (decl) == VAR_DECL)
&& !DECL_EXTERNAL (decl)
+ /* APPLE LOCAL coalescing */
+#ifdef DECL_IS_COALESCED_OR_WEAK
+ && ! DECL_IS_COALESCED_OR_WEAK (decl)
+#endif
&& ((TREE_STATIC (decl)
&& (!DECL_COMMON (decl) || !TREE_PUBLIC (decl)))
|| (DECL_INITIAL (decl)
&& DECL_INITIAL (decl) != error_mark_node)))
defined = 1;
+ /* APPLE LOCAL fix OBJC codegen */
+ if (TREE_CODE (decl) == VAR_DECL)
+ {
+ sym_ref = XEXP (DECL_RTL (decl), 0);
+ orig_str = XSTR (sym_ref, 0);
+ if ( orig_str[0] == '_'
+ && orig_str[1] == 'O'
+ && orig_str[2] == 'B'
+ && orig_str[3] == 'J'
+ && orig_str[4] == 'C'
+ && orig_str[5] == '_')
+ defined = 1;
+ }
if (TREE_CODE (decl) == FUNCTION_DECL)
code = (defined ? 'T' : 't');
@@ -1041,7 +1239,15 @@ darwin_encode_section_info (tree decl, rtx rtl, int first ATTRIBUTE_UNUSED)
new_str[0] = '!';
new_str[1] = code;
new_str[2] = '_';
+ /* APPLE LOCAL private extern */
+ if (DECL_VISIBILITY (decl) == VISIBILITY_HIDDEN)
+ new_str[2] = 'p';
new_str[3] = '_';
+ /* APPLE LOCAL BEGIN fix-and-continue mrs */
+ if (TARGET_INDIRECT_ALL_DATA
+ && TREE_CODE (decl) == VAR_DECL && ! TREE_PUBLIC (decl))
+ new_str[3] = 's';
+ /* APPLE LOCAL END fix-and-continue mrs */
memcpy (new_str + 4, orig_str, len);
XSTR (sym_ref, 0) = ggc_alloc_string (new_str, new_len);
}
@@ -1161,9 +1367,24 @@ machopic_select_section (tree exp, int reloc,
&& TREE_CODE (TREE_TYPE (exp)) == RECORD_TYPE
&& TYPE_NAME (TREE_TYPE (exp)))
{
+ /* APPLE LOCAL begin constant strings */
+ extern int flag_next_runtime;
+ extern const char *constant_string_class_name;
+ /* APPLE LOCAL end constant strings */
tree name = TYPE_NAME (TREE_TYPE (exp));
if (TREE_CODE (name) == TYPE_DECL)
name = DECL_NAME (name);
+ /* APPLE LOCAL begin constant strings */
+ if (constant_string_class_name
+ && !strcmp (IDENTIFIER_POINTER (name),
+ constant_string_class_name))
+ {
+ if (flag_next_runtime)
+ objc_constant_string_object_section ();
+ else
+ objc_string_object_section ();
+ }
+ /* APPLE LOCAL end constant strings */
if (!strcmp (IDENTIFIER_POINTER (name), "NSConstantString"))
objc_constant_string_object_section ();
else if (!strcmp (IDENTIFIER_POINTER (name), "NXConstantString"))
@@ -1171,6 +1392,26 @@ machopic_select_section (tree exp, int reloc,
else
base_function ();
}
+ /* APPLE LOCAL begin constant cfstrings */
+ else if (TREE_CODE (exp) == CONSTRUCTOR
+ && TREE_TYPE (exp)
+ && TREE_CODE (TREE_TYPE (exp)) == ARRAY_TYPE
+ && TREE_OPERAND (exp, 0))
+ {
+ tree name = TREE_OPERAND (exp, 0);
+ if (TREE_CODE (name) == TREE_LIST && TREE_VALUE (name)
+ && TREE_CODE (TREE_VALUE (name)) == NOP_EXPR
+ && TREE_OPERAND (TREE_VALUE (name), 0)
+ && TREE_OPERAND (TREE_OPERAND (TREE_VALUE (name), 0), 0))
+ name = TREE_OPERAND (TREE_OPERAND (TREE_VALUE (name), 0), 0);
+ if (TREE_CODE (name) == VAR_DECL
+ && !strcmp (IDENTIFIER_POINTER (DECL_NAME (name)),
+ "__CFConstantStringClassReference"))
+ cfstring_constant_object_section ();
+ else
+ base_function ();
+ }
+ /* APPLE LOCAL end constant cfstrings */
else if (TREE_CODE (exp) == VAR_DECL &&
DECL_NAME (exp) &&
TREE_CODE (DECL_NAME (exp)) == IDENTIFIER_NODE &&
@@ -1228,6 +1469,10 @@ machopic_select_section (tree exp, int reloc,
else
base_function ();
}
+ /* APPLE LOCAL begin darwin_set_section_for_var_p */
+ else if (darwin_set_section_for_var_p (exp, reloc, align))
+ ;
+ /* APPLE LOCAL end darwin_set_section_for_var_p */
else
base_function ();
}
@@ -1289,6 +1534,188 @@ darwin_globalize_label (FILE *stream, const char *name)
default_globalize_label (stream, name);
}
+/* APPLE LOCAL begin assembly "abort" directive */
+/* This can be called instead of EXIT. It will emit a '.abort' directive
+ into any existing assembly file, causing assembly to immediately abort,
+ thus preventing the assembler from spewing out numerous, irrelevant
+ error messages. */
+
+void
+abort_assembly_and_exit (status)
+ int status;
+{
+ /* If we're aborting, get the assembler to abort, too. */
+ if (status == FATAL_EXIT_CODE && asm_out_file != 0)
+ fprintf (asm_out_file, "\n.abort\n");
+
+ exit (status);
+}
+/* APPLE LOCAL end assembly "abort" directive */
+
+/* APPLE LOCAL coalescing */
+void
+darwin_asm_named_section (name, flags)
+ const char *name;
+ unsigned int flags ATTRIBUTE_UNUSED;
+{
+ fprintf (asm_out_file, ".section %s\n", name);
+}
+
+unsigned int
+darwin_section_type_flags (decl, name, reloc)
+ tree decl;
+ const char *name;
+ int reloc;
+{
+ unsigned int flags = default_section_type_flags (decl, name, reloc);
+
+ /* Weak or coalesced variables live in a writable section. */
+ if (decl != 0 && TREE_CODE (decl) != FUNCTION_DECL
+ && DECL_IS_COALESCED_OR_WEAK (decl))
+ flags |= SECTION_WRITE;
+
+ return flags;
+}
+/* APPLE LOCAL end coalescing */
+
+/* APPLE LOCAL begin double destructor turly 20020214 */
+#include "c-common.h"
+
+/* Handle __attribute__ ((apple_kext_compatibility)).
+ This only applies to darwin kexts for 295 compatibility -- it shrinks the
+ vtable for classes with this attribute (and their descendants) by not
+ outputting the new 3.0 nondeleting destructor. This means that such
+ objects CANNOT be allocated on the stack or as globals UNLESS they have
+ a completely empty `operator delete'.
+ Luckily, this fits in with the Darwin kext model.
+
+ This attribute also disables gcc3's potential overlaying of derived
+ class data members on the padding at the end of the base class. */
+
+tree
+darwin_handle_odd_attribute (node, name, args, flags, no_add_attrs)
+ tree *node;
+ tree name;
+ tree args ATTRIBUTE_UNUSED;
+ int flags ATTRIBUTE_UNUSED;
+ bool *no_add_attrs;
+{
+ if (! POSSIBLY_COMPILING_APPLE_KEXT_P ())
+ {
+ warning ("`%s' 2.95 vtable-compatability attribute applies "
+ "only when compiling a kext", IDENTIFIER_POINTER (name));
+
+ *no_add_attrs = true;
+ }
+ else if (TREE_CODE (*node) != RECORD_TYPE)
+ {
+ warning ("`%s' 2.95 vtable-compatability attribute applies "
+ "only to C++ classes", IDENTIFIER_POINTER (name));
+
+ *no_add_attrs = true;
+ }
+
+ return NULL_TREE;
+}
+/* APPLE LOCAL end double destructor turly 20020214 */
+
+/* APPLE LOCAL begin darwin_set_section_for_var_p turly 20020226 */
+
+/* This is specifically for any initialised static class constants
+ which may be output by the C++ front end at the end of compilation.
+ SELECT_SECTION () macro won't do because these are VAR_DECLs, not
+ STRING_CSTs or INTEGER_CSTs. And by putting 'em in appropriate
+ sections, we save space. */
+
+extern void cstring_section (void),
+ literal4_section (void), literal8_section (void);
+int
+darwin_set_section_for_var_p (exp, reloc, align)
+ tree exp;
+ int reloc;
+ int align;
+{
+ if (!reloc && TREE_CODE (exp) == VAR_DECL
+ && DECL_ALIGN (exp) == align
+ && TREE_READONLY (exp) && DECL_INITIAL (exp))
+ {
+ /* Put constant string vars in ".cstring" section. */
+
+ if (TREE_CODE (TREE_TYPE (exp)) == ARRAY_TYPE
+ && TREE_CODE (TREE_TYPE (TREE_TYPE (exp))) == INTEGER_TYPE
+ && integer_onep (TYPE_SIZE_UNIT (TREE_TYPE (TREE_TYPE (exp))))
+ && TREE_CODE (DECL_INITIAL (exp)) == STRING_CST)
+ {
+
+ /* Compare string length with actual number of characters
+ the compiler will write out (which is not necessarily
+ TREE_STRING_LENGTH, in the case of a constant array of
+ characters that is not null-terminated). Select appropriate
+ section accordingly. */
+
+ if (MIN ( TREE_STRING_LENGTH (DECL_INITIAL(exp)),
+ int_size_in_bytes (TREE_TYPE (exp)))
+ == (long) strlen (TREE_STRING_POINTER (DECL_INITIAL (exp))) + 1)
+ {
+ cstring_section ();
+ return 1;
+ }
+ else
+ {
+ const_section ();
+ return 1;
+ }
+ }
+ else
+ if (TREE_READONLY (TREE_TYPE (exp))
+ && ((TREE_CODE (TREE_TYPE (exp)) == INTEGER_TYPE
+ && TREE_CODE (DECL_INITIAL (exp)) == INTEGER_CST)
+ || (TREE_CODE (TREE_TYPE (exp)) == REAL_TYPE
+ && TREE_CODE (DECL_INITIAL (exp)) == REAL_CST))
+ && TREE_CODE (TYPE_SIZE_UNIT (TREE_TYPE (DECL_INITIAL (exp))))
+ == INTEGER_CST)
+ {
+ tree size = TYPE_SIZE_UNIT (TREE_TYPE (DECL_INITIAL (exp)));
+ if (TREE_INT_CST_HIGH (size) != 0)
+ return 0;
+
+ /* Put integer and float consts in the literal4|8 sections. */
+
+ if (TREE_INT_CST_LOW (size) == 4)
+ {
+ literal4_section ();
+ return 1;
+ }
+ else if (TREE_INT_CST_LOW (size) == 8)
+ {
+ literal8_section ();
+ return 1;
+ }
+ }
+ }
+ return 0;
+}
+/* APPLE LOCAL end darwin_set_section_for_var_p turly 20020226 */
+
+/* APPLE LOCAL begin C++ EH */
+/* Generate a PC-relative reference to a Mach-O non-lazy-symbol. */
+void
+darwin_non_lazy_pcrel (FILE *file, rtx addr)
+{
+ const char *str;
+ const char *nlp_name;
+
+ if (GET_CODE (addr) != SYMBOL_REF)
+ abort ();
+
+ str = darwin_strip_name_encoding (XSTR (addr, 0));
+ nlp_name = machopic_non_lazy_ptr_name (str);
+ fputs ("\t.long\t", file);
+ ASM_OUTPUT_LABELREF (file, nlp_name);
+ fputs ("-.", file);
+}
+/* APPLE LOCAL end C++ EH */
+
/* Emit an assembler directive to set visibility for a symbol. The
only supported visibilities are VISIBILITY_DEFAULT and
VISIBILITY_HIDDEN; the latter corresponds to Darwin's "private
diff --git a/gcc/config/darwin.h b/gcc/config/darwin.h
index b5dae39e967..17bd0fabb1f 100644
--- a/gcc/config/darwin.h
+++ b/gcc/config/darwin.h
@@ -82,6 +82,16 @@ Boston, MA 02111-1307, USA. */
#undef DEFAULT_PCC_STRUCT_RETURN
#define DEFAULT_PCC_STRUCT_RETURN 0
+/* APPLE LOCAL framework headers */
+/* Need to look for framework headers. */
+#define FRAMEWORK_HEADERS
+
+/* APPLE LOCAL begin -Wfour-char-constants */
+/* Don't warn about MacOS-style 'APPL' four-char-constants. */
+#undef WARN_FOUR_CHAR_CONSTANTS
+#define WARN_FOUR_CHAR_CONSTANTS 0
+/* APPLE LOCAL end -Wfour-char-constants */
+
/* This table intercepts weirdo options whose names would interfere
with normal driver conventions, and either translates them into
standardly-named options, or adds a 'Z' so that they can get to
@@ -181,9 +191,16 @@ Boston, MA 02111-1307, USA. */
isn't. */
#undef CPP_SPEC
-#define CPP_SPEC "%{static:%{!dynamic:-D__STATIC__}}%{!static:-D__DYNAMIC__}\
- -D__APPLE_CC__=1"
+/* APPLE LOCAL -precomp-trustfile, -arch */
+/* APPLE LOCAL __APPLE__ setting, don't set __APPLE__ here, as we do it someplace else */
+#define CPP_SPEC "%{static:%{!dynamic:-D__STATIC__}}%{!static:-D__DYNAMIC__} \
+ %{precomp-trustfile} %{arch}"
+
+/* APPLE LOCAL cc1plus spec */
+#undef CC1PLUS_SPEC
+#define CC1PLUS_SPEC "-D__private_extern__=extern"
+/* APPLE LOCAL begin fat builds */
/* This is mostly a clone of the standard LINK_COMMAND_SPEC, plus
precomp, libtool, and fat build additions. Also we
don't specify a second %G after %L because libSystem is
@@ -193,10 +210,10 @@ Boston, MA 02111-1307, USA. */
specifying the handling of options understood by generic Unix
linkers, and for positional arguments like libraries. */
#define LINK_COMMAND_SPEC "\
-%{!fdump=*:%{!fsyntax-only:%{!precomp:%{!c:%{!M:%{!MM:%{!E:%{!S:\
+%{!foutput-dbg*:%{!fdump=*:%{!fsyntax-only:%{!precomp:%{!c:%{!M:%{!MM:%{!E:%{!S:\
%{!Zdynamiclib:%(linker)}%{Zdynamiclib:/usr/bin/libtool} \
- %{!Zdynamiclib:-arch %(darwin_arch)} \
- %{Zdynamiclib:-arch_only %(darwin_arch)} \
+ %{!Zdynamiclib:-arch %T %{@:-arch_multiple}} \
+ %{Zdynamiclib:-arch_only %T} \
%l %X %{d} %{s} %{t} %{Z} \
%{!Zdynamiclib:%{A} %{e*} %{m} %{N} %{n} %{r} %{u*} %{x} %{z}} \
%{@:-o %f%u.out}%{!@:%{o*}%{!o:-o a.out}} \
@@ -204,7 +221,15 @@ Boston, MA 02111-1307, USA. */
%{L*} %(link_libgcc) %o %{fprofile-arcs|fprofile-generate:-lgcov} \
%{!nostdlib:%{!nodefaultlibs:%G %L}} \
%{!A:%{!nostdlib:%{!nostartfiles:%E}}} %{T*} %{F*} \
- %{!--help:%{!no-c++filt|c++filt:| c++filt3 }} }}}}}}}}"
+ %{!--help:%{!no-c++filt|c++filt:| c++filt3 }} }}}}}}}}}"
+
+/* Note that the linker
+ output is always piped through c++filt (unless -no-c++filt is
+ specified) to ensure error messages have demangled C++ names.
+ We do this even for C. */
+/* nice idea, needs some work
+ "%{!no-c++filt|c++filt:| " STANDARD_BINDIR_PREFIX cppfilt " }}}}}}}}" */
+/* APPLE LOCAL end fat builds */
/* Please keep the random linker options in alphabetical order (modulo
'Z' and 'no' prefixes). Options that can only go to one of libtool
@@ -234,7 +259,6 @@ Boston, MA 02111-1307, USA. */
%{client_name*:%e-client_name not allowed with -dynamiclib} \
%{compatibility_version*} \
%{current_version*} \
- %{Zforce_cpusubtype_ALL:%e-force_cpusubtype_ALL not allowed with -dynamiclib} \
%{Zforce_flat_namespace:%e-force_flat_namespace not allowed with -dynamiclib} \
%{Zinstall_name*:-install_name %*} \
%{keep_private_externs:%e-keep_private_externs not allowed with -dynamiclib} \
@@ -279,6 +303,16 @@ Boston, MA 02111-1307, USA. */
#undef LIB_SPEC
#define LIB_SPEC "%{!static:-lSystem}"
+/* APPLE LOCAL begin radar 3554191 and 3127145 */
+#undef LIBGCC_SPEC
+#undef REAL_LIBGCC_SPEC
+#define REAL_LIBGCC_SPEC \
+ "%{static:-lgcc_static} \
+ %{!static:%{static-libgcc:-lgcc -lgcc_eh} \
+ %{!static-libgcc:%{shared-libgcc:-lgcc_s%M -lgcc} \
+ %{!shared-libgcc:-lgcc -lgcc_eh}}}"
+/* APPLE LOCAL end radar 3554191 and 3127145 */
+
/* We specify crt0.o as -lcrt0.o so that ld will search the library path. */
#undef STARTFILE_SPEC
@@ -302,6 +336,29 @@ Boston, MA 02111-1307, USA. */
#define DBX_DEBUGGING_INFO 1
+/* APPLE LOCAL dwarf */
+/* Also enable Dwarf 2 as an option. */
+#define DWARF2_DEBUGGING_INFO
+#define PREFERRED_DEBUGGING_TYPE DBX_DEBUG
+
+#define DEBUG_FRAME_SECTION "__DWARFXA,__debug_frame"
+#define DEBUG_INFO_SECTION "__DWARFXA,__debug_info"
+#define DEBUG_ABBREV_SECTION "__DWARFXA,__debug_abbrev"
+#define DEBUG_ARANGES_SECTION "__DWARFXA,__debug_aranges"
+#define DEBUG_MACINFO_SECTION "__DWARFXA,__debug_macinfo"
+#define DEBUG_LINE_SECTION "__DWARFXA,__debug_line"
+#define DEBUG_LOC_SECTION "__DWARFXA,__debug_loc"
+#define DEBUG_PUBNAMES_SECTION "__DWARFXA,__debug_pubnames"
+#define DEBUG_STR_SECTION "__DWARFXA,__debug_str"
+#define DEBUG_RANGES_SECTION "__DWARFXA,__debug_ranges"
+/* APPLE LOCAL end dwarf */
+
+/* APPLE LOCAL begin gdb only used symbols */
+/* Support option to generate stabs for only used symbols. */
+
+#define DBX_ONLY_USED_SYMBOLS
+/* APPLE LOCAL end gdb only used symbols */
+
/* When generating stabs debugging, use N_BINCL entries. */
#define DBX_USE_BINCL
@@ -326,6 +383,9 @@ do { text_section (); \
#undef INIT_SECTION_ASM_OP
#define INIT_SECTION_ASM_OP
+/* APPLE LOCAL static structors in __StaticInit section */
+#define STATIC_INIT_SECTION "__TEXT,__StaticInit,regular,pure_instructions"
+
#undef INVOKE__main
#define TARGET_ASM_CONSTRUCTOR machopic_asm_out_constructor
@@ -374,9 +434,11 @@ do { text_section (); \
&& (!DECL_COMMON (DECL) || !TREE_PUBLIC (DECL))) \
|| DECL_INITIAL (DECL)) \
machopic_define_name (xname); \
- if ((TREE_STATIC (DECL) \
- && (!DECL_COMMON (DECL) || !TREE_PUBLIC (DECL))) \
- || DECL_INITIAL (DECL)) \
+ /* APPLE LOCAL coalescing */ \
+ if (! DECL_IS_COALESCED_OR_WEAK (DECL) \
+ && ((TREE_STATIC (DECL) \
+ && (!DECL_COMMON (DECL) || !TREE_PUBLIC (DECL))) \
+ || DECL_INITIAL (DECL))) \
(* targetm.encode_section_info) (DECL, DECL_RTL (DECL), false); \
ASM_OUTPUT_LABEL (FILE, xname); \
/* Darwin doesn't support zero-size objects, so give them a \
@@ -390,7 +452,9 @@ do { text_section (); \
const char *xname = NAME; \
if (GET_CODE (XEXP (DECL_RTL (DECL), 0)) != SYMBOL_REF) \
xname = IDENTIFIER_POINTER (DECL_NAME (DECL)); \
- if ((TREE_STATIC (DECL) \
+ /* APPLE LOCAL coalescing */ \
+ if (! DECL_IS_COALESCED_OR_WEAK (DECL)) \
+ if ((TREE_STATIC (DECL) \
&& (!DECL_COMMON (DECL) || !TREE_PUBLIC (DECL))) \
|| DECL_INITIAL (DECL)) \
machopic_define_name (xname); \
@@ -428,7 +492,12 @@ do { text_section (); \
machopic_validate_stub_or_non_lazy_ptr (xname, 1); \
else if (len > 14 && !strcmp ("$non_lazy_ptr", xname + len - 13)) \
machopic_validate_stub_or_non_lazy_ptr (xname, 0); \
- fputs (&xname[1], FILE); \
+ /* APPLE LOCAL begin Objective-C++ */ \
+ if (xname[1] != '"' && name_needs_quotes (&xname[1])) \
+ fprintf (FILE, "\"%s\"", &xname[1]); \
+ else \
+ fputs (&xname[1], FILE); \
+ /* APPLE LOCAL end Objective-C++ */ \
} \
else if (xname[0] == '+' || xname[0] == '-') \
fprintf (FILE, "\"%s\"", xname); \
@@ -436,6 +505,10 @@ do { text_section (); \
fprintf (FILE, "L%s", xname); \
else if (!strncmp (xname, ".objc_class_name_", 17)) \
fprintf (FILE, "%s", xname); \
+ /* APPLE LOCAL begin Objective-C++ */ \
+ else if (xname[0] != '"' && name_needs_quotes (xname)) \
+ fprintf (FILE, "\"%s\"", xname); \
+ /* APPLE LOCAL end Objective-C++ */ \
else \
fprintf (FILE, "_%s", xname); \
} while (0)
@@ -516,6 +589,8 @@ FUNCTION (void) \
in_objc_symbols, in_objc_module_info, \
in_objc_protocol, in_objc_string_object, \
in_objc_constant_string_object, \
+ /* APPLE LOCAL constant cfstrings */ \
+ in_cfstring_constant_object, \
in_objc_image_info, \
in_objc_class_names, in_objc_meth_var_names, \
in_objc_meth_var_types, in_objc_cls_refs, \
@@ -606,6 +681,14 @@ SECTION_FUNCTION (objc_string_object_section, \
SECTION_FUNCTION (objc_constant_string_object_section, \
in_objc_constant_string_object, \
".section __OBJC, __cstring_object", 1) \
+/* APPLE LOCAL begin constant cfstrings */ \
+/* Unlike constant NSStrings, constant CFStrings do not live */\
+/* in the __OBJC segment since they may also occur in pure C */\
+/* or C++ programs. */\
+SECTION_FUNCTION (cfstring_constant_object_section, \
+ in_cfstring_constant_object, \
+ ".section __DATA, __cfstring", 0) \
+/* APPLE LOCAL end constant cfstrings */ \
/* Fix-and-Continue image marker. */ \
SECTION_FUNCTION (objc_image_info_section, \
in_objc_image_info, \
@@ -646,7 +729,8 @@ SECTION_FUNCTION (darwin_exception_section, \
".section __DATA,__gcc_except_tab", 0) \
SECTION_FUNCTION (darwin_eh_frame_section, \
in_darwin_eh_frame, \
- ".section __TEXT,__eh_frame", 0) \
+ /* APPLE LOCAL eh in data segment */ \
+ ".section " EH_FRAME_SECTION_NAME ",__eh_frame" EH_FRAME_SECTION_ATTR, 0) \
\
static void \
objc_section_init (void) \
@@ -714,6 +798,13 @@ objc_section_init (void) \
#define GLOBAL_ASM_OP ".globl "
#define TARGET_ASM_GLOBALIZE_LABEL darwin_globalize_label
+/* APPLE LOCAL begin weak definition */
+#define ASM_WEAK_DEFINITIONIZE_LABEL(FILE, NAME) \
+ do { const char* _x = (NAME); if (!!strncmp (_x, "_OBJC_", 6)) { \
+ fputs (".weak_definition ", FILE); assemble_name (FILE, _x); \
+ fputs ("\n", FILE); }} while (0)
+/* APPLE LOCAL end weak definition */
+
/* Emit an assembler directive to set visibility for a symbol. Used
to support visibility attribute and Darwin's private extern
feature. */
@@ -754,6 +845,11 @@ enum machopic_addr_class {
#undef TARGET_STRIP_NAME_ENCODING
#define TARGET_STRIP_NAME_ENCODING darwin_strip_name_encoding
+/* APPLE LOCAL what is this for? */
+/* Be conservative and always redo the encoding. */
+
+#define REDO_SECTION_INFO_P(DECL) (1)
+
#define GEN_BINDER_NAME_FOR_STUB(BUF,STUB,STUB_LENGTH) \
do { \
const char *const stub_ = (STUB); \
@@ -823,21 +919,235 @@ enum machopic_addr_class {
#define ASM_OUTPUT_DWARF_DELTA(FILE,SIZE,LABEL1,LABEL2) \
darwin_asm_output_dwarf_delta (FILE, SIZE, LABEL1, LABEL2)
-#define TARGET_TERMINATE_DW2_EH_FRAME_INFO false
+/* APPLE LOCAL begin coalescing */
+/* The __eh_frame section attributes: a "normal" section by default. */
+#define EH_FRAME_SECTION_ATTR /*nothing*/
+
+/* The only EH item we can't do PC-relative is the reference to
+ __gxx_personality_v0. So we cheat, since moving the __eh_frame section
+ to the DATA segment is expensive.
+ We output a 4-byte encoding - including the last 2 chars of the
+ personality function name: {0, 'g', 'v', '0', 0xff}
+ (The first zero byte coincides with the "absolute" encoding.)
+ This means we can now use DW_EH_PE_pcrel for everything. And there
+ was much rejoicing. */
+
+#define EH_FRAME_SECTION_NAME "__TEXT"
+
+#define COALESCED_UNWIND_INFO
+
+#ifdef COALESCED_UNWIND_INFO
+#undef EH_FRAME_SECTION_ATTR
+#define EH_FRAME_SECTION_ATTR ",coalesced,no_toc+strip_static_syms"
+
+
+/* Implicit or explicit template instantiations' EH info are GLOBAL
+ symbols. ("Implicit" here implies "coalesced".)
+ Note that .weak_definition is commented out until 'as' supports it. */
+
+
+#define APPLE_ASM_WEAK_DEF_FMT_STRING(LAB) \
+ (name_needs_quotes(LAB) ? ".weak_definition \"%s.eh\"\n" : ".weak_definition %s.eh\n")
-#define DARWIN_REGISTER_TARGET_PRAGMAS() \
+#define ASM_OUTPUT_COAL_UNWIND_LABEL(FILE, LAB, COAL, PUBLIC, PRIVATE_EXTERN) \
+ do { \
+ if ((COAL) || (PUBLIC) || (PRIVATE_EXTERN)) \
+ fprintf ((FILE), \
+ (name_needs_quotes(LAB) ? "%s \"%s.eh\"\n" : "%s %s.eh\n"), \
+ ((PUBLIC) ? ".globl" : ".private_extern"), \
+ (LAB)); \
+ if (COAL) \
+ fprintf ((FILE), \
+ APPLE_ASM_WEAK_DEF_FMT_STRING(LAB), \
+ (LAB)); \
+ fprintf ((FILE), \
+ (name_needs_quotes(LAB) ? "\"%s.eh\":\n" : "%s.eh:\n"), \
+ (LAB)); \
+ } while (0)
+
+#endif /* COALESCED_UNWIND_INFO */
+
+#define ASM_MAYBE_OUTPUT_ENCODED_ADDR_RTX(ASM_OUT_FILE, ENCODING, SIZE, ADDR, DONE) \
+ if (ENCODING == ASM_PREFERRED_EH_DATA_FORMAT (2, 1)) { \
+ darwin_non_lazy_pcrel (ASM_OUT_FILE, ADDR); \
+ goto DONE; \
+ }
+/* APPLE LOCAL end coalescing */
+
+/* APPLE LOCAL OS pragma hook */
+#define REGISTER_OS_PRAGMAS(PFILE) \
do { \
c_register_pragma (0, "mark", darwin_pragma_ignore); \
c_register_pragma (0, "options", darwin_pragma_options); \
c_register_pragma (0, "segment", darwin_pragma_ignore); \
c_register_pragma (0, "unused", darwin_pragma_unused); \
+ /* APPLE LOCAL begin Macintosh alignment 2002-1-22 ff */ \
+ cpp_register_pragma (PFILE, 0, "pack", darwin_pragma_pack); \
+ /* APPLE LOCAL end Macintosh alignment 2002-1-22 ff */ \
+ /* APPLE LOCAL begin CALL_ON_LOAD/CALL_ON_UNLOAD pragmas 20020202 turly */ \
+ cpp_register_pragma (PFILE, 0, "CALL_ON_LOAD", \
+ darwin_pragma_call_on_load); \
+ cpp_register_pragma (PFILE, 0, "CALL_ON_UNLOAD", \
+ darwin_pragma_call_on_unload); \
+ /* APPLE LOCAL end CALL_ON_LOAD/CALL_ON_UNLOAD pragmas 20020202 turly */ \
+ /* APPLE LOCAL begin CALL_ON_MODULE_BIND deprecated 2002-4-10 ff */ \
+ cpp_register_pragma (PFILE, 0, "CALL_ON_MODULE_BIND", darwin_pragma_call_on_module_bind); \
+ /* APPLE LOCAL end CALL_ON_MODULE_BIND deprecated 2002-4-10 ff */ \
+ /* APPLE LOCAL begin temporary pragmas 2001-07-05 sts */ \
+ cpp_register_pragma (PFILE, 0, "CC_NO_MACH_TEXT_SECTIONS", darwin_pragma_cc_no_mach_text_sections); \
+ cpp_register_pragma (PFILE, 0, "CC_OPT_OFF", darwin_pragma_cc_opt_off); \
+ cpp_register_pragma (PFILE, 0, "CC_OPT_ON", darwin_pragma_cc_opt_on); \
+ cpp_register_pragma (PFILE, 0, "CC_OPT_RESTORE", darwin_pragma_cc_opt_restore); \
+ cpp_register_pragma (PFILE, 0, "CC_WRITABLE_STRINGS", darwin_pragma_cc_writable_strings); \
+ cpp_register_pragma (PFILE, 0, "CC_NON_WRITABLE_STRINGS", darwin_pragma_cc_non_writable_strings); \
+ /* APPLE LOCAL end temporary pragmas 2001-07-05 sts */ \
} while (0)
+/* APPLE LOCAL coalescing */
+extern void make_decl_coalesced (tree, int private_extern_p);
+
+/* Coalesced symbols are private extern by default. This behavior can
+ be changed with the EXPERIMENTAL export-coalesced flag. There is
+ not (yet?) any means for coalesced symbols to be selectively exported. */
+
+#define MAKE_DECL_COALESCED(DECL) \
+ make_decl_coalesced (DECL, !flag_export_coalesced)
+
+#define COALESCE_STATIC_THUNK(DECL, PUBLIC) \
+ make_decl_coalesced (DECL, !PUBLIC)
+
+extern int flag_coalescing_enabled,
+ flag_coalesce_templates, flag_weak_coalesced_definitions;
+
+/* Coalesced symbols are private extern by default. This EXPERIMENTAL
+ flag will make them global instead. */
+extern int flag_export_coalesced;
+
+#define COALESCING_ENABLED_P() (flag_coalescing_enabled && MACHOPIC_INDIRECT)
+
+#define COALESCING_TEMPLATES_P(DECL) \
+ (COALESCING_ENABLED_P () && flag_coalesce_templates)
+
+#define TARGET_TERMINATE_DW2_EH_FRAME_INFO false
+
+#define MARK_TEMPLATE_COALESCED(DECL) \
+ do { \
+ if (COALESCING_TEMPLATES_P (DECL)) { \
+ int explicit = TREE_PUBLIC (DECL) \
+ && (DECL_EXPLICIT_INSTANTIATION (DECL) \
+ /* Or an explicitly instantiated function. */ \
+ || (TREE_CODE (DECL) == FUNCTION_DECL \
+ && DECL_INTERFACE_KNOWN (DECL) \
+ && DECL_NOT_REALLY_EXTERN (DECL)) \
+ /* Or a non-common VAR_DECL. */ \
+ || (TREE_CODE (DECL) == VAR_DECL && ! DECL_COMMON (DECL))); \
+ if (!explicit \
+ || /*it IS explicit, but*/ !flag_weak_coalesced_definitions) \
+ MAKE_DECL_COALESCED (DECL); \
+ } \
+ } while (0)
+
+#undef TARGET_ASM_NAMED_SECTION
+#define TARGET_ASM_NAMED_SECTION darwin_asm_named_section
+#undef TARGET_SECTION_TYPE_FLAGS
+#define TARGET_SECTION_TYPE_FLAGS darwin_section_type_flags
+
+#define DECL_IS_COALESCED_OR_WEAK(DECL) \
+ (DECL_COALESCED (DECL) || DECL_WEAK (DECL))
+
+extern int machopic_var_referred_to_p PARAMS ((const char*));
+#define MACHOPIC_VAR_REFERRED_TO_P(NAME) machopic_var_referred_to_p (NAME)
+/* APPLE LOCAL end coalescing */
+
+/* APPLE LOCAL insert assembly ".abort" directive on fatal error */
+#define EXIT_FROM_FATAL_DIAGNOSTIC(status) abort_assembly_and_exit (status)
+extern void abort_assembly_and_exit (int status) ATTRIBUTE_NORETURN;
+
+/* APPLE LOCAL begin Macintosh alignment 2002-2-13 ff */
+#ifdef RS6000_VECTOR_ALIGNMENT
+/* When adjusting (lowering) the alignment of fields when in the
+ mac68k alignment mode, the 128-bit alignment of vectors *MUST*
+ be preserved. */
+#define PEG_ALIGN_FOR_MAC68K(DESIRED) \
+ ((TARGET_ALTIVEC && (DESIRED) == RS6000_VECTOR_ALIGNMENT) \
+ ? RS6000_VECTOR_ALIGNMENT \
+ : MIN ((DESIRED), 16))
+#else
+#define PEG_ALIGN_FOR_MAC68K(DESIRED) MIN ((DESIRED), 16)
+#endif
+/* APPLE LOCAL end Macintosh alignment 2002-2-13 ff */
+
+/* APPLE LOCAL begin double destructor turly 20020214 */
+/* Handle __attribute__((apple_kext_compatibility)). This shrinks the
+ vtable for all classes with this attribute (and their descendants)
+ back to 2.95 dimensions. It causes only the deleting destructor to
+ be emitted, which means that such objects CANNOT be allocated on
+ the stack or as globals. Luckily, this fits in with the Darwin
+ kext model. */
+#define SUBTARGET_ATTRIBUTE_TABLE \
+ /* { name, min_len, max_len, decl_req, type_req, fn_type_req, handler } */ \
+ { "apple_kext_compatibility", 0, 0, 0, 1, 0, darwin_handle_odd_attribute },
+
+/* APPLE KEXT stuff -- only applies with pure static C++ code. */
+/* NB: Can't use flag_apple_kext as it's in the C++ FE, and this macro
+ is used in the back end for the above __attribute__ handler. */
+#define POSSIBLY_COMPILING_APPLE_KEXT_P() \
+ (! MACHOPIC_INDIRECT && c_dialect_cxx())
+
+/* Need a mechanism to tell whether a C++ operator delete is empty so
+ we overload TREE_SIDE_EFFECTS here (it is unused for FUNCTION_DECLS.)
+ Fromage, c'est moi! */
+#define CHECK_TRIVIAL_FUNCTION(DECL) \
+ do { \
+ const char *_name = IDENTIFIER_POINTER (DECL_NAME (DECL)); \
+ if (POSSIBLY_COMPILING_APPLE_KEXT_P () && DECL_SAVED_TREE (DECL) \
+ && strstr (_name, "operator delete") \
+ && TREE_CODE (DECL_SAVED_TREE (DECL)) == COMPOUND_STMT \
+ && compound_body_is_empty_p ( \
+ COMPOUND_BODY (DECL_SAVED_TREE (DECL))))\
+ TREE_SIDE_EFFECTS (DECL) = 1; \
+ } while (0)
+
+/* gcc3 initialises the vptr field of all objects so that it points at the
+ first virtual function slot, NOT the base address of the vtable proper.
+ This is different from gcc2.95 which always initialised the vptr to
+ point at the base address of the vtable. The difference here is 8 bytes.
+ So, for 2.95 compatibility, we need to:
+
+ (1) subtract 8 from the vptr initialiser, and
+ (2) add 2 to every vfunc index. (2 * 4 == 8.)
+
+ This is getting ever cheesier. */
+
+#define VPTR_INITIALIZER_ADJUSTMENT 8
+#define ADJUST_VTABLE_INDEX(IDX, VTBL) \
+ do { \
+ if (POSSIBLY_COMPILING_APPLE_KEXT_P () && flag_apple_kext) \
+ (IDX) = fold (build (PLUS_EXPR, TREE_TYPE (IDX), IDX, size_int (2))); \
+ } while (0)
+/* APPLE LOCAL end double destructor turly 20020214 */
+
+/* APPLE LOCAL begin zerofill turly 20020218 */
+/* This keeps uninitialized data from bloating the data when -fno-common.
+ Radar 2863107. */
+#define ASM_OUTPUT_ZEROFILL(FILE, NAME, SIZE, ALIGNMENT) \
+ do { \
+ fputs (".zerofill __DATA, __common, ", (FILE)); \
+ assemble_name ((FILE), (NAME)); \
+ fprintf ((FILE), ", " HOST_WIDE_INT_PRINT_DEC, (HOST_WIDE_INT) (SIZE)); \
+ fprintf ((FILE), ", " HOST_WIDE_INT_PRINT_DEC "\n", \
+ (HOST_WIDE_INT) (ALIGNMENT)); \
+ in_section = no_section; \
+ } while (0)
+/* APPLE LOCAL end zerofill turly 20020218 */
+
#undef ASM_APP_ON
#define ASM_APP_ON ""
#undef ASM_APP_OFF
#define ASM_APP_OFF ""
+extern const char *machopic_non_lazy_ptr_name PARAMS ((const char *));
+
void darwin_register_frameworks (int);
#define TARGET_EXTRA_INCLUDES darwin_register_frameworks
diff --git a/gcc/config/h8300/t-rtems b/gcc/config/h8300/t-rtems
deleted file mode 100644
index 104ee2366f1..00000000000
--- a/gcc/config/h8300/t-rtems
+++ /dev/null
@@ -1,7 +0,0 @@
-# Custom multilibs for RTEMS
-
-# -mn is not applicable to RTEMS (-mn implies 16bit void*)
-
-MULTILIB_OPTIONS = mh/ms mint32
-MULTILIB_DIRNAMES = h8300h h8300s int32
-MULTILIB_EXCEPTIONS = mint32
diff --git a/gcc/config/host-linux.c b/gcc/config/host-linux.c
deleted file mode 100644
index 7302d381dbe..00000000000
--- a/gcc/config/host-linux.c
+++ /dev/null
@@ -1,137 +0,0 @@
-/* Linux host-specific hook definitions.
- Copyright (C) 2004 Free Software Foundation, Inc.
-
- This file is part of GCC.
-
- GCC is free software; you can redistribute it and/or modify it
- under the terms of the GNU General Public License as published
- by the Free Software Foundation; either version 2, or (at your
- option) any later version.
-
- GCC is distributed in the hope that it will be useful, but WITHOUT
- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public
- License for more details.
-
- You should have received a copy of the GNU General Public License
- along with GCC; see the file COPYING. If not, write to the
- Free Software Foundation, 59 Temple Place - Suite 330, Boston,
- MA 02111-1307, USA. */
-
-#include "config.h"
-#include "system.h"
-#include "coretypes.h"
-#include <sys/mman.h>
-#include "hosthooks.h"
-#include "hosthooks-def.h"
-
-
-/* Linux has a feature called exec-shield-randomize that perturbs the
- address of non-fixed mapped segments by a (relatively) small amount.
- The feature is intended to make it harder to attack the system with
- buffer overflow attacks, since every invocation of a program will
- have its libraries and data segments at slightly different addresses.
-
- This feature causes us problems with PCH because it makes it that
- much harder to acquire a stable location at which to map our PCH
- data file.
-
- [ The feature causes other points of non-determinism within the
- compiler as well, so we'd *really* like to be able to have the
- driver disable exec-shield-randomize for the process group, but
- that isn't possible at present. ]
-
- We're going to try several things:
-
- * Select an architecture specific address as "likely" and see
- if that's free. For our 64-bit hosts, we can easily choose
- an address in Never Never Land.
-
- * If exec-shield-randomize is disabled, then just use the
- address chosen by mmap in step one.
-
- * If exec-shield-randomize is enabled, then temporarily allocate
- 32M of memory as a buffer, then allocate PCH memory, then
- free the buffer. The theory here is that the perturbation is
- no more than 16M, and so by allocating our buffer larger than
- that we make it considerably more likely that the address will
- be free when we want to load the data back.
-*/
-
-#undef HOST_HOOKS_GT_PCH_GET_ADDRESS
-#define HOST_HOOKS_GT_PCH_GET_ADDRESS linux_gt_pch_get_address
-
-/* For various ports, try to guess a fixed spot in the vm space
- that's probably free. */
-#if defined(__alpha)
-# define TRY_EMPTY_VM_SPACE 0x10000000000
-#elif defined(__ia64)
-# define TRY_EMPTY_VM_SPACE 0x2000000100000000
-#elif defined(__x86_64)
-# define TRY_EMPTY_VM_SPACE 0x1000000000
-#elif defined(__i386)
-# define TRY_EMPTY_VM_SPACE 0x60000000
-#else
-# define TRY_EMPTY_VM_SPACE 0
-#endif
-
-/* Determine a location where we might be able to reliably allocate SIZE
- bytes. FD is the PCH file, though we should return with the file
- unmapped. */
-
-static void *
-linux_gt_pch_get_address (size_t size, int fd)
-{
- size_t buffer_size = 32 * 1024 * 1024;
- void *addr, *buffer;
- FILE *f;
- bool randomize_on;
-
- addr = mmap ((void *)TRY_EMPTY_VM_SPACE, size, PROT_READ | PROT_WRITE,
- MAP_PRIVATE, fd, 0);
-
- /* If we failed the map, that means there's *no* free space. */
- if (addr == (void *) MAP_FAILED)
- return NULL;
- /* Unmap the area before returning. */
- munmap (addr, size);
-
- /* If we got the exact area we requested, then that's great. */
- if (TRY_EMPTY_VM_SPACE && addr == (void *) TRY_EMPTY_VM_SPACE)
- return addr;
-
- /* If we didn't, then we need to look to see if randomization is on. */
- f = fopen ("/proc/sys/kernel/exec-shield-randomize", "r");
- randomize_on = false;
- if (f != NULL)
- {
- char buf[100];
- size_t c;
-
- c = fread (buf, 1, sizeof buf - 1, f);
- if (c > 0)
- {
- buf[c] = '\0';
- randomize_on = (atoi (buf) > 0);
- }
- fclose (f);
- }
-
- /* If it isn't, then accept the address that mmap selected as fine. */
- if (!randomize_on)
- return addr;
-
- /* Otherwise, we need to try again with buffer space. */
- buffer = mmap (0, buffer_size, PROT_NONE, MAP_PRIVATE | MAP_ANON, -1, 0);
- addr = mmap (0, size, PROT_READ | PROT_WRITE, MAP_PRIVATE, fd, 0);
- if (buffer != (void *) MAP_FAILED)
- munmap (buffer, buffer_size);
- if (addr == (void *) MAP_FAILED)
- return NULL;
- munmap (addr, size);
-
- return addr;
-}
-
-
-const struct host_hooks host_hooks = HOST_HOOKS_INITIALIZER;
diff --git a/gcc/config/host-solaris.c b/gcc/config/host-solaris.c
deleted file mode 100644
index 4fa7a5b1ad0..00000000000
--- a/gcc/config/host-solaris.c
+++ /dev/null
@@ -1,79 +0,0 @@
-/* Solaris host-specific hook definitions.
- Copyright (C) 2004 Free Software Foundation, Inc.
-
- This file is part of GCC.
-
- GCC is free software; you can redistribute it and/or modify it
- under the terms of the GNU General Public License as published
- by the Free Software Foundation; either version 2, or (at your
- option) any later version.
-
- GCC is distributed in the hope that it will be useful, but WITHOUT
- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public
- License for more details.
-
- You should have received a copy of the GNU General Public License
- along with GCC; see the file COPYING. If not, write to the
- Free Software Foundation, 59 Temple Place - Suite 330, Boston,
- MA 02111-1307, USA. */
-
-#include "config.h"
-#include "system.h"
-#include "coretypes.h"
-#include <sys/mman.h>
-#include "hosthooks.h"
-#include "hosthooks-def.h"
-
-
-#undef HOST_HOOKS_GT_PCH_USE_ADDRESS
-#define HOST_HOOKS_GT_PCH_USE_ADDRESS sol_gt_pch_use_address
-
-/* Map SIZE bytes of FD+OFFSET at BASE. Return 1 if we succeeded at
- mapping the data at BASE, -1 if we couldn't. */
-
-static int
-sol_gt_pch_use_address (void *base, size_t size, int fd, size_t offset)
-{
- void *addr;
-
- /* We're called with size == 0 if we're not planning to load a PCH
- file at all. This allows the hook to free any static space that
- we might have allocated at link time. */
- if (size == 0)
- return -1;
-
- addr = mmap (base, size, PROT_READ | PROT_WRITE, MAP_PRIVATE,
- fd, offset);
-
- /* Solaris isn't good about honoring the mmap START parameter
- without MAP_FIXED set. Before we give up, search the desired
- address space with mincore to see if the space is really free. */
- if (addr != base)
- {
- size_t page_size = getpagesize();
- char one_byte;
- size_t i;
-
- if (addr != (void *) MAP_FAILED)
- munmap (addr, size);
-
- errno = 0;
- for (i = 0; i < size; i += page_size)
- if (mincore ((char *)base + i, page_size, (void *)&one_byte) == -1
- && errno == ENOMEM)
- continue; /* The page is not mapped. */
- else
- break;
-
- if (i >= size)
- addr = mmap (base, size,
- PROT_READ | PROT_WRITE, MAP_PRIVATE | MAP_FIXED,
- fd, offset);
- }
-
- return addr == base ? 1 : -1;
-}
-
-
-const struct host_hooks host_hooks = HOST_HOOKS_INITIALIZER;
diff --git a/gcc/config/i386/darwin.h b/gcc/config/i386/darwin.h
index accffeee90c..0212184c3fb 100644
--- a/gcc/config/i386/darwin.h
+++ b/gcc/config/i386/darwin.h
@@ -23,7 +23,13 @@ Boston, MA 02111-1307, USA. */
#undef TARGET_MACHO
#define TARGET_MACHO 1
-#define TARGET_VERSION fprintf (stderr, " (i686 Darwin)");
+/* APPLE LOCAL begin default to ppro */
+/* Default to -mcpu=pentiumpro instead of i386 (radar 2730299) ilr */
+#undef TARGET_CPU_DEFAULT
+#define TARGET_CPU_DEFAULT 4
+/* APPLE LOCAL end default to ppro */
+
+#define TARGET_VERSION fprintf (stderr, " (i386 Darwin)");
#define TARGET_OS_CPP_BUILTINS() \
do \
@@ -39,7 +45,13 @@ Boston, MA 02111-1307, USA. */
the kernel or some such. */
#undef CC1_SPEC
-#define CC1_SPEC "%{!static:-fPIC}"
+/* APPLE LOCAL dynamic-no-pic */
+/* APPLE LOCAL ignore -mcpu=G4 -mcpu=G5 */
+/* When -mdynamic-no-pic finally works, remove the "xx" below. FIXME!! */
+#define CC1_SPEC "%{!static:%{!mxxdynamic-no-pic:-fPIC}} %<faltivec %<mlong-branch %<mlongcall %<mcpu=G4 %<mcpu=G5"
+
+/* APPLE LOCAL AltiVec */
+#define CPP_ALTIVEC_SPEC "%<faltivec"
#define ASM_SPEC "-arch i686 \
-force_cpusubtype_ALL \
@@ -104,7 +116,12 @@ Boston, MA 02111-1307, USA. */
#define ASM_OUTPUT_ALIGN(FILE,LOG) \
do { if ((LOG) != 0) \
{ \
- if (in_text_section ()) \
+ /* APPLE LOCAL coalescing */ \
+ if (in_text_section () \
+ || in_unlikely_text_section () \
+ || darwin_named_section_is ("__TEXT,__textcoal,coalesced") \
+ || darwin_named_section_is ("__TEXT,__textcoal_nt,coalesced,no_toc") \
+ || darwin_named_section_is (STATIC_INIT_SECTION)) \
fprintf (FILE, "\t%s %d,0x90\n", ALIGN_ASM_OP, (LOG)); \
else \
fprintf (FILE, "\t%s %d\n", ALIGN_ASM_OP, (LOG)); \
@@ -127,6 +144,27 @@ Boston, MA 02111-1307, USA. */
assemble_name ((FILE), (NAME)), \
fprintf ((FILE), ","HOST_WIDE_INT_PRINT_UNSIGNED"\n", (ROUNDED)))
+
+/* APPLE LOCAL begin Macintosh alignment 2002-2-19 ff */
+#define MASK_ALIGN_NATURAL 0x40000000
+#define TARGET_ALIGN_NATURAL (target_flags & MASK_ALIGN_NATURAL)
+#define rs6000_alignment_flags target_flags
+#define MASK_ALIGN_MAC68K 0x20000000
+#define TARGET_ALIGN_MAC68K (target_flags & MASK_ALIGN_MAC68K)
+
+#undef SUBTARGET_SWITCHES
+#define SUBTARGET_SWITCHES \
+ {"align-mac68k", MASK_ALIGN_MAC68K, \
+ N_("Align structs and unions according to mac68k rules")}, \
+ {"align-power", - (MASK_ALIGN_MAC68K | MASK_ALIGN_NATURAL), \
+ N_("Align structs and unions according to PowerPC rules")}, \
+ {"align-natural", MASK_ALIGN_NATURAL, \
+ N_("Align structs and unions according to natural rules")}, \
+ {"dynamic-no-pic", MASK_MACHO_DYNAMIC_NO_PIC, \
+ N_("Generate code suitable for executables (NOT shared libs)")},\
+ {"no-dynamic-no-pic", -MASK_MACHO_DYNAMIC_NO_PIC, ""},
+/* APPLE LOCAL end Macintosh alignment 2002-2-19 ff */
+
/* Darwin profiling -- call mcount. */
#undef FUNCTION_PROFILER
#define FUNCTION_PROFILER(FILE, LABELNO) \
@@ -139,3 +177,14 @@ Boston, MA 02111-1307, USA. */
} \
else fprintf (FILE, "\tcall mcount\n"); \
} while (0)
+
+/* APPLE LOCAL SSE stack alignment */
+#define BASIC_STACK_BOUNDARY (128)
+
+#undef SUBTARGET_OVERRIDE_OPTIONS
+/* Force Darwin/x86 to default as "-march=i686 -mcpu=pentium4". */
+#define SUBTARGET_OVERRIDE_OPTIONS \
+ do { \
+ if (!ix86_arch_string) ix86_arch_string = "pentiumpro"; \
+ if (!ix86_tune_string) ix86_tune_string = "pentium4"; \
+ } while (0)
diff --git a/gcc/config/i386/i386.c b/gcc/config/i386/i386.c
index 58e26333a5c..582102c18ea 100644
--- a/gcc/config/i386/i386.c
+++ b/gcc/config/i386/i386.c
@@ -459,6 +459,34 @@ struct processor_costs pentium4_cost = {
const struct processor_costs *ix86_cost = &pentium_cost;
+/* APPLE LOCAL begin Altivec */
+/* vector types */
+static GTY(()) tree unsigned_V16QI_type_node;
+static GTY(()) tree unsigned_V4SI_type_node;
+static GTY(()) tree unsigned_V8QI_type_node;
+static GTY(()) tree unsigned_V8HI_type_node;
+static GTY(()) tree unsigned_V4HI_type_node;
+static GTY(()) tree unsigned_V2HI_type_node;
+static GTY(()) tree unsigned_V2SI_type_node;
+static GTY(()) tree unsigned_V2DI_type_node;
+static GTY(()) tree unsigned_V1DI_type_node;
+
+static GTY(()) tree V16QI_type_node;
+static GTY(()) tree V4SF_type_node;
+static GTY(()) tree V4SI_type_node;
+static GTY(()) tree V8QI_type_node;
+static GTY(()) tree V8HI_type_node;
+static GTY(()) tree V4HI_type_node;
+static GTY(()) tree V2HI_type_node;
+static GTY(()) tree V2SI_type_node;
+static GTY(()) tree V2SF_type_node;
+static GTY(()) tree V2DI_type_node;
+static GTY(()) tree V2DF_type_node;
+static GTY(()) tree V16SF_type_node;
+static GTY(()) tree V1DI_type_node;
+static GTY(()) tree V4DF_type_node;
+/* APPLE LOCAL end Altivec */
+
/* Processor feature/optimization bitmasks. */
#define m_386 (1<<PROCESSOR_I386)
#define m_486 (1<<PROCESSOR_I486)
@@ -1004,6 +1032,12 @@ static void init_ext_80387_constants (void);
#undef TARGET_ADDRESS_COST
#define TARGET_ADDRESS_COST ix86_address_cost
+/* APPLE LOCAL begin SSE stack alignment */
+#ifndef BASIC_STACK_BOUNDARY
+#define BASIC_STACK_BOUNDARY (32)
+#endif
+/* APPLE LOCAL end SSE stack alignment */
+
#undef TARGET_FIXED_CONDITION_CODE_REGS
#define TARGET_FIXED_CONDITION_CODE_REGS ix86_fixed_condition_code_regs
#undef TARGET_CC_MODES_COMPATIBLE
@@ -1345,9 +1379,11 @@ override_options (void)
The default of 128 bits is for Pentium III's SSE __m128, but we
don't want additional code to keep the stack aligned when
optimizing for code size. */
+ /* APPLE LOCAL begin SSE stack alignment */
ix86_preferred_stack_boundary = (optimize_size
- ? TARGET_64BIT ? 128 : 32
+ ? TARGET_64BIT ? 128 : BASIC_STACK_BOUNDARY
: 128);
+ /* APPLE LOCAL end SSE stack alignment */
if (ix86_preferred_stack_boundary_string)
{
i = atoi (ix86_preferred_stack_boundary_string);
@@ -1485,11 +1521,24 @@ override_options (void)
internal_label_prefix_len = p - internal_label_prefix;
*p = '\0';
}
+
+ /* APPLE LOCAL begin dynamic-no-pic */
+ if (flag_pic == 1)
+ {
+ /* Darwin doesn't support -fpic. */
+ warning ("-fpic is not supported; -fPIC assumed");
+ flag_pic = 2;
+ }
+ /* APPLE LOCAL end dynamic-no-pic */
}
void
optimization_options (int level, int size ATTRIBUTE_UNUSED)
{
+ /* APPLE LOCAL disable strict aliasing; breaks too much existing code. */
+#if TARGET_MACHO
+ flag_strict_aliasing = 0;
+#endif
/* For -O2 and beyond, turn off -fschedule-insns by default. It tends to
make the problem with not enough registers even worse. */
#ifdef INSN_SCHEDULING
@@ -1529,6 +1578,11 @@ const struct attribute_spec ix86_attribute_table[] =
#endif
{ "ms_struct", 0, 0, false, false, false, ix86_handle_struct_attribute },
{ "gcc_struct", 0, 0, false, false, false, ix86_handle_struct_attribute },
+ /* APPLE LOCAL begin double destructor */
+#ifdef SUBTARGET_ATTRIBUTE_TABLE
+ SUBTARGET_ATTRIBUTE_TABLE
+#endif
+ /* APPLE LOCAL end double destructor */
{ NULL, 0, 0, false, false, false, NULL }
};
@@ -2959,7 +3013,19 @@ ix86_build_builtin_va_list (void)
return build_array_type (record, build_index_type (size_zero_node));
}
-/* Worker function for TARGET_SETUP_INCOMING_VARARGS. */
+/* Perform any needed actions needed for a function that is receiving a
+ variable number of arguments.
+
+ CUM is as above.
+
+ MODE and TYPE are the mode and type of the current parameter.
+
+ PRETEND_SIZE is a variable that should be set to the amount of stack
+ that must be pushed by the prolog to pretend that our caller pushed
+ it.
+
+ Normally, this macro will push all remaining incoming registers on the
+ stack and set PRETEND_SIZE to the length of the registers pushed. */
static void
ix86_setup_incoming_varargs (CUMULATIVE_ARGS *cum, enum machine_mode mode,
diff --git a/gcc/config/i386/i386.h b/gcc/config/i386/i386.h
index b90f590b98a..a658ec7fb1b 100644
--- a/gcc/config/i386/i386.h
+++ b/gcc/config/i386/i386.h
@@ -34,6 +34,9 @@ Boston, MA 02111-1307, USA. */
ADDR_BEG, ADDR_END, PRINT_IREG, PRINT_SCALE, PRINT_B_I_S, and many
that start with ASM_ or end in ASM_OP. */
+/* APPLE LOCAL fat builds */
+#define DEFAULT_TARGET_ARCH "i386"
+
/* Define the specific costs for a given cpu */
struct processor_costs {
@@ -207,6 +210,11 @@ extern int target_flags;
#endif
#endif
+/* APPLE LOCAL begin hot/cold partitioning */
+#define HAS_LONG_COND_BRANCH 1
+#define HAS_LONG_UNCOND_BRANCH 1
+/* APPLE LOCAL end hot/cold partitioning */
+
/* Avoid adding %gs:0 in TLS references; use %gs:address directly. */
#define TARGET_TLS_DIRECT_SEG_REFS (target_flags & MASK_TLS_DIRECT_SEG_REFS)
@@ -774,7 +782,8 @@ extern int x86_prefetch_sse;
#define PARM_BOUNDARY BITS_PER_WORD
/* Boundary (in *bits*) on which stack pointer should be aligned. */
-#define STACK_BOUNDARY BITS_PER_WORD
+/* APPLE LOCAL 3232990 - compiler should obey -mpreferred-stack-boundary */
+#define STACK_BOUNDARY ((ix86_preferred_stack_boundary > 128) ? 128 : ix86_preferred_stack_boundary)
/* Boundary (in *bits*) on which the stack pointer prefers to be
aligned; the compiler cannot rely on having this alignment. */
@@ -825,7 +834,8 @@ extern int x86_prefetch_sse;
#define BIGGEST_FIELD_ALIGNMENT 32
#endif
#else
-#define ADJUST_FIELD_ALIGN(FIELD, COMPUTED) \
+/* APPLE LOCAL Macintosh alignment */
+#define ADJUST_FIELD_ALIGN(FIELD, COMPUTED, FIRST_FIELD_P) \
x86_field_alignment (FIELD, COMPUTED)
#endif
diff --git a/gcc/config/i386/t-djgpp b/gcc/config/i386/t-djgpp
deleted file mode 100644
index 7b54b7ba7aa..00000000000
--- a/gcc/config/i386/t-djgpp
+++ /dev/null
@@ -1,2 +0,0 @@
-# Location of DJGPP's header directory.
-NATIVE_SYSTEM_HEADER_DIR=$(DJDIR)/include
diff --git a/gcc/config/ia64/t-hpux b/gcc/config/ia64/t-hpux
deleted file mode 100644
index 597c2acbe2a..00000000000
--- a/gcc/config/ia64/t-hpux
+++ /dev/null
@@ -1,43 +0,0 @@
-# We need multilib support for HPUX's ILP32 & LP64 modes.
-
-LIBGCC = stmp-multilib
-INSTALL_LIBGCC = install-multilib
-
-MULTILIB_OPTIONS = milp32/mlp64
-MULTILIB_DIRNAMES = hpux32 hpux64
-MULTILIB_MATCHES =
-
-# Support routines for HP-UX 128 bit floats.
-
-LIB2FUNCS_EXTRA=quadlib.c
-
-quadlib.c: $(srcdir)/config/ia64/quadlib.c
- cat $(srcdir)/config/ia64/quadlib.c > quadlib.c
-
-# We get an undefined main when building a cross compiler because our
-# linkspec has "-u main" and we want that for linking but it makes
-# LIBGCC1_TEST fail because it uses -nostdlib -nostartup.
-
-LIBGCC1_TEST =
-
-# We do not want to include the EH stuff that linux uses, we want to use
-# the HP-UX libunwind library.
-
-LIB2ADDEH =
-
-SHLIB_EXT = .so
-# Must include -lunwind in the link, so that libgcc_s.so has the necessary
-# DT_NEEDED entry for libunwind.
-SHLIB_LINK = $(GCC_FOR_TARGET) $(LIBGCC2_CFLAGS) -shared -nodefaultlibs \
- -Wl,+h,@shlib_base_name@.so.0 \
- -o @shlib_base_name@.so @multilib_flags@ @shlib_objs@ -lunwind -lc && \
- rm -f @shlib_base_name@.so.0 && \
- $(LN_S) @shlib_base_name@.so @shlib_base_name@.so.0
-# $(slibdir) double quoted to protect it from expansion while building
-# libgcc.mk. We want this delayed until actual install time.
-SHLIB_INSTALL = $(INSTALL_DATA) @shlib_base_name@.so $$(DESTDIR)$$(slibdir)/@shlib_base_name@.so.0; \
- rm -f $$(DESTDIR)$$(slibdir)/@shlib_base_name@.so; \
- $(LN_S) @shlib_base_name@.so.0 $$(DESTDIR)$$(slibdir)/@shlib_base_name@.so; \
- chmod +x $$(DESTDIR)$$(slibdir)/@shlib_base_name@.so
-
-SHLIB_MKMAP = $(srcdir)/mkmap-flat.awk
diff --git a/gcc/config/mips/t-mips b/gcc/config/mips/t-mips
deleted file mode 100644
index 497f4fb20cb..00000000000
--- a/gcc/config/mips/t-mips
+++ /dev/null
@@ -1,21 +0,0 @@
-# fp-bit and dp-bit are really part of libgcc1, but this will cause
-# them to be built correctly, so... [taken from t-sparclite]
-# We want fine grained libraries, so use the new code to build the
-# floating point emulation libraries.
-FPBIT = fp-bit.c
-DPBIT = dp-bit.c
-
-dp-bit.c: $(srcdir)/config/fp-bit.c
- echo '#ifdef __MIPSEL__' > dp-bit.c
- echo '#define FLOAT_BIT_ORDER_MISMATCH' >> dp-bit.c
- echo '#endif' >> dp-bit.c
- echo '#define QUIET_NAN_NEGATED' >> dp-bit.c
- cat $(srcdir)/config/fp-bit.c >> dp-bit.c
-
-fp-bit.c: $(srcdir)/config/fp-bit.c
- echo '#define FLOAT' > fp-bit.c
- echo '#ifdef __MIPSEL__' >> fp-bit.c
- echo '#define FLOAT_BIT_ORDER_MISMATCH' >> fp-bit.c
- echo '#endif' >> fp-bit.c
- echo '#define QUIET_NAN_NEGATED' >> fp-bit.c
- cat $(srcdir)/config/fp-bit.c >> fp-bit.c
diff --git a/gcc/config/rs6000/altivec.h b/gcc/config/rs6000/altivec.h
index 2ae567ef3d4..07278e95789 100644
--- a/gcc/config/rs6000/altivec.h
+++ b/gcc/config/rs6000/altivec.h
@@ -36,10 +36,11 @@
#error Use the "-maltivec" flag to enable PowerPC AltiVec support
#endif
-/* You are allowed to undef these for C++ compatibility. */
-#define vector __vector
-#define pixel __pixel
-#define bool __bool
+/* APPLE LOCAL begin AltiVec */
+/* The keywords 'vector', 'pixel' and 'bool' are now implemented as
+ context-sensitive macros, and hence should not be defined
+ unconditionally. */
+/* APPLE LOCAL end AltiVec */
/* Condition register codes for AltiVec predicates. */
@@ -117,7 +118,7 @@ inline void vec_dst (const vector unsigned int *, int, const int) __attribute__
inline void vec_dst (const vector signed int *, int, const int) __attribute__ ((always_inline));
inline void vec_dst (const vector bool int *, int, const int) __attribute__ ((always_inline));
inline void vec_dst (const vector float *, int, const int) __attribute__ ((always_inline));
-inline void vec_dst (const int *, int, const int) __attribute__ ((always_inline));
+inline void vec_dst (const unsigned char *, int, const int) __attribute__ ((always_inline));
inline void vec_dst (const signed char *, int, const int) __attribute__ ((always_inline));
inline void vec_dst (const unsigned short *, int, const int) __attribute__ ((always_inline));
inline void vec_dst (const short *, int, const int) __attribute__ ((always_inline));
@@ -138,7 +139,7 @@ inline void vec_dstst (const vector unsigned int *, int, const int) __attribute_
inline void vec_dstst (const vector signed int *, int, const int) __attribute__ ((always_inline));
inline void vec_dstst (const vector bool int *, int, const int) __attribute__ ((always_inline));
inline void vec_dstst (const vector float *, int, const int) __attribute__ ((always_inline));
-inline void vec_dstst (const int *, int, const int) __attribute__ ((always_inline));
+inline void vec_dstst (const unsigned char *, int, const int) __attribute__ ((always_inline));
inline void vec_dstst (const signed char *, int, const int) __attribute__ ((always_inline));
inline void vec_dstst (const unsigned short *, int, const int) __attribute__ ((always_inline));
inline void vec_dstst (const short *, int, const int) __attribute__ ((always_inline));
@@ -159,7 +160,7 @@ inline void vec_dststt (const vector unsigned int *, int, const int) __attribute
inline void vec_dststt (const vector signed int *, int, const int) __attribute__ ((always_inline));
inline void vec_dststt (const vector bool int *, int, const int) __attribute__ ((always_inline));
inline void vec_dststt (const vector float *, int, const int) __attribute__ ((always_inline));
-inline void vec_dststt (const int *, int, const int) __attribute__ ((always_inline));
+inline void vec_dststt (const unsigned char *, int, const int) __attribute__ ((always_inline));
inline void vec_dststt (const signed char *, int, const int) __attribute__ ((always_inline));
inline void vec_dststt (const unsigned short *, int, const int) __attribute__ ((always_inline));
inline void vec_dststt (const short *, int, const int) __attribute__ ((always_inline));
@@ -180,7 +181,7 @@ inline void vec_dstt (const vector unsigned int *, int, const int) __attribute__
inline void vec_dstt (const vector signed int *, int, const int) __attribute__ ((always_inline));
inline void vec_dstt (const vector bool int *, int, const int) __attribute__ ((always_inline));
inline void vec_dstt (const vector float *, int, const int) __attribute__ ((always_inline));
-inline void vec_dstt (const int *, int, const int) __attribute__ ((always_inline));
+inline void vec_dstt (const unsigned char *, int, const int) __attribute__ ((always_inline));
inline void vec_dstt (const signed char *, int, const int) __attribute__ ((always_inline));
inline void vec_dstt (const unsigned short *, int, const int) __attribute__ ((always_inline));
inline void vec_dstt (const short *, int, const int) __attribute__ ((always_inline));
@@ -195,15 +196,20 @@ inline vector signed int vec_sld (vector signed int, vector signed int, const in
inline vector unsigned int vec_sld (vector unsigned int, vector unsigned int, const int) __attribute__ ((always_inline));
inline vector signed short vec_sld (vector signed short, vector signed short, const int) __attribute__ ((always_inline));
inline vector unsigned short vec_sld (vector unsigned short, vector unsigned short, const int) __attribute__ ((always_inline));
+inline vector pixel vec_sld (vector pixel, vector pixel, const int) __attribute__ ((always_inline));
inline vector signed char vec_sld (vector signed char, vector signed char, const int) __attribute__ ((always_inline));
inline vector unsigned char vec_sld (vector unsigned char, vector unsigned char, const int) __attribute__ ((always_inline));
inline vector signed char vec_splat (vector signed char, const int) __attribute__ ((always_inline));
inline vector unsigned char vec_splat (vector unsigned char, const int) __attribute__ ((always_inline));
+inline vector bool char vec_splat (vector bool char, const int) __attribute__ ((always_inline));
inline vector signed short vec_splat (vector signed short, const int) __attribute__ ((always_inline));
inline vector unsigned short vec_splat (vector unsigned short, const int) __attribute__ ((always_inline));
+inline vector bool short vec_splat (vector bool short, const int) __attribute__ ((always_inline));
+inline vector pixel vec_splat (vector pixel, const int) __attribute__ ((always_inline));
inline vector float vec_splat (vector float, const int) __attribute__ ((always_inline));
inline vector signed int vec_splat (vector signed int, const int) __attribute__ ((always_inline));
inline vector unsigned int vec_splat (vector unsigned int, const int) __attribute__ ((always_inline));
+inline vector bool int vec_splat (vector bool int, const int) __attribute__ ((always_inline));
inline vector signed char vec_splat_s8 (const int) __attribute__ ((always_inline));
inline vector signed short vec_splat_s16 (const int) __attribute__ ((always_inline));
inline vector signed int vec_splat_s32 (const int) __attribute__ ((always_inline));
@@ -8897,7 +8903,7 @@ __ch (__bin_args_eq (vector unsigned int, (a1), vector unsigned int, (a2)), \
((vector unsigned int) __builtin_altivec_vmrghw ((vector signed int) (a1), (vector signed int) (a2))), \
__ch (__bin_args_eq (vector bool int, (a1), vector bool int, (a2)), \
((vector bool int) __builtin_altivec_vmrghw ((vector signed int) (a1), (vector signed int) (a2))), \
- __builtin_altivec_compiletime_error ("vec_mergeh")))))))))))
+ __builtin_altivec_compiletime_error ("vec_mergeh"))))))))))))
#define vec_vmrghw(a1, a2) \
__ch (__bin_args_eq (vector float, (a1), vector float, (a2)), \
@@ -8945,7 +8951,7 @@ __ch (__bin_args_eq (vector unsigned int, (a1), vector unsigned int, (a2)), \
((vector unsigned int) __builtin_altivec_vmrglw ((vector signed int) (a1), (vector signed int) (a2))), \
__ch (__bin_args_eq (vector bool int, (a1), vector bool int, (a2)), \
((vector bool int) __builtin_altivec_vmrglw ((vector signed int) (a1), (vector signed int) (a2))), \
- __builtin_altivec_compiletime_error ("vec_mergel"))))))))
+ __builtin_altivec_compiletime_error ("vec_mergel"))))))))))))
#define vec_vmrglw(a1, a2) \
__ch (__bin_args_eq (vector float, (a1), vector float, (a2)), \
diff --git a/gcc/config/rs6000/builtin.ops b/gcc/config/rs6000/builtin.ops
new file mode 100644
index 00000000000..a28e35654fc
--- /dev/null
+++ b/gcc/config/rs6000/builtin.ops
@@ -0,0 +1,297 @@
+# APPLE LOCAL file AltiVec
+# ops-to-gp -gcc vec.ops builtin.ops
+# @ betype betype-code type-spelling
+@ @ float BETYPE_R4 float
+@ @ ushort BETYPE_U4 unsigned=short
+@ @ uint BETYPE_U4 unsigned=int
+@ @ ulong BETYPE_U4 unsigned=long
+@ @ immed_u2 U2 0..3
+@ @ immed_u4 U4 0..15
+@ @ immed_s5 I5 -16..15
+@ @ immed_u5 U5 0..31
+@ @ int BETYPE_I4 int
+@ @ long BETYPE_I4 long
+@ @ ptr PTR void=*
+@ @ v16 BETYPE_V16 vec_type
+@ @ void BETYPE_I4 void
+# fetype betype [code [spelling]]
+@ float_ptr ptr i float=*
+@ const_float_ptr ptr i float=*
+@ const_volatile_float_ptr ptr i float=*
+@ int int i
+@ int_ptr ptr i int=*
+@ long_ptr ptr i long=*
+@ const_int_ptr ptr i int=*
+@ const_long_ptr ptr i long=*
+@ const_volatile_int_ptr ptr i int=*
+@ const_volatile_long_ptr ptr i long=*
+@ immed_s5 immed_s5 A
+@ immed_u5 immed_u5 B
+@ immed_u4 immed_u4 C
+@ immed_u2 immed_u2 D
+@ cc24f int j=24=f
+@ cc24fd int j=24=f=d
+@ cc24fr int j=24=f=r
+@ cc24t int j=24=t
+@ cc24td int j=24=t=d
+@ cc24tr int j=24=t=r
+@ cc26f int j=26=f
+@ cc26fd int j=26=f=d
+@ cc26fr int j=26=f=r
+@ cc26t int j=26=t
+@ cc26td int j=26=t=d
+@ cc26tr int j=26=t=r
+@ short_ptr ptr i short=*
+@ signed_char_ptr ptr i signed=char=*
+@ unsigned_char_ptr ptr i unsigned=char=*
+@ unsigned_short_ptr ptr i unsigned=short=*
+@ unsigned_int_ptr ptr i unsigned=int=*
+@ unsigned_long_ptr ptr i unsigned=long=*
+@ const_short_ptr ptr i short=*
+@ const_signed_char_ptr ptr i signed=char=*
+@ const_unsigned_char_ptr ptr i unsigned=char=*
+@ const_unsigned_short_ptr ptr i unsigned=short=*
+@ const_unsigned_int_ptr ptr i unsigned=int=*
+@ const_unsigned_long_ptr ptr i unsigned=long=*
+@ const_volatile_short_ptr ptr i short=*
+@ const_volatile_signed_char_ptr ptr i signed=char=*
+@ const_volatile_unsigned_char_ptr ptr i unsigned=char=*
+@ const_volatile_unsigned_short_ptr ptr i unsigned=short=*
+@ const_volatile_unsigned_int_ptr ptr i unsigned=int=*
+@ const_volatile_unsigned_long_ptr ptr i unsigned=long=*
+@ vec_b16 v16 x vec_b16
+@ vec_b16_load_op v16 xl vec_b16
+@ vec_b16_ptr ptr i vec_b16=*
+@ const_vec_b16_ptr ptr i vec_b16=*
+@ vec_b32 v16 x vec_b32
+@ vec_b32_load_op v16 xl vec_b32
+@ vec_b32_ptr ptr i vec_b32=*
+@ const_vec_b32_ptr ptr i vec_b32=*
+@ vec_b8 v16 x vec_b8
+@ vec_b8_load_op v16 xl vec_b8
+@ vec_b8_ptr ptr i vec_b8=*
+@ const_vec_b8_ptr ptr i vec_b8=*
+@ vec_f32 v16 x vec_f32
+@ vec_f32_load_op v16 xl vec_f32
+@ vec_f32_ptr ptr i vec_f32=*
+@ const_vec_f32_ptr ptr i vec_f32=*
+@ vec_p16 v16 x vec_p16
+@ vec_p16_load_op v16 xl vec_p16
+@ vec_p16_ptr ptr i vec_p16=*
+@ const_vec_p16_ptr ptr i vec_p16=*
+@ vec_s16 v16 x vec_s16
+@ vec_s16_load_op v16 xl vec_s16
+@ vec_s16_ptr ptr i vec_s16=*
+@ const_vec_s16_ptr ptr i vec_s16=*
+@ vec_s32 v16 x vec_s32
+@ vec_s32_load_op v16 xl vec_s32
+@ vec_s32_ptr ptr i vec_s32=*
+@ const_vec_s32_ptr ptr i vec_s32=*
+@ vec_s8 v16 x vec_s8
+@ vec_s8_load_op v16 xl vec_s8
+@ vec_s8_ptr ptr i vec_s8=*
+@ const_vec_s8_ptr ptr i vec_s8=*
+@ vec_u16 v16 x vec_u16
+@ vec_u16_load_op v16 xl vec_u16
+@ vec_u16_ptr ptr i vec_u16=*
+@ const_vec_u16_ptr ptr i vec_u16=*
+@ vec_u32 v16 x vec_u32
+@ vec_u32_load_op v16 xl vec_u32
+@ vec_u32_ptr ptr i vec_u32=*
+@ const_vec_u32_ptr ptr i vec_u32=*
+@ vec_u8 v16 x vec_u8
+@ vec_u8_load_op v16 xl vec_u8
+@ vec_u8_ptr ptr i vec_u8=*
+@ const_vec_u8_ptr ptr i vec_u8=*
+@ void_store_op void s
+@ volatile_void void v
+@ volatile_void_load_op void vl
+@ volatile_void_store_op void vs
+@ volatile_vec_u16 v16 vx vec_u16
+@ char_ptr ptr i char=*
+@ const_char_ptr ptr i char=*
+# @ @ instruction type
+@ @ @ MOP_mfvscr fxu
+@ @ @ MOP_mtvscr fxu
+@ @ @ MOP_dss load
+@ @ @ MOP_dssall load
+@ @ @ MOP_dst load
+@ @ @ MOP_dstst load
+@ @ @ MOP_dststt load
+@ @ @ MOP_dstt load
+@ @ @ MOP_lvebx load
+@ @ @ MOP_lvehx load
+@ @ @ MOP_lvewx load
+@ @ @ MOP_lvsl load
+@ @ @ MOP_lvsr load
+@ @ @ MOP_lvx load
+@ @ @ MOP_lvxl load
+@ @ @ MOP_stvebx store
+@ @ @ MOP_stvehx store
+@ @ @ MOP_stvewx store
+@ @ @ MOP_stvx store
+@ @ @ MOP_stvxl store
+@ @ @ MOP_vaddcuw simple
+@ @ @ MOP_vaddfp fp
+@ @ @ MOP_vaddsbs simple
+@ @ @ MOP_vaddshs simple
+@ @ @ MOP_vaddsws simple
+@ @ @ MOP_vaddubm simple
+@ @ @ MOP_vaddubs simple
+@ @ @ MOP_vadduhm simple
+@ @ @ MOP_vadduhs simple
+@ @ @ MOP_vadduwm simple
+@ @ @ MOP_vadduws simple
+@ @ @ MOP_vand simple
+@ @ @ MOP_vandc simple
+@ @ @ MOP_vavgsb simple
+@ @ @ MOP_vavgsh simple
+@ @ @ MOP_vavgsw simple
+@ @ @ MOP_vavgub simple
+@ @ @ MOP_vavguh simple
+@ @ @ MOP_vavguw simple
+@ @ @ MOP_vcfsx fp
+@ @ @ MOP_vcfux fp
+@ @ @ MOP_vcmpbfp simple
+@ @ @ MOP_vcmpbfpD simple
+@ @ @ MOP_vcmpeqfp simple
+@ @ @ MOP_vcmpeqfpD simple
+@ @ @ MOP_vcmpequb simple
+@ @ @ MOP_vcmpequbD simple
+@ @ @ MOP_vcmpequh simple
+@ @ @ MOP_vcmpequhD simple
+@ @ @ MOP_vcmpequw simple
+@ @ @ MOP_vcmpequwD simple
+@ @ @ MOP_vcmpgefp simple
+@ @ @ MOP_vcmpgefpD simple
+@ @ @ MOP_vcmpgtfp simple
+@ @ @ MOP_vcmpgtfpD simple
+@ @ @ MOP_vcmpgtsb simple
+@ @ @ MOP_vcmpgtsbD simple
+@ @ @ MOP_vcmpgtsh simple
+@ @ @ MOP_vcmpgtshD simple
+@ @ @ MOP_vcmpgtsw simple
+@ @ @ MOP_vcmpgtswD simple
+@ @ @ MOP_vcmpgtub simple
+@ @ @ MOP_vcmpgtubD simple
+@ @ @ MOP_vcmpgtuh simple
+@ @ @ MOP_vcmpgtuhD simple
+@ @ @ MOP_vcmpgtuw simple
+@ @ @ MOP_vcmpgtuwD simple
+@ @ @ MOP_vctsxs fp
+@ @ @ MOP_vctuxs fp
+@ @ @ MOP_vexptefp fp
+@ @ @ MOP_vlogefp fp
+@ @ @ MOP_vmaddfp fp
+@ @ @ MOP_vmaxfp simple
+@ @ @ MOP_vmaxsb simple
+@ @ @ MOP_vmaxsh simple
+@ @ @ MOP_vmaxsw simple
+@ @ @ MOP_vmaxub simple
+@ @ @ MOP_vmaxuh simple
+@ @ @ MOP_vmaxuw simple
+@ @ @ MOP_vmhaddshs complex
+@ @ @ MOP_vmhraddshs complex
+@ @ @ MOP_vminfp simple
+@ @ @ MOP_vminsb simple
+@ @ @ MOP_vminsh simple
+@ @ @ MOP_vminsw simple
+@ @ @ MOP_vminub simple
+@ @ @ MOP_vminuh simple
+@ @ @ MOP_vminuw simple
+@ @ @ MOP_vmladduhm complex
+@ @ @ MOP_vmrghb perm
+@ @ @ MOP_vmrghh perm
+@ @ @ MOP_vmrghw perm
+@ @ @ MOP_vmrglb perm
+@ @ @ MOP_vmrglh perm
+@ @ @ MOP_vmrglw perm
+@ @ @ MOP_vmsummbm complex
+@ @ @ MOP_vmsumshm complex
+@ @ @ MOP_vmsumshs complex
+@ @ @ MOP_vmsumubm complex
+@ @ @ MOP_vmsumuhm complex
+@ @ @ MOP_vmsumuhs complex
+@ @ @ MOP_vmulesb complex
+@ @ @ MOP_vmulesh complex
+@ @ @ MOP_vmuleub complex
+@ @ @ MOP_vmuleuh complex
+@ @ @ MOP_vmulosb complex
+@ @ @ MOP_vmulosh complex
+@ @ @ MOP_vmuloub complex
+@ @ @ MOP_vmulouh complex
+@ @ @ MOP_vnmsubfp fp
+@ @ @ MOP_vnor simple
+@ @ @ MOP_vor simple
+@ @ @ MOP_vperm perm
+@ @ @ MOP_vpkpx perm
+@ @ @ MOP_vpkshss perm
+@ @ @ MOP_vpkshus perm
+@ @ @ MOP_vpkswss perm
+@ @ @ MOP_vpkswus perm
+@ @ @ MOP_vpkuhum perm
+@ @ @ MOP_vpkuhus perm
+@ @ @ MOP_vpkuwum perm
+@ @ @ MOP_vpkuwus perm
+@ @ @ MOP_vrefp fp
+@ @ @ MOP_vrfim fp
+@ @ @ MOP_vrfin fp
+@ @ @ MOP_vrfip fp
+@ @ @ MOP_vrfiz fp
+@ @ @ MOP_vrlb simple
+@ @ @ MOP_vrlh simple
+@ @ @ MOP_vrlw simple
+@ @ @ MOP_vrsqrtefp fp
+@ @ @ MOP_vsel simple
+@ @ @ MOP_vsl simple
+@ @ @ MOP_vslb simple
+@ @ @ MOP_vsldoi perm
+@ @ @ MOP_vslh simple
+@ @ @ MOP_vslo perm_bug
+@ @ @ MOP_vslw simple
+@ @ @ MOP_vspltb perm
+@ @ @ MOP_vsplth perm
+@ @ @ MOP_vspltisb perm
+@ @ @ MOP_vspltish perm
+@ @ @ MOP_vspltisw perm
+@ @ @ MOP_vspltw perm
+@ @ @ MOP_vsr simple
+@ @ @ MOP_vsrab simple
+@ @ @ MOP_vsrah simple
+@ @ @ MOP_vsraw simple
+@ @ @ MOP_vsrb simple
+@ @ @ MOP_vsrh simple
+@ @ @ MOP_vsro perm_bug
+@ @ @ MOP_vsrw simple
+@ @ @ MOP_vsubcuw simple
+@ @ @ MOP_vsubfp fp
+@ @ @ MOP_vsubsbs simple
+@ @ @ MOP_vsubshs simple
+@ @ @ MOP_vsubsws simple
+@ @ @ MOP_vsububm simple
+@ @ @ MOP_vsububs simple
+@ @ @ MOP_vsubuhm simple
+@ @ @ MOP_vsubuhs simple
+@ @ @ MOP_vsubuwm simple
+@ @ @ MOP_vsubuws simple
+@ @ @ MOP_vsum2sws complex
+@ @ @ MOP_vsum4sbs complex
+@ @ @ MOP_vsum4shs complex
+@ @ @ MOP_vsum4ubs complex
+@ @ @ MOP_vsumsws complex
+@ @ @ MOP_vupkhpx perm
+@ @ @ MOP_vupkhsb perm
+@ @ @ MOP_vupkhsh perm
+@ @ @ MOP_vupklpx perm
+@ @ @ MOP_vupklsb perm
+@ @ @ MOP_vupklsh perm
+@ @ @ MOP_vxor simple
+# The vec_abs and vec_abss operations identify their variants with insn_name.
+# Map these into a valid insn code (xfx_perm).
+@ @ @ 1 perm
+@ @ @ 2 perm
+@ @ @ 3 perm
+@ @ @ 4 perm
+@ @ @ 5 perm
+@ @ @ 6 perm
+@ @ @ 7 perm
diff --git a/gcc/config/rs6000/darwin-fpsave.asm b/gcc/config/rs6000/darwin-fpsave.asm
new file mode 100644
index 00000000000..d25a1141c45
--- /dev/null
+++ b/gcc/config/rs6000/darwin-fpsave.asm
@@ -0,0 +1,69 @@
+/* APPLE LOCAL file performance improvement */
+/* This file contains the floating-point save and restore routines.
+
+ THE SAVE AND RESTORE ROUTINES CAN HAVE ONLY ONE GLOBALLY VISIBLE
+ ENTRY POINT - callers have to jump to "saveFP+60" to save f29..f31,
+ for example. For FP reg saves/restores, it takes one instruction
+ (4 bytes) to do the operation; for Vector regs, 2 instructions are
+ required (8 bytes.)
+
+ MORAL: DO NOT MESS AROUND WITH THESE FUNCTIONS! */
+
+.text
+ .align 2
+
+/* saveFP saves R0 -- assumed to be the callers LR -- to 8(R1). */
+
+.private_extern saveFP
+saveFP:
+ stfd f14,-144(r1)
+ stfd f15,-136(r1)
+ stfd f16,-128(r1)
+ stfd f17,-120(r1)
+ stfd f18,-112(r1)
+ stfd f19,-104(r1)
+ stfd f20,-96(r1)
+ stfd f21,-88(r1)
+ stfd f22,-80(r1)
+ stfd f23,-72(r1)
+ stfd f24,-64(r1)
+ stfd f25,-56(r1)
+ stfd f26,-48(r1)
+ stfd f27,-40(r1)
+ stfd f28,-32(r1)
+ stfd f29,-24(r1)
+ stfd f30,-16(r1)
+ stfd f31,-8(r1)
+ stw r0,8(r1)
+ blr
+
+/* restFP restores the caller`s LR from 8(R1). Note that the code for
+ this starts at the offset of F30 restoration, so calling this
+ routine in an attempt to restore only F31 WILL NOT WORK (it would
+ be a stupid thing to do, anyway.) */
+
+.private_extern restFP
+restFP:
+ lfd f14,-144(r1)
+ lfd f15,-136(r1)
+ lfd f16,-128(r1)
+ lfd f17,-120(r1)
+ lfd f18,-112(r1)
+ lfd f19,-104(r1)
+ lfd f20,-96(r1)
+ lfd f21,-88(r1)
+ lfd f22,-80(r1)
+ lfd f23,-72(r1)
+ lfd f24,-64(r1)
+ lfd f25,-56(r1)
+ lfd f26,-48(r1)
+ lfd f27,-40(r1)
+ lfd f28,-32(r1)
+ lfd f29,-24(r1)
+ /* <OFFSET OF F30 RESTORE> restore callers LR */
+ lwz r0,8(r1)
+ lfd f30,-16(r1)
+ /* and prepare for return to caller */
+ mtlr r0
+ lfd f31,-8(r1)
+ blr
diff --git a/gcc/config/rs6000/darwin-vecsave.asm b/gcc/config/rs6000/darwin-vecsave.asm
new file mode 100644
index 00000000000..8c5352ee709
--- /dev/null
+++ b/gcc/config/rs6000/darwin-vecsave.asm
@@ -0,0 +1,133 @@
+/* APPLE LOCAL file AltiVec */
+/* Vector save/restore routines for Darwin. Note that each vector
+ save/restore requires 2 instructions (8 bytes.)
+
+ THE SAVE AND RESTORE ROUTINES CAN HAVE ONLY ONE GLOBALLY VISIBLE
+ ENTRY POINT - callers have to jump to "saveFP+60" to save f29..f31,
+ for example. For FP reg saves/restores, it takes one instruction
+ (4 bytes) to do the operation; for Vector regs, 2 instructions are
+ required (8 bytes.)
+
+ MORAL: DO NOT MESS AROUND WITH THESE FUNCTIONS! */
+
+.text
+ .align 2
+
+.private_extern saveVEC
+saveVEC:
+ li r11,-192
+ stvx v20,r11,r0
+ li r11,-176
+ stvx v21,r11,r0
+ li r11,-160
+ stvx v22,r11,r0
+ li r11,-144
+ stvx v23,r11,r0
+ li r11,-128
+ stvx v24,r11,r0
+ li r11,-112
+ stvx v25,r11,r0
+ li r11,-96
+ stvx v26,r11,r0
+ li r11,-80
+ stvx v27,r11,r0
+ li r11,-64
+ stvx v28,r11,r0
+ li r11,-48
+ stvx v29,r11,r0
+ li r11,-32
+ stvx v30,r11,r0
+ li r11,-16
+ stvx v31,r11,r0
+ blr
+
+.private_extern restVEC
+restVEC:
+ li r11,-192
+ lvx v20,r11,r0
+ li r11,-176
+ lvx v21,r11,r0
+ li r11,-160
+ lvx v22,r11,r0
+ li r11,-144
+ lvx v23,r11,r0
+ li r11,-128
+ lvx v24,r11,r0
+ li r11,-112
+ lvx v25,r11,r0
+ li r11,-96
+ lvx v26,r11,r0
+ li r11,-80
+ lvx v27,r11,r0
+ li r11,-64
+ lvx v28,r11,r0
+ li r11,-48
+ lvx v29,r11,r0
+ li r11,-32
+ lvx v30,r11,r0
+ li r11,-16
+ lvx v31,r11,r0
+ blr
+
+/* saveVEC_vr11 -- as saveVEC but VRsave is returned in R11. */
+
+.private_extern saveVEC_vr11
+saveVEC_vr11:
+ li r11,-192
+ stvx v20,r11,r0
+ li r11,-176
+ stvx v21,r11,r0
+ li r11,-160
+ stvx v22,r11,r0
+ li r11,-144
+ stvx v23,r11,r0
+ li r11,-128
+ stvx v24,r11,r0
+ li r11,-112
+ stvx v25,r11,r0
+ li r11,-96
+ stvx v26,r11,r0
+ li r11,-80
+ stvx v27,r11,r0
+ li r11,-64
+ stvx v28,r11,r0
+ li r11,-48
+ stvx v29,r11,r0
+ li r11,-32
+ stvx v30,r11,r0
+ li r11,-16
+ stvx v31,r11,r0
+ mfspr r11,VRsave
+ blr
+
+/* As restVec, but the original VRsave value passed in R10. */
+
+.private_extern restVEC_vr10
+restVEC_vr10:
+ li r11,-192
+ lvx v20,r11,r0
+ li r11,-176
+ lvx v21,r11,r0
+ li r11,-160
+ lvx v22,r11,r0
+ li r11,-144
+ lvx v23,r11,r0
+ li r11,-128
+ lvx v24,r11,r0
+ li r11,-112
+ lvx v25,r11,r0
+ li r11,-96
+ lvx v26,r11,r0
+ li r11,-80
+ lvx v27,r11,r0
+ li r11,-64
+ lvx v28,r11,r0
+ li r11,-48
+ lvx v29,r11,r0
+ li r11,-32
+ lvx v30,r11,r0
+ li r11,-16
+ lvx v31,r11,r0
+ /* restore VRsave from R10. */
+ mtspr VRsave,r10
+ blr
diff --git a/gcc/config/rs6000/darwin-worldsave.asm b/gcc/config/rs6000/darwin-worldsave.asm
new file mode 100644
index 00000000000..2d43f61adde
--- /dev/null
+++ b/gcc/config/rs6000/darwin-worldsave.asm
@@ -0,0 +1,233 @@
+/* APPLE LOCAL file world save/restore */
+/* This file contains the exception-handling save_world and
+ restore_world routines, which need to do a run-time check to see if
+ they should save and restore the vector regs. */
+
+.data
+ .align 2
+
+#ifdef __DYNAMIC__
+
+.non_lazy_symbol_pointer
+L_has_vec$non_lazy_ptr:
+ .indirect_symbol __cpu_has_altivec
+ .long 0
+
+#else
+
+/* For static, "pretend" we have a non-lazy-pointer. */
+
+L_has_vec$non_lazy_ptr:
+ .long __cpu_has_altivec
+
+#endif
+
+
+.text
+ .align 2
+
+/* save_world and rest_world save/restore F14-F31 and possibly V20-V31
+ (assuming you have a CPU with vector registers; we use a global var
+ provided by the System Framework to determine this.)
+
+ SAVE_WORLD takes R0 (the caller`s caller`s return address) and R11
+ (the stack frame size) as parameters. It returns VRsave in R0 if
+ we`re on a CPU with vector regs.
+
+ With gcc3, we now need to save and restore CR as well, since gcc3's
+ scheduled prologs can cause comparisons to be moved before calls to
+ save_world!
+
+ USES: R0 R11 R12 */
+
+.private_extern save_world
+save_world:
+ stw r0,8(r1)
+ mflr r0
+ bcl 20,31,Ls$pb
+Ls$pb: mflr r12
+ addis r12,r12,ha16(L_has_vec$non_lazy_ptr-Ls$pb)
+ lwz r12,lo16(L_has_vec$non_lazy_ptr-Ls$pb)(r12)
+ mtlr r0
+ lwz r12,0(r12)
+ /* grab CR */
+ mfcr r0
+ /* test HAS_VEC */
+ cmpwi r12,0
+ stfd f14,-144(r1)
+ stfd f15,-136(r1)
+ stfd f16,-128(r1)
+ stfd f17,-120(r1)
+ stfd f18,-112(r1)
+ stfd f19,-104(r1)
+ stfd f20,-96(r1)
+ stfd f21,-88(r1)
+ stfd f22,-80(r1)
+ stfd f23,-72(r1)
+ stfd f24,-64(r1)
+ stfd f25,-56(r1)
+ stfd f26,-48(r1)
+ stfd f27,-40(r1)
+ stfd f28,-32(r1)
+ stfd f29,-24(r1)
+ stfd f30,-16(r1)
+ stfd f31,-8(r1)
+ stmw r13,-220(r1)
+ /* stash CR */
+ stw r0,4(r1)
+ /* set R12 pointing at Vector Reg save area */
+ addi r12,r1,-224
+ /* allocate stack frame */
+ stwux r1,r1,r11
+ /* ...but return if HAS_VEC is zero */
+ bne+ L$saveVMX
+ /* Not forgetting to restore CR. */
+ mtcr r0
+ blr
+
+L$saveVMX:
+ /* We're saving Vector regs too. */
+ /* Restore CR from R0. No More Branches! */
+ mtcr r0
+
+ /* We should really use VRSAVE to figure out which vector regs
+ we actually need to save and restore. Some other time :-/ */
+
+ li r11,-192
+ stvx v20,r11,r12
+ li r11,-176
+ stvx v21,r11,r12
+ li r11,-160
+ stvx v22,r11,r12
+ li r11,-144
+ stvx v23,r11,r12
+ li r11,-128
+ stvx v24,r11,r12
+ li r11,-112
+ stvx v25,r11,r12
+ li r11,-96
+ stvx v26,r11,r12
+ li r11,-80
+ stvx v27,r11,r12
+ li r11,-64
+ stvx v28,r11,r12
+ li r11,-48
+ stvx v29,r11,r12
+ li r11,-32
+ stvx v30,r11,r12
+ mfspr r0,VRsave
+ li r11,-16
+ stvx v31,r11,r12
+ /* VRsave lives at -224(R1) */
+ stw r0,0(r12)
+ blr
+
+
+/* eh_rest_world_r10 is jumped to, not called, so no need to worry about LR.
+ R10 is the C++ EH stack adjust parameter, we return to the caller`s caller.
+
+ USES: R0 R10 R11 R12 and R7 R8
+ RETURNS: C++ EH Data registers (R3 - R6.)
+
+ We now set up R7/R8 and jump to rest_world_eh_r7r8.
+
+ rest_world doesn't use the R10 stack adjust parameter, nor does it
+ pick up the R3-R6 exception handling stuff. */
+
+.private_extern rest_world
+rest_world:
+ /* Pickup previous SP */
+ lwz r11, 0(r1)
+ li r7, 0
+ lwz r8, 8(r11)
+ li r10, 0
+ b rest_world_eh_r7r8
+
+.private_extern eh_rest_world_r10
+eh_rest_world_r10:
+ /* Pickup previous SP */
+ lwz r11, 0(r1)
+ mr r7,r10
+ lwz r8, 8(r11)
+ /* pickup the C++ EH data regs (R3 - R6.) */
+ lwz r6,-420(r11)
+ lwz r5,-424(r11)
+ lwz r4,-428(r11)
+ lwz r3,-432(r11)
+
+ b rest_world_eh_r7r8
+
+/* rest_world_eh_r7r8 is jumped to -- not called! -- when we're doing
+ the exception-handling epilog. R7 contains the offset to add to
+ the SP, and R8 contains the 'real' return address.
+
+ USES: R0 R11 R12 [R7/R8]
+ RETURNS: C++ EH Data registers (R3 - R6.) */
+
+rest_world_eh_r7r8:
+ bcl 20,31,Lr7r8$pb
+Lr7r8$pb: mflr r12
+ lwz r11,0(r1)
+ /* R11 := previous SP */
+ addis r12,r12,ha16(L_has_vec$non_lazy_ptr-Lr7r8$pb)
+ lwz r12,lo16(L_has_vec$non_lazy_ptr-Lr7r8$pb)(r12)
+ lwz r0,4(r11)
+ /* R0 := old CR */
+ lwz r12,0(r12)
+ /* R12 := HAS_VEC */
+ mtcr r0
+ cmpwi r12,0
+ lmw r13,-220(r11)
+ beq L.rest_world_fp_eh
+ /* restore VRsave and V20..V31 */
+ lwz r0,-224(r11)
+ li r12,-416
+ mtspr VRsave,r0
+ lvx v20,r11,r12
+ li r12,-400
+ lvx v21,r11,r12
+ li r12,-384
+ lvx v22,r11,r12
+ li r12,-368
+ lvx v23,r11,r12
+ li r12,-352
+ lvx v24,r11,r12
+ li r12,-336
+ lvx v25,r11,r12
+ li r12,-320
+ lvx v26,r11,r12
+ li r12,-304
+ lvx v27,r11,r12
+ li r12,-288
+ lvx v28,r11,r12
+ li r12,-272
+ lvx v29,r11,r12
+ li r12,-256
+ lvx v30,r11,r12
+ li r12,-240
+ lvx v31,r11,r12
+
+L.rest_world_fp_eh:
+ lfd f14,-144(r11)
+ lfd f15,-136(r11)
+ lfd f16,-128(r11)
+ lfd f17,-120(r11)
+ lfd f18,-112(r11)
+ lfd f19,-104(r11)
+ lfd f20,-96(r11)
+ lfd f21,-88(r11)
+ lfd f22,-80(r11)
+ lfd f23,-72(r11)
+ lfd f24,-64(r11)
+ lfd f25,-56(r11)
+ lfd f26,-48(r11)
+ lfd f27,-40(r11)
+ lfd f28,-32(r11)
+ lfd f29,-24(r11)
+ lfd f30,-16(r11)
+ /* R8 is the exception-handler's address */
+ mtctr r8
+ lfd f31,-8(r11)
+ /* set SP to original value + R7 offset */
+ add r1,r11,r7
+ bctr
diff --git a/gcc/config/rs6000/darwin.h b/gcc/config/rs6000/darwin.h
index 6f193f739c3..378cf3debf3 100644
--- a/gcc/config/rs6000/darwin.h
+++ b/gcc/config/rs6000/darwin.h
@@ -96,7 +96,7 @@ do { \
#define CC1_SPEC "\
%{gused: -feliminate-unused-debug-symbols %<gused }\
%{static: %{Zdynamic: %e conflicting code gen style switches are used}}\
-%{!static:%{!mdynamic-no-pic:-fPIC}}"
+%{!static:%{!fast:%{!fastf:%{!fastcp:%{!mdynamic-no-pic:-fPIC}}}}}"
/* It's virtually impossible to predict all the possible combinations
of -mcpu and -maltivec and whatnot, so just supply
@@ -130,6 +130,24 @@ do { \
#undef RS6000_PIC_OFFSET_TABLE_REGNUM
#define RS6000_PIC_OFFSET_TABLE_REGNUM 31
+/* APPLE LOCAL begin -pg fix */
+/* -pg has a problem which is normally concealed by -fPIC;
+ either -mdynamic-no-pic or -static exposes the -pg problem, causing the
+ crash. FSF gcc for Darwin also has this bug. The problem is that -pg
+ causes several int registers to be saved and restored although they may
+ not actually be used (config/rs6000/rs6000.c:first_reg_to_save()). In the
+ rare case where none of them is actually used, a consistency check fails
+ (correctly). This cannot happen with -fPIC because the PIC register (R31)
+ is always "used" in the sense checked by the consistency check. The
+ easy fix, here, is therefore to mark R31 always "used" whenever -pg is on.
+ A better, but harder, fix would be to improve -pg's register-use
+ logic along the lines suggested by comments in the function listed above. */
+#undef PIC_OFFSET_TABLE_REGNUM
+#define PIC_OFFSET_TABLE_REGNUM ((flag_pic || profile_flag) \
+ ? RS6000_PIC_OFFSET_TABLE_REGNUM \
+ : INVALID_REGNUM)
+/* APPLE LOCAL end -pg fix */
+
/* Pad the outgoing args area to 16 bytes instead of the usual 8. */
#undef STARTING_FRAME_OFFSET
@@ -145,14 +163,27 @@ do { \
/* These are used by -fbranch-probabilities */
#define HOT_TEXT_SECTION_NAME "__TEXT,__text,regular,pure_instructions"
+/* APPLE LOCAL begin hot/cold partitioning */
#define UNLIKELY_EXECUTED_TEXT_SECTION_NAME \
- "__TEXT,__text2,regular,pure_instructions"
+ "__TEXT,__unlikely,regular,pure_instructions"
+/* APPLE LOCAL end hot/cold partitioning */
+/* APPLE LOCAL begin long branch */
/* Define cutoff for using external functions to save floating point.
- Currently on Darwin, always use inline stores. */
+ For Darwin, use the function for more than a few registers. */
+
+#undef FP_SAVE_INLINE
+#define FP_SAVE_INLINE(FIRST_REG) \
+ (((FIRST_REG) > 60 && (FIRST_REG) < 64) \
+ || TARGET_LONG_BRANCH)
+
+/* Define cutoff for using external functions to save vector registers. */
-#undef FP_SAVE_INLINE
-#define FP_SAVE_INLINE(FIRST_REG) ((FIRST_REG) < 64)
+#undef VECTOR_SAVE_INLINE
+#define VECTOR_SAVE_INLINE(FIRST_REG) \
+ (((FIRST_REG) >= LAST_ALTIVEC_REGNO - 1 && (FIRST_REG) <= LAST_ALTIVEC_REGNO) \
+ || TARGET_LONG_BRANCH)
+/* APPLE LOCAL end long branch */
/* The assembler wants the alternate register names, but without
leading percent sign. */
@@ -212,11 +243,7 @@ do { \
#undef ASM_COMMENT_START
#define ASM_COMMENT_START ";"
-/* FP save and restore routines. */
-#define SAVE_FP_PREFIX "._savef"
-#define SAVE_FP_SUFFIX ""
-#define RESTORE_FP_PREFIX "._restf"
-#define RESTORE_FP_SUFFIX ""
+/* APPLE LOCAL don't define SAVE_FP_PREFIX and friends */
/* This is how to output an assembler line that says to advance
the location counter to a multiple of 2**LOG bytes using the
@@ -288,38 +315,63 @@ do { \
? GENERAL_REGS \
: (CLASS))
-/* Fix for emit_group_load (): force large constants to be pushed via regs. */
-#define ALWAYS_PUSH_CONSTS_USING_REGS_P 1
-
-/* This now supports a natural alignment mode */
-/* Darwin word-aligns FP doubles but doubleword-aligns 64-bit ints. */
-#define ADJUST_FIELD_ALIGN(FIELD, COMPUTED) \
- (TARGET_ALIGN_NATURAL ? (COMPUTED) : \
- (TYPE_MODE (TREE_CODE (TREE_TYPE (FIELD)) == ARRAY_TYPE \
- ? get_inner_array_type (FIELD) \
- : TREE_TYPE (FIELD)) == DFmode \
- ? MIN ((COMPUTED), 32) : (COMPUTED)))
-
-/* Darwin increases natural record alignment to doubleword if the first
- field is an FP double while the FP fields remain word aligned. */
-#define ROUND_TYPE_ALIGN(STRUCT, COMPUTED, SPECIFIED) \
- ((TREE_CODE (STRUCT) == RECORD_TYPE \
- || TREE_CODE (STRUCT) == UNION_TYPE \
- || TREE_CODE (STRUCT) == QUAL_UNION_TYPE) \
- && TARGET_ALIGN_NATURAL == 0 \
- ? rs6000_special_round_type_align (STRUCT, COMPUTED, SPECIFIED) \
- : (TARGET_ALTIVEC && TREE_CODE (STRUCT) == VECTOR_TYPE) \
- ? MAX (MAX ((COMPUTED), (SPECIFIED)), 128) \
- : MAX ((COMPUTED), (SPECIFIED)))
+/* APPLE LOCAL begin Macintosh alignment 2002-2-26 ff */
+/* This now supports the Macintosh power, mac68k, and natural
+ alignment modes. It now has one more parameter than the standard
+ version of the ADJUST_FIELD_ALIGN macro.
+
+ The macro works as follows: We use the computed alignment of the
+ field if we are in the natural alignment mode or if the field is
+ a vector. Otherwise, if we are in the mac68k alignment mode, we
+ use the minimum of the computed alignment and 16 (pegging at
+ 2-byte alignment). If we are in the power mode, we peg at 32
+ (word alignment) unless it is the first field of the struct, in
+ which case we use the computed alignment. */
+#undef ADJUST_FIELD_ALIGN
+#define ADJUST_FIELD_ALIGN(FIELD, COMPUTED, FIRST_FIELD_P) \
+ (TARGET_ALIGN_NATURAL ? (COMPUTED) : \
+ (((COMPUTED) == RS6000_VECTOR_ALIGNMENT) \
+ ? RS6000_VECTOR_ALIGNMENT \
+ : (MIN ((COMPUTED), \
+ (TARGET_ALIGN_MAC68K ? 16 \
+ : ((FIRST_FIELD_P) ? (COMPUTED) \
+ : 32))))))
+
+#undef ROUND_TYPE_ALIGN
+/* Macintosh alignment modes require more complicated handling
+ of alignment, so we replace the macro with a call to a
+ out-of-line function. */
+union tree_node;
+extern unsigned round_type_align (union tree_node*, unsigned, unsigned); /* rs6000.c */
+#define ROUND_TYPE_ALIGN(STRUCT, COMPUTED, SPECIFIED) \
+ round_type_align(STRUCT, COMPUTED, SPECIFIED)
+/* APPLE LOCAL end Macintosh alignment 2002-2-26 ff */
+
+/* APPLE LOCAL begin alignment */
+/* Make sure local alignments come from the type node, not the mode;
+ mode-based alignments are wrong for vectors. */
+#undef LOCAL_ALIGNMENT
+#define LOCAL_ALIGNMENT(TYPE, ALIGN) (MAX ((unsigned) ALIGN, \
+ TYPE_ALIGN (TYPE)))
+/* APPLE LOCAL end alignment */
/* XXX: Darwin supports neither .quad, or .llong, but it also doesn't
support 64 bit PowerPC either, so this just keeps things happy. */
#define DOUBLE_INT_ASM_OP "\t.quad\t"
+/* APPLE LOCAL begin branch cost */
+#undef BRANCH_COST
+/* Better code is generated by saying conditional branches take 1 tick. */
+#define BRANCH_COST 1
+/* APPLE LOCAL end branch cost */
+
+/* APPLE LOCAL indirect calls in R12 */
+/* Address of indirect call must be computed here */
+#define MAGIC_INDIRECT_CALL_REG 12
+
/* For binary compatibility with 2.95; Darwin C APIs use bool from
stdbool.h, which was an int-sized enum in 2.95. */
#define BOOL_TYPE_SIZE INT_TYPE_SIZE
-#undef REGISTER_TARGET_PRAGMAS
-#define REGISTER_TARGET_PRAGMAS DARWIN_REGISTER_TARGET_PRAGMAS
-
+/* APPLE LOCAL OS pragma hook */
+/* Register generic Darwin pragmas as "OS" pragmas. */
diff --git a/gcc/config/rs6000/ops-to-gp b/gcc/config/rs6000/ops-to-gp
new file mode 100755
index 00000000000..becb406749b
--- /dev/null
+++ b/gcc/config/rs6000/ops-to-gp
@@ -0,0 +1,620 @@
+#!/bin/sh
+# APPLE LOCAL file AltiVec
+# ops-to-gp -gcc vec.ops builtin.ops
+# Creates vec.h used by rs6000.c
+
+arg0=`basename $0`
+err() {
+ echo "$arg0: $*" 1>&2
+ exit 2
+}
+
+if [ $# -eq 0 ] ; then
+ echo "Usage: $arg0 [ -mcc | -gcc ] builtin-ops ..." 1>&2
+ exit 1
+fi
+
+MCC=1
+GCC=0
+suffix="gp"
+if [ "$1" = "-mcc" ] ; then
+ shift;
+elif [ "$1" = "-gcc" ] ; then
+ GCC=1
+ MCC=0
+ suffix="h"
+ shift;
+fi
+
+output=`basename $1 .ops`
+gperf="gperf -G -a -o -k1-15 -p -t -D -T -N Is_Builtin_Function $output.gp";
+
+# Lines in the ops file have the form
+# @ @ betype betype-code type-spelling
+# @ fetype betype [code]
+# @ @ @ instruction type
+# generic op1 op2 ... opn = result specific when configure [addressible
+# [instruction [const_ptr_ok [volatile_ptr_ok [transform [predicate]]]]]]
+
+# Sort the ops file to put it in a canonical order.
+sort -u $* | \
+
+# Add specific function uid's, make generic functions from specific
+# functions, validate the types used, compute default parameters, and
+# compute parts of the default transform and predicate functions.
+awk 'BEGIN {
+ i = 0
+ EQ = i++
+ RESULT = i++
+ SPECIFIC = i++
+ WHEN = i++
+ CONFIGURED = i++
+ ADDRESSIBLE = i++
+ INSTRUCTION = i++
+ CONST_PTR_OK = i++
+ VOLATILE_PTR_OK = i++
+ TRANSFORM = i++
+ PREDICATE = i++
+ n_lines = 1;
+ tree[3] = "Make_Folded_4tree";
+ tree[2] = "Make_Folded_3tree";
+ tree[1] = "Make_Folded_Btree";
+ tree[0] = "Make_Utree";
+ optimize["vec_sub"] = 1;
+ optimize["vec_subs"] = 1;
+ optimize["vec_xor"] = 1;
+ optimize["vec_andc"] = 1;
+ optimize["vec_avg"] = 2;
+ optimize["vec_or"] = 2;
+ optimize["vec_and"] = 2;
+ optimize["vec_max"] = 2;
+ optimize["vec_min"] = 2;
+ optimize["vec_sld"] = 3;
+ optimize["vec_splat_s8"] = 4;
+ optimize["vec_splat_s16"] = 5;
+ optimize["vec_splat_s32"] = 6;
+ optimize["vec_splat_u8"] = 4;
+ optimize["vec_splat_u16"] = 5;
+ optimize["vec_splat_u32"] = 6;
+ optimize["vec_cmpeq"] = 7;
+ optimize["vec_lvsl"] = 8;
+ optimize["vec_lvsr"] = 9;
+ # These operations need additional transformation. Key off the
+ # optimize attribute to identify them.
+ optimize["vec_cmplt"] = 10;
+ optimize["vec_cmple"] = 10;
+ optimize["vec_abs"] = 11;
+ optimize["vec_abss"] = 11;
+ }
+ function no_type(t) {
+ printf "%% Error: type %s not declared.\n", t;
+ status = 1;
+ exit;
+ }
+ # Record the type.
+ $1 == "@" {
+ if ($2 == "@") {
+ if ($3 == "@") {
+ # Definition of an instruction.
+ insn_type[$4] = $5; # type
+ } else {
+ # Definition of a betype.
+ becode[$3] = $4; # betype-code
+ bespell[$3] = $5; # type-spelling
+ gsub(/\=/, " ", bespell[$3]);
+ }
+ } else {
+ # Definition of a fetype.
+ print $0;
+ if (!becode[$3]) no_type($3); # Must have defined the betype.
+ betype[$2] = $3; # betype;
+ if (NF == 3)
+ code[$2] = "";
+ else
+ code[$2] = $4; # code
+ }
+ }
+ function no_equal(i,l) {
+ printf "%% Syntax error %d: %s\n", i, l;
+ status = 1;
+ exit;
+ }
+ function error(f,a) {
+ printf( ("%% error: " f), a);
+ status = 1;
+ exit;
+ }
+ # Ignore comment lines.
+ $1 != "#" && $1 != "@" {
+ # Generate the signature of the specific function, the predicate,
+ # the transform, the arguments to the transform function, the
+ # arguments to the predicate function, and the spelling of the
+ # function type.
+ signature = "";
+ predicate = "";
+ transform = "";
+ insn_code = "";
+ transform_args = "";
+ predicate_args = "";
+ function_type = "";
+ # First, consider the parameter types.
+ for (i = 2; $i != "=" && i < NF; i++) {
+ if ($i != "...") {
+ if (!betype[$i]) no_type($i);
+ signature = (signature " " $i);
+ predicate = (predicate "_" betype[$i]);
+ transform = (transform code[$i]);
+ transform_args = (transform_args ", ND_kid(t," i-1 ")");
+ predicate_args = (predicate_args " " becode[betype[$i]]);
+ if (function_type)
+ function_type = (function_type ", " bespell[betype[$i]]);
+ else
+ function_type = bespell[betype[$i]];
+ }
+ }
+ constraints = (transform "@");
+ # Check the syntax of the ops file.
+ if ($i != "=" || NF > i+PREDICATE || NF < i+CONFIGURE) no_equal(i,$0);
+ if (!betype[$(i+RESULT)]) no_type($(i+RESULT));
+ # Incorporate the result type.
+ if (i == 2) {
+ predicate = "_void";
+ function_type = "void";
+ }
+ signature = ($(i+SPECIFIC) signature);
+ predicate = sprintf("is_%s_func%s", betype[$(i+RESULT)], predicate);
+ predicate_args = (becode[betype[$(i+RESULT)]] predicate_args);
+ function_type = sprintf("(%s (*)(%s))", bespell[betype[$(i+RESULT)]], \
+ function_type);
+ if (substr(code[$(i+RESULT)], 1, 1) == "j") {
+ # Handle a jump asm. The code is expedted to be
+ # j={cc-bit-num}={cc-bit-value}[={r|d}]. The operation must have
+ # one operand if the code d is used and two operands otherwise.
+ # The transform function can implement the r code by reversing the
+ # two operands. In all cases, the first operand is a computed
+ # constant encoding both the bit number and the test.
+ n = split(code[$(i+RESULT)], jmp, "=");
+ if (jmp[n] == "d" && i != 3) error("%d operands", i-2);
+ if (jmp[n] != "d" && i != 4) error("%d operands", i-2);
+ if (jmp[n] == "r")
+ transform_args = ", ND_kid(t,2), ND_kid(t,1)";
+ transform_args = sprintf("%s(OP_VCMP%s%s", tree[i-2], \
+ toupper(jmp[3]), transform_args);
+ if (jmp[n] == "r")
+ transform = ("r" transform);
+ insn_code = sprintf("CODE_FOR_j_%d_%s_f%s", jmp[2], jmp[3], \
+ transform);
+ transform = sprintf("transform_j_%d_%s_f%s", jmp[2], jmp[3], \
+ transform);
+ } else {
+ transform_args = sprintf("%s(OP_%sASM%s%s", tree[i-2], \
+ toupper(code[$(i+RESULT)]), \
+ toupper(transform), transform_args);
+ insn_code = sprintf("CODE_FOR_%sf%s", code[$(i+RESULT)], transform);
+ transform = sprintf("transform_%sf%s", code[$(i+RESULT)], transform);
+ }
+ # Give a unique id to the signature
+ if (count[signature] == 0)
+ count[signature] = ++uid[$(i+SPECIFIC)];
+
+ # Compute the default instruction name
+ nf = split($(i+SPECIFIC), part, "_");
+ instruction = ("MOP_" part[nf]);
+
+ # Compute the insn_code, but use the instruction override if given.
+ if (NF >= i+INSTRUCTION)
+ instruction = $(i+INSTRUCTION);
+ if (insn_type[instruction])
+ insn_code = (insn_code "_" insn_type[instruction]);
+
+ # Allow the user to override the addressibility, instruction,
+ # const_ptr_ok, volatile_ptr_ok, transform, and predicate.
+ if (NF >= i+ADDRESSIBLE)
+ addressible = "";
+ else
+ addressible = "FALSE";
+
+ if (NF >= i+INSTRUCTION)
+ instruction = "";
+ else if (substr($1, 1, 4) == "vec_")
+ print "@ @3", instruction;
+
+ if (NF >= i+CONST_PTR_OK)
+ const_ptr_ok = "";
+ else
+ const_ptr_ok = "FALSE";
+
+ if (NF >= i+VOLATILE_PTR_OK)
+ volatile_ptr_ok = "";
+ else
+ volatile_ptr_ok = "FALSE";
+
+ if (NF >= i+TRANSFORM)
+ transform = "";
+ else
+ print "@ @1", transform, transform_args;
+
+ if (NF >= i+PREDICATE)
+ predicate = "";
+ else
+ print "@ @2", i-2, predicate, predicate_args, function_type;
+
+ if (optimize[$1])
+ optimize_method = optimize[$1];
+ else
+ optimize_method = "0";
+
+ # Record the line, addressibility, instruction, transform,
+ # predicate, and unique id.
+ line[n_lines++] = ($0 " " addressible " " instruction " " \
+ const_ptr_ok " " volatile_ptr_ok " " transform " " \
+ predicate " " insn_code " " constraints " " \
+ optimize_method " " count[signature]);
+ }
+ END {
+ if (status) exit;
+ # generic op1 op2 ... opn = result specific when configured
+ # addressable instruction const_ptr_ok volatile_ptr_ok
+ # transform predicate insn_code constraints optimize uid
+ SPECIFIC = 12
+ for (i = 1; i < n_lines; i++) {
+ nf = split(line[i], part);
+ specific = part[nf-SPECIFIC];
+
+ # Print the generic form.
+ printf "%s", part[1];
+ for (j = 2; j <= nf-SPECIFIC; j++) printf " %s", part[j];
+ if (uid[specific] > 1) printf ":%d", part[nf];
+ while (j < nf) printf " %s", part[j++];
+ printf "\n";
+
+ # Print the specific form.
+ printf "%s", specific;
+ for (j = 2; j <= nf-SPECIFIC; j++) printf " %s", part[j];
+ if (uid[specific] > 1) printf ":%d", part[nf];
+ while (j < nf) printf " %s", part[j++];
+ printf "\n";
+ }
+ }' | \
+
+# Strip out load and store qualifiers.
+sed -e 's/_load_op//g' -e 's/_store_op//g' | \
+
+# Sort the processed file and eliminate duplicates.
+sort -u | \
+
+# Append the count of each generic function to each line.
+awk 'function push() {
+ if (num)
+ for (i = 0; i < num; i++)
+ print line[i], num;
+ num = 0;
+ }
+ $1 == "@" {
+ print $0;
+ }
+ $1 != "@" {
+ if (last != $1)
+ push();
+ last = $1;
+ line[num++] = $0;
+ }
+ END {
+ push();
+ }' | \
+
+# Now compute the gperf input file.
+# Lines now have a fixed format
+# generic op1 ... opn = result specific instruction when configured
+# addressible const_ptr_ok volatile_ptr_ok transform predicate
+# insn_code constraints optimize count
+awk 'BEGIN {
+ MCC = '$MCC'
+ GCC = '$GCC'
+ i = 0;
+ COUNT = i++
+ OPTIMIZE = i++
+ CONSTRAINTS = i++
+ INSN_CODE = i++
+ PREDICATE = i++
+ TRANSFORM = i++
+ VOLATILE_PTR_OK = i++
+ CONST_PTR_OK = i++
+ INSTRUCTION = i++
+ ADDRESSIBLE = i++
+ CONFIGURED = i++
+ WHEN = i++
+ SPECIFIC = i++
+ RESULT = i++
+ EQ = i++
+ OPN = i++
+ NARGS = i++
+ if (MCC) {
+ print "%{";
+ print "/* Command-line: '"$gperf"' */";
+ MAXARGS = 5
+ }
+ if (GCC)
+ MAXARGS = 3
+ }
+ function write_test(tree, type, num) {
+ if (type == "PTR") {
+ printf "\n && TY_kind(%s) == KIND_POINTER", tree;
+ } else if (type == "I5") {
+ printf "\n && is_integer_type(%s)", tree;
+ printf "\n && Is_Const(ND_kid0(ND_kid(t,%d)), &tc)", num;
+ printf "\n && ((UINT32)Targ_To_Host(tc) + 16) < 32";
+ } else if (type == "U5") {
+ printf "\n && is_integer_type(%s)", tree;
+ printf "\n && Is_Const(ND_kid0(ND_kid(t,%d)), &tc)", num;
+ printf "\n && (UINT32)Targ_To_Host(tc) < 32";
+ } else if (type == "U4") {
+ printf "\n && is_integer_type(%s)", tree;
+ printf "\n && Is_Const(ND_kid0(ND_kid(t,%d)), &tc)", num;
+ printf "\n && (UINT32)Targ_To_Host(tc) < 16";
+ } else if (type == "U2") {
+ printf "\n && is_integer_type(%s)", tree;
+ printf "\n && Is_Const(ND_kid0(ND_kid(t,%d)), &tc)", num;
+ printf "\n && (UINT32)Targ_To_Host(tc) < 4";
+ } else if (type == "BETYPE_U4" || type == "BETYPE_I4") {
+ printf "\n && is_integer_type(%s)", tree;
+ } else {
+ printf "\n && Similar_Types(%s,", tree;
+ printf "\n\t\t Be_Type_Tbl(%s), IGNORE_QUALIFIERS)", type;
+ }
+ }
+ $1 == "@" {
+ if (MCC) {
+ if ($2 == "@1") {
+ # Write the predicate function from the given parameters.
+ # The format is:
+ # @ @1 transform_ifii Make_3tree(OP_IASMII, ND_kid(t,1), ND_kid(t,2)
+ print "";
+ print "/*ARGSUSED*/";
+ print "static void";
+ print $3 "(ND *func, ND *parent, ND *t, struct builtin *self)";
+ print "{";
+ printf " *t = *%s", $4;
+ for (i = 5; i <= NF; i++) printf " %s", $i;
+ print ",";
+ if (split($3,jmp,"_") == 5 && jmp[2] == "j")
+ printf "\t\t MK_I4CONST_ND((self->data << 5) + %d));\n", \
+ jmp[3];
+ else
+ print "\t\t MK_I4CONST_ND(self->data));";
+
+ print " Is_True(self->data > 0, (\"No implementation for %s\", self->name));";
+ print "}";
+ } else if ($2 == "@2") {
+ # Write the transform function from the given parameters.
+ # The format is:
+ # @ @2 2 is_int_func_int_int BETYPE_I4 BETYPE_I4 BETYPE_I4
+ # (int (*)(int, int))
+ print "";
+ print "/*ARGSUSED*/";
+ print "static BOOL";
+ print $4 "(ND *func, ND *parent, ND *t, struct builtin *self)";
+ print "{";
+ print " TCON tc;";
+ printf " if (ND_nkids(t) == %d", $3+1;
+ write_test("ST_type(ND_dec(func))", $5, "");
+ for (i = 1; i <= $3; i++) {
+ printf "\n && ND_name(ND_kid(t,%d)) == TO_VAL", i;
+ write_test(sprintf("The_Tree_Type(ND_kid(t,%d))", i), $(i+5), i);
+ }
+ print ")";
+ print " return TRUE;";
+ print " Error_Prt_Line (ND_linenum(t), ec_builtin_function_type, self->name,";
+ i = $3+6;
+ printf "\t\t \"%s", $i;
+ while (++i <= NF) printf " %s", $i;
+ print "\");";
+ print " return FALSE;";
+ print "}";
+ } else if ($2 == "@3") {
+ if (once++ == 0) printf "\n#ifndef HAVE_ALTIVEC\n";
+ printf "#define %s -1\n", $3;
+ } else {
+ if (once && twice++ == 0) printf "#endif /* HAVE_ALTIVEC */\n\n";
+ printf "extern struct a_type *T_%s;\n", $2;
+ }
+ }
+ next;
+ }
+ $1 == "%" {
+ print $0;
+ status = 1;
+ exit;
+ }
+ {
+ # Compute the signature of the generic function.
+ signature=$1;
+ for (i = 2; i <= NF-OPN; i++) {
+ if ($i != "...")
+ signature=(signature " " $i);
+ }
+
+ # Ensure that the signature is unique.
+ if (signature_line[signature]) {
+ print "Ambiguous signatures:";
+ print $0;
+ print line[signature_line[signature]];
+ }
+ signature_line[signature] = n_lines;
+
+ # Require that overloaded functions have the same attributes:
+ # number of arguments, when, configured, and addressible.
+ if (same_arg_count[$1] && same_arg_count[$1] != NF)
+ printf "%% number of arguments for %s varies: %d and %d\n", \
+ $1, NF-NARGS, same_arg_count[$1]-NARGS;
+ same_arg_count[$1] = NF;
+
+ if (same_when[$1] && same_when[$1] != $(NF-WHEN))
+ printf "%% when for %s varies: %s and %s\n", \
+ $1, $(NF-WHEN), same_when[$1];
+ same_when[$1] = $(NF-WHEN);
+
+ if (same_configured[$1] && same_configured[$1] != $(NF-CONFIGURED))
+ printf "%% configured for %s varies: %s and %s\n", \
+ $1, $(NF-CONFIGURED), same_configured[$1];
+ same_configured[$1] = $(NF-CONFIGURED);
+
+ if (same_addressible[$1] && same_addressible[$1] != $(NF-ADDRESSIBLE))
+ printf "%% addressible for %s varies: %s and %s\n", \
+ $1, $(NF-ADDRESSIBLE), same_addressible[$1];
+ else if (same_addressible[$1] && same_addressible[$1] != "FALSE")
+ printf "%% Overloaded function %s is addressible\n", $1
+ same_addressible[$1] = $(NF-ADDRESSIBLE);
+
+ # Record the line.
+ line[n_lines++] = $0;
+ }
+ function push(fcn, n) {
+ if (last) printf "};\n";
+ # Gcc3: declare as arrays of const pointers
+ if (fcn) printf "static const struct builtin *const O_%s[%d] = {\n", fcn, n;
+ last = fcn;
+ }
+ function mangle(name) {
+ if (split(name, names, ":") == 1)
+ return ("B_" names[1]);
+ return ("B" names[2] "_" names[1]);
+ }
+ END {
+ if (status) exit;
+
+ # Gcc3: Mark file as Apple local
+ printf "/* APPLE LOCAL file AltiVec */\n";
+ printf "/* This file is generated by ops-to-gp. Do not edit. */\n\n";
+ printf "/* To regenerate execute:\n";
+ printf " ops-to-gp -gcc vec.ops builtin.ops\n";
+ printf " with the current directory being gcc/config/rs6000. */\n\n";
+
+ # Output the description of each specific function.
+ uid = 0;
+ if (MCC) print "";
+ for (i = 0; i < n_lines; i++) {
+ nf = split(line[i], part);
+ fcn = part[nf-SPECIFIC];
+ if (!done[fcn]) {
+ printf "static const struct builtin %s = {", mangle(fcn);
+ if (GCC) printf " {";
+ ellipsis = 1;
+ for (j = 2; j <= nf-OPN; j++)
+ if (part[j] != "...") {
+ printf " &T_%s,", part[j];
+ } else {
+ ellipsis = -1;
+ printf " NULL,";
+ }
+ while (j++ <= MAXARGS+1)
+ printf " NULL,";
+ instruction = part[nf-INSTRUCTION];
+ if (substr(instruction, 1, 4) == "MOP_")
+ instruction = substr(instruction, 5);
+ if (substr(instruction, length(instruction)) == "D")
+ instruction = (substr(instruction, 1, length(instruction) - 1) ".");
+ # Gcc3: Prefix each specific instruction with a "*"
+ if (match (instruction, "^[a-zA-Z]") > 0)
+ instruction = "*" instruction;
+ if (GCC) printf " },";
+ if (GCC) printf " \"%s\",", substr(part[nf-CONSTRAINTS], 1, length(part[nf-CONSTRAINTS]) - 1);
+ printf " &T_%s,", part[nf-RESULT];
+ if (MCC) printf " \"%s\",", part[nf-SPECIFIC];
+ printf " %d,", ellipsis * (nf - NARGS);
+ if (MCC) {
+ printf " %s,", part[nf-WHEN];
+ printf " %s,", part[nf-ADDRESSIBLE];
+ printf " %s,", part[nf-CONST_PTR_OK];
+ printf " %s,", part[nf-VOLATILE_PTR_OK];
+ printf " %s,", part[nf-CONFIGURED];
+ printf " %s,", part[nf-INSTRUCTION];
+ printf " %s,", part[nf-TRANSFORM];
+ printf " %s", part[nf-PREDICATE];
+ } else if (GCC) {
+ printf " %s,", part[nf-CONST_PTR_OK];
+ printf " %s,", part[nf-VOLATILE_PTR_OK];
+ printf " %s,", part[nf-OPTIMIZE];
+ printf " \"%s\",", part[nf-SPECIFIC];
+ printf " \"%s\",", instruction;
+ printf " %s,", part[nf-INSN_CODE];
+ printf " B_UID(%d)", uid++;
+ }
+ printf " };\n";
+ }
+ done[fcn] = 1;
+ }
+
+ if (GCC) printf "#define LAST_B_UID B_UID(%d)\n", uid;
+
+ if (GCC) {
+ # Output the description of each specific function.
+ print "";
+ uid = 0;
+ for (i in done)
+ done[i] = "";
+ print "const struct builtin * const Builtin[] = {"
+ for (i = 0; i < n_lines; i++) {
+ nf = split(line[i], part);
+ fcn = part[nf-SPECIFIC];
+ if (!done[fcn]) {
+ printf " &%s,\n", mangle(fcn);
+ }
+ done[fcn] = 1;
+ }
+ print "};"
+ }
+
+ # Output the overload tables for each generic function.
+ print "";
+ for (i = 0; i < n_lines; i++) {
+ nf = split(line[i], part);
+ fcn = part[1];
+ if (last != fcn)
+ push(fcn, part[nf]);
+ printf " &%s,\n", mangle(part[nf-SPECIFIC]);
+ }
+ push("", 0);
+
+ # Output the builtin function structure.
+ print "";
+ if (MCC) {
+ print "%}";
+ print "struct overloadx {";
+ print " char *name;";
+ print " int fcns;";
+ print " int args;";
+ print " struct builtin **functions;";
+ print "};";
+ print "%%";
+ } else if (GCC) {
+ print "const struct overloadx Overload[] = {";
+ }
+
+ # Output the builtin function list and data.
+ uid = 0;
+ for (i = 0; i < n_lines; i++) {
+ nf = split(line[i], part);
+ fcn = part[1];
+ args = nf - NARGS;
+ if (part[nf-OPN] == "...") args = -args;
+ if (last != fcn) {
+ if (MCC) printf "%s, %d, %d, O_%s\n", fcn, part[nf], args, fcn;
+ if (GCC) printf " { \"%s\", %d, %d, O_%s, O_UID(%d) },\n", \
+ fcn, part[nf], args, fcn, uid++;
+ }
+ last = fcn;
+ }
+
+ if (GCC) {
+ print " { NULL, 0, 0, NULL, 0 }"
+ print "};";
+
+ printf "#define LAST_O_UID O_UID(%d)\n", uid;
+ }
+
+ }' > $output.$suffix
+
+if [ "$MCC" = "1" ] ; then
+ $gperf > $output.h
+fi
diff --git a/gcc/config/rs6000/rs6000-c.c b/gcc/config/rs6000/rs6000-c.c
index 5d36d5d28b3..ddf3b4b750e 100644
--- a/gcc/config/rs6000/rs6000-c.c
+++ b/gcc/config/rs6000/rs6000-c.c
@@ -30,6 +30,11 @@
#include "c-pragma.h"
#include "errors.h"
#include "tm_p.h"
+/* APPLE LOCAL begin AltiVec */
+#include "c-common.h"
+#include "cpplib.h"
+#include "target.h"
+/* APPLE LOCAL end AltiVec */
/* Handle the machine specific pragma longcall. Its syntax is
@@ -78,6 +83,94 @@ rs6000_pragma_longcall (cpp_reader *pfile ATTRIBUTE_UNUSED)
#define builtin_define(TXT) cpp_define (pfile, TXT)
#define builtin_assert(TXT) cpp_assert (pfile, TXT)
+/* APPLE LOCAL begin AltiVec */
+/* Keep the AltiVec keywords handy for fast comparisons. */
+static GTY(()) cpp_hashnode *__vector_keyword, *vector_keyword;
+static GTY(()) cpp_hashnode *__pixel_keyword, *pixel_keyword;
+static GTY(()) cpp_hashnode *__bool_keyword, *bool_keyword, *_Bool_keyword;
+
+/* Called to decide whether a conditional macro should be expanded. */
+
+bool
+rs6000_expand_macro_p (const cpp_token *tok)
+{
+ static bool expand_bool_pixel = 0;
+ bool expand_this = 0;
+ const cpp_hashnode *ident = tok->val.node;
+
+ if (ident == vector_keyword)
+ {
+ tok = c_lex_peek (0);
+ if (tok->type == CPP_NAME)
+ {
+ ident = tok->val.node;
+ if (ident == pixel_keyword || ident == __pixel_keyword
+ || ident == bool_keyword || ident == __bool_keyword
+ || ident == _Bool_keyword)
+ expand_this = expand_bool_pixel = 1;
+ else
+ {
+ enum rid rid_code = (enum rid)(ident->rid_code);
+
+ if (rid_code == RID_UNSIGNED || rid_code == RID_LONG
+ || rid_code == RID_SHORT || rid_code == RID_SIGNED
+ || rid_code == RID_INT || rid_code == RID_CHAR
+ || rid_code == RID_FLOAT)
+ {
+ expand_this = 1;
+ /* If the next keyword is bool or pixel, it
+ will need to be expanded as well. */
+ tok = c_lex_peek (1);
+ if (tok->type == CPP_NAME)
+ {
+ ident = tok->val.node;
+ if (ident == pixel_keyword || ident == __pixel_keyword
+ || ident == bool_keyword || ident == __bool_keyword
+ || ident == _Bool_keyword)
+ expand_bool_pixel = 1;
+ }
+ }
+ }
+ }
+ }
+ else if (ident == pixel_keyword || ident == bool_keyword
+ || ident == _Bool_keyword)
+ {
+ if (expand_bool_pixel)
+ {
+ expand_this = 1;
+ expand_bool_pixel = 0;
+ }
+ }
+
+ return expand_this;
+}
+
+static void
+cb_define_conditional_macro (cpp_reader *pfile ATTRIBUTE_UNUSED,
+ unsigned int n ATTRIBUTE_UNUSED,
+ cpp_hashnode *node) {
+ const unsigned char *name = node->ident.str;
+ bool underscore = (name[1] == '_');
+ char kwd = (underscore ? name[2] : name[0]);
+ cpp_hashnode **kwd_node = 0;
+
+ if (!underscore) /* macros without two leading underscores */
+ node->flags |= NODE_DISABLED; /* shall be conditional */
+
+ switch (kwd)
+ {
+ case 'v': kwd_node = (underscore ? &__vector_keyword : &vector_keyword); break;
+ case 'p': kwd_node = (underscore ? &__pixel_keyword : &pixel_keyword); break;
+ case 'b': kwd_node = (underscore ? &__bool_keyword : &bool_keyword); break;
+ case '_': kwd_node = &_Bool_keyword; break;
+ default: abort ();
+ }
+ *kwd_node = node;
+}
+
+/* APPLE LOCAL end AltiVec */
+
void
rs6000_cpu_cpp_builtins (cpp_reader *pfile)
{
@@ -93,13 +186,39 @@ rs6000_cpu_cpp_builtins (cpp_reader *pfile)
builtin_define ("_ARCH_COM");
if (TARGET_ALTIVEC)
{
+ /* APPLE LOCAL begin AltiVec */
+ struct cpp_callbacks *cb = cpp_get_callbacks (pfile);
+ void (*old_cb_define) (cpp_reader *, unsigned int, cpp_hashnode *)
+ = cb->define;
+ /* APPLE LOCAL end AltiVec */
+
builtin_define ("__ALTIVEC__");
builtin_define ("__VEC__=10206");
/* Define the AltiVec syntactic elements. */
+
+ /* APPLE LOCAL AltiVec */
+ cb->define = cb_define_conditional_macro;
+
builtin_define ("__vector=__attribute__((altivec(vector__)))");
builtin_define ("__pixel=__attribute__((altivec(pixel__))) unsigned short");
builtin_define ("__bool=__attribute__((altivec(bool__))) unsigned");
+
+ /* APPLE LOCAL begin AltiVec */
+ /* Keywords without two leading underscores are context-sensitive, and hence
+ implemented as conditional macros, controlled by the rs6000_expand_macro_p()
+ predicate above. */
+ builtin_define ("vector=__attribute__((altivec(vector__)))");
+ builtin_define ("pixel=__attribute__((altivec(pixel__))) unsigned short");
+ builtin_define ("bool=__attribute__((altivec(bool__))) unsigned");
+ builtin_define ("_Bool=__attribute__((altivec(bool__))) unsigned");
+ cb->define = old_cb_define;
+
+ /* Enable context-sensitive macros. */
+ targetm.expand_macro_p = rs6000_expand_macro_p;
+ /* Enable '(vector signed int)(a, b, c, d)' vector literal notation. */
+ targetm.cast_expr_as_vector_init = true;
+ /* APPLE LOCAL end AltiVec */
}
if (TARGET_SPE)
builtin_define ("__SPE__");
diff --git a/gcc/config/rs6000/rs6000-protos.h b/gcc/config/rs6000/rs6000-protos.h
index 1121e309db9..accb6087d28 100644
--- a/gcc/config/rs6000/rs6000-protos.h
+++ b/gcc/config/rs6000/rs6000-protos.h
@@ -29,6 +29,7 @@
#ifdef TREE_CODE
extern void init_cumulative_args (CUMULATIVE_ARGS *, tree, rtx, int, int, int);
+
extern void rs6000_va_start (tree, rtx);
#endif /* TREE_CODE */
@@ -127,10 +128,13 @@ extern int mfcr_operation (rtx, enum machine_mode);
extern int mtcrf_operation (rtx, enum machine_mode);
extern int lmw_operation (rtx, enum machine_mode);
extern struct rtx_def *create_TOC_reference (rtx);
+/* APPLE LOCAL RTX_COST for multiply */
+extern int rs6000_rtx_mult_cost (rtx);
extern void rs6000_split_multireg_move (rtx, rtx);
extern void rs6000_emit_move (rtx, rtx, enum machine_mode);
extern rtx rs6000_legitimize_address (rtx, rtx, enum machine_mode);
-extern rtx rs6000_legitimize_reload_address (rtx, enum machine_mode,
+/* APPLE LOCAL pass reload addr by address */
+extern rtx rs6000_legitimize_reload_address (rtx *, enum machine_mode,
int, int, int, int *);
extern int rs6000_legitimate_address (enum machine_mode, rtx, int);
extern bool rs6000_mode_dependent_address (rtx);
@@ -204,8 +208,13 @@ extern int rs6000_tls_symbol_ref (rtx, enum machine_mode);
extern void rs6000_pragma_longcall (struct cpp_reader *);
extern void rs6000_cpu_cpp_builtins (struct cpp_reader *);
+/* APPLE LOCAL AltiVec */
+extern bool rs6000_expand_macro_p (const struct cpp_token *);
+
#if TARGET_MACHO
-char *output_call (rtx, rtx *, int, int);
+void add_compiler_stub PARAMS ((tree, tree, int));
+void output_compiler_stub PARAMS ((void));
+extern char* output_call PARAMS ((rtx, rtx *, int, int));
#endif
#endif /* rs6000-protos.h */
diff --git a/gcc/config/rs6000/rs6000.c b/gcc/config/rs6000/rs6000.c
index 73b912cf930..d5ce123aef7 100644
--- a/gcc/config/rs6000/rs6000.c
+++ b/gcc/config/rs6000/rs6000.c
@@ -50,12 +50,20 @@
#include "target-def.h"
#include "langhooks.h"
#include "reload.h"
+/* APPLE LOCAL why is this needed? */
+#include "insn-addr.h"
#include "cfglayout.h"
#include "sched-int.h"
#if TARGET_XCOFF
#include "xcoffout.h" /* get declarations of xcoff_*_section_name */
#endif
+/* APPLE LOCAL begin Macintosh alignment */
+#ifndef TARGET_ALIGN_MAC68K
+#define TARGET_ALIGN_MAC68K 0
+#endif
+/* APPLE LOCAL end Macintosh alignment */
+
#ifndef TARGET_NO_PROTOTYPE
#define TARGET_NO_PROTOTYPE 0
#endif
@@ -216,9 +224,16 @@ int rs6000_debug_arg; /* debug argument handling */
static GTY(()) tree opaque_V2SI_type_node;
static GTY(()) tree opaque_V2SF_type_node;
static GTY(()) tree opaque_p_V2SI_type_node;
-
-/* AltiVec requires a few more basic types in addition to the vector
- types already defined in tree.c. */
+static GTY(()) tree V16QI_type_node;
+static GTY(()) tree V2SI_type_node;
+static GTY(()) tree V2SF_type_node;
+static GTY(()) tree V4HI_type_node;
+static GTY(()) tree V4SI_type_node;
+static GTY(()) tree V4SF_type_node;
+static GTY(()) tree V8HI_type_node;
+static GTY(()) tree unsigned_V16QI_type_node;
+static GTY(()) tree unsigned_V8HI_type_node;
+static GTY(()) tree unsigned_V4SI_type_node;
static GTY(()) tree bool_char_type_node; /* __bool char */
static GTY(()) tree bool_short_type_node; /* __bool short */
static GTY(()) tree bool_int_type_node; /* __bool int */
@@ -302,6 +317,7 @@ static void rs6000_assemble_visibility (tree, int);
static int rs6000_ra_ever_killed (void);
static tree rs6000_handle_longcall_attribute (tree *, tree, tree, int, bool *);
static tree rs6000_handle_altivec_attribute (tree *, tree, tree, int, bool *);
+static const char *rs6000_mangle_fundamental_type (tree);
extern const struct attribute_spec rs6000_attribute_table[];
static void rs6000_set_default_type_attributes (tree);
static void rs6000_output_function_prologue (FILE *, HOST_WIDE_INT);
@@ -410,15 +426,15 @@ static rtx rs6000_spe_function_arg (CUMULATIVE_ARGS *,
enum machine_mode, tree);
static rtx rs6000_mixed_function_arg (CUMULATIVE_ARGS *,
enum machine_mode, tree, int);
-static void rs6000_move_block_from_reg(int regno, rtx x, int nregs);
+static void rs6000_move_block_from_reg (int regno, rtx x, int nregs);
static void setup_incoming_varargs (CUMULATIVE_ARGS *,
enum machine_mode, tree,
int *, int);
#if TARGET_MACHO
static void macho_branch_islands (void);
static void add_compiler_branch_island (tree, tree, int);
-static int no_previous_def (tree function_name);
-static tree get_prev_label (tree function_name);
+static int no_previous_def (tree);
+static tree get_prev_label (tree);
#endif
static tree rs6000_build_builtin_va_list (void);
@@ -575,6 +591,9 @@ static const char alt_reg_names[][8] =
#undef TARGET_EXPAND_BUILTIN
#define TARGET_EXPAND_BUILTIN rs6000_expand_builtin
+#undef TARGET_MANGLE_FUNDAMENTAL_TYPE
+#define TARGET_MANGLE_FUNDAMENTAL_TYPE rs6000_mangle_fundamental_type
+
#undef TARGET_INIT_LIBFUNCS
#define TARGET_INIT_LIBFUNCS rs6000_init_libfuncs
@@ -636,6 +655,9 @@ rs6000_override_options (const char *default_cpu)
size_t i, j;
struct rs6000_cpu_select *ptr;
int set_masks;
+/* APPLE LOCAL begin -fast */
+ enum processor_type mcpu_cpu;
+/* APPLE LOCAL end -fast */
/* Simplifications for entries below. */
@@ -746,6 +768,20 @@ rs6000_override_options (const char *default_cpu)
rs6000_select[0].string = default_cpu;
rs6000_cpu = TARGET_POWERPC64 ? PROCESSOR_DEFAULT64 : PROCESSOR_DEFAULT;
+ /* APPLE LOCAL begin -fast */
+ if (flag_fast || flag_fastf || flag_fastcp)
+ {
+ mcpu_cpu = PROCESSOR_POWER4;
+ if (rs6000_select[1].string == (char *)0 && rs6000_select[2].string == (char *)0)
+ {
+ /* -mcpu and -mtune unspecified. Assume both are G5 */
+ set_target_switch ("tune=G5");
+ set_target_switch ("cpu=G5");
+ }
+ }
+ /* APPLE LOCAL end -fast */
+
+
for (i = 0; i < ARRAY_SIZE (rs6000_select); i++)
{
ptr = &rs6000_select[i];
@@ -762,6 +798,9 @@ rs6000_override_options (const char *default_cpu)
target_flags &= ~set_masks;
target_flags |= (processor_target_table[j].target_enable
& set_masks);
+ /* APPLE LOCAL begin -fast */
+ mcpu_cpu = processor_target_table[j].processor;
+ /* APPLE LOCAL end -fast */
}
break;
}
@@ -771,6 +810,52 @@ rs6000_override_options (const char *default_cpu)
}
}
+ /* APPLE LOCAL begin -fast */
+ if (flag_fast || flag_fastf || flag_fastcp)
+ {
+ flag_gcse_sm = 1;
+ flag_loop_transpose = 1;
+ rs6000_sched_insert_nops = sched_finish_regroup_exact;
+ flag_unroll_loops = 1;
+ flag_strict_aliasing = 1;
+ flag_schedule_interblock = 1;
+ align_jumps_max_skip = 15;
+ align_loops_max_skip = 15;
+ align_functions = 16;
+ align_loops = 16;
+ align_jumps = 16;
+ set_fast_math_flags (1);
+ flag_reorder_blocks = 1;
+ if (flag_branch_probabilities)
+ flag_reorder_blocks_and_partition = 1;
+ if (!flag_pic)
+ set_target_switch ("dynamic-no-pic");
+
+ if (mcpu_cpu == PROCESSOR_POWER4)
+ {
+ set_target_switch ("powerpc-gpopt");
+ set_target_switch ("powerpc64");
+ }
+ if (flag_fast
+#if 0
+ /* C++ libraries which are part of the compiler package do not have the
+ -malign-natural workaround. So, eon will fail with -fastcp. */
+ || flag_fastcp
+#endif
+ )
+ /* This doesn't work with NAG Fortran output. The Panther C++ libraries
+ have been adjusted so that it now works with them. */
+ set_target_switch ("align-natural");
+ if (flag_fastf)
+ /* This applies Fortran argument semantics; for NAG Fortran output only. */
+ flag_argument_noalias = 2;
+ /* IMI flags */
+ disable_typechecking_for_spec_flag = 1;
+ flag_unit_at_a_time = 1;
+ }
+ /* APPLE LOCAL end -fast */
+
+
if (TARGET_E500)
rs6000_isel = 1;
@@ -1070,6 +1155,10 @@ rs6000_parse_alignment_option (void)
{
if (rs6000_alignment_string == 0)
return;
+/* APPLE LOCAL begin Macintosh alignment 2002-2-26 ff */
+ else if (! strcmp (rs6000_alignment_string, "mac68k"))
+ rs6000_alignment_flags = MASK_ALIGN_MAC68K;
+/* APPLE LOCAL end Macintosh alignment 2002-2-26 ff */
else if (! strcmp (rs6000_alignment_string, "power"))
rs6000_alignment_flags = MASK_ALIGN_POWER;
else if (! strcmp (rs6000_alignment_string, "natural"))
@@ -1099,6 +1188,22 @@ rs6000_parse_tls_size_option (void)
void
optimization_options (int level ATTRIBUTE_UNUSED, int size ATTRIBUTE_UNUSED)
{
+ /* APPLE LOCAL begin tweak default optimizations */
+ if (DEFAULT_ABI == ABI_DARWIN)
+ {
+ /* Turn these on only if specifically requested, not with -O* */
+ /* Strict aliasing breaks too much existing code */
+ flag_strict_aliasing = 0;
+ /* Block reordering causes code bloat, and very little speedup */
+ flag_reorder_blocks = 0;
+ /* Multi-basic-block scheduling loses badly when the compiler
+ misguesses which blocks are going to be executed, more than
+ it gains when it guesses correctly. Its guesses for cases
+ where interblock scheduling occurs (if-then-else's) are
+ little better than random, so disable this unless requested. */
+ flag_schedule_interblock = 0;
+ }
+ /* APPLE LOCAL end tweak default optimizations */
}
/* Do anything needed at the start of the asm file. */
@@ -2271,6 +2376,11 @@ call_operand (rtx op, enum machine_mode mode)
return 0;
return (GET_CODE (op) == SYMBOL_REF
+ /* APPLE LOCAL begin accept hard R12 as target reg */
+#ifdef MAGIC_INDIRECT_CALL_REG
+ || (GET_CODE (op) == REG && REGNO (op) == MAGIC_INDIRECT_CALL_REG)
+#endif
+ /* APPLE LOCAL end accept hard R12 as target reg */
|| (GET_CODE (op) == REG
&& (REGNO (op) == LINK_REGISTER_REGNUM
|| REGNO (op) == COUNT_REGISTER_REGNUM
@@ -2356,7 +2466,7 @@ rs6000_special_round_type_align (tree type, int computed, int specified)
tree field = TYPE_FIELDS (type);
/* Skip all the static variables only if ABI is greater than
- 1 or equal to 0. */
+ 1 or equal to 0. */
while (field != NULL && TREE_CODE (field) == VAR_DECL)
field = TREE_CHAIN (field);
@@ -3050,9 +3160,12 @@ rs6000_tls_symbol_ref_1 (rtx *x, void *data ATTRIBUTE_UNUSED)
The Darwin code is inside #if TARGET_MACHO because only then is
machopic_function_base_name() defined. */
rtx
-rs6000_legitimize_reload_address (rtx x, enum machine_mode mode,
+/* APPLE LOCAL pass reload addr by address */
+rs6000_legitimize_reload_address (rtx *addr_x, enum machine_mode mode,
int opnum, int type, int ind_levels ATTRIBUTE_UNUSED, int *win)
{
+ /* APPLE LOCAL pass reload addr by address */
+ rtx x = *addr_x;
/* We must recognize output that we have already generated ourselves. */
if (GET_CODE (x) == PLUS
&& GET_CODE (XEXP (x, 0)) == PLUS
@@ -3408,6 +3521,57 @@ rs6000_emit_set_long_const (rtx dest, HOST_WIDE_INT c1, HOST_WIDE_INT c2)
return dest;
}
+/* APPLE LOCAL begin RTX_COST for multiply */
+int
+rs6000_rtx_mult_cost (rtx x)
+{
+ switch (rs6000_cpu)
+ {
+ case PROCESSOR_RIOS1:
+ case PROCESSOR_PPC405:
+ return (GET_CODE (XEXP (x, 1)) != CONST_INT
+ ? COSTS_N_INSNS (5)
+ : INTVAL (XEXP (x, 1)) >= -256 && INTVAL (XEXP (x, 1)) <= 255
+ ? COSTS_N_INSNS (3) : COSTS_N_INSNS (4));
+ case PROCESSOR_RS64A:
+ return (GET_CODE (XEXP (x, 1)) != CONST_INT
+ ? GET_MODE (XEXP (x, 1)) != DImode
+ ? COSTS_N_INSNS (20) : COSTS_N_INSNS (34)
+ : INTVAL (XEXP (x, 1)) >= -256 && INTVAL (XEXP (x, 1)) <= 255
+ ? COSTS_N_INSNS (8) : COSTS_N_INSNS (12));
+ case PROCESSOR_RIOS2:
+ case PROCESSOR_MPCCORE:
+ case PROCESSOR_PPC604e:
+ return COSTS_N_INSNS (2);
+ case PROCESSOR_PPC601:
+ return COSTS_N_INSNS (5);
+ case PROCESSOR_PPC603:
+ case PROCESSOR_PPC7400:
+ case PROCESSOR_PPC750:
+ return (GET_CODE (XEXP (x, 1)) != CONST_INT
+ ? COSTS_N_INSNS (5)
+ : INTVAL (XEXP (x, 1)) >= -256 && INTVAL (XEXP (x, 1)) <= 255
+ ? COSTS_N_INSNS (2) : COSTS_N_INSNS (3));
+ case PROCESSOR_PPC7450:
+ return (GET_CODE (XEXP (x, 1)) != CONST_INT
+ ? COSTS_N_INSNS (4)
+ : COSTS_N_INSNS (3));
+ case PROCESSOR_PPC403:
+ case PROCESSOR_PPC604:
+ return COSTS_N_INSNS (4);
+ case PROCESSOR_PPC620:
+ case PROCESSOR_PPC630:
+ return (GET_CODE (XEXP (x, 1)) != CONST_INT
+ ? GET_MODE (XEXP (x, 1)) != DImode
+ ? COSTS_N_INSNS (5) : COSTS_N_INSNS (7)
+ : INTVAL (XEXP (x, 1)) >= -256 && INTVAL (XEXP (x, 1)) <= 255
+ ? COSTS_N_INSNS (3) : COSTS_N_INSNS (4));
+ default:
+ abort ();
+ }
+}
+/* APPLE LOCAL end RTX_COST for multiply */
+
/* Emit a move from SOURCE to DEST in mode MODE. */
void
rs6000_emit_move (rtx dest, rtx source, enum machine_mode mode)
@@ -3845,6 +4009,8 @@ init_cumulative_args (CUMULATIVE_ARGS *cum, tree fntype,
/* Check for a longcall attribute. */
if (fntype
+ /* APPLE LOCAL long-branch */
+ && TARGET_LONG_BRANCH
&& lookup_attribute ("longcall", TYPE_ATTRIBUTES (fntype))
&& !lookup_attribute ("shortcall", TYPE_ATTRIBUTES (fntype)))
cum->call_cookie = CALL_LONG;
@@ -3953,6 +4119,7 @@ function_arg_boundary (enum machine_mode mode, tree type ATTRIBUTE_UNUSED)
else
return PARM_BOUNDARY;
}
+
/* Update the data in CUM to advance over an argument
of mode MODE and data type TYPE.
@@ -4224,7 +4391,49 @@ rs6000_mixed_function_arg (CUMULATIVE_ARGS *cum, enum machine_mode mode,
k == 0 ? const0_rtx : GEN_INT (k*4));
return gen_rtx_PARALLEL (BLKmode, gen_rtvec_v (k, rtlvec));
- }
+ }
+ else if (ALTIVEC_VECTOR_MODE(mode) && align_words <= (GP_ARG_NUM_REG - 1))
+ {
+ /* Varargs vector regs must be saved in R5-R8 or R9-R10. */
+ if (align_words == GP_ARG_NUM_REG - 2)
+ {
+ /* R9-R10 */
+ return gen_rtx_PARALLEL (mode,
+ gen_rtvec (3,
+ gen_rtx_EXPR_LIST (VOIDmode,
+ NULL_RTX, const0_rtx),
+ gen_rtx_EXPR_LIST (VOIDmode,
+ gen_rtx_REG (SImode,
+ GP_ARG_MIN_REG
+ + align_words),
+ const0_rtx),
+ gen_rtx_EXPR_LIST (VOIDmode,
+ gen_rtx_REG (SImode,
+ GP_ARG_MIN_REG
+ + align_words+1),
+ GEN_INT(4))));
+ }
+ else
+ {
+ /* R5-R8 */
+ int k;
+ int size = int_size_in_bytes (type);
+ int no_units = ((size - 1) / 4) + 1;
+ int max_no_words = GP_ARG_NUM_REG - align_words;
+ int rtlvec_len = no_units < max_no_words ? no_units : max_no_words;
+ rtx *rtlvec = (rtx *) alloca (rtlvec_len * sizeof (rtx));
+ memset ((char *) rtlvec, 0, rtlvec_len * sizeof (rtx));
+
+ for (k=0; k < rtlvec_len; k++)
+ rtlvec[k] = gen_rtx_EXPR_LIST (VOIDmode,
+ gen_rtx_REG (SImode,
+ GP_ARG_MIN_REG
+ + align_words + k),
+ k == 0 ? const0_rtx : GEN_INT (k*4));
+
+ return gen_rtx_PARALLEL (mode, gen_rtvec_v (k, rtlvec));
+ }
+ }
return NULL_RTX;
}
@@ -4343,7 +4552,11 @@ function_arg (CUMULATIVE_ARGS *cum, enum machine_mode mode,
is either wholly in GPRs or half in GPRs and half not. */
part_mode = DImode;
- return gen_rtx_REG (part_mode, GP_ARG_MIN_REG + align_words);
+ if ((TARGET_32BIT && TARGET_POWERPC64)
+ || (align_words == GP_ARG_NUM_REG - 2))
+ return rs6000_mixed_function_arg (cum, part_mode, type, align_words);
+ else
+ return gen_rtx_REG (part_mode, GP_ARG_MIN_REG + align_words);
}
}
else if (TARGET_SPE_ABI && TARGET_SPE && SPE_VECTOR_MODE (mode))
@@ -5885,6 +6098,7 @@ altivec_expand_dst_builtin (tree exp, rtx target ATTRIBUTE_UNUSED,
|| arg2 == error_mark_node)
return const0_rtx;
+ *expandedp = true;
STRIP_NOPS (arg2);
if (TREE_CODE (arg2) != INTEGER_CST
|| TREE_INT_CST_LOW (arg2) & ~0x3)
@@ -5902,7 +6116,6 @@ altivec_expand_dst_builtin (tree exp, rtx target ATTRIBUTE_UNUSED,
if (pat != 0)
emit_insn (pat);
- *expandedp = true;
return NULL_RTX;
}
@@ -6456,6 +6669,18 @@ rs6000_expand_builtin (tree exp, rtx target, rtx subtarget ATTRIBUTE_UNUSED,
static void
rs6000_init_builtins (void)
{
+ V2SI_type_node = build_vector_type (intSI_type_node, 2);
+ V2SF_type_node = build_vector_type (float_type_node, 2);
+ V4HI_type_node = build_vector_type (intHI_type_node, 4);
+ V4SI_type_node = build_vector_type (intSI_type_node, 4);
+ V4SF_type_node = build_vector_type (float_type_node, 4);
+ V8HI_type_node = build_vector_type (intHI_type_node, 8);
+ V16QI_type_node = build_vector_type (intQI_type_node, 16);
+
+ unsigned_V16QI_type_node = build_vector_type (unsigned_intQI_type_node, 16);
+ unsigned_V8HI_type_node = build_vector_type (unsigned_intHI_type_node, 8);
+ unsigned_V4SI_type_node = build_vector_type (unsigned_intSI_type_node, 4);
+
opaque_V2SI_type_node = copy_node (V2SI_type_node);
opaque_V2SF_type_node = copy_node (V2SF_type_node);
opaque_p_V2SI_type_node = build_pointer_type (opaque_V2SI_type_node);
@@ -6486,10 +6711,10 @@ rs6000_init_builtins (void)
get_identifier ("__pixel"),
pixel_type_node));
- bool_V16QI_type_node = make_vector (V16QImode, bool_char_type_node, 1);
- bool_V8HI_type_node = make_vector (V8HImode, bool_short_type_node, 1);
- bool_V4SI_type_node = make_vector (V4SImode, bool_int_type_node, 1);
- pixel_V8HI_type_node = make_vector (V8HImode, pixel_type_node, 1);
+ bool_V16QI_type_node = build_vector_type (bool_char_type_node, 16);
+ bool_V8HI_type_node = build_vector_type (bool_short_type_node, 8);
+ bool_V4SI_type_node = build_vector_type (bool_int_type_node, 4);
+ pixel_V8HI_type_node = build_vector_type (pixel_type_node, 8);
(*lang_hooks.decls.pushdecl) (build_decl (TYPE_DECL,
get_identifier ("__vector unsigned char"),
@@ -8648,7 +8873,11 @@ rs6000_got_register (rtx value ATTRIBUTE_UNUSED)
static struct machine_function *
rs6000_init_machine_status (void)
{
- return ggc_alloc_cleared (sizeof (machine_function));
+ /* APPLE LOCAL begin volatile pic base reg in leaves */
+ machine_function *mf = (machine_function *) ggc_alloc_cleared (sizeof (machine_function));
+ mf->substitute_pic_base_reg = -1;
+ return mf;
+ /* APPLE LOCAL end volatile pic base reg in leaves */
}
/* These macros test for integers and extract the low-order bits. */
@@ -9478,6 +9707,47 @@ print_operand_address (FILE *file, rtx x)
abort ();
}
+/* APPLE LOCAL begin weak import */
+static void
+find_weak_imports (rtx x)
+{
+ /* Patterns accepted here follow output_addr_const in final.c. */
+ switch ( GET_CODE (x))
+ {
+ case CONST:
+ case ZERO_EXTEND:
+ case SIGN_EXTEND:
+ case SUBREG:
+ find_weak_imports (XEXP (x, 0));
+ break;
+
+ case CONST_INT:
+ case CONST_DOUBLE:
+ case CODE_LABEL:
+ case LABEL_REF:
+ default:
+ break;
+
+ case PLUS:
+ case MINUS:
+ find_weak_imports (XEXP (x, 0));
+ find_weak_imports (XEXP (x, 1));
+ break;
+
+ case SYMBOL_REF:
+ if ( SYMBOL_REF_WEAK_IMPORT (x))
+ {
+ fprintf (asm_out_file, "\t.weak_reference ");
+ assemble_name (asm_out_file, XSTR (x, 0));
+ fprintf (asm_out_file, "\n");
+ /* Attempt to prevent multiple weak_reference directives. */
+ SYMBOL_REF_WEAK_IMPORT (x) = 0;
+ }
+ break;
+ }
+}
+/* APPLE LOCAL end weak import */
+
/* Target hook for assembling integer objects. The PowerPC version has
to handle fixup entries for relocatable code if RELOCATABLE_NEEDS_FIXUP
is defined. It also needs to handle DI-mode objects on 64-bit
@@ -9498,6 +9768,9 @@ rs6000_assemble_integer (rtx x, unsigned int size, int aligned_p)
if (TARGET_RELOCATABLE
&& !in_toc_section ()
&& !in_text_section ()
+ /* APPLE LOCAL begin hot/cold partitioning */
+ && !in_text_unlikely_section ()
+ /* APPLE LOCAL end hot/cold partitioning */
&& !recurse
&& GET_CODE (x) != CONST_INT
&& GET_CODE (x) != CONST_DOUBLE
@@ -9536,6 +9809,9 @@ rs6000_assemble_integer (rtx x, unsigned int size, int aligned_p)
}
}
#endif /* RELOCATABLE_NEEDS_FIXUP */
+ /* APPLE LOCAL weak import */
+ if (DEFAULT_ABI == ABI_DARWIN)
+ find_weak_imports (x);
return default_assemble_integer (x, size, aligned_p);
}
@@ -10352,6 +10628,8 @@ first_reg_to_save (void)
#if TARGET_MACHO
if (flag_pic
&& current_function_uses_pic_offset_table
+ /* APPLE LOCAL volatile pic base reg in leaves */
+ && cfun->machine->substitute_pic_base_reg == -1
&& first_reg > RS6000_PIC_OFFSET_TABLE_REGNUM)
return RS6000_PIC_OFFSET_TABLE_REGNUM;
#endif
@@ -10540,7 +10818,7 @@ rs6000_stack_info (void)
{
static rs6000_stack_t info, zero_info;
rs6000_stack_t *info_ptr = &info;
- int reg_size = TARGET_POWERPC64 ? 8 : 4;
+ int reg_size = TARGET_32BIT ? 4 : 8;
int ehrd_size;
HOST_WIDE_INT total_raw_size;
@@ -10652,7 +10930,7 @@ rs6000_stack_info (void)
info_ptr->varargs_size = RS6000_VARARGS_AREA;
info_ptr->vars_size = RS6000_ALIGN (get_frame_size (), 8);
info_ptr->parm_size = RS6000_ALIGN (current_function_outgoing_args_size,
- 8);
+ TARGET_ALTIVEC ? 16 : 8);
if (TARGET_SPE_ABI && info_ptr->spe_64bit_regs_used != 0)
info_ptr->spe_gp_size = 8 * (32 - info_ptr->first_gp_reg_save);
@@ -10689,7 +10967,7 @@ rs6000_stack_info (void)
/* Align stack so vector save area is on a quadword boundary. */
if (info_ptr->altivec_size != 0)
info_ptr->altivec_padding_size
- = 16 - (-info_ptr->vrsave_save_offset % 16);
+ = (16 - (-info_ptr->vrsave_save_offset % 16)) % 16;
else
info_ptr->altivec_padding_size = 0;
@@ -10768,10 +11046,10 @@ rs6000_stack_info (void)
+ ehrd_size
+ info_ptr->cr_size
+ info_ptr->lr_size
- + info_ptr->vrsave_size
+ /* APPLE LOCAL fix redundant add? */
+ info_ptr->toc_size,
- (TARGET_ALTIVEC_ABI || ABI_DARWIN)
- ? 16 : 8);
+ /* APPLE LOCAL darwin native */
+ (TARGET_ALTIVEC_ABI ? 16 : 8));
total_raw_size = (info_ptr->vars_size
+ info_ptr->parm_size
@@ -11055,6 +11333,9 @@ static bool
rs6000_function_ok_for_sibcall (tree decl, tree exp ATTRIBUTE_UNUSED)
{
tree type;
+ /* APPLE LOCAL -mlong-branch */
+ if (TARGET_LONG_BRANCH)
+ return 0;
if (decl)
{
if (TARGET_ALTIVEC_VRSAVE)
@@ -11669,6 +11950,131 @@ generate_set_vrsave (rtx reg, rs6000_stack_t *info, int epiloguep)
return insn;
}
+/* APPLE LOCAL begin special ObjC method use of R12 */
+static int objc_method_using_pic = 0;
+
+/* Determine whether a name is an ObjC method. */
+static int name_encodes_objc_method_p (const char *piclabel_name)
+{
+ return (piclabel_name[0] == '*' && piclabel_name[1] == '"'
+ ? (piclabel_name[2] == 'L'
+ && (piclabel_name[3] == '+' || piclabel_name[3] == '-'))
+ : (piclabel_name[1] == 'L'
+ && (piclabel_name[2] == '+' || piclabel_name[2] == '-')));
+}
+/* APPLE LOCAL end special ObjC method use of R12 */
+
+/* APPLE LOCAL begin recompute PIC register use */
+/* Sometimes a function has references that require the PIC register,
+ but optimization removes them all. To catch this case
+ recompute current_function_uses_pic_offset_table here.
+ This may allow us to eliminate the prologue and epilogue. */
+
+static int
+recompute_PIC_register_use (void)
+{
+ if (DEFAULT_ABI == ABI_DARWIN
+ && flag_pic && current_function_uses_pic_offset_table
+ && !cfun->machine->ra_needs_full_frame)
+ {
+ rtx insn;
+ current_function_uses_pic_offset_table = 0;
+ push_topmost_sequence ();
+ for (insn = get_insns (); insn != NULL; insn = NEXT_INSN (insn))
+ if ( reg_mentioned_p (pic_offset_table_rtx, insn))
+ {
+ current_function_uses_pic_offset_table = 1;
+ break;
+ }
+ pop_topmost_sequence ();
+ }
+ return 0;
+}
+/* APPLE LOCAL end recompute PIC register use */
+
+/* APPLE LOCAL begin volatile pic base reg in leaves */
+/* If this is a leaf function and we used any pic-based references,
+ see if there is an unused volatile reg we can use instead of R31.
+ If so set substitute_pic_base_reg to this reg, set its reg_ever_used
+ bit (to avoid confusing later calls to alloc_volatile_reg), and
+ make a pass through the existing RTL, substituting the new reg for
+ the old one wherever it appears.
+ Logically this is a void function; it is int so it can be used to
+ initialize a dummy variable, thus getting executed ahead of other
+ initializations. Technicolour yawn. */
+
+/* ALLOC_VOLATILE_REG allocates a volatile register AFTER all gcc
+ register allocations have been done; we use it to reserve an
+ unused reg for holding VRsave. Returns -1 in case of failure (all
+ volatile regs are in use.) */
+/* Note, this is called from both the prologue and epilogue code,
+ with the assumption that it will return the same result both
+ times! Since the register arrays are not changed in between
+ this is valid, if a bit fragile. */
+/* In future we may also use this to grab an unused volatile reg to
+ hold the PIC base reg in the event that the current function makes
+ no procedure calls; this was done in 2.95. */
+static int
+alloc_volatile_reg (void)
+{
+ if (current_function_is_leaf
+ && reload_completed
+ && !cfun->machine->ra_needs_full_frame)
+ {
+ int r;
+ for (r = 10; r >= 2; --r)
+ if (! fixed_regs[r] && ! regs_ever_live[r])
+ return r;
+ }
+
+ return -1; /* fail */
+}
+
+static int
+try_leaf_pic_optimization (void)
+{
+ if ( DEFAULT_ABI==ABI_DARWIN
+ && flag_pic && current_function_uses_pic_offset_table
+ && current_function_is_leaf
+ && !cfun->machine->ra_needs_full_frame )
+ {
+ int reg = alloc_volatile_reg ();
+ if ( reg != -1 )
+ {
+ /* Run through the insns, changing references to the original
+ PIC_OFFSET_TABLE_REGNUM to our new one. */
+ rtx insn;
+ const int nregs = PIC_OFFSET_TABLE_REGNUM + 1;
+ rtx *reg_map = (rtx *) xmalloc (nregs * sizeof (rtx));
+ memset (reg_map, 0, nregs * sizeof (rtx));
+ reg_map[PIC_OFFSET_TABLE_REGNUM] = gen_rtx_REG (SImode, reg);
+
+ push_topmost_sequence ();
+ for (insn = get_insns (); insn != NULL; insn = NEXT_INSN (insn))
+ {
+ if (GET_CODE (insn) == INSN || GET_CODE (insn) == JUMP_INSN)
+ {
+ replace_regs (PATTERN (insn), reg_map, nregs, 1);
+ replace_regs (REG_NOTES (insn), reg_map, nregs, 1);
+ }
+ else if (GET_CODE (insn) == CALL_INSN)
+ {
+ if ( !SIBLING_CALL_P (insn))
+ abort ();
+ }
+ }
+ pop_topmost_sequence ();
+ free (reg_map);
+
+ regs_ever_live[reg] = 1;
+ regs_ever_live[PIC_OFFSET_TABLE_REGNUM] = 0;
+ cfun->machine->substitute_pic_base_reg = reg;
+ }
+ }
+ return 0;
+}
+/* APPLE LOCAL end volatile pic base reg in leaves */
+
/* Save a register into the frame, and emit RTX_FRAME_RELATED_P notes.
Save REGNO into [FRAME_REG + OFFSET] in mode MODE. */
@@ -11738,9 +12144,13 @@ gen_frame_mem_offset (enum machine_mode mode, rtx reg, int offset)
void
rs6000_emit_prologue (void)
{
+ /* APPLE LOCAL recompute PIC register use */
+ int dummy ATTRIBUTE_UNUSED = recompute_PIC_register_use ();
+ /* APPLE LOCAL volatile pic base reg in leaves */
+ int ignored ATTRIBUTE_UNUSED = try_leaf_pic_optimization ();
rs6000_stack_t *info = rs6000_stack_info ();
enum machine_mode reg_mode = Pmode;
- int reg_size = UNITS_PER_WORD;
+ int reg_size = TARGET_32BIT ? 4 : 8;
rtx sp_reg_rtx = gen_rtx_REG (Pmode, STACK_POINTER_REGNUM);
rtx frame_ptr_rtx = gen_rtx_REG (Pmode, 12);
rtx frame_reg_rtx = sp_reg_rtx;
@@ -11749,7 +12159,24 @@ rs6000_emit_prologue (void)
int saving_FPRs_inline;
int using_store_multiple;
HOST_WIDE_INT sp_offset = 0;
+ /* APPLE LOCAL: callers_lr_already_saved */
+ int callers_lr_already_saved = 0;
+#if TARGET_MACHO
+ int lr_already_set_up_for_pic = 0;
+#endif
+ /* APPLE LOCAL special ObjC method use of R12 */
+ objc_method_using_pic = 0;
+ /* APPLE LOCAL BEGIN fix-and-continue mrs */
+ if (TARGET_FIX_AND_CONTINUE)
+ {
+ emit_insn (gen_nop ());
+ emit_insn (gen_nop ());
+ emit_insn (gen_nop ());
+ emit_insn (gen_nop ());
+ }
+ /* APPLE LOCAL END fix-and-continue mrs */
+
if (TARGET_SPE_ABI && info->spe_64bit_regs_used != 0)
{
reg_mode = V2SImode;
@@ -11785,6 +12212,31 @@ rs6000_emit_prologue (void)
rs6000_emit_stack_tie ();
}
+ /* APPLE LOCAL begin special ObjC method use of R12 */
+#if TARGET_MACHO
+ if (DEFAULT_ABI == ABI_DARWIN
+ && current_function_uses_pic_offset_table && flag_pic)
+ {
+ const char *piclabel_name = machopic_function_base_name ();
+
+ if (name_encodes_objc_method_p (piclabel_name)
+ /* If we're saving vector or FP regs via a function call,
+ then don't bother with this ObjC R12 optimization.
+ This test also eliminates world_save. */
+ && (info->first_altivec_reg_save > LAST_ALTIVEC_REGNO
+ || VECTOR_SAVE_INLINE (info->first_altivec_reg_save))
+ && (info->first_fp_reg_save == 64
+ || FP_SAVE_INLINE (info->first_fp_reg_save)))
+ {
+ /* We cannot output the label now; there seems to be no
+ way to prevent cfgcleanup from deleting it. It is done
+ in rs6000_output_function_prologue with fprintf! */
+ objc_method_using_pic = 1;
+ }
+ }
+#endif /* TARGET_MACHO */
+ /* APPLE LOCAL end special ObjC method use of R12 */
+
/* Save AltiVec registers if needed. */
if (TARGET_ALTIVEC_ABI && info->altivec_size != 0)
{
@@ -11862,7 +12314,12 @@ rs6000_emit_prologue (void)
/* If we need to save CR, put it into r12. */
if (info->cr_save_p && frame_reg_rtx != frame_ptr_rtx)
{
- cr_save_rtx = gen_rtx_REG (SImode, 12);
+ /* APPLE LOCAL begin special ObjC method use of R12 */
+ /* For Darwin, use R2, so we don't clobber the special ObjC
+ method use of R12. R11 has a special meaning for Ada, so we
+ can't use that. */
+ cr_save_rtx = gen_rtx_REG (SImode, DEFAULT_ABI == ABI_DARWIN ? 2 : 12);
+ /* APPLE LOCAL end special ObjC method use of R12 */
emit_insn (gen_movesi_from_cr (cr_save_rtx));
}
@@ -11885,17 +12342,57 @@ rs6000_emit_prologue (void)
char rname[30];
const char *alloc_rname;
rtvec p;
- p = rtvec_alloc (2 + 64 - info->first_fp_reg_save);
+
+ /* APPLE LOCAL begin Reduce code size / improve performance */
+ int gen_following_label = 0;
+ int count = 0;
+
+ if (current_function_uses_pic_offset_table && flag_pic
+#ifdef INSN_SCHEDULING
+ /* Prevent the compiler from crashing
+ while scheduling insns after global_alloc! */
+ && (optimize == 0 || !flag_schedule_insns_after_reload)
+#endif
+ /* If this is the last CALL in the prolog, then we've got our PC.
+ If we're saving AltiVec regs via a function, we're not last. */
+ && (info->first_altivec_reg_save > LAST_ALTIVEC_REGNO
+ || VECTOR_SAVE_INLINE (info->first_altivec_reg_save)))
+ gen_following_label = lr_already_set_up_for_pic = 1;
+
+ /* APPLE LOCAL: +2 (could be conditionalized) */
+ p = rtvec_alloc (2 + 64 - info->first_fp_reg_save + 2
+ + gen_following_label);
- RTVEC_ELT (p, 0) = gen_rtx_CLOBBER (VOIDmode,
+ RTVEC_ELT (p, count++) = gen_rtx_CLOBBER (VOIDmode,
gen_rtx_REG (Pmode,
LINK_REGISTER_REGNUM));
+ /* APPLE LOCAL begin reduce code size */
+#if TARGET_MACHO
+ /* We have to calculate the offset into saveFP to where we must
+ call (!!) SAVEFP also saves the caller's LR -- placed into
+ R0 above -- into 8(R1). SAVEFP/RESTOREFP should never be
+ called to save or restore only F31. */
+
+ if (info->lr_save_offset != 8 || info->first_fp_reg_save == 63)
+ abort ();
+
+ sprintf (rname, "*saveFP%s%.0d ; save f%d-f31",
+ (info->first_fp_reg_save - 32 == 14 ? "" : "+"),
+ (info->first_fp_reg_save - 46) * 4,
+ info->first_fp_reg_save - 32);
+#else
+ /* APPLE LOCAL end reduce code size */
sprintf (rname, "%s%d%s", SAVE_FP_PREFIX,
info->first_fp_reg_save - 32, SAVE_FP_SUFFIX);
+ /* APPLE LOCAL reduce code size */
+#endif /* TARGET_MACHO */
alloc_rname = ggc_strdup (rname);
- RTVEC_ELT (p, 1) = gen_rtx_USE (VOIDmode,
+ RTVEC_ELT (p, count++) = gen_rtx_USE (VOIDmode,
gen_rtx_SYMBOL_REF (Pmode,
alloc_rname));
+ /* APPLE LOCAL reduce code size */
+ if ( gen_following_label )
+ RTVEC_ELT (p, count++) = gen_rtx_USE (VOIDmode, const0_rtx);
for (i = 0; i < 64 - info->first_fp_reg_save; i++)
{
rtx addr, reg, mem;
@@ -11906,11 +12403,31 @@ rs6000_emit_prologue (void)
mem = gen_rtx_MEM (DFmode, addr);
set_mem_alias_set (mem, rs6000_sr_alias_set);
- RTVEC_ELT (p, i + 2) = gen_rtx_SET (VOIDmode, mem, reg);
+ RTVEC_ELT (p, count++) = gen_rtx_SET (VOIDmode, mem, reg);
+ }
+ /* APPLE LOCAL begin fix 2866661 */
+#if TARGET_MACHO
+ /* Darwin version of these functions stores R0. */
+ RTVEC_ELT (p, count++) = gen_rtx_USE (VOIDmode, gen_rtx_REG (Pmode, 0));
+
+ /* If we saved LR, *tell* people about it! */
+ if (info->lr_save_p)
+ {
+ rtx addr = gen_rtx_PLUS (Pmode, frame_reg_rtx,
+ GEN_INT (info->lr_save_offset + sp_offset));
+ rtx mem = gen_rtx_MEM (Pmode, addr);
+ /* This should not be of rs6000_sr_alias_set, because of
+ __builtin_return_address. */
+ RTVEC_ELT (p, count++) = gen_rtx_SET (Pmode, mem,
+ gen_rtx_REG (Pmode, LINK_REGISTER_REGNUM));
}
+#endif
+ /* APPLE LOCAL end fix 2866661 */
insn = emit_insn (gen_rtx_PARALLEL (VOIDmode, p));
rs6000_frame_related (insn, frame_ptr_rtx, info->total_size,
NULL_RTX, NULL_RTX);
+ /* APPLE LOCAL: callers_lr_already_saved */
+ callers_lr_already_saved = 1;
}
/* Save GPRs. This is done as a PARALLEL if we are using
@@ -11945,7 +12462,11 @@ rs6000_emit_prologue (void)
&& ! call_used_regs[info->first_gp_reg_save+i])
|| (i+info->first_gp_reg_save == RS6000_PIC_OFFSET_TABLE_REGNUM
&& ((DEFAULT_ABI == ABI_V4 && flag_pic != 0)
- || (DEFAULT_ABI == ABI_DARWIN && flag_pic))))
+ /* APPLE LOCAL begin volatile pic base reg in leaves */
+ || (DEFAULT_ABI == ABI_DARWIN && flag_pic
+ && current_function_uses_pic_offset_table
+ && cfun->machine->substitute_pic_base_reg == -1))))
+ /* APPLE LOCAL end volatile pic base reg in leaves */
{
rtx addr, reg, mem;
reg = gen_rtx_REG (reg_mode, info->first_gp_reg_save + i);
@@ -12027,8 +12548,18 @@ rs6000_emit_prologue (void)
}
}
+ /* APPLE LOCAL special ObjC method use of R12 */
+ if (objc_method_using_pic)
+ rs6000_maybe_dead (
+ emit_move_insn (gen_rtx_REG (Pmode,
+ cfun->machine->substitute_pic_base_reg == -1
+ ? PIC_OFFSET_TABLE_REGNUM
+ : cfun->machine->substitute_pic_base_reg),
+ gen_rtx_REG (Pmode, 12)));
+
/* Save lr if we used it. */
- if (info->lr_save_p)
+ /* APPLE LOCAL: callers_lr_already_saved */
+ if (info->lr_save_p && !callers_lr_already_saved)
{
rtx addr = gen_rtx_PLUS (Pmode, frame_reg_rtx,
GEN_INT (info->lr_save_offset + sp_offset));
@@ -12111,17 +12642,38 @@ rs6000_emit_prologue (void)
#if TARGET_MACHO
if (DEFAULT_ABI == ABI_DARWIN
+ /* APPLE LOCAL special ObjC method use of R12 */
+ && !objc_method_using_pic
&& flag_pic && current_function_uses_pic_offset_table)
{
rtx dest = gen_rtx_REG (Pmode, LINK_REGISTER_REGNUM);
const char *picbase = machopic_function_base_name ();
rtx src = gen_rtx_SYMBOL_REF (Pmode, picbase);
- rs6000_maybe_dead (emit_insn (gen_load_macho_picbase (dest, src)));
+ /* APPLE LOCAL begin save and restore LR */
+ /* Save and restore LR locally around this call (in R0). */
+ if (!info->lr_save_p)
+ rs6000_maybe_dead (emit_move_insn (gen_rtx_REG (Pmode, 0), dest));
+ /* APPLE LOCAL end save and restore LR */
+
+ /* APPLE LOCAL begin performance enhancement */
+#if TARGET_MACHO
+ if (!lr_already_set_up_for_pic)
+ rs6000_maybe_dead (emit_insn (gen_load_macho_picbase (dest, src)));
+#endif
+ /* APPLE LOCAL end performance enhancement */
+ /* APPLE LOCAL begin volatile pic base reg in leaves */
rs6000_maybe_dead (
- emit_move_insn (gen_rtx_REG (Pmode, RS6000_PIC_OFFSET_TABLE_REGNUM),
- gen_rtx_REG (Pmode, LINK_REGISTER_REGNUM)));
+ emit_move_insn (
+ gen_rtx_REG (Pmode,
+ cfun->machine->substitute_pic_base_reg == -1
+ ? RS6000_PIC_OFFSET_TABLE_REGNUM
+ : cfun->machine->substitute_pic_base_reg),
+ dest));
+ if (!info->lr_save_p)
+ rs6000_maybe_dead (emit_move_insn (dest, gen_rtx_REG (Pmode, 0)));
+ /* APPLE LOCAL end */
}
#endif
}
@@ -12137,6 +12689,8 @@ rs6000_output_function_prologue (FILE *file,
if (TARGET_DEBUG_STACK)
debug_stack_info (info);
+ /* APPLE LOCAL do not extern fp save/restore */
+#if !TARGET_MACHO
/* Write .extern for any function we will call to save and restore
fp values. */
if (info->first_fp_reg_save < 64
@@ -12145,6 +12699,8 @@ rs6000_output_function_prologue (FILE *file,
SAVE_FP_PREFIX, info->first_fp_reg_save - 32, SAVE_FP_SUFFIX,
RESTORE_FP_PREFIX, info->first_fp_reg_save - 32,
RESTORE_FP_SUFFIX);
+ /* APPLE LOCAL do not extern fp save/restore */
+#endif /* !TARGET_MACHO */
/* Write .extern for AIX common mode routines, if needed. */
if (! TARGET_POWER && ! TARGET_POWERPC && ! common_mode_defined)
@@ -12158,6 +12714,16 @@ rs6000_output_function_prologue (FILE *file,
common_mode_defined = 1;
}
+ /* APPLE LOCAL special ObjC method use of R12 */
+#if TARGET_MACHO
+ if ( HAVE_prologue && DEFAULT_ABI == ABI_DARWIN && objc_method_using_pic )
+ {
+ /* APPLE FIXME isn't there an asm macro to do all this? */
+ const char* piclabel = machopic_function_base_name ();
+ fprintf(file, "%s:\n", (*piclabel == '*') ? piclabel + 1 : piclabel);
+ }
+#endif
+
if (! HAVE_prologue)
{
start_sequence ();
@@ -12207,7 +12773,7 @@ rs6000_emit_epilogue (int sibcall)
rtx sp_reg_rtx = gen_rtx_REG (Pmode, 1);
rtx frame_reg_rtx = sp_reg_rtx;
enum machine_mode reg_mode = Pmode;
- int reg_size = UNITS_PER_WORD;
+ int reg_size = TARGET_32BIT ? 4 : 8;
int i;
info = rs6000_stack_info ();
@@ -12232,6 +12798,8 @@ rs6000_emit_epilogue (int sibcall)
using_mfcr_multiple = (rs6000_cpu == PROCESSOR_PPC601
|| rs6000_cpu == PROCESSOR_PPC603
|| rs6000_cpu == PROCESSOR_PPC750
+ /* APPLE LOCAL ? */
+ || rs6000_cpu == PROCESSOR_PPC7400
|| optimize_size);
/* If we have a frame pointer, a call to alloca, or a large stack
@@ -12324,7 +12892,9 @@ rs6000_emit_epilogue (int sibcall)
set_mem_alias_set (mem, rs6000_sr_alias_set);
- emit_move_insn (gen_rtx_REG (SImode, 12), mem);
+ /* APPLE LOCAL use R11 because of ObjC use of R12 in sibcall to CTR */
+ emit_move_insn (gen_rtx_REG (SImode,
+ DEFAULT_ABI == ABI_DARWIN ? 11 : 12), mem);
}
/* Set LR here to try to overlap restores below. */
@@ -12394,7 +12964,11 @@ rs6000_emit_epilogue (int sibcall)
&& ! call_used_regs[info->first_gp_reg_save+i])
|| (i+info->first_gp_reg_save == RS6000_PIC_OFFSET_TABLE_REGNUM
&& ((DEFAULT_ABI == ABI_V4 && flag_pic != 0)
- || (DEFAULT_ABI == ABI_DARWIN && flag_pic))))
+ /* APPLE LOCAL begin darwin native */
+ || (DEFAULT_ABI == ABI_DARWIN && flag_pic
+ && current_function_uses_pic_offset_table
+ && cfun->machine->substitute_pic_base_reg == -1))))
+ /* APPLE LOCAL end darwin native */
{
rtx addr = gen_rtx_PLUS (Pmode, frame_reg_rtx,
GEN_INT (info->gp_save_offset
@@ -12448,7 +13022,9 @@ rs6000_emit_epilogue (int sibcall)
/* If we saved cr, restore it here. Just those that were used. */
if (info->cr_save_p)
{
- rtx r12_rtx = gen_rtx_REG (SImode, 12);
+ /* APPLE LOCAL use R11 because of ObjC use of R12 in sibcall to CTR */
+ /* APPLE LOCAL silly name retained to minimize deviation from FSF */
+ rtx r12_rtx = gen_rtx_REG (SImode, DEFAULT_ABI == ABI_DARWIN ? 11 : 12);
int count = 0;
if (using_mfcr_multiple)
@@ -12548,8 +13124,25 @@ rs6000_emit_epilogue (int sibcall)
char rname[30];
const char *alloc_rname;
+ /* APPLE LOCAL begin code size reduction / performance enhancement */
+#if TARGET_MACHO
+ /* We have to calculate the offset into RESTFP to where we must
+ call (!!) RESTFP also restores the caller's LR from 8(R1).
+ RESTFP should *never* be called to restore only F31. */
+
+ if (info->lr_save_offset != 8 || info->first_fp_reg_save == 63)
+ abort ();
+
+ sprintf (rname, "*restFP%s%.0d ; restore f%d-f31",
+ (info->first_fp_reg_save - 32 == 14 ? "" : "+"),
+ (info->first_fp_reg_save - 46) * 4,
+ info->first_fp_reg_save - 32);
+#else
+ /* APPLE LOCAL end code size reduction / performance enhancement */
sprintf (rname, "%s%d%s", RESTORE_FP_PREFIX,
info->first_fp_reg_save - 32, RESTORE_FP_SUFFIX);
+ /* APPLE LOCAL code size reduction / performance enhancement */
+#endif /* TARGET_MACHO */
alloc_rname = ggc_strdup (rname);
RTVEC_ELT (p, 2) = gen_rtx_USE (VOIDmode,
gen_rtx_SYMBOL_REF (Pmode,
@@ -14663,6 +15256,11 @@ rs6000_initialize_trampoline (rtx addr, rtx fnaddr, rtx cxt)
const struct attribute_spec rs6000_attribute_table[] =
{
/* { name, min_len, max_len, decl_req, type_req, fn_type_req, handler } */
+ /* APPLE LOCAL begin double destructor */
+#ifdef SUBTARGET_ATTRIBUTE_TABLE
+ SUBTARGET_ATTRIBUTE_TABLE
+#endif
+ /* APPLE LOCAL end double destructor */
{ "altivec", 1, 1, false, true, false, rs6000_handle_altivec_attribute },
{ "longcall", 0, 0, false, true, true, rs6000_handle_longcall_attribute },
{ "shortcall", 0, 0, false, true, true, rs6000_handle_longcall_attribute },
@@ -14756,6 +15354,21 @@ rs6000_handle_altivec_attribute (tree *node, tree name, tree args,
return NULL_TREE;
}
+/* AltiVec defines four built-in scalar types that serve as vector
+ elements; we must teach the compiler how to mangle them. */
+
+static const char *
+rs6000_mangle_fundamental_type (tree type)
+{
+ if (type == bool_char_type_node) return "U6__boolc";
+ if (type == bool_short_type_node) return "U6__bools";
+ if (type == pixel_type_node) return "u7__pixel";
+ if (type == bool_int_type_node) return "U6__booli";
+
+ /* For all other types, use normal C++ mangling. */
+ return NULL;
+}
+
/* Handle a "longcall" or "shortcall" attribute; arguments as in
struct attribute_spec.handler. */
@@ -14998,6 +15611,7 @@ symbolic_operand (rtx op)
#if TARGET_MACHO
static tree branch_island_list = 0;
+static int local_label_unique_number = 0;
/* Remember to generate a branch island for far calls to the given
function. */
@@ -15027,17 +15641,20 @@ macho_branch_islands (void)
{
char tmp_buf[512];
tree branch_island;
+ const char *name;
+ const char *label;
+ char name_buf[512];
+ char *local_label_0;
+ const char *non_lazy_pointer_name, *unencoded_non_lazy_pointer_name;
+ int length;
for (branch_island = branch_island_list;
branch_island;
branch_island = TREE_CHAIN (branch_island))
{
- const char *label =
- IDENTIFIER_POINTER (BRANCH_ISLAND_LABEL_NAME (branch_island));
- const char *name =
- darwin_strip_name_encoding (
- IDENTIFIER_POINTER (BRANCH_ISLAND_FUNCTION_NAME (branch_island)));
- char name_buf[512];
+ label = IDENTIFIER_POINTER (BRANCH_ISLAND_LABEL_NAME (branch_island));
+ name = darwin_strip_name_encoding (
+ IDENTIFIER_POINTER (BRANCH_ISLAND_FUNCTION_NAME (branch_island)));
/* Cheap copy of the details from the Darwin ASM_OUTPUT_LABELREF(). */
if (name[0] == '*' || name[0] == '&')
strcpy (name_buf, name+1);
@@ -15053,15 +15670,66 @@ macho_branch_islands (void)
fprintf (asm_out_file, "\t.stabd 68,0," HOST_WIDE_INT_PRINT_UNSIGNED "\n",
BRANCH_ISLAND_LINE_NUMBER(branch_island));
#endif /* DBX_DEBUGGING_INFO || XCOFF_DEBUGGING_INFO */
- if (flag_pic)
+ /* If PIC and the callee has no stub, do an indirect call through a
+ non-lazy-pointer. 'save_world' expects a parameter in R11;
+ theh dyld_stub_binding_helper (part of the Mach-O stub
+ interface) expects a different parameter in R11. This is
+ effectively a "non-lazy stub." By-the-way, a
+ "non-lazy-pointer" is a .long that gets coalesced with others
+ of the same value, so one NLP suffices for an entire
+ application. */
+ if (flag_pic && (machopic_classify_ident (get_identifier (name)) == MACHOPIC_UNDEFINED))
+ {
+ /* This is the address of the non-lazy pointer; load from it
+ to get the address we want. */
+ non_lazy_pointer_name = machopic_non_lazy_ptr_name (name);
+ machopic_validate_stub_or_non_lazy_ptr (non_lazy_pointer_name,
+ /* non-lazy-pointer */0);
+ unencoded_non_lazy_pointer_name =
+ (*targetm.strip_name_encoding) (non_lazy_pointer_name);
+ length = strlen (name);
+ local_label_0 = alloca (length + 32);
+ /* Cheap copy of the details from the Darwin ASM_OUTPUT_LABELREF(). */
+ if (name[0] == '*' || name[0] == '&')
+ strcpy (name_buf, name+1);
+ else
+ {
+ name_buf[0] = '_';
+ strcpy (name_buf+1, name);
+ }
+
+ sprintf (local_label_0, "%s_%d_pic", local_label_unique_number, name_buf);
+ local_label_unique_number++;
+ strcpy (tmp_buf, "\n");
+ strcat (tmp_buf, label);
+ strcat (tmp_buf, "\tmflr r0\n");
+ strcat (tmp_buf, "\tbcl 20,31,");
+ strcat (tmp_buf, "\tbcl 20,31,%s\n");
+ strcat (tmp_buf, local_label_0);
+ strcat (tmp_buf, ":\n");
+ strcat (tmp_buf, "\tmflr r12\n");
+ strcat (tmp_buf, "\taddis r12,r12,ha16(");
+ strcat (tmp_buf, non_lazy_pointer_name);
+ strcat (tmp_buf, "-");
+ strcat (tmp_buf, local_label_0);
+ strcat (tmp_buf, ")\n\tlwz r12,lo16(");
+ strcat (tmp_buf, non_lazy_pointer_name);
+ strcat (tmp_buf, "-");
+ strcat (tmp_buf, local_label_0);
+ strcat (tmp_buf, ")(r12)\n");
+ strcat (tmp_buf, "\tmtlr r0\n");
+ strcat (tmp_buf, "\tmtctr r12\n");
+ strcat (tmp_buf, "\tbctr\n");
+ }
+ else if (flag_pic)
{
strcat (tmp_buf, ":\n\tmflr r0\n\tbcl 20,31,");
strcat (tmp_buf, label);
strcat (tmp_buf, "_pic\n");
strcat (tmp_buf, label);
- strcat (tmp_buf, "_pic:\n\tmflr r11\n");
+ strcat (tmp_buf, "_pic:\n\tmflr r12\n");
- strcat (tmp_buf, "\taddis r11,r11,ha16(");
+ strcat (tmp_buf, "\taddis r12,r12,ha16(");
strcat (tmp_buf, name_buf);
strcat (tmp_buf, " - ");
strcat (tmp_buf, label);
@@ -15069,7 +15737,7 @@ macho_branch_islands (void)
strcat (tmp_buf, "\tmtlr r0\n");
- strcat (tmp_buf, "\taddi r12,r11,lo16(");
+ strcat (tmp_buf, "\taddi r12,r12,lo16(");
strcat (tmp_buf, name_buf);
strcat (tmp_buf, " - ");
strcat (tmp_buf, label);
@@ -15135,12 +15803,55 @@ char *
output_call (rtx insn, rtx *operands, int dest_operand_number, int cookie_operand_number)
{
static char buf[256];
+ const char *far_call_instr_str=NULL, *near_call_instr_str=NULL;
+ rtx pattern;
+
+ switch (GET_CODE (insn))
+ {
+ case CALL_INSN:
+ far_call_instr_str = "jbsr";
+ near_call_instr_str = "bl";
+ pattern = NULL_RTX;
+ break;
+ case JUMP_INSN:
+ far_call_instr_str = "jmp";
+ near_call_instr_str = "b";
+ pattern = NULL_RTX;
+ break;
+ case INSN:
+ pattern = PATTERN (insn);
+ break;
+ default:
+ abort();
+ break;
+ }
+
if (GET_CODE (operands[dest_operand_number]) == SYMBOL_REF
&& (INTVAL (operands[cookie_operand_number]) & CALL_LONG))
{
tree labelname;
tree funname = get_identifier (XSTR (operands[dest_operand_number], 0));
+ /* This insn represents a prologue or epilogue. */
+ if ((pattern != NULL_RTX) && GET_CODE (pattern) == PARALLEL)
+ {
+ rtx parallel_first_op = XVECEXP (pattern, 0, 0);
+ switch (GET_CODE (parallel_first_op))
+ {
+ case CLOBBER: /* Prologue: a call to save_world. */
+ far_call_instr_str = "jbsr";
+ near_call_instr_str = "bl";
+ break;
+ case RETURN: /* Epilogue: a call to rest_world. */
+ far_call_instr_str = "jmp";
+ near_call_instr_str = "b";
+ break;
+ default:
+ abort();
+ break;
+ }
+ }
+
if (no_previous_def (funname))
{
int line_number = 0;
@@ -15303,6 +16014,129 @@ toc_section (void)
#endif /* TARGET_MACHO */
+/* APPLE LOCAL begin Macintosh alignment 2002-1-22 ff */
+/* Return the alignment of a struct based on the Macintosh PowerPC
+ alignment rules. In general the alignment of a struct is
+ determined by the greatest alignment of its elements. However, the
+ PowerPC rules cause the alignment of a struct to peg at word
+ alignment except when the first field has greater than word
+ (32-bit) alignment, in which case the alignment is determined by
+ the alignment of the first field. */
+
+unsigned
+round_type_align (tree the_struct, unsigned computed, unsigned specified)
+{
+ if (TARGET_ALTIVEC && TREE_CODE (the_struct) == VECTOR_TYPE)
+ {
+ /* All vectors are (at least) 16-byte aligned. A struct or
+ union with a vector element is also 16-byte aligned. */
+ return MAX (RS6000_VECTOR_ALIGNMENT, MAX (computed, specified));
+ }
+
+ if (TREE_CODE (the_struct) == RECORD_TYPE
+ || TREE_CODE (the_struct) == UNION_TYPE
+ || TREE_CODE (the_struct) == QUAL_UNION_TYPE)
+ {
+ tree first_field = TYPE_FIELDS (the_struct);
+
+ /* Skip past static fields, enums, and constant fields that are
+ not really a part of the record layout. */
+ while ((first_field != 0)
+ && (TREE_CODE (first_field) != FIELD_DECL))
+ first_field = TREE_CHAIN (first_field);
+
+ if (first_field != 0)
+ {
+ /* If other-than-default alignment (which includes mac68k
+ mode) is in effect, then no adjustments to the alignment
+ should be necessary. Ditto if the struct has the
+ __packed__ attribute. */
+ if (TYPE_PACKED (the_struct) || TARGET_ALIGN_MAC68K
+ || TARGET_ALIGN_NATURAL || maximum_field_alignment != 0)
+ /* Do nothing */ ;
+ else
+ {
+ /* The following code handles Macintosh PowerPC
+ alignment. The implementation is complicated by the
+ fact that BIGGEST_ALIGNMENT is 128 when AltiVec is
+ enabled and 32 when it is not. So when AltiVec is
+ not enabled, alignment is generally limited to word
+ alignment. Consequently, the alignment of unions has
+ to be recalculated if AltiVec is not enabled.
+
+ Below we explicitly test for fields with greater than
+ word alignment: doubles, long longs, and structs and
+ arrays with greater than word alignment. */
+ unsigned val;
+ tree field_type;
+
+ val = MAX (computed, specified);
+
+ if (TREE_CODE (the_struct) == UNION_TYPE && !TARGET_ALTIVEC)
+ {
+ tree field = first_field;
+
+ while (field != 0)
+ {
+ /* Don't consider statics, enums and constant fields
+ which are not really a part of the record. */
+ if (TREE_CODE (field) != FIELD_DECL)
+ {
+ field = TREE_CHAIN (field);
+ continue;
+ }
+ field_type = TREE_TYPE(field);
+ if (TREE_CODE (TREE_TYPE (field)) == ARRAY_TYPE)
+ field_type = get_inner_array_type (field);
+ else
+ field_type = TREE_TYPE (field);
+ val = MAX (TYPE_ALIGN (field_type), val);
+ if (FLOAT_TYPE_P (field_type)
+ && TYPE_MODE (field_type) == DFmode)
+ val = MAX (RS6000_DOUBLE_ALIGNMENT, val);
+ else if (INTEGRAL_TYPE_P (field_type)
+ && TYPE_MODE (field_type) == DImode)
+ val = MAX (RS6000_LONGLONG_ALIGNMENT, val);
+ field = TREE_CHAIN (field);
+ }
+ }
+ else
+ {
+ if (TREE_CODE (TREE_TYPE (first_field)) == ARRAY_TYPE)
+ field_type = get_inner_array_type (first_field);
+ else
+ field_type = TREE_TYPE (first_field);
+
+ if (field_type == error_mark_node)
+ return val;
+ val = MAX (TYPE_ALIGN (field_type), val);
+
+ if (FLOAT_TYPE_P (field_type)
+ && TYPE_MODE (field_type) == DFmode)
+ val = MAX (RS6000_DOUBLE_ALIGNMENT, val);
+ else if (INTEGRAL_TYPE_P (field_type)
+ && TYPE_MODE (field_type) == DImode)
+ val = MAX (RS6000_LONGLONG_ALIGNMENT, val);
+ }
+
+ return val;
+ }
+ } /* first_field != 0 */
+
+ /* Ensure all MAC68K structs are at least 16-bit aligned.
+ Unless the struct has __attribute__ ((packed)). */
+
+ if (TARGET_ALIGN_MAC68K && ! TYPE_PACKED (the_struct))
+ {
+ if (computed < 16)
+ computed = 16;
+ }
+ } /* RECORD_TYPE, etc */
+
+ return (MAX (computed, specified));
+}
+/* APPLE LOCAL end Macintosh alignment 2002-1-22 ff */
+
#if TARGET_ELF
static unsigned int
rs6000_elf_section_type_flags (tree decl, const char *name, int reloc)
diff --git a/gcc/config/rs6000/rs6000.h b/gcc/config/rs6000/rs6000.h
index 641e4bbb8af..311918073fe 100644
--- a/gcc/config/rs6000/rs6000.h
+++ b/gcc/config/rs6000/rs6000.h
@@ -23,6 +23,9 @@
/* Note that some other tm.h files include this one and then override
many of the definitions. */
+/* APPLE LOCAL fat builds */
+#define DEFAULT_TARGET_ARCH "ppc"
+
/* Definitions for the object file format. These are set at
compile-time. */
@@ -197,6 +200,15 @@ extern int target_flags;
0x00100000, and sysv4.h uses 0x00800000 -> 0x40000000.
0x80000000 is not available because target_flags is signed. */
+/* APPLE LOCAL long-branch */
+/* gen call addr in register for >64M range */
+#define MASK_LONG_BRANCH 0x02000000
+
+/* APPLE LOCAL BEGIN fix-and-continue mrs */
+#define MASK_FIX_AND_CONTINUE 0x04000000
+#define MASK_INDIRECT_ALL_DATA 0x08000000
+/* APPLE LOCAL END fix-and-continue mrs */
+
#define TARGET_POWER (target_flags & MASK_POWER)
#define TARGET_POWER2 (target_flags & MASK_POWER2)
#define TARGET_POWERPC (target_flags & MASK_POWERPC)
@@ -215,6 +227,8 @@ extern int target_flags;
#define TARGET_SCHED_PROLOG (target_flags & MASK_SCHED_PROLOG)
#define TARGET_ALTIVEC (target_flags & MASK_ALTIVEC)
#define TARGET_AIX_STRUCT_RET (target_flags & MASK_AIX_STRUCT_RET)
+/* APPLE LOCAL long-branch */
+#define TARGET_LONG_BRANCH (target_flags & MASK_LONG_BRANCH)
/* Define TARGET_MFCRF if the target assembler supports the optional
field operand for mfcr and the target processor supports the
@@ -226,7 +240,6 @@ extern int target_flags;
#define TARGET_MFCRF 0
#endif
-
#define TARGET_32BIT (! TARGET_64BIT)
#define TARGET_HARD_FLOAT (! TARGET_SOFT_FLOAT)
#define TARGET_UPDATE (! TARGET_NO_UPDATE)
@@ -248,6 +261,10 @@ extern int target_flags;
#endif
#define TARGET_XL_CALL 0
+/* APPLE LOCAL BEGIN fix-and-continue mrs */
+#define TARGET_FIX_AND_CONTINUE (target_flags & MASK_FIX_AND_CONTINUE)
+#define TARGET_INDIRECT_ALL_DATA (target_flags & MASK_INDIRECT_ALL_DATA)
+/* APPLE LOCAL END fix-and-continue mrs */
/* Run-time compilation parameters selecting different hardware subsets.
@@ -346,6 +363,23 @@ extern int target_flags;
""}, \
{"no-svr4-struct-return", MASK_AIX_STRUCT_RET, \
""}, \
+ /* APPLE LOCAL long-branch */ \
+ {"long-branch", MASK_LONG_BRANCH, \
+ N_("Generate 32-bit call addresses (range > 64M)")}, \
+ {"no-long-branch", -MASK_LONG_BRANCH, ""}, \
+ {"longcall", MASK_LONG_BRANCH, \
+ N_("Generate 32-bit call addresses (range > 64M)")}, \
+ {"no-longcall", -MASK_LONG_BRANCH, ""}, \
+ /* APPLE LOCAL BEGIN fix-and-continue mrs */ \
+ {"fix-and-continue", MASK_FIX_AND_CONTINUE, \
+ N_("Generate code suitable for fast turn around debugging")}, \
+ {"no-fix-and-continue", -MASK_FIX_AND_CONTINUE, \
+ N_("Don't generate code suitable for fast turn around debugging")},\
+ {"indirect-data", MASK_INDIRECT_ALL_DATA, \
+ N_("Generate code suitable for fast turn around debugging")}, \
+ {"no-indirect-data", -MASK_INDIRECT_ALL_DATA, \
+ N_("Don't generate code suitable for fast turn around debugging")},\
+ /* APPLE LOCAL END fix-and-continue mrs */ \
{"mfcrf", MASK_MFCRF, \
N_("Generate single field mfcr instruction")}, \
{"no-mfcrf", - MASK_MFCRF, \
@@ -539,6 +573,10 @@ extern const char *rs6000_warn_altivec_long_switch;
#define MASK_ALIGN_POWER 0x00000000
#define MASK_ALIGN_NATURAL 0x00000001
#define TARGET_ALIGN_NATURAL (rs6000_alignment_flags & MASK_ALIGN_NATURAL)
+/* APPLE LOCAL begin Macintosh alignment 2002-2-26 ff */
+#define MASK_ALIGN_MAC68K 0x00000002
+#define TARGET_ALIGN_MAC68K (rs6000_alignment_flags & MASK_ALIGN_MAC68K)
+/* APPLE LOCAL end Macintosh alignment 2002-2-26 ff */
#else
#define TARGET_ALIGN_NATURAL 0
#endif
@@ -728,6 +766,13 @@ extern const char *rs6000_warn_altivec_long_switch;
/* Allocation boundary (in *bits*) for the code of a function. */
#define FUNCTION_BOUNDARY 32
+/* Constants for alignment macros below. */
+/* APPLE LOCAL begin Macintosh alignment */
+#define RS6000_DOUBLE_ALIGNMENT 64
+#define RS6000_LONGLONG_ALIGNMENT 64
+#define RS6000_VECTOR_ALIGNMENT 128
+/* APPLE LOCAL end Macintosh alignment */
+
/* No data type wants to be aligned rounder than this. */
#define BIGGEST_ALIGNMENT 128
@@ -1162,8 +1207,7 @@ extern const char *rs6000_warn_altivec_long_switch;
= call_really_used_regs[RS6000_PIC_OFFSET_TABLE_REGNUM] = 1; \
if (DEFAULT_ABI == ABI_DARWIN \
&& PIC_OFFSET_TABLE_REGNUM != INVALID_REGNUM) \
- global_regs[RS6000_PIC_OFFSET_TABLE_REGNUM] \
- = fixed_regs[RS6000_PIC_OFFSET_TABLE_REGNUM] \
+ fixed_regs[RS6000_PIC_OFFSET_TABLE_REGNUM] \
= call_used_regs[RS6000_PIC_OFFSET_TABLE_REGNUM] \
= call_really_used_regs[RS6000_PIC_OFFSET_TABLE_REGNUM] = 1; \
if (TARGET_ALTIVEC) \
@@ -1528,6 +1572,9 @@ extern enum rs6000_abi rs6000_current_abi; /* available for use by subtarget */
makes the stack pointer a smaller address. */
#define STACK_GROWS_DOWNWARD
+/* Offsets recorded in opcodes are a multiple of this alignment factor. */
+#define DWARF_CIE_DATA_ALIGNMENT (-((int) (TARGET_32BIT ? 4 : 8)))
+
/* Define this if the nominal address of the stack frame
is at the high-address end of the local variables;
that is, each additional local variable allocated
@@ -1717,6 +1764,9 @@ typedef struct machine_function GTY(())
int sysv_varargs_p;
/* Flags if __builtin_return_address (n) with n >= 1 was used. */
int ra_needs_full_frame;
+ /* APPLE LOCAL volatile pic base reg in leaves */
+ /* Substitute PIC register in leaf functions */
+ int substitute_pic_base_reg;
/* Some local-dynamic symbol. */
const char *some_ld_name;
/* Whether the instruction chain has been scanned already. */
@@ -2015,7 +2065,6 @@ typedef struct rs6000_args
On the RS/6000, all integer constants are acceptable, most won't be valid
for particular insns, though. Only easy FP constants are
acceptable. */
-
#define LEGITIMATE_CONSTANT_P(X) \
(((GET_CODE (X) != CONST_DOUBLE \
&& GET_CODE (X) != CONST_VECTOR) \
@@ -2126,7 +2175,8 @@ typedef struct rs6000_args
#define LEGITIMIZE_RELOAD_ADDRESS(X,MODE,OPNUM,TYPE,IND_LEVELS,WIN) \
do { \
int win; \
- (X) = rs6000_legitimize_reload_address ((X), (MODE), (OPNUM), \
+ /* APPLE LOCAL pass reload addr by address */ \
+ (X) = rs6000_legitimize_reload_address (&(X), (MODE), (OPNUM), \
(int)(TYPE), (IND_LEVELS), &win); \
if ( win ) \
goto WIN; \
diff --git a/gcc/config/rs6000/rs6000.md b/gcc/config/rs6000/rs6000.md
index 29b36d6e4e5..d5f4f878b68 100644
--- a/gcc/config/rs6000/rs6000.md
+++ b/gcc/config/rs6000/rs6000.md
@@ -67,7 +67,7 @@
(const_string "integer"))
;; Length (in bytes).
-; '(pc)' in the following doesn't include the instruction itself; it is
+; '(pc)' in the following doesn't include the instruction itself; it is
; calculated as if the instruction had zero size.
(define_attr "length" ""
(if_then_else (eq_attr "type" "branch")
@@ -1632,7 +1632,7 @@
operands[3] = gen_reg_rtx (SImode);
operands[4] = gen_reg_rtx (SImode);
})
-
+
(define_expand "ffssi2"
[(set (match_dup 2)
(neg:SI (match_operand:SI 1 "gpc_reg_operand" "r")))
@@ -1648,7 +1648,7 @@
operands[3] = gen_reg_rtx (SImode);
operands[4] = gen_reg_rtx (SImode);
})
-
+
(define_expand "mulsi3"
[(use (match_operand:SI 0 "gpc_reg_operand" ""))
(use (match_operand:SI 1 "gpc_reg_operand" ""))
@@ -1672,10 +1672,10 @@
"@
{muls|mullw} %0,%1,%2
{muli|mulli} %0,%1,%2"
- [(set (attr "type")
+ [(set (attr "type")
(cond [(match_operand:SI 2 "s8bit_cint_operand" "")
(const_string "imul3")
- (match_operand:SI 2 "short_cint_operand" "")
+ (match_operand:SI 2 "short_cint_operand" "")
(const_string "imul2")]
(const_string "imul")))])
@@ -1687,10 +1687,10 @@
"@
{muls|mullw} %0,%1,%2
{muli|mulli} %0,%1,%2"
- [(set (attr "type")
+ [(set (attr "type")
(cond [(match_operand:SI 2 "s8bit_cint_operand" "")
(const_string "imul3")
- (match_operand:SI 2 "short_cint_operand" "")
+ (match_operand:SI 2 "short_cint_operand" "")
(const_string "imul2")]
(const_string "imul")))])
@@ -2568,7 +2568,7 @@
(const_int 0)))]
"")
-;; Split a logical operation that we can't do in one insn into two insns,
+;; Split a logical operation that we can't do in one insn into two insns,
;; each of which does one 16-bit part. This is used by combine.
(define_split
@@ -4686,7 +4686,7 @@
"TARGET_PPC_GFXOPT && TARGET_HARD_FLOAT && TARGET_FPRS"
[(const_int 0)]
"
-{ rs6000_emit_minmax (operands[0], GET_CODE (operands[3]),
+{ rs6000_emit_minmax (operands[0], GET_CODE (operands[3]),
operands[1], operands[2]);
DONE;
}")
@@ -4879,7 +4879,7 @@
(minus:DF (match_operand:DF 3 "gpc_reg_operand" "f")
(mult:DF (match_operand:DF 1 "gpc_reg_operand" "%f")
(match_operand:DF 2 "gpc_reg_operand" "f"))))]
- "TARGET_HARD_FLOAT && TARGET_FPRS && TARGET_FUSED_MADD
+ "TARGET_HARD_FLOAT && TARGET_FPRS && TARGET_FUSED_MADD
&& ! HONOR_SIGNED_ZEROS (DFmode)"
"{fnms|fnmsub} %0,%1,%2,%3"
[(set_attr "type" "dmul")])
@@ -4892,7 +4892,7 @@
[(set_attr "type" "dsqrt")])
;; The conditional move instructions allow us to perform max and min
-;; operations even when
+;; operations even when
(define_expand "maxdf3"
[(set (match_operand:DF 0 "gpc_reg_operand" "")
@@ -4920,7 +4920,7 @@
"TARGET_PPC_GFXOPT && TARGET_HARD_FLOAT && TARGET_FPRS"
[(const_int 0)]
"
-{ rs6000_emit_minmax (operands[0], GET_CODE (operands[3]),
+{ rs6000_emit_minmax (operands[0], GET_CODE (operands[3]),
operands[1], operands[2]);
DONE;
}")
@@ -4991,7 +4991,11 @@
{
if (TARGET_POWERPC64)
{
- rtx mem = assign_stack_temp (DImode, GET_MODE_SIZE (DImode), 0);
+ /* APPLE LOCAL assign_stack_local_with_alias is used instead of
+ assign_stack_temp to get better scheduling, at the cost of some
+ stack space. */
+ rtx mem = assign_stack_local_with_alias (DImode, GET_MODE_SIZE (DImode),
+ GET_MODE_ALIGNMENT (DImode));
rtx t1 = gen_reg_rtx (DImode);
rtx t2 = gen_reg_rtx (DImode);
emit_insn (gen_floatsidf_ppc64 (operands[0], operands[1], mem, t1, t2));
@@ -5000,7 +5004,11 @@
operands[2] = force_reg (SImode, GEN_INT (0x43300000));
operands[3] = force_reg (DFmode, CONST_DOUBLE_ATOF (\"4503601774854144\", DFmode));
- operands[4] = assign_stack_temp (DFmode, GET_MODE_SIZE (DFmode), 0);
+ /* APPLE LOCAL assign_stack_local_with_alias is used instead of
+ assign_stack_temp to get better scheduling, at the cost of some
+ stack space. */
+ operands[4] = assign_stack_local_with_alias (DFmode, GET_MODE_SIZE (DFmode),
+ GET_MODE_ALIGNMENT (DFmode));
operands[5] = gen_reg_rtx (DFmode);
operands[6] = gen_reg_rtx (SImode);
}")
@@ -5046,7 +5054,7 @@
tmp = highword; highword = lowword; lowword = tmp;
}
- emit_insn (gen_xorsi3 (operands[6], operands[1],
+ emit_insn (gen_xorsi3 (operands[6], operands[1],
GEN_INT (~ (HOST_WIDE_INT) 0x7fffffff)));
emit_move_insn (gen_rtx_MEM (SImode, lowword), operands[6]);
emit_move_insn (gen_rtx_MEM (SImode, highword), operands[2]);
@@ -5073,7 +5081,11 @@
{
if (TARGET_POWERPC64)
{
- rtx mem = assign_stack_temp (DImode, GET_MODE_SIZE (DImode), 0);
+ /* APPLE LOCAL assign_stack_local_with_alias is used instead of
+ assign_stack_temp to get better scheduling, at the cost of some
+ stack space. */
+ rtx mem = assign_stack_local_with_alias (DImode, GET_MODE_SIZE (DImode),
+ GET_MODE_ALIGNMENT (DImode));
rtx t1 = gen_reg_rtx (DImode);
rtx t2 = gen_reg_rtx (DImode);
emit_insn (gen_floatunssidf_ppc64 (operands[0], operands[1], mem,
@@ -5083,7 +5095,11 @@
operands[2] = force_reg (SImode, GEN_INT (0x43300000));
operands[3] = force_reg (DFmode, CONST_DOUBLE_ATOF (\"4503599627370496\", DFmode));
- operands[4] = assign_stack_temp (DFmode, GET_MODE_SIZE (DFmode), 0);
+ /* APPLE LOCAL assign_stack_local_with_alias is used instead of
+ assign_stack_temp to get better scheduling, at the cost of some
+ stack space. */
+ operands[4] = assign_stack_local_with_alias (DFmode, GET_MODE_SIZE (DFmode),
+ GET_MODE_ALIGNMENT (DFmode));
operands[5] = gen_reg_rtx (DFmode);
}")
@@ -5141,7 +5157,11 @@
"
{
operands[2] = gen_reg_rtx (DImode);
- operands[3] = assign_stack_temp (DImode, GET_MODE_SIZE (DImode), 0);
+ /* APPLE LOCAL assign_stack_local_with_alias is used instead of
+ assign_stack_temp to get better scheduling, at the cost of some
+ stack space. */
+ operands[3] = assign_stack_local_with_alias (DImode, GET_MODE_SIZE (DImode),
+ GET_MODE_ALIGNMENT (DImode));
}")
(define_insn "*fix_truncdfsi2_internal"
@@ -5642,7 +5662,7 @@
(define_insn "*ashrdisi3_noppc64"
[(set (match_operand:SI 0 "gpc_reg_operand" "=r")
- (subreg:SI (ashiftrt:DI (match_operand:DI 1 "gpc_reg_operand" "r")
+ (subreg:SI (ashiftrt:DI (match_operand:DI 1 "gpc_reg_operand" "r")
(const_int 32)) 4))]
"TARGET_32BIT && !TARGET_POWERPC64"
"*
@@ -5652,7 +5672,7 @@
else
return \"mr %0,%1\";
}"
- [(set_attr "length" "4")])
+ [(set_attr "length" "4")])
;; PowerPC64 DImode operations.
@@ -6032,15 +6052,15 @@
(define_expand "ctzdi2"
[(set (match_dup 2)
(neg:DI (match_operand:DI 1 "gpc_reg_operand" "r")))
- (parallel [(set (match_dup 3) (and:DI (match_dup 1)
- (match_dup 2)))
+ (parallel [(set (match_dup 3) (and:DI (match_dup 1)
+ (match_dup 2)))
(clobber (scratch:CC))])
(set (match_dup 4) (clz:DI (match_dup 3)))
(set (match_operand:DI 0 "gpc_reg_operand" "=r")
(minus:DI (const_int 63) (match_dup 4)))]
"TARGET_POWERPC64"
{
- operands[2] = gen_reg_rtx (DImode);
+ operands[2] = gen_reg_rtx (DImode);
operands[3] = gen_reg_rtx (DImode);
operands[4] = gen_reg_rtx (DImode);
})
@@ -6048,15 +6068,15 @@
(define_expand "ffsdi2"
[(set (match_dup 2)
(neg:DI (match_operand:DI 1 "gpc_reg_operand" "r")))
- (parallel [(set (match_dup 3) (and:DI (match_dup 1)
- (match_dup 2)))
+ (parallel [(set (match_dup 3) (and:DI (match_dup 1)
+ (match_dup 2)))
(clobber (scratch:CC))])
(set (match_dup 4) (clz:DI (match_dup 3)))
(set (match_operand:DI 0 "gpc_reg_operand" "=r")
(minus:DI (const_int 64) (match_dup 4)))]
"TARGET_POWERPC64"
{
- operands[2] = gen_reg_rtx (DImode);
+ operands[2] = gen_reg_rtx (DImode);
operands[3] = gen_reg_rtx (DImode);
operands[4] = gen_reg_rtx (DImode);
})
@@ -6656,7 +6676,7 @@
"TARGET_POWERPC64"
"sld%I2 %0,%1,%H2"
[(set_attr "length" "8")])
-
+
(define_insn "*ashldi3_internal2"
[(set (match_operand:CC 0 "cc_reg_operand" "=x,?y")
(compare:CC (ashift:DI (match_operand:DI 1 "gpc_reg_operand" "r,r")
@@ -6669,7 +6689,7 @@
#"
[(set_attr "type" "delayed_compare")
(set_attr "length" "4,8")])
-
+
(define_split
[(set (match_operand:CC 0 "cc_reg_not_cr0_operand" "")
(compare:CC (ashift:DI (match_operand:DI 1 "gpc_reg_operand" "")
@@ -7335,7 +7355,7 @@
(const_int 0)))]
"")
-;; Split a logical operation that we can't do in one insn into two insns,
+;; Split a logical operation that we can't do in one insn into two insns,
;; each of which does one 16-bit part. This is used by combine.
(define_split
@@ -7349,7 +7369,7 @@
"
{
rtx i3,i4;
-
+
if (GET_CODE (operands[2]) == CONST_DOUBLE)
{
HOST_WIDE_INT value = CONST_DOUBLE_LOW (operands[2]);
@@ -7577,7 +7597,7 @@
;; Used by sched, shorten_branches and final when the GOT pseudo reg
;; didn't get allocated to a hard register.
-(define_split
+(define_split
[(set (match_operand:SI 0 "gpc_reg_operand" "")
(unspec:SI [(match_operand:SI 1 "got_no_const_operand" "")
(match_operand:SI 2 "memory_operand" "")]
@@ -7640,12 +7660,16 @@
return \"ld %0,lo16(%2)(%1)\";
else
{
- operands2[3] = gen_rtx_REG (SImode, RS6000_PIC_OFFSET_TABLE_REGNUM);
+ /* APPLE LOCAL volatile pic base reg in leaves */
+ operands2[3] = gen_rtx_REG (SImode,
+ (cfun->machine->substitute_pic_base_reg == -1
+ ? RS6000_PIC_OFFSET_TABLE_REGNUM
+ : cfun->machine->substitute_pic_base_reg));
output_asm_insn (\"{l|lwz} %0,lo16(%2)(%1)\", operands);
#if TARGET_MACHO
if (MACHO_DYNAMIC_NO_PIC_P)
output_asm_insn (\"{liu|lis} %L0,ha16(%2+4)\", operands);
- else
+ else
/* We cannot rely on ha16(low half)==ha16(high half), alas,
although in practice it almost always is. */
output_asm_insn (\"{cau|addis} %L0,%3,ha16(%2+4)\", operands2);
@@ -8254,7 +8278,7 @@
emit_move_insn (simplify_gen_subreg (DFmode, operands[0], TFmode, lo_word),
operands[2]);
DONE;
-})
+})
(define_expand "extendsftf2"
[(set (match_operand:TF 0 "nonimmediate_operand" "")
@@ -8474,7 +8498,7 @@
(define_split
[(set (match_operand:DI 0 "nonimmediate_operand" "")
(match_operand:DI 1 "input_operand" ""))]
- "reload_completed && !TARGET_POWERPC64
+ "reload_completed && !TARGET_POWERPC64
&& gpr_or_gpr_p (operands[0], operands[1])"
[(pc)]
{ rs6000_split_multireg_move (operands[0], operands[1]); DONE; })
@@ -8634,7 +8658,7 @@
[(set (match_operand:TI 0 "reg_or_mem_operand" "=Q,m,????r,????r,????r")
(match_operand:TI 1 "reg_or_mem_operand" "r,r,r,Q,m"))
(clobber (match_scratch:SI 2 "=q,q#X,X,X,X"))]
- "TARGET_POWER && ! TARGET_POWERPC64
+ "TARGET_POWER && ! TARGET_POWERPC64
&& (gpc_reg_operand (operands[0], TImode) || gpc_reg_operand (operands[1], TImode))"
"*
{
@@ -8682,7 +8706,7 @@
case 3:
/* If the address is not used in the output, we can use lsi. Otherwise,
fall through to generating four loads. */
- if (TARGET_STRING
+ if (TARGET_STRING
&& ! reg_overlap_mentioned_p (operands[0], operands[1]))
return \"{lsi|lswi} %0,%P1,16\";
/* ... fall through ... */
@@ -8698,8 +8722,8 @@
"TARGET_POWERPC64 && (gpc_reg_operand (operands[0], TImode)
|| gpc_reg_operand (operands[1], TImode))"
"@
- #
- #
+ #
+ #
#"
[(set_attr "type" "*,load,store")])
@@ -9831,7 +9855,7 @@
if (current_function_limit_stack)
{
rtx available;
- available = expand_binop (Pmode, sub_optab,
+ available = expand_binop (Pmode, sub_optab,
stack_pointer_rtx, stack_limit_rtx,
NULL_RTX, 1, OPTAB_WIDEN);
emit_insn (gen_cond_trap (LTU, available, operands[1], const0_rtx));
@@ -10277,6 +10301,12 @@
else if (INTVAL (operands[2]) & CALL_V4_CLEAR_FP_ARGS)
output_asm_insn (\"creqv 6,6,6\", operands);
+/* APPLE LOCAL -mlongcall */
+#ifdef RS6000_LONG_BRANCH
+ if (!flag_pic)
+ return output_call(insn, operands[0], 0);
+ else
+#endif
return (DEFAULT_ABI == ABI_V4 && flag_pic) ? \"bl %z0@local\" : \"bl %z0\";
}"
[(set_attr "type" "branch")
@@ -10392,7 +10422,7 @@
(match_operand 1 "" "g"))
(use (match_operand:SI 2 "immediate_operand" "O"))
(clobber (match_scratch:SI 3 "=l"))]
- "TARGET_64BIT
+ "TARGET_64BIT
&& DEFAULT_ABI == ABI_AIX
&& (INTVAL (operands[2]) & CALL_LONG) == 0"
"bl %z0\;%."
@@ -10446,7 +10476,7 @@
(match_operand 2 "" "g")))
(use (match_operand:SI 3 "immediate_operand" "O"))
(clobber (match_scratch:SI 4 "=l"))]
- "TARGET_64BIT
+ "TARGET_64BIT
&& DEFAULT_ABI == ABI_AIX
&& (INTVAL (operands[3]) & CALL_LONG) == 0"
"bl %z1\;%."
@@ -10459,11 +10489,12 @@
;; operands[2] is the value FUNCTION_ARG returns for the VOID argument
;; which indicates how to set cr1
+;; APPLE LOCAL separate cl into c,*l; switch and attr's expanded to match
(define_insn "*call_indirect_nonlocal_sysv"
- [(call (mem:SI (match_operand:SI 0 "register_operand" "cl,cl"))
- (match_operand 1 "" "g,g"))
- (use (match_operand:SI 2 "immediate_operand" "O,n"))
- (clobber (match_scratch:SI 3 "=l,l"))]
+ [(call (mem:SI (match_operand:SI 0 "register_operand" "c,*l,c,*l"))
+ (match_operand 1 "" "g,g,g,g"))
+ (use (match_operand:SI 2 "immediate_operand" "O,O,n,n"))
+ (clobber (match_scratch:SI 3 "=l,l,l,l"))]
"DEFAULT_ABI == ABI_V4
|| DEFAULT_ABI == ABI_DARWIN"
{
@@ -10475,8 +10506,8 @@
return "b%T0l";
}
- [(set_attr "type" "jmpreg,jmpreg")
- (set_attr "length" "4,8")])
+ [(set_attr "type" "jmpreg,jmpreg,jmpreg,jmpreg")
+ (set_attr "length" "4,4,8,8")])
(define_insn "*call_nonlocal_sysv"
[(call (mem:SI (match_operand:SI 0 "symbol_ref_operand" "s,s"))
@@ -10497,17 +10528,18 @@
return output_call(insn, operands, 0, 2);
#else
return (DEFAULT_ABI == ABI_V4 && flag_pic) ? "bl %z0@plt" : "bl %z0";
-#endif
+#endif
}
[(set_attr "type" "branch,branch")
(set_attr "length" "4,8")])
+;; APPLE LOCAL separate cl into c,*l; switch and attr's expanded to match
(define_insn "*call_value_indirect_nonlocal_sysv"
[(set (match_operand 0 "" "")
- (call (mem:SI (match_operand:SI 1 "register_operand" "cl,cl"))
- (match_operand 2 "" "g,g")))
- (use (match_operand:SI 3 "immediate_operand" "O,n"))
- (clobber (match_scratch:SI 4 "=l,l"))]
+ (call (mem:SI (match_operand:SI 1 "register_operand" "c,*l,c,*l"))
+ (match_operand 2 "" "g,g,g,g")))
+ (use (match_operand:SI 3 "immediate_operand" "O,O,n,n"))
+ (clobber (match_scratch:SI 4 "=l,l,l,l"))]
"DEFAULT_ABI == ABI_V4
|| DEFAULT_ABI == ABI_DARWIN"
{
@@ -10519,8 +10551,8 @@
return "b%T1l";
}
- [(set_attr "type" "jmpreg,jmpreg")
- (set_attr "length" "4,8")])
+ [(set_attr "type" "jmpreg,jmpreg,jmpreg,jmpreg")
+ (set_attr "length" "4,4,8,8")])
(define_insn "*call_value_nonlocal_sysv"
[(set (match_operand 0 "" "")
@@ -10542,7 +10574,7 @@
return output_call(insn, operands, 1, 3);
#else
return (DEFAULT_ABI == ABI_V4 && flag_pic) ? "bl %z1@plt" : "bl %z1";
-#endif
+#endif
}
[(set_attr "type" "branch,branch")
(set_attr "length" "4,8")])
@@ -10575,6 +10607,52 @@
DONE;
}")
+;; APPLE LOCAL sibcall patterns
+;; APPLE MERGE modify FSF patterns below instead?
+;; this and similar patterns must be marked as using LR, otherwise
+;; dataflow will try to delete the store into it. This is true
+;; even when the actual reg to jump to is in CTR, when LR was
+;; saved and restored around the PIC-setting BCL.
+(define_insn "*sibcall_symbolic"
+ [(call (mem:SI (match_operand:SI 0 "call_operand" "s,c"))
+ (match_operand 1 "" ""))
+ (use (match_operand 2 "" ""))
+ (use (match_scratch:SI 3 "=l,l"))
+ (return)]
+ "! TARGET_64BIT && DEFAULT_ABI == ABI_DARWIN"
+ "*
+{
+ switch (which_alternative)
+ {
+ case 0: return \"b %z0\";
+ case 1: return \"b%T0\";
+ default: abort();
+ }
+}"
+ [(set_attr "type" "branch")
+ (set_attr "length" "4")])
+
+(define_insn "*sibcall_value_symbolic"
+ [(set (match_operand 0 "" "")
+ (call (mem:SI (match_operand:SI 1 "call_operand" "s,c"))
+ (match_operand 2 "" "")))
+ (use (match_operand:SI 3 "" ""))
+ (use (match_scratch:SI 4 "=l,l"))
+ (return)]
+ "! TARGET_64BIT && DEFAULT_ABI == ABI_DARWIN"
+ "*
+{
+ switch (which_alternative)
+ {
+ case 0: return \"b %z1\";
+ case 1: return \"b%T1\";
+ default: abort();
+ }
+}"
+ [(set_attr "type" "branch")
+ (set_attr "length" "4")])
+;; APPLE LOCAL end sibcall patterns
+
;; sibling call patterns
(define_expand "sibcall"
[(parallel [(call (mem:SI (match_operand 0 "address_operand" ""))
@@ -10704,7 +10782,7 @@
(use (match_operand:SI 2 "immediate_operand" "O"))
(use (match_operand:SI 3 "register_operand" "l"))
(return)]
- "TARGET_64BIT
+ "TARGET_64BIT
&& DEFAULT_ABI == ABI_AIX
&& (INTVAL (operands[2]) & CALL_LONG) == 0"
"b %z0"
@@ -10732,7 +10810,7 @@
(use (match_operand:SI 3 "immediate_operand" "O"))
(use (match_operand:SI 4 "register_operand" "l"))
(return)]
- "TARGET_64BIT
+ "TARGET_64BIT
&& DEFAULT_ABI == ABI_AIX
&& (INTVAL (operands[3]) & CALL_LONG) == 0"
"b %z1"
@@ -11009,11 +11087,11 @@
[(clobber (match_operand:SI 0 "gpc_reg_operand" ""))]
""
"
-{
+{
if (! rs6000_compare_fp_p)
FAIL;
- rs6000_emit_sCOND (NE, operands[0]);
+ rs6000_emit_sCOND (NE, operands[0]);
DONE;
}")
@@ -11041,7 +11119,7 @@
&& (! TARGET_POWER || rs6000_compare_op1 == const0_rtx))
FAIL;
- rs6000_emit_sCOND (GT, operands[0]);
+ rs6000_emit_sCOND (GT, operands[0]);
DONE;
}")
@@ -11055,7 +11133,7 @@
&& (! TARGET_POWER || rs6000_compare_op1 == const0_rtx))
FAIL;
- rs6000_emit_sCOND (LE, operands[0]);
+ rs6000_emit_sCOND (LE, operands[0]);
DONE;
}")
@@ -11065,11 +11143,11 @@
""
"
{
- if (! rs6000_compare_fp_p
+ if (! rs6000_compare_fp_p
&& (! TARGET_POWER || rs6000_compare_op1 == const0_rtx))
FAIL;
- rs6000_emit_sCOND (LT, operands[0]);
+ rs6000_emit_sCOND (LT, operands[0]);
DONE;
}")
@@ -13791,7 +13869,7 @@
}")
(define_expand "tablejumpdi"
- [(set (match_dup 4)
+ [(set (match_dup 4)
(sign_extend:DI (match_operand:SI 0 "lwa_operand" "rm")))
(set (match_dup 3)
(plus:DI (match_dup 4)
@@ -14363,7 +14441,7 @@
(define_insn "movesi_from_cr"
[(set (match_operand:SI 0 "gpc_reg_operand" "=r")
- (unspec:SI [(reg:CC 68) (reg:CC 69) (reg:CC 70) (reg:CC 71)
+ (unspec:SI [(reg:CC 68) (reg:CC 69) (reg:CC 70) (reg:CC 71)
(reg:CC 72) (reg:CC 73) (reg:CC 74) (reg:CC 75)]
UNSPEC_MOVESI_FROM_CR))]
""
@@ -14376,7 +14454,7 @@
(match_operand:SI 2 "gpc_reg_operand" "r"))])]
"TARGET_MULTIPLE"
"{stm|stmw} %2,%1")
-
+
(define_insn "*save_fpregs_si"
[(match_parallel 0 "any_operand"
[(clobber (match_operand:SI 1 "register_operand" "=l"))
@@ -14388,6 +14466,35 @@
[(set_attr "type" "branch")
(set_attr "length" "4")])
+/* APPLE LOCAL begin unnamed*/
+(define_insn "*save_fpregs_with_label_si"
+ [(match_parallel 0 "any_operand"
+ [(clobber (match_operand:SI 1 "register_operand" "=l"))
+ (use (match_operand:SI 2 "call_operand" "s"))
+ (use (match_operand:SI 3 "" ""))
+ (set (match_operand:DF 4 "memory_operand" "=m")
+ (match_operand:DF 5 "gpc_reg_operand" "f"))])]
+ "TARGET_32BIT"
+ "*
+#if TARGET_MACHO
+ char *picbase = machopic_function_base_name ();
+ char *tmp;
+ operands[3] = gen_rtx_SYMBOL_REF (Pmode, ggc_alloc_string (picbase, -1));
+ if (TARGET_LONG_BRANCH)
+ {
+ tmp = ggc_alloc (strlen (XSTR (operands[2], 0)) + strlen (XSTR (operands[3], 0)) + 2);
+ strcpy (tmp, output_call(insn, operands[2], 2, \"\"));
+ strcat (tmp, \"\\n%3:\");
+ return tmp;
+ }
+ else
+#endif
+ return \"bl %z2\\n%3:\";
+"
+ [(set_attr "type" "branch")
+ (set_attr "length" "4")])
+/* APPLE LOCAL end unnamed */
+
(define_insn "*save_fpregs_di"
[(match_parallel 0 "any_operand"
[(clobber (match_operand:DI 1 "register_operand" "=l"))
@@ -14452,7 +14559,7 @@
(unspec:CC [(match_operand:SI 1 "gpc_reg_operand" "r")
(match_operand 2 "immediate_operand" "n")]
UNSPEC_MOVESI_TO_CR))]
- "GET_CODE (operands[0]) == REG
+ "GET_CODE (operands[0]) == REG
&& CR_REGNO_P (REGNO (operands[0]))
&& GET_CODE (operands[2]) == CONST_INT
&& INTVAL (operands[2]) == 1 << (75 - REGNO (operands[0]))"
@@ -14469,7 +14576,7 @@
(match_operand:SI 2 "memory_operand" "m"))])]
"TARGET_MULTIPLE"
"{lm|lmw} %1,%2")
-
+
(define_insn "*return_internal_si"
[(return)
(use (match_operand:SI 0 "register_operand" "lc"))]
@@ -14495,7 +14602,14 @@
(set (match_operand:DF 3 "gpc_reg_operand" "=f")
(match_operand:DF 4 "memory_operand" "m"))])]
"TARGET_32BIT"
- "b %z2")
+ {
+#if TARGET_MACHO
+ if (TARGET_LONG_BRANCH)
+ return output_call(insn, operands[2], 2, "");
+ else
+#endif
+ return "b %z2";
+ })
(define_insn "*return_and_restore_fpregs_di"
[(match_parallel 0 "any_operand"
@@ -14505,7 +14619,14 @@
(set (match_operand:DF 3 "gpc_reg_operand" "=f")
(match_operand:DF 4 "memory_operand" "m"))])]
"TARGET_64BIT"
- "b %z2")
+ {
+#if TARGET_MACHO
+ if (TARGET_LONG_BRANCH)
+ return output_call(insn, operands[2], 2, "");
+ else
+#endif
+ return "b %z2";
+ })
; This is used in compiling the unwind routines.
(define_expand "eh_return"
diff --git a/gcc/config/rs6000/sysv4.h b/gcc/config/rs6000/sysv4.h
index 1e0ac3707f6..88bf8196b17 100644
--- a/gcc/config/rs6000/sysv4.h
+++ b/gcc/config/rs6000/sysv4.h
@@ -434,6 +434,13 @@ do { \
#define BSS_SECTION_ASM_OP "\t.section\t\".bss\""
+/* APPLE LOCAL begin hot/cold partitioning */
+#define HOT_TEXT_SECTION_NAME ".text"
+#define NORMAL_TEXT_SECTION_NAME ".text"
+#define UNLIKELY_EXECUTED_TEXT_SECTION_NAME ".text.unlikely"
+#define SECTION_FORMAT_STRING ".section\t\"%s\"\n\t.align 2\n"
+/* APPLE LOCAL end hot/cold partitioning */
+
/* Override elfos.h definition. */
#undef INIT_SECTION_ASM_OP
#define INIT_SECTION_ASM_OP "\t.section\t\".init\",\"ax\""
diff --git a/gcc/config/rs6000/t-darwin b/gcc/config/rs6000/t-darwin
index 185bb00eed2..af710ed7cef 100644
--- a/gcc/config/rs6000/t-darwin
+++ b/gcc/config/rs6000/t-darwin
@@ -1,7 +1,11 @@
+# APPLE LOCAL begin AltiVec
# Add trampoline and long double support to libgcc.
LIB2FUNCS_EXTRA = $(srcdir)/config/rs6000/darwin-tramp.asm \
- $(srcdir)/config/rs6000/darwin-ldouble.c
+ $(srcdir)/config/rs6000/darwin-fpsave.asm \
+ $(srcdir)/config/rs6000/darwin-ldouble.c
+# Enable AltiVec instructions when assembling the aforementioned .asm files.
# For libgcc, we always want 128-bit long double, since a libgcc built with
# that will work without it.
-TARGET_LIBGCC2_CFLAGS = -mlong-double-128
+TARGET_LIBGCC2_CFLAGS = -mlong-double-128 -Wa,-force_cpusubtype_ALL
+# APPLE LOCAL end AltiVec
diff --git a/gcc/config/rs6000/t-rs6000 b/gcc/config/rs6000/t-rs6000
index 9546461e57d..9cc60036c00 100644
--- a/gcc/config/rs6000/t-rs6000
+++ b/gcc/config/rs6000/t-rs6000
@@ -18,6 +18,7 @@ rs6000-c.o: $(srcdir)/config/rs6000/rs6000-c.c \
# The rs6000 backend doesn't cause warnings in these files.
insn-conditions.o-warn =
+
# The files below trigger warnings in tree-ssa because of the gimplifier
# emitting code that confuse the compiler into thinking that some variables
# are used uninitialized.
diff --git a/gcc/config/rs6000/t-rtems b/gcc/config/rs6000/t-rtems
deleted file mode 100644
index 364a22d2278..00000000000
--- a/gcc/config/rs6000/t-rtems
+++ /dev/null
@@ -1,86 +0,0 @@
-# Multilibs for powerpc RTEMS targets.
-
-MULTILIB_OPTIONS = \
-mcpu=403/mcpu=505/mcpu=601/mcpu=602/mcpu=603/mcpu=603e/mcpu=604/mcpu=750/mcpu=821/mcpu=860 \
-Dmpc509/Dmpc8260 \
-D_OLD_EXCEPTIONS \
-msoft-float
-
-MULTILIB_DIRNAMES = \
-m403 m505 m601 m602 m603 m603e m604 m750 m821 m860 \
-mpc509 \
-mpc8260 \
-roe \
-nof
-
-MULTILIB_EXTRA_OPTS = mrelocatable-lib mno-eabi mstrict-align
-
-# MULTILIB_MATCHES = ${MULTILIB_MATCHES_FLOAT}
-MULTILIB_MATCHES = ${MULTILIB_MATCHES_ENDIAN} \
- ${MULTILIB_MATCHES_SYSV} \
- mcpu?505/Dmpc505=mcpu?505/Dmpc509
-
-#
-# RTEMS old/new-exceptions handling
-#
-# old-exception processing is depredicated, therefore
-#
-# * Cpu-variants supporting new exception processing are build
-# with new exception processing only
-# * Cpu-variants not having been ported to new exception processing are
-# build with old and new exception processing
-#
-
-# Cpu-variants supporting new exception processing only
-MULTILIB_NEW_EXCEPTIONS_ONLY = \
-*mcpu=604*/*D_OLD_EXCEPTIONS* \
-*mcpu=750*/*D_OLD_EXCEPTIONS* \
-*mcpu=821*/*D_OLD_EXCEPTIONS* \
-*Dmpc8260*/*D_OLD_EXCEPTIONS* \
-*mcpu=860*/*D_OLD_EXCEPTIONS*
-
-# Soft-float only, default implies msoft-float
-# NOTE: Must match with MULTILIB_MATCHES_FLOAT and MULTILIB_MATCHES
-MULTILIB_SOFTFLOAT_ONLY = \
-mcpu=403/*msoft-float* \
-mcpu=821/*msoft-float* \
-mcpu=860/*msoft-float*
-
-# Hard-float only, take out msoft-float
-MULTILIB_HARDFLOAT_ONLY = \
-mcpu=505/*msoft-float*
-
-MULTILIB_EXCEPTIONS =
-
-# Disallow -D_OLD_EXCEPTIONS without other options
-MULTILIB_EXCEPTIONS += D_OLD_EXCEPTIONS*
-
-# Disallow -Dppc and -Dmpc without other options
-MULTILIB_EXCEPTIONS += Dppc* Dmpc*
-
-MULTILIB_EXCEPTIONS += \
-${MULTILIB_NEW_EXCEPTIONS_ONLY} \
-${MULTILIB_SOFTFLOAT_ONLY} \
-${MULTILIB_HARDFLOAT_ONLY}
-
-# Special rules
-# Take out all variants we don't want
-MULTILIB_EXCEPTIONS += mcpu=403/Dmpc509*
-MULTILIB_EXCEPTIONS += mcpu=403/Dmpc8260*
-MULTILIB_EXCEPTIONS += mcpu=505/Dmpc509*
-MULTILIB_EXCEPTIONS += mcpu=505/Dmpc8260*
-MULTILIB_EXCEPTIONS += mcpu=601/Dmpc509*
-MULTILIB_EXCEPTIONS += mcpu=601/Dmpc8260*
-MULTILIB_EXCEPTIONS += mcpu=602/Dmpc509*
-MULTILIB_EXCEPTIONS += mcpu=602/Dmpc8260*
-MULTILIB_EXCEPTIONS += mcpu=603/Dmpc509*
-MULTILIB_EXCEPTIONS += mcpu=603/Dmpc8260*
-MULTILIB_EXCEPTIONS += mcpu=603e/Dmpc509*
-MULTILIB_EXCEPTIONS += mcpu=604/Dmpc509*
-MULTILIB_EXCEPTIONS += mcpu=604/Dmpc8260*
-MULTILIB_EXCEPTIONS += mcpu=750/Dmpc509*
-MULTILIB_EXCEPTIONS += mcpu=750/Dmpc8260*
-MULTILIB_EXCEPTIONS += mcpu=821/Dmpc509*
-MULTILIB_EXCEPTIONS += mcpu=821/Dmpc8260*
-MULTILIB_EXCEPTIONS += mcpu=860/Dmpc509*
-MULTILIB_EXCEPTIONS += mcpu=860/Dmpc8260*
diff --git a/gcc/config/rs6000/vec.h b/gcc/config/rs6000/vec.h
new file mode 100644
index 00000000000..56e8786f25b
--- /dev/null
+++ b/gcc/config/rs6000/vec.h
@@ -0,0 +1,4515 @@
+/* APPLE LOCAL file AltiVec */
+/* This file is generated by ops-to-gp. Do not edit. */
+
+/* To regenerate execute:
+ ops-to-gp -gcc vec.ops builtin.ops
+ with the current directory being gcc/config/rs6000. */
+
+static const struct builtin B1_vec_abs = { { &T_vec_f32, NULL, NULL, }, "x", &T_vec_f32, 1, FALSE, FALSE, 11, "vec_abs:1", "4", CODE_FOR_xfx_perm, B_UID(0) };
+static const struct builtin B2_vec_abs = { { &T_vec_s16, NULL, NULL, }, "x", &T_vec_s16, 1, FALSE, FALSE, 11, "vec_abs:2", "2", CODE_FOR_xfx_perm, B_UID(1) };
+static const struct builtin B3_vec_abs = { { &T_vec_s32, NULL, NULL, }, "x", &T_vec_s32, 1, FALSE, FALSE, 11, "vec_abs:3", "3", CODE_FOR_xfx_perm, B_UID(2) };
+static const struct builtin B4_vec_abs = { { &T_vec_s8, NULL, NULL, }, "x", &T_vec_s8, 1, FALSE, FALSE, 11, "vec_abs:4", "1", CODE_FOR_xfx_perm, B_UID(3) };
+static const struct builtin B1_vec_abss = { { &T_vec_s16, NULL, NULL, }, "x", &T_vec_s16, 1, FALSE, FALSE, 11, "vec_abss:1", "6", CODE_FOR_xfx_perm, B_UID(4) };
+static const struct builtin B2_vec_abss = { { &T_vec_s32, NULL, NULL, }, "x", &T_vec_s32, 1, FALSE, FALSE, 11, "vec_abss:2", "7", CODE_FOR_xfx_perm, B_UID(5) };
+static const struct builtin B3_vec_abss = { { &T_vec_s8, NULL, NULL, }, "x", &T_vec_s8, 1, FALSE, FALSE, 11, "vec_abss:3", "5", CODE_FOR_xfx_perm, B_UID(6) };
+static const struct builtin B1_vec_vadduhm = { { &T_vec_b16, &T_vec_s16, NULL, }, "xx", &T_vec_s16, 2, FALSE, FALSE, 0, "vec_vadduhm:1", "*vadduhm", CODE_FOR_xfxx_simple, B_UID(7) };
+static const struct builtin B2_vec_vadduhm = { { &T_vec_b16, &T_vec_u16, NULL, }, "xx", &T_vec_u16, 2, FALSE, FALSE, 0, "vec_vadduhm:2", "*vadduhm", CODE_FOR_xfxx_simple, B_UID(8) };
+static const struct builtin B1_vec_vadduwm = { { &T_vec_b32, &T_vec_s32, NULL, }, "xx", &T_vec_s32, 2, FALSE, FALSE, 0, "vec_vadduwm:1", "*vadduwm", CODE_FOR_xfxx_simple, B_UID(9) };
+static const struct builtin B2_vec_vadduwm = { { &T_vec_b32, &T_vec_u32, NULL, }, "xx", &T_vec_u32, 2, FALSE, FALSE, 0, "vec_vadduwm:2", "*vadduwm", CODE_FOR_xfxx_simple, B_UID(10) };
+static const struct builtin B1_vec_vaddubm = { { &T_vec_b8, &T_vec_s8, NULL, }, "xx", &T_vec_s8, 2, FALSE, FALSE, 0, "vec_vaddubm:1", "*vaddubm", CODE_FOR_xfxx_simple, B_UID(11) };
+static const struct builtin B2_vec_vaddubm = { { &T_vec_b8, &T_vec_u8, NULL, }, "xx", &T_vec_u8, 2, FALSE, FALSE, 0, "vec_vaddubm:2", "*vaddubm", CODE_FOR_xfxx_simple, B_UID(12) };
+static const struct builtin B_vec_vaddfp = { { &T_vec_f32, &T_vec_f32, NULL, }, "xx", &T_vec_f32, 2, FALSE, FALSE, 0, "vec_vaddfp", "*vaddfp", CODE_FOR_xfxx_fp, B_UID(13) };
+static const struct builtin B3_vec_vadduhm = { { &T_vec_s16, &T_vec_b16, NULL, }, "xx", &T_vec_s16, 2, FALSE, FALSE, 0, "vec_vadduhm:3", "*vadduhm", CODE_FOR_xfxx_simple, B_UID(14) };
+static const struct builtin B4_vec_vadduhm = { { &T_vec_s16, &T_vec_s16, NULL, }, "xx", &T_vec_s16, 2, FALSE, FALSE, 0, "vec_vadduhm:4", "*vadduhm", CODE_FOR_xfxx_simple, B_UID(15) };
+static const struct builtin B3_vec_vadduwm = { { &T_vec_s32, &T_vec_b32, NULL, }, "xx", &T_vec_s32, 2, FALSE, FALSE, 0, "vec_vadduwm:3", "*vadduwm", CODE_FOR_xfxx_simple, B_UID(16) };
+static const struct builtin B4_vec_vadduwm = { { &T_vec_s32, &T_vec_s32, NULL, }, "xx", &T_vec_s32, 2, FALSE, FALSE, 0, "vec_vadduwm:4", "*vadduwm", CODE_FOR_xfxx_simple, B_UID(17) };
+static const struct builtin B3_vec_vaddubm = { { &T_vec_s8, &T_vec_b8, NULL, }, "xx", &T_vec_s8, 2, FALSE, FALSE, 0, "vec_vaddubm:3", "*vaddubm", CODE_FOR_xfxx_simple, B_UID(18) };
+static const struct builtin B4_vec_vaddubm = { { &T_vec_s8, &T_vec_s8, NULL, }, "xx", &T_vec_s8, 2, FALSE, FALSE, 0, "vec_vaddubm:4", "*vaddubm", CODE_FOR_xfxx_simple, B_UID(19) };
+static const struct builtin B5_vec_vadduhm = { { &T_vec_u16, &T_vec_b16, NULL, }, "xx", &T_vec_u16, 2, FALSE, FALSE, 0, "vec_vadduhm:5", "*vadduhm", CODE_FOR_xfxx_simple, B_UID(20) };
+static const struct builtin B6_vec_vadduhm = { { &T_vec_u16, &T_vec_u16, NULL, }, "xx", &T_vec_u16, 2, FALSE, FALSE, 0, "vec_vadduhm:6", "*vadduhm", CODE_FOR_xfxx_simple, B_UID(21) };
+static const struct builtin B5_vec_vadduwm = { { &T_vec_u32, &T_vec_b32, NULL, }, "xx", &T_vec_u32, 2, FALSE, FALSE, 0, "vec_vadduwm:5", "*vadduwm", CODE_FOR_xfxx_simple, B_UID(22) };
+static const struct builtin B6_vec_vadduwm = { { &T_vec_u32, &T_vec_u32, NULL, }, "xx", &T_vec_u32, 2, FALSE, FALSE, 0, "vec_vadduwm:6", "*vadduwm", CODE_FOR_xfxx_simple, B_UID(23) };
+static const struct builtin B5_vec_vaddubm = { { &T_vec_u8, &T_vec_b8, NULL, }, "xx", &T_vec_u8, 2, FALSE, FALSE, 0, "vec_vaddubm:5", "*vaddubm", CODE_FOR_xfxx_simple, B_UID(24) };
+static const struct builtin B6_vec_vaddubm = { { &T_vec_u8, &T_vec_u8, NULL, }, "xx", &T_vec_u8, 2, FALSE, FALSE, 0, "vec_vaddubm:6", "*vaddubm", CODE_FOR_xfxx_simple, B_UID(25) };
+static const struct builtin B_vec_vaddcuw = { { &T_vec_u32, &T_vec_u32, NULL, }, "xx", &T_vec_u32, 2, FALSE, FALSE, 0, "vec_vaddcuw", "*vaddcuw", CODE_FOR_xfxx_simple, B_UID(26) };
+static const struct builtin B1_vec_vaddshs = { { &T_vec_b16, &T_vec_s16, NULL, }, "xx", &T_vec_s16, 2, FALSE, FALSE, 0, "vec_vaddshs:1", "*vaddshs", CODE_FOR_xfxx_simple, B_UID(27) };
+static const struct builtin B1_vec_vadduhs = { { &T_vec_b16, &T_vec_u16, NULL, }, "xx", &T_vec_u16, 2, FALSE, FALSE, 0, "vec_vadduhs:1", "*vadduhs", CODE_FOR_xfxx_simple, B_UID(28) };
+static const struct builtin B1_vec_vaddsws = { { &T_vec_b32, &T_vec_s32, NULL, }, "xx", &T_vec_s32, 2, FALSE, FALSE, 0, "vec_vaddsws:1", "*vaddsws", CODE_FOR_xfxx_simple, B_UID(29) };
+static const struct builtin B1_vec_vadduws = { { &T_vec_b32, &T_vec_u32, NULL, }, "xx", &T_vec_u32, 2, FALSE, FALSE, 0, "vec_vadduws:1", "*vadduws", CODE_FOR_xfxx_simple, B_UID(30) };
+static const struct builtin B1_vec_vaddsbs = { { &T_vec_b8, &T_vec_s8, NULL, }, "xx", &T_vec_s8, 2, FALSE, FALSE, 0, "vec_vaddsbs:1", "*vaddsbs", CODE_FOR_xfxx_simple, B_UID(31) };
+static const struct builtin B1_vec_vaddubs = { { &T_vec_b8, &T_vec_u8, NULL, }, "xx", &T_vec_u8, 2, FALSE, FALSE, 0, "vec_vaddubs:1", "*vaddubs", CODE_FOR_xfxx_simple, B_UID(32) };
+static const struct builtin B2_vec_vaddshs = { { &T_vec_s16, &T_vec_b16, NULL, }, "xx", &T_vec_s16, 2, FALSE, FALSE, 0, "vec_vaddshs:2", "*vaddshs", CODE_FOR_xfxx_simple, B_UID(33) };
+static const struct builtin B3_vec_vaddshs = { { &T_vec_s16, &T_vec_s16, NULL, }, "xx", &T_vec_s16, 2, FALSE, FALSE, 0, "vec_vaddshs:3", "*vaddshs", CODE_FOR_xfxx_simple, B_UID(34) };
+static const struct builtin B2_vec_vaddsws = { { &T_vec_s32, &T_vec_b32, NULL, }, "xx", &T_vec_s32, 2, FALSE, FALSE, 0, "vec_vaddsws:2", "*vaddsws", CODE_FOR_xfxx_simple, B_UID(35) };
+static const struct builtin B3_vec_vaddsws = { { &T_vec_s32, &T_vec_s32, NULL, }, "xx", &T_vec_s32, 2, FALSE, FALSE, 0, "vec_vaddsws:3", "*vaddsws", CODE_FOR_xfxx_simple, B_UID(36) };
+static const struct builtin B2_vec_vaddsbs = { { &T_vec_s8, &T_vec_b8, NULL, }, "xx", &T_vec_s8, 2, FALSE, FALSE, 0, "vec_vaddsbs:2", "*vaddsbs", CODE_FOR_xfxx_simple, B_UID(37) };
+static const struct builtin B3_vec_vaddsbs = { { &T_vec_s8, &T_vec_s8, NULL, }, "xx", &T_vec_s8, 2, FALSE, FALSE, 0, "vec_vaddsbs:3", "*vaddsbs", CODE_FOR_xfxx_simple, B_UID(38) };
+static const struct builtin B2_vec_vadduhs = { { &T_vec_u16, &T_vec_b16, NULL, }, "xx", &T_vec_u16, 2, FALSE, FALSE, 0, "vec_vadduhs:2", "*vadduhs", CODE_FOR_xfxx_simple, B_UID(39) };
+static const struct builtin B3_vec_vadduhs = { { &T_vec_u16, &T_vec_u16, NULL, }, "xx", &T_vec_u16, 2, FALSE, FALSE, 0, "vec_vadduhs:3", "*vadduhs", CODE_FOR_xfxx_simple, B_UID(40) };
+static const struct builtin B2_vec_vadduws = { { &T_vec_u32, &T_vec_b32, NULL, }, "xx", &T_vec_u32, 2, FALSE, FALSE, 0, "vec_vadduws:2", "*vadduws", CODE_FOR_xfxx_simple, B_UID(41) };
+static const struct builtin B3_vec_vadduws = { { &T_vec_u32, &T_vec_u32, NULL, }, "xx", &T_vec_u32, 2, FALSE, FALSE, 0, "vec_vadduws:3", "*vadduws", CODE_FOR_xfxx_simple, B_UID(42) };
+static const struct builtin B2_vec_vaddubs = { { &T_vec_u8, &T_vec_b8, NULL, }, "xx", &T_vec_u8, 2, FALSE, FALSE, 0, "vec_vaddubs:2", "*vaddubs", CODE_FOR_xfxx_simple, B_UID(43) };
+static const struct builtin B3_vec_vaddubs = { { &T_vec_u8, &T_vec_u8, NULL, }, "xx", &T_vec_u8, 2, FALSE, FALSE, 0, "vec_vaddubs:3", "*vaddubs", CODE_FOR_xfxx_simple, B_UID(44) };
+static const struct builtin B1_vec_all_eq = { { &T_vec_b16, &T_vec_b16, NULL, }, "xx", &T_cc24t, 2, FALSE, FALSE, 0, "vec_all_eq:1", "*vcmpequh.", CODE_FOR_j_24_t_fxx_simple, B_UID(45) };
+static const struct builtin B2_vec_all_eq = { { &T_vec_b16, &T_vec_s16, NULL, }, "xx", &T_cc24t, 2, FALSE, FALSE, 0, "vec_all_eq:2", "*vcmpequh.", CODE_FOR_j_24_t_fxx_simple, B_UID(46) };
+static const struct builtin B3_vec_all_eq = { { &T_vec_b16, &T_vec_u16, NULL, }, "xx", &T_cc24t, 2, FALSE, FALSE, 0, "vec_all_eq:3", "*vcmpequh.", CODE_FOR_j_24_t_fxx_simple, B_UID(47) };
+static const struct builtin B4_vec_all_eq = { { &T_vec_b32, &T_vec_b32, NULL, }, "xx", &T_cc24t, 2, FALSE, FALSE, 0, "vec_all_eq:4", "*vcmpequw.", CODE_FOR_j_24_t_fxx_simple, B_UID(48) };
+static const struct builtin B5_vec_all_eq = { { &T_vec_b32, &T_vec_s32, NULL, }, "xx", &T_cc24t, 2, FALSE, FALSE, 0, "vec_all_eq:5", "*vcmpequw.", CODE_FOR_j_24_t_fxx_simple, B_UID(49) };
+static const struct builtin B6_vec_all_eq = { { &T_vec_b32, &T_vec_u32, NULL, }, "xx", &T_cc24t, 2, FALSE, FALSE, 0, "vec_all_eq:6", "*vcmpequw.", CODE_FOR_j_24_t_fxx_simple, B_UID(50) };
+static const struct builtin B7_vec_all_eq = { { &T_vec_b8, &T_vec_b8, NULL, }, "xx", &T_cc24t, 2, FALSE, FALSE, 0, "vec_all_eq:7", "*vcmpequb.", CODE_FOR_j_24_t_fxx_simple, B_UID(51) };
+static const struct builtin B8_vec_all_eq = { { &T_vec_b8, &T_vec_s8, NULL, }, "xx", &T_cc24t, 2, FALSE, FALSE, 0, "vec_all_eq:8", "*vcmpequb.", CODE_FOR_j_24_t_fxx_simple, B_UID(52) };
+static const struct builtin B9_vec_all_eq = { { &T_vec_b8, &T_vec_u8, NULL, }, "xx", &T_cc24t, 2, FALSE, FALSE, 0, "vec_all_eq:9", "*vcmpequb.", CODE_FOR_j_24_t_fxx_simple, B_UID(53) };
+static const struct builtin B10_vec_all_eq = { { &T_vec_f32, &T_vec_f32, NULL, }, "xx", &T_cc24t, 2, FALSE, FALSE, 0, "vec_all_eq:10", "*vcmpeqfp.", CODE_FOR_j_24_t_fxx_simple, B_UID(54) };
+static const struct builtin B11_vec_all_eq = { { &T_vec_p16, &T_vec_p16, NULL, }, "xx", &T_cc24t, 2, FALSE, FALSE, 0, "vec_all_eq:11", "*vcmpequh.", CODE_FOR_j_24_t_fxx_simple, B_UID(55) };
+static const struct builtin B12_vec_all_eq = { { &T_vec_s16, &T_vec_b16, NULL, }, "xx", &T_cc24t, 2, FALSE, FALSE, 0, "vec_all_eq:12", "*vcmpequh.", CODE_FOR_j_24_t_fxx_simple, B_UID(56) };
+static const struct builtin B13_vec_all_eq = { { &T_vec_s16, &T_vec_s16, NULL, }, "xx", &T_cc24t, 2, FALSE, FALSE, 0, "vec_all_eq:13", "*vcmpequh.", CODE_FOR_j_24_t_fxx_simple, B_UID(57) };
+static const struct builtin B14_vec_all_eq = { { &T_vec_s32, &T_vec_b32, NULL, }, "xx", &T_cc24t, 2, FALSE, FALSE, 0, "vec_all_eq:14", "*vcmpequw.", CODE_FOR_j_24_t_fxx_simple, B_UID(58) };
+static const struct builtin B15_vec_all_eq = { { &T_vec_s32, &T_vec_s32, NULL, }, "xx", &T_cc24t, 2, FALSE, FALSE, 0, "vec_all_eq:15", "*vcmpequw.", CODE_FOR_j_24_t_fxx_simple, B_UID(59) };
+static const struct builtin B16_vec_all_eq = { { &T_vec_s8, &T_vec_b8, NULL, }, "xx", &T_cc24t, 2, FALSE, FALSE, 0, "vec_all_eq:16", "*vcmpequb.", CODE_FOR_j_24_t_fxx_simple, B_UID(60) };
+static const struct builtin B17_vec_all_eq = { { &T_vec_s8, &T_vec_s8, NULL, }, "xx", &T_cc24t, 2, FALSE, FALSE, 0, "vec_all_eq:17", "*vcmpequb.", CODE_FOR_j_24_t_fxx_simple, B_UID(61) };
+static const struct builtin B18_vec_all_eq = { { &T_vec_u16, &T_vec_b16, NULL, }, "xx", &T_cc24t, 2, FALSE, FALSE, 0, "vec_all_eq:18", "*vcmpequh.", CODE_FOR_j_24_t_fxx_simple, B_UID(62) };
+static const struct builtin B19_vec_all_eq = { { &T_vec_u16, &T_vec_u16, NULL, }, "xx", &T_cc24t, 2, FALSE, FALSE, 0, "vec_all_eq:19", "*vcmpequh.", CODE_FOR_j_24_t_fxx_simple, B_UID(63) };
+static const struct builtin B20_vec_all_eq = { { &T_vec_u32, &T_vec_b32, NULL, }, "xx", &T_cc24t, 2, FALSE, FALSE, 0, "vec_all_eq:20", "*vcmpequw.", CODE_FOR_j_24_t_fxx_simple, B_UID(64) };
+static const struct builtin B21_vec_all_eq = { { &T_vec_u32, &T_vec_u32, NULL, }, "xx", &T_cc24t, 2, FALSE, FALSE, 0, "vec_all_eq:21", "*vcmpequw.", CODE_FOR_j_24_t_fxx_simple, B_UID(65) };
+static const struct builtin B22_vec_all_eq = { { &T_vec_u8, &T_vec_b8, NULL, }, "xx", &T_cc24t, 2, FALSE, FALSE, 0, "vec_all_eq:22", "*vcmpequb.", CODE_FOR_j_24_t_fxx_simple, B_UID(66) };
+static const struct builtin B23_vec_all_eq = { { &T_vec_u8, &T_vec_u8, NULL, }, "xx", &T_cc24t, 2, FALSE, FALSE, 0, "vec_all_eq:23", "*vcmpequb.", CODE_FOR_j_24_t_fxx_simple, B_UID(67) };
+static const struct builtin B1_vec_all_ge = { { &T_vec_b16, &T_vec_s16, NULL, }, "xx", &T_cc26tr, 2, FALSE, FALSE, 0, "vec_all_ge:1", "*vcmpgtsh.", CODE_FOR_j_26_t_frxx_simple, B_UID(68) };
+static const struct builtin B2_vec_all_ge = { { &T_vec_b16, &T_vec_u16, NULL, }, "xx", &T_cc26tr, 2, FALSE, FALSE, 0, "vec_all_ge:2", "*vcmpgtuh.", CODE_FOR_j_26_t_frxx_simple, B_UID(69) };
+static const struct builtin B3_vec_all_ge = { { &T_vec_b32, &T_vec_s32, NULL, }, "xx", &T_cc26tr, 2, FALSE, FALSE, 0, "vec_all_ge:3", "*vcmpgtsw.", CODE_FOR_j_26_t_frxx_simple, B_UID(70) };
+static const struct builtin B4_vec_all_ge = { { &T_vec_b32, &T_vec_u32, NULL, }, "xx", &T_cc26tr, 2, FALSE, FALSE, 0, "vec_all_ge:4", "*vcmpgtuw.", CODE_FOR_j_26_t_frxx_simple, B_UID(71) };
+static const struct builtin B5_vec_all_ge = { { &T_vec_b8, &T_vec_s8, NULL, }, "xx", &T_cc26tr, 2, FALSE, FALSE, 0, "vec_all_ge:5", "*vcmpgtsb.", CODE_FOR_j_26_t_frxx_simple, B_UID(72) };
+static const struct builtin B6_vec_all_ge = { { &T_vec_b8, &T_vec_u8, NULL, }, "xx", &T_cc26tr, 2, FALSE, FALSE, 0, "vec_all_ge:6", "*vcmpgtub.", CODE_FOR_j_26_t_frxx_simple, B_UID(73) };
+static const struct builtin B7_vec_all_ge = { { &T_vec_f32, &T_vec_f32, NULL, }, "xx", &T_cc24t, 2, FALSE, FALSE, 0, "vec_all_ge:7", "*vcmpgefp.", CODE_FOR_j_24_t_fxx_simple, B_UID(74) };
+static const struct builtin B8_vec_all_ge = { { &T_vec_s16, &T_vec_b16, NULL, }, "xx", &T_cc26tr, 2, FALSE, FALSE, 0, "vec_all_ge:8", "*vcmpgtsh.", CODE_FOR_j_26_t_frxx_simple, B_UID(75) };
+static const struct builtin B9_vec_all_ge = { { &T_vec_s16, &T_vec_s16, NULL, }, "xx", &T_cc26tr, 2, FALSE, FALSE, 0, "vec_all_ge:9", "*vcmpgtsh.", CODE_FOR_j_26_t_frxx_simple, B_UID(76) };
+static const struct builtin B10_vec_all_ge = { { &T_vec_s32, &T_vec_b32, NULL, }, "xx", &T_cc26tr, 2, FALSE, FALSE, 0, "vec_all_ge:10", "*vcmpgtsw.", CODE_FOR_j_26_t_frxx_simple, B_UID(77) };
+static const struct builtin B11_vec_all_ge = { { &T_vec_s32, &T_vec_s32, NULL, }, "xx", &T_cc26tr, 2, FALSE, FALSE, 0, "vec_all_ge:11", "*vcmpgtsw.", CODE_FOR_j_26_t_frxx_simple, B_UID(78) };
+static const struct builtin B12_vec_all_ge = { { &T_vec_s8, &T_vec_b8, NULL, }, "xx", &T_cc26tr, 2, FALSE, FALSE, 0, "vec_all_ge:12", "*vcmpgtsb.", CODE_FOR_j_26_t_frxx_simple, B_UID(79) };
+static const struct builtin B13_vec_all_ge = { { &T_vec_s8, &T_vec_s8, NULL, }, "xx", &T_cc26tr, 2, FALSE, FALSE, 0, "vec_all_ge:13", "*vcmpgtsb.", CODE_FOR_j_26_t_frxx_simple, B_UID(80) };
+static const struct builtin B14_vec_all_ge = { { &T_vec_u16, &T_vec_b16, NULL, }, "xx", &T_cc26tr, 2, FALSE, FALSE, 0, "vec_all_ge:14", "*vcmpgtuh.", CODE_FOR_j_26_t_frxx_simple, B_UID(81) };
+static const struct builtin B15_vec_all_ge = { { &T_vec_u16, &T_vec_u16, NULL, }, "xx", &T_cc26tr, 2, FALSE, FALSE, 0, "vec_all_ge:15", "*vcmpgtuh.", CODE_FOR_j_26_t_frxx_simple, B_UID(82) };
+static const struct builtin B16_vec_all_ge = { { &T_vec_u32, &T_vec_b32, NULL, }, "xx", &T_cc26tr, 2, FALSE, FALSE, 0, "vec_all_ge:16", "*vcmpgtuw.", CODE_FOR_j_26_t_frxx_simple, B_UID(83) };
+static const struct builtin B17_vec_all_ge = { { &T_vec_u32, &T_vec_u32, NULL, }, "xx", &T_cc26tr, 2, FALSE, FALSE, 0, "vec_all_ge:17", "*vcmpgtuw.", CODE_FOR_j_26_t_frxx_simple, B_UID(84) };
+static const struct builtin B18_vec_all_ge = { { &T_vec_u8, &T_vec_b8, NULL, }, "xx", &T_cc26tr, 2, FALSE, FALSE, 0, "vec_all_ge:18", "*vcmpgtub.", CODE_FOR_j_26_t_frxx_simple, B_UID(85) };
+static const struct builtin B19_vec_all_ge = { { &T_vec_u8, &T_vec_u8, NULL, }, "xx", &T_cc26tr, 2, FALSE, FALSE, 0, "vec_all_ge:19", "*vcmpgtub.", CODE_FOR_j_26_t_frxx_simple, B_UID(86) };
+static const struct builtin B1_vec_all_gt = { { &T_vec_b16, &T_vec_s16, NULL, }, "xx", &T_cc24t, 2, FALSE, FALSE, 0, "vec_all_gt:1", "*vcmpgtsh.", CODE_FOR_j_24_t_fxx_simple, B_UID(87) };
+static const struct builtin B2_vec_all_gt = { { &T_vec_b16, &T_vec_u16, NULL, }, "xx", &T_cc24t, 2, FALSE, FALSE, 0, "vec_all_gt:2", "*vcmpgtuh.", CODE_FOR_j_24_t_fxx_simple, B_UID(88) };
+static const struct builtin B3_vec_all_gt = { { &T_vec_b32, &T_vec_s32, NULL, }, "xx", &T_cc24t, 2, FALSE, FALSE, 0, "vec_all_gt:3", "*vcmpgtsw.", CODE_FOR_j_24_t_fxx_simple, B_UID(89) };
+static const struct builtin B4_vec_all_gt = { { &T_vec_b32, &T_vec_u32, NULL, }, "xx", &T_cc24t, 2, FALSE, FALSE, 0, "vec_all_gt:4", "*vcmpgtuw.", CODE_FOR_j_24_t_fxx_simple, B_UID(90) };
+static const struct builtin B5_vec_all_gt = { { &T_vec_b8, &T_vec_s8, NULL, }, "xx", &T_cc24t, 2, FALSE, FALSE, 0, "vec_all_gt:5", "*vcmpgtsb.", CODE_FOR_j_24_t_fxx_simple, B_UID(91) };
+static const struct builtin B6_vec_all_gt = { { &T_vec_b8, &T_vec_u8, NULL, }, "xx", &T_cc24t, 2, FALSE, FALSE, 0, "vec_all_gt:6", "*vcmpgtub.", CODE_FOR_j_24_t_fxx_simple, B_UID(92) };
+static const struct builtin B7_vec_all_gt = { { &T_vec_f32, &T_vec_f32, NULL, }, "xx", &T_cc24t, 2, FALSE, FALSE, 0, "vec_all_gt:7", "*vcmpgtfp.", CODE_FOR_j_24_t_fxx_simple, B_UID(93) };
+static const struct builtin B8_vec_all_gt = { { &T_vec_s16, &T_vec_b16, NULL, }, "xx", &T_cc24t, 2, FALSE, FALSE, 0, "vec_all_gt:8", "*vcmpgtsh.", CODE_FOR_j_24_t_fxx_simple, B_UID(94) };
+static const struct builtin B9_vec_all_gt = { { &T_vec_s16, &T_vec_s16, NULL, }, "xx", &T_cc24t, 2, FALSE, FALSE, 0, "vec_all_gt:9", "*vcmpgtsh.", CODE_FOR_j_24_t_fxx_simple, B_UID(95) };
+static const struct builtin B10_vec_all_gt = { { &T_vec_s32, &T_vec_b32, NULL, }, "xx", &T_cc24t, 2, FALSE, FALSE, 0, "vec_all_gt:10", "*vcmpgtsw.", CODE_FOR_j_24_t_fxx_simple, B_UID(96) };
+static const struct builtin B11_vec_all_gt = { { &T_vec_s32, &T_vec_s32, NULL, }, "xx", &T_cc24t, 2, FALSE, FALSE, 0, "vec_all_gt:11", "*vcmpgtsw.", CODE_FOR_j_24_t_fxx_simple, B_UID(97) };
+static const struct builtin B12_vec_all_gt = { { &T_vec_s8, &T_vec_b8, NULL, }, "xx", &T_cc24t, 2, FALSE, FALSE, 0, "vec_all_gt:12", "*vcmpgtsb.", CODE_FOR_j_24_t_fxx_simple, B_UID(98) };
+static const struct builtin B13_vec_all_gt = { { &T_vec_s8, &T_vec_s8, NULL, }, "xx", &T_cc24t, 2, FALSE, FALSE, 0, "vec_all_gt:13", "*vcmpgtsb.", CODE_FOR_j_24_t_fxx_simple, B_UID(99) };
+static const struct builtin B14_vec_all_gt = { { &T_vec_u16, &T_vec_b16, NULL, }, "xx", &T_cc24t, 2, FALSE, FALSE, 0, "vec_all_gt:14", "*vcmpgtuh.", CODE_FOR_j_24_t_fxx_simple, B_UID(100) };
+static const struct builtin B15_vec_all_gt = { { &T_vec_u16, &T_vec_u16, NULL, }, "xx", &T_cc24t, 2, FALSE, FALSE, 0, "vec_all_gt:15", "*vcmpgtuh.", CODE_FOR_j_24_t_fxx_simple, B_UID(101) };
+static const struct builtin B16_vec_all_gt = { { &T_vec_u32, &T_vec_b32, NULL, }, "xx", &T_cc24t, 2, FALSE, FALSE, 0, "vec_all_gt:16", "*vcmpgtuw.", CODE_FOR_j_24_t_fxx_simple, B_UID(102) };
+static const struct builtin B17_vec_all_gt = { { &T_vec_u32, &T_vec_u32, NULL, }, "xx", &T_cc24t, 2, FALSE, FALSE, 0, "vec_all_gt:17", "*vcmpgtuw.", CODE_FOR_j_24_t_fxx_simple, B_UID(103) };
+static const struct builtin B18_vec_all_gt = { { &T_vec_u8, &T_vec_b8, NULL, }, "xx", &T_cc24t, 2, FALSE, FALSE, 0, "vec_all_gt:18", "*vcmpgtub.", CODE_FOR_j_24_t_fxx_simple, B_UID(104) };
+static const struct builtin B19_vec_all_gt = { { &T_vec_u8, &T_vec_u8, NULL, }, "xx", &T_cc24t, 2, FALSE, FALSE, 0, "vec_all_gt:19", "*vcmpgtub.", CODE_FOR_j_24_t_fxx_simple, B_UID(105) };
+static const struct builtin B_vec_all_in = { { &T_vec_f32, &T_vec_f32, NULL, }, "xx", &T_cc26t, 2, FALSE, FALSE, 0, "vec_all_in", "*vcmpbfp.", CODE_FOR_j_26_t_fxx_simple, B_UID(106) };
+static const struct builtin B1_vec_all_le = { { &T_vec_b16, &T_vec_s16, NULL, }, "xx", &T_cc26t, 2, FALSE, FALSE, 0, "vec_all_le:1", "*vcmpgtsh.", CODE_FOR_j_26_t_fxx_simple, B_UID(107) };
+static const struct builtin B2_vec_all_le = { { &T_vec_b16, &T_vec_u16, NULL, }, "xx", &T_cc26t, 2, FALSE, FALSE, 0, "vec_all_le:2", "*vcmpgtuh.", CODE_FOR_j_26_t_fxx_simple, B_UID(108) };
+static const struct builtin B3_vec_all_le = { { &T_vec_b32, &T_vec_s32, NULL, }, "xx", &T_cc26t, 2, FALSE, FALSE, 0, "vec_all_le:3", "*vcmpgtsw.", CODE_FOR_j_26_t_fxx_simple, B_UID(109) };
+static const struct builtin B4_vec_all_le = { { &T_vec_b32, &T_vec_u32, NULL, }, "xx", &T_cc26t, 2, FALSE, FALSE, 0, "vec_all_le:4", "*vcmpgtuw.", CODE_FOR_j_26_t_fxx_simple, B_UID(110) };
+static const struct builtin B5_vec_all_le = { { &T_vec_b8, &T_vec_s8, NULL, }, "xx", &T_cc26t, 2, FALSE, FALSE, 0, "vec_all_le:5", "*vcmpgtsb.", CODE_FOR_j_26_t_fxx_simple, B_UID(111) };
+static const struct builtin B6_vec_all_le = { { &T_vec_b8, &T_vec_u8, NULL, }, "xx", &T_cc26t, 2, FALSE, FALSE, 0, "vec_all_le:6", "*vcmpgtub.", CODE_FOR_j_26_t_fxx_simple, B_UID(112) };
+static const struct builtin B7_vec_all_le = { { &T_vec_f32, &T_vec_f32, NULL, }, "xx", &T_cc24tr, 2, FALSE, FALSE, 0, "vec_all_le:7", "*vcmpgefp.", CODE_FOR_j_24_t_frxx_simple, B_UID(113) };
+static const struct builtin B8_vec_all_le = { { &T_vec_s16, &T_vec_b16, NULL, }, "xx", &T_cc26t, 2, FALSE, FALSE, 0, "vec_all_le:8", "*vcmpgtsh.", CODE_FOR_j_26_t_fxx_simple, B_UID(114) };
+static const struct builtin B9_vec_all_le = { { &T_vec_s16, &T_vec_s16, NULL, }, "xx", &T_cc26t, 2, FALSE, FALSE, 0, "vec_all_le:9", "*vcmpgtsh.", CODE_FOR_j_26_t_fxx_simple, B_UID(115) };
+static const struct builtin B10_vec_all_le = { { &T_vec_s32, &T_vec_b32, NULL, }, "xx", &T_cc26t, 2, FALSE, FALSE, 0, "vec_all_le:10", "*vcmpgtsw.", CODE_FOR_j_26_t_fxx_simple, B_UID(116) };
+static const struct builtin B11_vec_all_le = { { &T_vec_s32, &T_vec_s32, NULL, }, "xx", &T_cc26t, 2, FALSE, FALSE, 0, "vec_all_le:11", "*vcmpgtsw.", CODE_FOR_j_26_t_fxx_simple, B_UID(117) };
+static const struct builtin B12_vec_all_le = { { &T_vec_s8, &T_vec_b8, NULL, }, "xx", &T_cc26t, 2, FALSE, FALSE, 0, "vec_all_le:12", "*vcmpgtsb.", CODE_FOR_j_26_t_fxx_simple, B_UID(118) };
+static const struct builtin B13_vec_all_le = { { &T_vec_s8, &T_vec_s8, NULL, }, "xx", &T_cc26t, 2, FALSE, FALSE, 0, "vec_all_le:13", "*vcmpgtsb.", CODE_FOR_j_26_t_fxx_simple, B_UID(119) };
+static const struct builtin B14_vec_all_le = { { &T_vec_u16, &T_vec_b16, NULL, }, "xx", &T_cc26t, 2, FALSE, FALSE, 0, "vec_all_le:14", "*vcmpgtuh.", CODE_FOR_j_26_t_fxx_simple, B_UID(120) };
+static const struct builtin B15_vec_all_le = { { &T_vec_u16, &T_vec_u16, NULL, }, "xx", &T_cc26t, 2, FALSE, FALSE, 0, "vec_all_le:15", "*vcmpgtuh.", CODE_FOR_j_26_t_fxx_simple, B_UID(121) };
+static const struct builtin B16_vec_all_le = { { &T_vec_u32, &T_vec_b32, NULL, }, "xx", &T_cc26t, 2, FALSE, FALSE, 0, "vec_all_le:16", "*vcmpgtuw.", CODE_FOR_j_26_t_fxx_simple, B_UID(122) };
+static const struct builtin B17_vec_all_le = { { &T_vec_u32, &T_vec_u32, NULL, }, "xx", &T_cc26t, 2, FALSE, FALSE, 0, "vec_all_le:17", "*vcmpgtuw.", CODE_FOR_j_26_t_fxx_simple, B_UID(123) };
+static const struct builtin B18_vec_all_le = { { &T_vec_u8, &T_vec_b8, NULL, }, "xx", &T_cc26t, 2, FALSE, FALSE, 0, "vec_all_le:18", "*vcmpgtub.", CODE_FOR_j_26_t_fxx_simple, B_UID(124) };
+static const struct builtin B19_vec_all_le = { { &T_vec_u8, &T_vec_u8, NULL, }, "xx", &T_cc26t, 2, FALSE, FALSE, 0, "vec_all_le:19", "*vcmpgtub.", CODE_FOR_j_26_t_fxx_simple, B_UID(125) };
+static const struct builtin B1_vec_all_lt = { { &T_vec_b16, &T_vec_s16, NULL, }, "xx", &T_cc24tr, 2, FALSE, FALSE, 0, "vec_all_lt:1", "*vcmpgtsh.", CODE_FOR_j_24_t_frxx_simple, B_UID(126) };
+static const struct builtin B2_vec_all_lt = { { &T_vec_b16, &T_vec_u16, NULL, }, "xx", &T_cc24tr, 2, FALSE, FALSE, 0, "vec_all_lt:2", "*vcmpgtuh.", CODE_FOR_j_24_t_frxx_simple, B_UID(127) };
+static const struct builtin B3_vec_all_lt = { { &T_vec_b32, &T_vec_s32, NULL, }, "xx", &T_cc24tr, 2, FALSE, FALSE, 0, "vec_all_lt:3", "*vcmpgtsw.", CODE_FOR_j_24_t_frxx_simple, B_UID(128) };
+static const struct builtin B4_vec_all_lt = { { &T_vec_b32, &T_vec_u32, NULL, }, "xx", &T_cc24tr, 2, FALSE, FALSE, 0, "vec_all_lt:4", "*vcmpgtuw.", CODE_FOR_j_24_t_frxx_simple, B_UID(129) };
+static const struct builtin B5_vec_all_lt = { { &T_vec_b8, &T_vec_s8, NULL, }, "xx", &T_cc24tr, 2, FALSE, FALSE, 0, "vec_all_lt:5", "*vcmpgtsb.", CODE_FOR_j_24_t_frxx_simple, B_UID(130) };
+static const struct builtin B6_vec_all_lt = { { &T_vec_b8, &T_vec_u8, NULL, }, "xx", &T_cc24tr, 2, FALSE, FALSE, 0, "vec_all_lt:6", "*vcmpgtub.", CODE_FOR_j_24_t_frxx_simple, B_UID(131) };
+static const struct builtin B7_vec_all_lt = { { &T_vec_f32, &T_vec_f32, NULL, }, "xx", &T_cc24tr, 2, FALSE, FALSE, 0, "vec_all_lt:7", "*vcmpgtfp.", CODE_FOR_j_24_t_frxx_simple, B_UID(132) };
+static const struct builtin B8_vec_all_lt = { { &T_vec_s16, &T_vec_b16, NULL, }, "xx", &T_cc24tr, 2, FALSE, FALSE, 0, "vec_all_lt:8", "*vcmpgtsh.", CODE_FOR_j_24_t_frxx_simple, B_UID(133) };
+static const struct builtin B9_vec_all_lt = { { &T_vec_s16, &T_vec_s16, NULL, }, "xx", &T_cc24tr, 2, FALSE, FALSE, 0, "vec_all_lt:9", "*vcmpgtsh.", CODE_FOR_j_24_t_frxx_simple, B_UID(134) };
+static const struct builtin B10_vec_all_lt = { { &T_vec_s32, &T_vec_b32, NULL, }, "xx", &T_cc24tr, 2, FALSE, FALSE, 0, "vec_all_lt:10", "*vcmpgtsw.", CODE_FOR_j_24_t_frxx_simple, B_UID(135) };
+static const struct builtin B11_vec_all_lt = { { &T_vec_s32, &T_vec_s32, NULL, }, "xx", &T_cc24tr, 2, FALSE, FALSE, 0, "vec_all_lt:11", "*vcmpgtsw.", CODE_FOR_j_24_t_frxx_simple, B_UID(136) };
+static const struct builtin B12_vec_all_lt = { { &T_vec_s8, &T_vec_b8, NULL, }, "xx", &T_cc24tr, 2, FALSE, FALSE, 0, "vec_all_lt:12", "*vcmpgtsb.", CODE_FOR_j_24_t_frxx_simple, B_UID(137) };
+static const struct builtin B13_vec_all_lt = { { &T_vec_s8, &T_vec_s8, NULL, }, "xx", &T_cc24tr, 2, FALSE, FALSE, 0, "vec_all_lt:13", "*vcmpgtsb.", CODE_FOR_j_24_t_frxx_simple, B_UID(138) };
+static const struct builtin B14_vec_all_lt = { { &T_vec_u16, &T_vec_b16, NULL, }, "xx", &T_cc24tr, 2, FALSE, FALSE, 0, "vec_all_lt:14", "*vcmpgtuh.", CODE_FOR_j_24_t_frxx_simple, B_UID(139) };
+static const struct builtin B15_vec_all_lt = { { &T_vec_u16, &T_vec_u16, NULL, }, "xx", &T_cc24tr, 2, FALSE, FALSE, 0, "vec_all_lt:15", "*vcmpgtuh.", CODE_FOR_j_24_t_frxx_simple, B_UID(140) };
+static const struct builtin B16_vec_all_lt = { { &T_vec_u32, &T_vec_b32, NULL, }, "xx", &T_cc24tr, 2, FALSE, FALSE, 0, "vec_all_lt:16", "*vcmpgtuw.", CODE_FOR_j_24_t_frxx_simple, B_UID(141) };
+static const struct builtin B17_vec_all_lt = { { &T_vec_u32, &T_vec_u32, NULL, }, "xx", &T_cc24tr, 2, FALSE, FALSE, 0, "vec_all_lt:17", "*vcmpgtuw.", CODE_FOR_j_24_t_frxx_simple, B_UID(142) };
+static const struct builtin B18_vec_all_lt = { { &T_vec_u8, &T_vec_b8, NULL, }, "xx", &T_cc24tr, 2, FALSE, FALSE, 0, "vec_all_lt:18", "*vcmpgtub.", CODE_FOR_j_24_t_frxx_simple, B_UID(143) };
+static const struct builtin B19_vec_all_lt = { { &T_vec_u8, &T_vec_u8, NULL, }, "xx", &T_cc24tr, 2, FALSE, FALSE, 0, "vec_all_lt:19", "*vcmpgtub.", CODE_FOR_j_24_t_frxx_simple, B_UID(144) };
+static const struct builtin B_vec_all_nan = { { &T_vec_f32, NULL, NULL, }, "x", &T_cc26td, 1, FALSE, FALSE, 0, "vec_all_nan", "*vcmpeqfp.", CODE_FOR_j_26_t_fx_simple, B_UID(145) };
+static const struct builtin B1_vec_all_ne = { { &T_vec_b16, &T_vec_b16, NULL, }, "xx", &T_cc26t, 2, FALSE, FALSE, 0, "vec_all_ne:1", "*vcmpequh.", CODE_FOR_j_26_t_fxx_simple, B_UID(146) };
+static const struct builtin B2_vec_all_ne = { { &T_vec_b16, &T_vec_s16, NULL, }, "xx", &T_cc26t, 2, FALSE, FALSE, 0, "vec_all_ne:2", "*vcmpequh.", CODE_FOR_j_26_t_fxx_simple, B_UID(147) };
+static const struct builtin B3_vec_all_ne = { { &T_vec_b16, &T_vec_u16, NULL, }, "xx", &T_cc26t, 2, FALSE, FALSE, 0, "vec_all_ne:3", "*vcmpequh.", CODE_FOR_j_26_t_fxx_simple, B_UID(148) };
+static const struct builtin B4_vec_all_ne = { { &T_vec_b32, &T_vec_b32, NULL, }, "xx", &T_cc26t, 2, FALSE, FALSE, 0, "vec_all_ne:4", "*vcmpequw.", CODE_FOR_j_26_t_fxx_simple, B_UID(149) };
+static const struct builtin B5_vec_all_ne = { { &T_vec_b32, &T_vec_s32, NULL, }, "xx", &T_cc26t, 2, FALSE, FALSE, 0, "vec_all_ne:5", "*vcmpequw.", CODE_FOR_j_26_t_fxx_simple, B_UID(150) };
+static const struct builtin B6_vec_all_ne = { { &T_vec_b32, &T_vec_u32, NULL, }, "xx", &T_cc26t, 2, FALSE, FALSE, 0, "vec_all_ne:6", "*vcmpequw.", CODE_FOR_j_26_t_fxx_simple, B_UID(151) };
+static const struct builtin B7_vec_all_ne = { { &T_vec_b8, &T_vec_b8, NULL, }, "xx", &T_cc26t, 2, FALSE, FALSE, 0, "vec_all_ne:7", "*vcmpequb.", CODE_FOR_j_26_t_fxx_simple, B_UID(152) };
+static const struct builtin B8_vec_all_ne = { { &T_vec_b8, &T_vec_s8, NULL, }, "xx", &T_cc26t, 2, FALSE, FALSE, 0, "vec_all_ne:8", "*vcmpequb.", CODE_FOR_j_26_t_fxx_simple, B_UID(153) };
+static const struct builtin B9_vec_all_ne = { { &T_vec_b8, &T_vec_u8, NULL, }, "xx", &T_cc26t, 2, FALSE, FALSE, 0, "vec_all_ne:9", "*vcmpequb.", CODE_FOR_j_26_t_fxx_simple, B_UID(154) };
+static const struct builtin B10_vec_all_ne = { { &T_vec_f32, &T_vec_f32, NULL, }, "xx", &T_cc26t, 2, FALSE, FALSE, 0, "vec_all_ne:10", "*vcmpeqfp.", CODE_FOR_j_26_t_fxx_simple, B_UID(155) };
+static const struct builtin B11_vec_all_ne = { { &T_vec_p16, &T_vec_p16, NULL, }, "xx", &T_cc26t, 2, FALSE, FALSE, 0, "vec_all_ne:11", "*vcmpequh.", CODE_FOR_j_26_t_fxx_simple, B_UID(156) };
+static const struct builtin B12_vec_all_ne = { { &T_vec_s16, &T_vec_b16, NULL, }, "xx", &T_cc26t, 2, FALSE, FALSE, 0, "vec_all_ne:12", "*vcmpequh.", CODE_FOR_j_26_t_fxx_simple, B_UID(157) };
+static const struct builtin B13_vec_all_ne = { { &T_vec_s16, &T_vec_s16, NULL, }, "xx", &T_cc26t, 2, FALSE, FALSE, 0, "vec_all_ne:13", "*vcmpequh.", CODE_FOR_j_26_t_fxx_simple, B_UID(158) };
+static const struct builtin B14_vec_all_ne = { { &T_vec_s32, &T_vec_b32, NULL, }, "xx", &T_cc26t, 2, FALSE, FALSE, 0, "vec_all_ne:14", "*vcmpequw.", CODE_FOR_j_26_t_fxx_simple, B_UID(159) };
+static const struct builtin B15_vec_all_ne = { { &T_vec_s32, &T_vec_s32, NULL, }, "xx", &T_cc26t, 2, FALSE, FALSE, 0, "vec_all_ne:15", "*vcmpequw.", CODE_FOR_j_26_t_fxx_simple, B_UID(160) };
+static const struct builtin B16_vec_all_ne = { { &T_vec_s8, &T_vec_b8, NULL, }, "xx", &T_cc26t, 2, FALSE, FALSE, 0, "vec_all_ne:16", "*vcmpequb.", CODE_FOR_j_26_t_fxx_simple, B_UID(161) };
+static const struct builtin B17_vec_all_ne = { { &T_vec_s8, &T_vec_s8, NULL, }, "xx", &T_cc26t, 2, FALSE, FALSE, 0, "vec_all_ne:17", "*vcmpequb.", CODE_FOR_j_26_t_fxx_simple, B_UID(162) };
+static const struct builtin B18_vec_all_ne = { { &T_vec_u16, &T_vec_b16, NULL, }, "xx", &T_cc26t, 2, FALSE, FALSE, 0, "vec_all_ne:18", "*vcmpequh.", CODE_FOR_j_26_t_fxx_simple, B_UID(163) };
+static const struct builtin B19_vec_all_ne = { { &T_vec_u16, &T_vec_u16, NULL, }, "xx", &T_cc26t, 2, FALSE, FALSE, 0, "vec_all_ne:19", "*vcmpequh.", CODE_FOR_j_26_t_fxx_simple, B_UID(164) };
+static const struct builtin B20_vec_all_ne = { { &T_vec_u32, &T_vec_b32, NULL, }, "xx", &T_cc26t, 2, FALSE, FALSE, 0, "vec_all_ne:20", "*vcmpequw.", CODE_FOR_j_26_t_fxx_simple, B_UID(165) };
+static const struct builtin B21_vec_all_ne = { { &T_vec_u32, &T_vec_u32, NULL, }, "xx", &T_cc26t, 2, FALSE, FALSE, 0, "vec_all_ne:21", "*vcmpequw.", CODE_FOR_j_26_t_fxx_simple, B_UID(166) };
+static const struct builtin B22_vec_all_ne = { { &T_vec_u8, &T_vec_b8, NULL, }, "xx", &T_cc26t, 2, FALSE, FALSE, 0, "vec_all_ne:22", "*vcmpequb.", CODE_FOR_j_26_t_fxx_simple, B_UID(167) };
+static const struct builtin B23_vec_all_ne = { { &T_vec_u8, &T_vec_u8, NULL, }, "xx", &T_cc26t, 2, FALSE, FALSE, 0, "vec_all_ne:23", "*vcmpequb.", CODE_FOR_j_26_t_fxx_simple, B_UID(168) };
+static const struct builtin B_vec_all_nge = { { &T_vec_f32, &T_vec_f32, NULL, }, "xx", &T_cc26t, 2, FALSE, FALSE, 0, "vec_all_nge", "*vcmpgefp.", CODE_FOR_j_26_t_fxx_simple, B_UID(169) };
+static const struct builtin B_vec_all_ngt = { { &T_vec_f32, &T_vec_f32, NULL, }, "xx", &T_cc26t, 2, FALSE, FALSE, 0, "vec_all_ngt", "*vcmpgtfp.", CODE_FOR_j_26_t_fxx_simple, B_UID(170) };
+static const struct builtin B_vec_all_nle = { { &T_vec_f32, &T_vec_f32, NULL, }, "xx", &T_cc26tr, 2, FALSE, FALSE, 0, "vec_all_nle", "*vcmpgefp.", CODE_FOR_j_26_t_frxx_simple, B_UID(171) };
+static const struct builtin B_vec_all_nlt = { { &T_vec_f32, &T_vec_f32, NULL, }, "xx", &T_cc26tr, 2, FALSE, FALSE, 0, "vec_all_nlt", "*vcmpgtfp.", CODE_FOR_j_26_t_frxx_simple, B_UID(172) };
+static const struct builtin B_vec_all_numeric = { { &T_vec_f32, NULL, NULL, }, "x", &T_cc24td, 1, FALSE, FALSE, 0, "vec_all_numeric", "*vcmpeqfp.", CODE_FOR_j_24_t_fx_simple, B_UID(173) };
+static const struct builtin B1_vec_vand = { { &T_vec_b16, &T_vec_b16, NULL, }, "xx", &T_vec_b16, 2, FALSE, FALSE, 2, "vec_vand:1", "*vand", CODE_FOR_xfxx_simple, B_UID(174) };
+static const struct builtin B2_vec_vand = { { &T_vec_b16, &T_vec_s16, NULL, }, "xx", &T_vec_s16, 2, FALSE, FALSE, 2, "vec_vand:2", "*vand", CODE_FOR_xfxx_simple, B_UID(175) };
+static const struct builtin B3_vec_vand = { { &T_vec_b16, &T_vec_u16, NULL, }, "xx", &T_vec_u16, 2, FALSE, FALSE, 2, "vec_vand:3", "*vand", CODE_FOR_xfxx_simple, B_UID(176) };
+static const struct builtin B4_vec_vand = { { &T_vec_b32, &T_vec_b32, NULL, }, "xx", &T_vec_b32, 2, FALSE, FALSE, 2, "vec_vand:4", "*vand", CODE_FOR_xfxx_simple, B_UID(177) };
+static const struct builtin B5_vec_vand = { { &T_vec_b32, &T_vec_f32, NULL, }, "xx", &T_vec_f32, 2, FALSE, FALSE, 2, "vec_vand:5", "*vand", CODE_FOR_xfxx_simple, B_UID(178) };
+static const struct builtin B6_vec_vand = { { &T_vec_b32, &T_vec_s32, NULL, }, "xx", &T_vec_s32, 2, FALSE, FALSE, 2, "vec_vand:6", "*vand", CODE_FOR_xfxx_simple, B_UID(179) };
+static const struct builtin B7_vec_vand = { { &T_vec_b32, &T_vec_u32, NULL, }, "xx", &T_vec_u32, 2, FALSE, FALSE, 2, "vec_vand:7", "*vand", CODE_FOR_xfxx_simple, B_UID(180) };
+static const struct builtin B8_vec_vand = { { &T_vec_b8, &T_vec_b8, NULL, }, "xx", &T_vec_b8, 2, FALSE, FALSE, 2, "vec_vand:8", "*vand", CODE_FOR_xfxx_simple, B_UID(181) };
+static const struct builtin B9_vec_vand = { { &T_vec_b8, &T_vec_s8, NULL, }, "xx", &T_vec_s8, 2, FALSE, FALSE, 2, "vec_vand:9", "*vand", CODE_FOR_xfxx_simple, B_UID(182) };
+static const struct builtin B10_vec_vand = { { &T_vec_b8, &T_vec_u8, NULL, }, "xx", &T_vec_u8, 2, FALSE, FALSE, 2, "vec_vand:10", "*vand", CODE_FOR_xfxx_simple, B_UID(183) };
+static const struct builtin B11_vec_vand = { { &T_vec_f32, &T_vec_b32, NULL, }, "xx", &T_vec_f32, 2, FALSE, FALSE, 2, "vec_vand:11", "*vand", CODE_FOR_xfxx_simple, B_UID(184) };
+static const struct builtin B12_vec_vand = { { &T_vec_f32, &T_vec_f32, NULL, }, "xx", &T_vec_f32, 2, FALSE, FALSE, 2, "vec_vand:12", "*vand", CODE_FOR_xfxx_simple, B_UID(185) };
+static const struct builtin B13_vec_vand = { { &T_vec_s16, &T_vec_b16, NULL, }, "xx", &T_vec_s16, 2, FALSE, FALSE, 2, "vec_vand:13", "*vand", CODE_FOR_xfxx_simple, B_UID(186) };
+static const struct builtin B14_vec_vand = { { &T_vec_s16, &T_vec_s16, NULL, }, "xx", &T_vec_s16, 2, FALSE, FALSE, 2, "vec_vand:14", "*vand", CODE_FOR_xfxx_simple, B_UID(187) };
+static const struct builtin B15_vec_vand = { { &T_vec_s32, &T_vec_b32, NULL, }, "xx", &T_vec_s32, 2, FALSE, FALSE, 2, "vec_vand:15", "*vand", CODE_FOR_xfxx_simple, B_UID(188) };
+static const struct builtin B16_vec_vand = { { &T_vec_s32, &T_vec_s32, NULL, }, "xx", &T_vec_s32, 2, FALSE, FALSE, 2, "vec_vand:16", "*vand", CODE_FOR_xfxx_simple, B_UID(189) };
+static const struct builtin B17_vec_vand = { { &T_vec_s8, &T_vec_b8, NULL, }, "xx", &T_vec_s8, 2, FALSE, FALSE, 2, "vec_vand:17", "*vand", CODE_FOR_xfxx_simple, B_UID(190) };
+static const struct builtin B18_vec_vand = { { &T_vec_s8, &T_vec_s8, NULL, }, "xx", &T_vec_s8, 2, FALSE, FALSE, 2, "vec_vand:18", "*vand", CODE_FOR_xfxx_simple, B_UID(191) };
+static const struct builtin B19_vec_vand = { { &T_vec_u16, &T_vec_b16, NULL, }, "xx", &T_vec_u16, 2, FALSE, FALSE, 2, "vec_vand:19", "*vand", CODE_FOR_xfxx_simple, B_UID(192) };
+static const struct builtin B20_vec_vand = { { &T_vec_u16, &T_vec_u16, NULL, }, "xx", &T_vec_u16, 2, FALSE, FALSE, 2, "vec_vand:20", "*vand", CODE_FOR_xfxx_simple, B_UID(193) };
+static const struct builtin B21_vec_vand = { { &T_vec_u32, &T_vec_b32, NULL, }, "xx", &T_vec_u32, 2, FALSE, FALSE, 2, "vec_vand:21", "*vand", CODE_FOR_xfxx_simple, B_UID(194) };
+static const struct builtin B22_vec_vand = { { &T_vec_u32, &T_vec_u32, NULL, }, "xx", &T_vec_u32, 2, FALSE, FALSE, 2, "vec_vand:22", "*vand", CODE_FOR_xfxx_simple, B_UID(195) };
+static const struct builtin B23_vec_vand = { { &T_vec_u8, &T_vec_b8, NULL, }, "xx", &T_vec_u8, 2, FALSE, FALSE, 2, "vec_vand:23", "*vand", CODE_FOR_xfxx_simple, B_UID(196) };
+static const struct builtin B24_vec_vand = { { &T_vec_u8, &T_vec_u8, NULL, }, "xx", &T_vec_u8, 2, FALSE, FALSE, 2, "vec_vand:24", "*vand", CODE_FOR_xfxx_simple, B_UID(197) };
+static const struct builtin B1_vec_vandc = { { &T_vec_b16, &T_vec_b16, NULL, }, "xx", &T_vec_b16, 2, FALSE, FALSE, 1, "vec_vandc:1", "*vandc", CODE_FOR_xfxx_simple, B_UID(198) };
+static const struct builtin B2_vec_vandc = { { &T_vec_b16, &T_vec_s16, NULL, }, "xx", &T_vec_s16, 2, FALSE, FALSE, 1, "vec_vandc:2", "*vandc", CODE_FOR_xfxx_simple, B_UID(199) };
+static const struct builtin B3_vec_vandc = { { &T_vec_b16, &T_vec_u16, NULL, }, "xx", &T_vec_u16, 2, FALSE, FALSE, 1, "vec_vandc:3", "*vandc", CODE_FOR_xfxx_simple, B_UID(200) };
+static const struct builtin B4_vec_vandc = { { &T_vec_b32, &T_vec_b32, NULL, }, "xx", &T_vec_b32, 2, FALSE, FALSE, 1, "vec_vandc:4", "*vandc", CODE_FOR_xfxx_simple, B_UID(201) };
+static const struct builtin B5_vec_vandc = { { &T_vec_b32, &T_vec_f32, NULL, }, "xx", &T_vec_f32, 2, FALSE, FALSE, 1, "vec_vandc:5", "*vandc", CODE_FOR_xfxx_simple, B_UID(202) };
+static const struct builtin B6_vec_vandc = { { &T_vec_b32, &T_vec_s32, NULL, }, "xx", &T_vec_s32, 2, FALSE, FALSE, 1, "vec_vandc:6", "*vandc", CODE_FOR_xfxx_simple, B_UID(203) };
+static const struct builtin B7_vec_vandc = { { &T_vec_b32, &T_vec_u32, NULL, }, "xx", &T_vec_u32, 2, FALSE, FALSE, 1, "vec_vandc:7", "*vandc", CODE_FOR_xfxx_simple, B_UID(204) };
+static const struct builtin B8_vec_vandc = { { &T_vec_b8, &T_vec_b8, NULL, }, "xx", &T_vec_b8, 2, FALSE, FALSE, 1, "vec_vandc:8", "*vandc", CODE_FOR_xfxx_simple, B_UID(205) };
+static const struct builtin B9_vec_vandc = { { &T_vec_b8, &T_vec_s8, NULL, }, "xx", &T_vec_s8, 2, FALSE, FALSE, 1, "vec_vandc:9", "*vandc", CODE_FOR_xfxx_simple, B_UID(206) };
+static const struct builtin B10_vec_vandc = { { &T_vec_b8, &T_vec_u8, NULL, }, "xx", &T_vec_u8, 2, FALSE, FALSE, 1, "vec_vandc:10", "*vandc", CODE_FOR_xfxx_simple, B_UID(207) };
+static const struct builtin B11_vec_vandc = { { &T_vec_f32, &T_vec_b32, NULL, }, "xx", &T_vec_f32, 2, FALSE, FALSE, 1, "vec_vandc:11", "*vandc", CODE_FOR_xfxx_simple, B_UID(208) };
+static const struct builtin B12_vec_vandc = { { &T_vec_f32, &T_vec_f32, NULL, }, "xx", &T_vec_f32, 2, FALSE, FALSE, 1, "vec_vandc:12", "*vandc", CODE_FOR_xfxx_simple, B_UID(209) };
+static const struct builtin B13_vec_vandc = { { &T_vec_s16, &T_vec_b16, NULL, }, "xx", &T_vec_s16, 2, FALSE, FALSE, 1, "vec_vandc:13", "*vandc", CODE_FOR_xfxx_simple, B_UID(210) };
+static const struct builtin B14_vec_vandc = { { &T_vec_s16, &T_vec_s16, NULL, }, "xx", &T_vec_s16, 2, FALSE, FALSE, 1, "vec_vandc:14", "*vandc", CODE_FOR_xfxx_simple, B_UID(211) };
+static const struct builtin B15_vec_vandc = { { &T_vec_s32, &T_vec_b32, NULL, }, "xx", &T_vec_s32, 2, FALSE, FALSE, 1, "vec_vandc:15", "*vandc", CODE_FOR_xfxx_simple, B_UID(212) };
+static const struct builtin B16_vec_vandc = { { &T_vec_s32, &T_vec_s32, NULL, }, "xx", &T_vec_s32, 2, FALSE, FALSE, 1, "vec_vandc:16", "*vandc", CODE_FOR_xfxx_simple, B_UID(213) };
+static const struct builtin B17_vec_vandc = { { &T_vec_s8, &T_vec_b8, NULL, }, "xx", &T_vec_s8, 2, FALSE, FALSE, 1, "vec_vandc:17", "*vandc", CODE_FOR_xfxx_simple, B_UID(214) };
+static const struct builtin B18_vec_vandc = { { &T_vec_s8, &T_vec_s8, NULL, }, "xx", &T_vec_s8, 2, FALSE, FALSE, 1, "vec_vandc:18", "*vandc", CODE_FOR_xfxx_simple, B_UID(215) };
+static const struct builtin B19_vec_vandc = { { &T_vec_u16, &T_vec_b16, NULL, }, "xx", &T_vec_u16, 2, FALSE, FALSE, 1, "vec_vandc:19", "*vandc", CODE_FOR_xfxx_simple, B_UID(216) };
+static const struct builtin B20_vec_vandc = { { &T_vec_u16, &T_vec_u16, NULL, }, "xx", &T_vec_u16, 2, FALSE, FALSE, 1, "vec_vandc:20", "*vandc", CODE_FOR_xfxx_simple, B_UID(217) };
+static const struct builtin B21_vec_vandc = { { &T_vec_u32, &T_vec_b32, NULL, }, "xx", &T_vec_u32, 2, FALSE, FALSE, 1, "vec_vandc:21", "*vandc", CODE_FOR_xfxx_simple, B_UID(218) };
+static const struct builtin B22_vec_vandc = { { &T_vec_u32, &T_vec_u32, NULL, }, "xx", &T_vec_u32, 2, FALSE, FALSE, 1, "vec_vandc:22", "*vandc", CODE_FOR_xfxx_simple, B_UID(219) };
+static const struct builtin B23_vec_vandc = { { &T_vec_u8, &T_vec_b8, NULL, }, "xx", &T_vec_u8, 2, FALSE, FALSE, 1, "vec_vandc:23", "*vandc", CODE_FOR_xfxx_simple, B_UID(220) };
+static const struct builtin B24_vec_vandc = { { &T_vec_u8, &T_vec_u8, NULL, }, "xx", &T_vec_u8, 2, FALSE, FALSE, 1, "vec_vandc:24", "*vandc", CODE_FOR_xfxx_simple, B_UID(221) };
+static const struct builtin B1_vec_any_eq = { { &T_vec_b16, &T_vec_b16, NULL, }, "xx", &T_cc26f, 2, FALSE, FALSE, 0, "vec_any_eq:1", "*vcmpequh.", CODE_FOR_j_26_f_fxx_simple, B_UID(222) };
+static const struct builtin B2_vec_any_eq = { { &T_vec_b16, &T_vec_s16, NULL, }, "xx", &T_cc26f, 2, FALSE, FALSE, 0, "vec_any_eq:2", "*vcmpequh.", CODE_FOR_j_26_f_fxx_simple, B_UID(223) };
+static const struct builtin B3_vec_any_eq = { { &T_vec_b16, &T_vec_u16, NULL, }, "xx", &T_cc26f, 2, FALSE, FALSE, 0, "vec_any_eq:3", "*vcmpequh.", CODE_FOR_j_26_f_fxx_simple, B_UID(224) };
+static const struct builtin B4_vec_any_eq = { { &T_vec_b32, &T_vec_b32, NULL, }, "xx", &T_cc26f, 2, FALSE, FALSE, 0, "vec_any_eq:4", "*vcmpequw.", CODE_FOR_j_26_f_fxx_simple, B_UID(225) };
+static const struct builtin B5_vec_any_eq = { { &T_vec_b32, &T_vec_s32, NULL, }, "xx", &T_cc26f, 2, FALSE, FALSE, 0, "vec_any_eq:5", "*vcmpequw.", CODE_FOR_j_26_f_fxx_simple, B_UID(226) };
+static const struct builtin B6_vec_any_eq = { { &T_vec_b32, &T_vec_u32, NULL, }, "xx", &T_cc26f, 2, FALSE, FALSE, 0, "vec_any_eq:6", "*vcmpequw.", CODE_FOR_j_26_f_fxx_simple, B_UID(227) };
+static const struct builtin B7_vec_any_eq = { { &T_vec_b8, &T_vec_b8, NULL, }, "xx", &T_cc26f, 2, FALSE, FALSE, 0, "vec_any_eq:7", "*vcmpequb.", CODE_FOR_j_26_f_fxx_simple, B_UID(228) };
+static const struct builtin B8_vec_any_eq = { { &T_vec_b8, &T_vec_s8, NULL, }, "xx", &T_cc26f, 2, FALSE, FALSE, 0, "vec_any_eq:8", "*vcmpequb.", CODE_FOR_j_26_f_fxx_simple, B_UID(229) };
+static const struct builtin B9_vec_any_eq = { { &T_vec_b8, &T_vec_u8, NULL, }, "xx", &T_cc26f, 2, FALSE, FALSE, 0, "vec_any_eq:9", "*vcmpequb.", CODE_FOR_j_26_f_fxx_simple, B_UID(230) };
+static const struct builtin B10_vec_any_eq = { { &T_vec_f32, &T_vec_f32, NULL, }, "xx", &T_cc26f, 2, FALSE, FALSE, 0, "vec_any_eq:10", "*vcmpeqfp.", CODE_FOR_j_26_f_fxx_simple, B_UID(231) };
+static const struct builtin B11_vec_any_eq = { { &T_vec_p16, &T_vec_p16, NULL, }, "xx", &T_cc26f, 2, FALSE, FALSE, 0, "vec_any_eq:11", "*vcmpequh.", CODE_FOR_j_26_f_fxx_simple, B_UID(232) };
+static const struct builtin B12_vec_any_eq = { { &T_vec_s16, &T_vec_b16, NULL, }, "xx", &T_cc26f, 2, FALSE, FALSE, 0, "vec_any_eq:12", "*vcmpequh.", CODE_FOR_j_26_f_fxx_simple, B_UID(233) };
+static const struct builtin B13_vec_any_eq = { { &T_vec_s16, &T_vec_s16, NULL, }, "xx", &T_cc26f, 2, FALSE, FALSE, 0, "vec_any_eq:13", "*vcmpequh.", CODE_FOR_j_26_f_fxx_simple, B_UID(234) };
+static const struct builtin B14_vec_any_eq = { { &T_vec_s32, &T_vec_b32, NULL, }, "xx", &T_cc26f, 2, FALSE, FALSE, 0, "vec_any_eq:14", "*vcmpequw.", CODE_FOR_j_26_f_fxx_simple, B_UID(235) };
+static const struct builtin B15_vec_any_eq = { { &T_vec_s32, &T_vec_s32, NULL, }, "xx", &T_cc26f, 2, FALSE, FALSE, 0, "vec_any_eq:15", "*vcmpequw.", CODE_FOR_j_26_f_fxx_simple, B_UID(236) };
+static const struct builtin B16_vec_any_eq = { { &T_vec_s8, &T_vec_b8, NULL, }, "xx", &T_cc26f, 2, FALSE, FALSE, 0, "vec_any_eq:16", "*vcmpequb.", CODE_FOR_j_26_f_fxx_simple, B_UID(237) };
+static const struct builtin B17_vec_any_eq = { { &T_vec_s8, &T_vec_s8, NULL, }, "xx", &T_cc26f, 2, FALSE, FALSE, 0, "vec_any_eq:17", "*vcmpequb.", CODE_FOR_j_26_f_fxx_simple, B_UID(238) };
+static const struct builtin B18_vec_any_eq = { { &T_vec_u16, &T_vec_b16, NULL, }, "xx", &T_cc26f, 2, FALSE, FALSE, 0, "vec_any_eq:18", "*vcmpequh.", CODE_FOR_j_26_f_fxx_simple, B_UID(239) };
+static const struct builtin B19_vec_any_eq = { { &T_vec_u16, &T_vec_u16, NULL, }, "xx", &T_cc26f, 2, FALSE, FALSE, 0, "vec_any_eq:19", "*vcmpequh.", CODE_FOR_j_26_f_fxx_simple, B_UID(240) };
+static const struct builtin B20_vec_any_eq = { { &T_vec_u32, &T_vec_b32, NULL, }, "xx", &T_cc26f, 2, FALSE, FALSE, 0, "vec_any_eq:20", "*vcmpequw.", CODE_FOR_j_26_f_fxx_simple, B_UID(241) };
+static const struct builtin B21_vec_any_eq = { { &T_vec_u32, &T_vec_u32, NULL, }, "xx", &T_cc26f, 2, FALSE, FALSE, 0, "vec_any_eq:21", "*vcmpequw.", CODE_FOR_j_26_f_fxx_simple, B_UID(242) };
+static const struct builtin B22_vec_any_eq = { { &T_vec_u8, &T_vec_b8, NULL, }, "xx", &T_cc26f, 2, FALSE, FALSE, 0, "vec_any_eq:22", "*vcmpequb.", CODE_FOR_j_26_f_fxx_simple, B_UID(243) };
+static const struct builtin B23_vec_any_eq = { { &T_vec_u8, &T_vec_u8, NULL, }, "xx", &T_cc26f, 2, FALSE, FALSE, 0, "vec_any_eq:23", "*vcmpequb.", CODE_FOR_j_26_f_fxx_simple, B_UID(244) };
+static const struct builtin B1_vec_any_ge = { { &T_vec_b16, &T_vec_s16, NULL, }, "xx", &T_cc24fr, 2, FALSE, FALSE, 0, "vec_any_ge:1", "*vcmpgtsh.", CODE_FOR_j_24_f_frxx_simple, B_UID(245) };
+static const struct builtin B2_vec_any_ge = { { &T_vec_b16, &T_vec_u16, NULL, }, "xx", &T_cc24fr, 2, FALSE, FALSE, 0, "vec_any_ge:2", "*vcmpgtuh.", CODE_FOR_j_24_f_frxx_simple, B_UID(246) };
+static const struct builtin B3_vec_any_ge = { { &T_vec_b32, &T_vec_s32, NULL, }, "xx", &T_cc24fr, 2, FALSE, FALSE, 0, "vec_any_ge:3", "*vcmpgtsw.", CODE_FOR_j_24_f_frxx_simple, B_UID(247) };
+static const struct builtin B4_vec_any_ge = { { &T_vec_b32, &T_vec_u32, NULL, }, "xx", &T_cc24fr, 2, FALSE, FALSE, 0, "vec_any_ge:4", "*vcmpgtuw.", CODE_FOR_j_24_f_frxx_simple, B_UID(248) };
+static const struct builtin B5_vec_any_ge = { { &T_vec_b8, &T_vec_s8, NULL, }, "xx", &T_cc24fr, 2, FALSE, FALSE, 0, "vec_any_ge:5", "*vcmpgtsb.", CODE_FOR_j_24_f_frxx_simple, B_UID(249) };
+static const struct builtin B6_vec_any_ge = { { &T_vec_b8, &T_vec_u8, NULL, }, "xx", &T_cc24fr, 2, FALSE, FALSE, 0, "vec_any_ge:6", "*vcmpgtub.", CODE_FOR_j_24_f_frxx_simple, B_UID(250) };
+static const struct builtin B7_vec_any_ge = { { &T_vec_f32, &T_vec_f32, NULL, }, "xx", &T_cc26f, 2, FALSE, FALSE, 0, "vec_any_ge:7", "*vcmpgefp.", CODE_FOR_j_26_f_fxx_simple, B_UID(251) };
+static const struct builtin B8_vec_any_ge = { { &T_vec_s16, &T_vec_b16, NULL, }, "xx", &T_cc24fr, 2, FALSE, FALSE, 0, "vec_any_ge:8", "*vcmpgtsh.", CODE_FOR_j_24_f_frxx_simple, B_UID(252) };
+static const struct builtin B9_vec_any_ge = { { &T_vec_s16, &T_vec_s16, NULL, }, "xx", &T_cc24fr, 2, FALSE, FALSE, 0, "vec_any_ge:9", "*vcmpgtsh.", CODE_FOR_j_24_f_frxx_simple, B_UID(253) };
+static const struct builtin B10_vec_any_ge = { { &T_vec_s32, &T_vec_b32, NULL, }, "xx", &T_cc24fr, 2, FALSE, FALSE, 0, "vec_any_ge:10", "*vcmpgtsw.", CODE_FOR_j_24_f_frxx_simple, B_UID(254) };
+static const struct builtin B11_vec_any_ge = { { &T_vec_s32, &T_vec_s32, NULL, }, "xx", &T_cc24fr, 2, FALSE, FALSE, 0, "vec_any_ge:11", "*vcmpgtsw.", CODE_FOR_j_24_f_frxx_simple, B_UID(255) };
+static const struct builtin B12_vec_any_ge = { { &T_vec_s8, &T_vec_b8, NULL, }, "xx", &T_cc24fr, 2, FALSE, FALSE, 0, "vec_any_ge:12", "*vcmpgtsb.", CODE_FOR_j_24_f_frxx_simple, B_UID(256) };
+static const struct builtin B13_vec_any_ge = { { &T_vec_s8, &T_vec_s8, NULL, }, "xx", &T_cc24fr, 2, FALSE, FALSE, 0, "vec_any_ge:13", "*vcmpgtsb.", CODE_FOR_j_24_f_frxx_simple, B_UID(257) };
+static const struct builtin B14_vec_any_ge = { { &T_vec_u16, &T_vec_b16, NULL, }, "xx", &T_cc24fr, 2, FALSE, FALSE, 0, "vec_any_ge:14", "*vcmpgtuh.", CODE_FOR_j_24_f_frxx_simple, B_UID(258) };
+static const struct builtin B15_vec_any_ge = { { &T_vec_u16, &T_vec_u16, NULL, }, "xx", &T_cc24fr, 2, FALSE, FALSE, 0, "vec_any_ge:15", "*vcmpgtuh.", CODE_FOR_j_24_f_frxx_simple, B_UID(259) };
+static const struct builtin B16_vec_any_ge = { { &T_vec_u32, &T_vec_b32, NULL, }, "xx", &T_cc24fr, 2, FALSE, FALSE, 0, "vec_any_ge:16", "*vcmpgtuw.", CODE_FOR_j_24_f_frxx_simple, B_UID(260) };
+static const struct builtin B17_vec_any_ge = { { &T_vec_u32, &T_vec_u32, NULL, }, "xx", &T_cc24fr, 2, FALSE, FALSE, 0, "vec_any_ge:17", "*vcmpgtuw.", CODE_FOR_j_24_f_frxx_simple, B_UID(261) };
+static const struct builtin B18_vec_any_ge = { { &T_vec_u8, &T_vec_b8, NULL, }, "xx", &T_cc24fr, 2, FALSE, FALSE, 0, "vec_any_ge:18", "*vcmpgtub.", CODE_FOR_j_24_f_frxx_simple, B_UID(262) };
+static const struct builtin B19_vec_any_ge = { { &T_vec_u8, &T_vec_u8, NULL, }, "xx", &T_cc24fr, 2, FALSE, FALSE, 0, "vec_any_ge:19", "*vcmpgtub.", CODE_FOR_j_24_f_frxx_simple, B_UID(263) };
+static const struct builtin B1_vec_any_gt = { { &T_vec_b16, &T_vec_s16, NULL, }, "xx", &T_cc26f, 2, FALSE, FALSE, 0, "vec_any_gt:1", "*vcmpgtsh.", CODE_FOR_j_26_f_fxx_simple, B_UID(264) };
+static const struct builtin B2_vec_any_gt = { { &T_vec_b16, &T_vec_u16, NULL, }, "xx", &T_cc26f, 2, FALSE, FALSE, 0, "vec_any_gt:2", "*vcmpgtuh.", CODE_FOR_j_26_f_fxx_simple, B_UID(265) };
+static const struct builtin B3_vec_any_gt = { { &T_vec_b32, &T_vec_s32, NULL, }, "xx", &T_cc26f, 2, FALSE, FALSE, 0, "vec_any_gt:3", "*vcmpgtsw.", CODE_FOR_j_26_f_fxx_simple, B_UID(266) };
+static const struct builtin B4_vec_any_gt = { { &T_vec_b32, &T_vec_u32, NULL, }, "xx", &T_cc26f, 2, FALSE, FALSE, 0, "vec_any_gt:4", "*vcmpgtuw.", CODE_FOR_j_26_f_fxx_simple, B_UID(267) };
+static const struct builtin B5_vec_any_gt = { { &T_vec_b8, &T_vec_s8, NULL, }, "xx", &T_cc26f, 2, FALSE, FALSE, 0, "vec_any_gt:5", "*vcmpgtsb.", CODE_FOR_j_26_f_fxx_simple, B_UID(268) };
+static const struct builtin B6_vec_any_gt = { { &T_vec_b8, &T_vec_u8, NULL, }, "xx", &T_cc26f, 2, FALSE, FALSE, 0, "vec_any_gt:6", "*vcmpgtub.", CODE_FOR_j_26_f_fxx_simple, B_UID(269) };
+static const struct builtin B7_vec_any_gt = { { &T_vec_f32, &T_vec_f32, NULL, }, "xx", &T_cc26f, 2, FALSE, FALSE, 0, "vec_any_gt:7", "*vcmpgtfp.", CODE_FOR_j_26_f_fxx_simple, B_UID(270) };
+static const struct builtin B8_vec_any_gt = { { &T_vec_s16, &T_vec_b16, NULL, }, "xx", &T_cc26f, 2, FALSE, FALSE, 0, "vec_any_gt:8", "*vcmpgtsh.", CODE_FOR_j_26_f_fxx_simple, B_UID(271) };
+static const struct builtin B9_vec_any_gt = { { &T_vec_s16, &T_vec_s16, NULL, }, "xx", &T_cc26f, 2, FALSE, FALSE, 0, "vec_any_gt:9", "*vcmpgtsh.", CODE_FOR_j_26_f_fxx_simple, B_UID(272) };
+static const struct builtin B10_vec_any_gt = { { &T_vec_s32, &T_vec_b32, NULL, }, "xx", &T_cc26f, 2, FALSE, FALSE, 0, "vec_any_gt:10", "*vcmpgtsw.", CODE_FOR_j_26_f_fxx_simple, B_UID(273) };
+static const struct builtin B11_vec_any_gt = { { &T_vec_s32, &T_vec_s32, NULL, }, "xx", &T_cc26f, 2, FALSE, FALSE, 0, "vec_any_gt:11", "*vcmpgtsw.", CODE_FOR_j_26_f_fxx_simple, B_UID(274) };
+static const struct builtin B12_vec_any_gt = { { &T_vec_s8, &T_vec_b8, NULL, }, "xx", &T_cc26f, 2, FALSE, FALSE, 0, "vec_any_gt:12", "*vcmpgtsb.", CODE_FOR_j_26_f_fxx_simple, B_UID(275) };
+static const struct builtin B13_vec_any_gt = { { &T_vec_s8, &T_vec_s8, NULL, }, "xx", &T_cc26f, 2, FALSE, FALSE, 0, "vec_any_gt:13", "*vcmpgtsb.", CODE_FOR_j_26_f_fxx_simple, B_UID(276) };
+static const struct builtin B14_vec_any_gt = { { &T_vec_u16, &T_vec_b16, NULL, }, "xx", &T_cc26f, 2, FALSE, FALSE, 0, "vec_any_gt:14", "*vcmpgtuh.", CODE_FOR_j_26_f_fxx_simple, B_UID(277) };
+static const struct builtin B15_vec_any_gt = { { &T_vec_u16, &T_vec_u16, NULL, }, "xx", &T_cc26f, 2, FALSE, FALSE, 0, "vec_any_gt:15", "*vcmpgtuh.", CODE_FOR_j_26_f_fxx_simple, B_UID(278) };
+static const struct builtin B16_vec_any_gt = { { &T_vec_u32, &T_vec_b32, NULL, }, "xx", &T_cc26f, 2, FALSE, FALSE, 0, "vec_any_gt:16", "*vcmpgtuw.", CODE_FOR_j_26_f_fxx_simple, B_UID(279) };
+static const struct builtin B17_vec_any_gt = { { &T_vec_u32, &T_vec_u32, NULL, }, "xx", &T_cc26f, 2, FALSE, FALSE, 0, "vec_any_gt:17", "*vcmpgtuw.", CODE_FOR_j_26_f_fxx_simple, B_UID(280) };
+static const struct builtin B18_vec_any_gt = { { &T_vec_u8, &T_vec_b8, NULL, }, "xx", &T_cc26f, 2, FALSE, FALSE, 0, "vec_any_gt:18", "*vcmpgtub.", CODE_FOR_j_26_f_fxx_simple, B_UID(281) };
+static const struct builtin B19_vec_any_gt = { { &T_vec_u8, &T_vec_u8, NULL, }, "xx", &T_cc26f, 2, FALSE, FALSE, 0, "vec_any_gt:19", "*vcmpgtub.", CODE_FOR_j_26_f_fxx_simple, B_UID(282) };
+static const struct builtin B1_vec_any_le = { { &T_vec_b16, &T_vec_s16, NULL, }, "xx", &T_cc24f, 2, FALSE, FALSE, 0, "vec_any_le:1", "*vcmpgtsh.", CODE_FOR_j_24_f_fxx_simple, B_UID(283) };
+static const struct builtin B2_vec_any_le = { { &T_vec_b16, &T_vec_u16, NULL, }, "xx", &T_cc24f, 2, FALSE, FALSE, 0, "vec_any_le:2", "*vcmpgtuh.", CODE_FOR_j_24_f_fxx_simple, B_UID(284) };
+static const struct builtin B3_vec_any_le = { { &T_vec_b32, &T_vec_s32, NULL, }, "xx", &T_cc24f, 2, FALSE, FALSE, 0, "vec_any_le:3", "*vcmpgtsw.", CODE_FOR_j_24_f_fxx_simple, B_UID(285) };
+static const struct builtin B4_vec_any_le = { { &T_vec_b32, &T_vec_u32, NULL, }, "xx", &T_cc24f, 2, FALSE, FALSE, 0, "vec_any_le:4", "*vcmpgtuw.", CODE_FOR_j_24_f_fxx_simple, B_UID(286) };
+static const struct builtin B5_vec_any_le = { { &T_vec_b8, &T_vec_s8, NULL, }, "xx", &T_cc24f, 2, FALSE, FALSE, 0, "vec_any_le:5", "*vcmpgtsb.", CODE_FOR_j_24_f_fxx_simple, B_UID(287) };
+static const struct builtin B6_vec_any_le = { { &T_vec_b8, &T_vec_u8, NULL, }, "xx", &T_cc24f, 2, FALSE, FALSE, 0, "vec_any_le:6", "*vcmpgtub.", CODE_FOR_j_24_f_fxx_simple, B_UID(288) };
+static const struct builtin B7_vec_any_le = { { &T_vec_f32, &T_vec_f32, NULL, }, "xx", &T_cc26fr, 2, FALSE, FALSE, 0, "vec_any_le:7", "*vcmpgefp.", CODE_FOR_j_26_f_frxx_simple, B_UID(289) };
+static const struct builtin B8_vec_any_le = { { &T_vec_s16, &T_vec_b16, NULL, }, "xx", &T_cc24f, 2, FALSE, FALSE, 0, "vec_any_le:8", "*vcmpgtsh.", CODE_FOR_j_24_f_fxx_simple, B_UID(290) };
+static const struct builtin B9_vec_any_le = { { &T_vec_s16, &T_vec_s16, NULL, }, "xx", &T_cc24f, 2, FALSE, FALSE, 0, "vec_any_le:9", "*vcmpgtsh.", CODE_FOR_j_24_f_fxx_simple, B_UID(291) };
+static const struct builtin B10_vec_any_le = { { &T_vec_s32, &T_vec_b32, NULL, }, "xx", &T_cc24f, 2, FALSE, FALSE, 0, "vec_any_le:10", "*vcmpgtsw.", CODE_FOR_j_24_f_fxx_simple, B_UID(292) };
+static const struct builtin B11_vec_any_le = { { &T_vec_s32, &T_vec_s32, NULL, }, "xx", &T_cc24f, 2, FALSE, FALSE, 0, "vec_any_le:11", "*vcmpgtsw.", CODE_FOR_j_24_f_fxx_simple, B_UID(293) };
+static const struct builtin B12_vec_any_le = { { &T_vec_s8, &T_vec_b8, NULL, }, "xx", &T_cc24f, 2, FALSE, FALSE, 0, "vec_any_le:12", "*vcmpgtsb.", CODE_FOR_j_24_f_fxx_simple, B_UID(294) };
+static const struct builtin B13_vec_any_le = { { &T_vec_s8, &T_vec_s8, NULL, }, "xx", &T_cc24f, 2, FALSE, FALSE, 0, "vec_any_le:13", "*vcmpgtsb.", CODE_FOR_j_24_f_fxx_simple, B_UID(295) };
+static const struct builtin B14_vec_any_le = { { &T_vec_u16, &T_vec_b16, NULL, }, "xx", &T_cc24f, 2, FALSE, FALSE, 0, "vec_any_le:14", "*vcmpgtuh.", CODE_FOR_j_24_f_fxx_simple, B_UID(296) };
+static const struct builtin B15_vec_any_le = { { &T_vec_u16, &T_vec_u16, NULL, }, "xx", &T_cc24f, 2, FALSE, FALSE, 0, "vec_any_le:15", "*vcmpgtuh.", CODE_FOR_j_24_f_fxx_simple, B_UID(297) };
+static const struct builtin B16_vec_any_le = { { &T_vec_u32, &T_vec_b32, NULL, }, "xx", &T_cc24f, 2, FALSE, FALSE, 0, "vec_any_le:16", "*vcmpgtuw.", CODE_FOR_j_24_f_fxx_simple, B_UID(298) };
+static const struct builtin B17_vec_any_le = { { &T_vec_u32, &T_vec_u32, NULL, }, "xx", &T_cc24f, 2, FALSE, FALSE, 0, "vec_any_le:17", "*vcmpgtuw.", CODE_FOR_j_24_f_fxx_simple, B_UID(299) };
+static const struct builtin B18_vec_any_le = { { &T_vec_u8, &T_vec_b8, NULL, }, "xx", &T_cc24f, 2, FALSE, FALSE, 0, "vec_any_le:18", "*vcmpgtub.", CODE_FOR_j_24_f_fxx_simple, B_UID(300) };
+static const struct builtin B19_vec_any_le = { { &T_vec_u8, &T_vec_u8, NULL, }, "xx", &T_cc24f, 2, FALSE, FALSE, 0, "vec_any_le:19", "*vcmpgtub.", CODE_FOR_j_24_f_fxx_simple, B_UID(301) };
+static const struct builtin B1_vec_any_lt = { { &T_vec_b16, &T_vec_s16, NULL, }, "xx", &T_cc26fr, 2, FALSE, FALSE, 0, "vec_any_lt:1", "*vcmpgtsh.", CODE_FOR_j_26_f_frxx_simple, B_UID(302) };
+static const struct builtin B2_vec_any_lt = { { &T_vec_b16, &T_vec_u16, NULL, }, "xx", &T_cc26fr, 2, FALSE, FALSE, 0, "vec_any_lt:2", "*vcmpgtuh.", CODE_FOR_j_26_f_frxx_simple, B_UID(303) };
+static const struct builtin B3_vec_any_lt = { { &T_vec_b32, &T_vec_s32, NULL, }, "xx", &T_cc26fr, 2, FALSE, FALSE, 0, "vec_any_lt:3", "*vcmpgtsw.", CODE_FOR_j_26_f_frxx_simple, B_UID(304) };
+static const struct builtin B4_vec_any_lt = { { &T_vec_b32, &T_vec_u32, NULL, }, "xx", &T_cc26fr, 2, FALSE, FALSE, 0, "vec_any_lt:4", "*vcmpgtuw.", CODE_FOR_j_26_f_frxx_simple, B_UID(305) };
+static const struct builtin B5_vec_any_lt = { { &T_vec_b8, &T_vec_s8, NULL, }, "xx", &T_cc26fr, 2, FALSE, FALSE, 0, "vec_any_lt:5", "*vcmpgtsb.", CODE_FOR_j_26_f_frxx_simple, B_UID(306) };
+static const struct builtin B6_vec_any_lt = { { &T_vec_b8, &T_vec_u8, NULL, }, "xx", &T_cc26fr, 2, FALSE, FALSE, 0, "vec_any_lt:6", "*vcmpgtub.", CODE_FOR_j_26_f_frxx_simple, B_UID(307) };
+static const struct builtin B7_vec_any_lt = { { &T_vec_f32, &T_vec_f32, NULL, }, "xx", &T_cc26fr, 2, FALSE, FALSE, 0, "vec_any_lt:7", "*vcmpgtfp.", CODE_FOR_j_26_f_frxx_simple, B_UID(308) };
+static const struct builtin B8_vec_any_lt = { { &T_vec_s16, &T_vec_b16, NULL, }, "xx", &T_cc26fr, 2, FALSE, FALSE, 0, "vec_any_lt:8", "*vcmpgtsh.", CODE_FOR_j_26_f_frxx_simple, B_UID(309) };
+static const struct builtin B9_vec_any_lt = { { &T_vec_s16, &T_vec_s16, NULL, }, "xx", &T_cc26fr, 2, FALSE, FALSE, 0, "vec_any_lt:9", "*vcmpgtsh.", CODE_FOR_j_26_f_frxx_simple, B_UID(310) };
+static const struct builtin B10_vec_any_lt = { { &T_vec_s32, &T_vec_b32, NULL, }, "xx", &T_cc26fr, 2, FALSE, FALSE, 0, "vec_any_lt:10", "*vcmpgtsw.", CODE_FOR_j_26_f_frxx_simple, B_UID(311) };
+static const struct builtin B11_vec_any_lt = { { &T_vec_s32, &T_vec_s32, NULL, }, "xx", &T_cc26fr, 2, FALSE, FALSE, 0, "vec_any_lt:11", "*vcmpgtsw.", CODE_FOR_j_26_f_frxx_simple, B_UID(312) };
+static const struct builtin B12_vec_any_lt = { { &T_vec_s8, &T_vec_b8, NULL, }, "xx", &T_cc26fr, 2, FALSE, FALSE, 0, "vec_any_lt:12", "*vcmpgtsb.", CODE_FOR_j_26_f_frxx_simple, B_UID(313) };
+static const struct builtin B13_vec_any_lt = { { &T_vec_s8, &T_vec_s8, NULL, }, "xx", &T_cc26fr, 2, FALSE, FALSE, 0, "vec_any_lt:13", "*vcmpgtsb.", CODE_FOR_j_26_f_frxx_simple, B_UID(314) };
+static const struct builtin B14_vec_any_lt = { { &T_vec_u16, &T_vec_b16, NULL, }, "xx", &T_cc26fr, 2, FALSE, FALSE, 0, "vec_any_lt:14", "*vcmpgtuh.", CODE_FOR_j_26_f_frxx_simple, B_UID(315) };
+static const struct builtin B15_vec_any_lt = { { &T_vec_u16, &T_vec_u16, NULL, }, "xx", &T_cc26fr, 2, FALSE, FALSE, 0, "vec_any_lt:15", "*vcmpgtuh.", CODE_FOR_j_26_f_frxx_simple, B_UID(316) };
+static const struct builtin B16_vec_any_lt = { { &T_vec_u32, &T_vec_b32, NULL, }, "xx", &T_cc26fr, 2, FALSE, FALSE, 0, "vec_any_lt:16", "*vcmpgtuw.", CODE_FOR_j_26_f_frxx_simple, B_UID(317) };
+static const struct builtin B17_vec_any_lt = { { &T_vec_u32, &T_vec_u32, NULL, }, "xx", &T_cc26fr, 2, FALSE, FALSE, 0, "vec_any_lt:17", "*vcmpgtuw.", CODE_FOR_j_26_f_frxx_simple, B_UID(318) };
+static const struct builtin B18_vec_any_lt = { { &T_vec_u8, &T_vec_b8, NULL, }, "xx", &T_cc26fr, 2, FALSE, FALSE, 0, "vec_any_lt:18", "*vcmpgtub.", CODE_FOR_j_26_f_frxx_simple, B_UID(319) };
+static const struct builtin B19_vec_any_lt = { { &T_vec_u8, &T_vec_u8, NULL, }, "xx", &T_cc26fr, 2, FALSE, FALSE, 0, "vec_any_lt:19", "*vcmpgtub.", CODE_FOR_j_26_f_frxx_simple, B_UID(320) };
+static const struct builtin B_vec_any_nan = { { &T_vec_f32, NULL, NULL, }, "x", &T_cc24fd, 1, FALSE, FALSE, 0, "vec_any_nan", "*vcmpeqfp.", CODE_FOR_j_24_f_fx_simple, B_UID(321) };
+static const struct builtin B1_vec_any_ne = { { &T_vec_b16, &T_vec_b16, NULL, }, "xx", &T_cc24f, 2, FALSE, FALSE, 0, "vec_any_ne:1", "*vcmpequh.", CODE_FOR_j_24_f_fxx_simple, B_UID(322) };
+static const struct builtin B2_vec_any_ne = { { &T_vec_b16, &T_vec_s16, NULL, }, "xx", &T_cc24f, 2, FALSE, FALSE, 0, "vec_any_ne:2", "*vcmpequh.", CODE_FOR_j_24_f_fxx_simple, B_UID(323) };
+static const struct builtin B3_vec_any_ne = { { &T_vec_b16, &T_vec_u16, NULL, }, "xx", &T_cc24f, 2, FALSE, FALSE, 0, "vec_any_ne:3", "*vcmpequh.", CODE_FOR_j_24_f_fxx_simple, B_UID(324) };
+static const struct builtin B4_vec_any_ne = { { &T_vec_b32, &T_vec_b32, NULL, }, "xx", &T_cc24f, 2, FALSE, FALSE, 0, "vec_any_ne:4", "*vcmpequw.", CODE_FOR_j_24_f_fxx_simple, B_UID(325) };
+static const struct builtin B5_vec_any_ne = { { &T_vec_b32, &T_vec_s32, NULL, }, "xx", &T_cc24f, 2, FALSE, FALSE, 0, "vec_any_ne:5", "*vcmpequw.", CODE_FOR_j_24_f_fxx_simple, B_UID(326) };
+static const struct builtin B6_vec_any_ne = { { &T_vec_b32, &T_vec_u32, NULL, }, "xx", &T_cc24f, 2, FALSE, FALSE, 0, "vec_any_ne:6", "*vcmpequw.", CODE_FOR_j_24_f_fxx_simple, B_UID(327) };
+static const struct builtin B7_vec_any_ne = { { &T_vec_b8, &T_vec_b8, NULL, }, "xx", &T_cc24f, 2, FALSE, FALSE, 0, "vec_any_ne:7", "*vcmpequb.", CODE_FOR_j_24_f_fxx_simple, B_UID(328) };
+static const struct builtin B8_vec_any_ne = { { &T_vec_b8, &T_vec_s8, NULL, }, "xx", &T_cc24f, 2, FALSE, FALSE, 0, "vec_any_ne:8", "*vcmpequb.", CODE_FOR_j_24_f_fxx_simple, B_UID(329) };
+static const struct builtin B9_vec_any_ne = { { &T_vec_b8, &T_vec_u8, NULL, }, "xx", &T_cc24f, 2, FALSE, FALSE, 0, "vec_any_ne:9", "*vcmpequb.", CODE_FOR_j_24_f_fxx_simple, B_UID(330) };
+static const struct builtin B10_vec_any_ne = { { &T_vec_f32, &T_vec_f32, NULL, }, "xx", &T_cc24f, 2, FALSE, FALSE, 0, "vec_any_ne:10", "*vcmpeqfp.", CODE_FOR_j_24_f_fxx_simple, B_UID(331) };
+static const struct builtin B11_vec_any_ne = { { &T_vec_p16, &T_vec_p16, NULL, }, "xx", &T_cc24f, 2, FALSE, FALSE, 0, "vec_any_ne:11", "*vcmpequh.", CODE_FOR_j_24_f_fxx_simple, B_UID(332) };
+static const struct builtin B12_vec_any_ne = { { &T_vec_s16, &T_vec_b16, NULL, }, "xx", &T_cc24f, 2, FALSE, FALSE, 0, "vec_any_ne:12", "*vcmpequh.", CODE_FOR_j_24_f_fxx_simple, B_UID(333) };
+static const struct builtin B13_vec_any_ne = { { &T_vec_s16, &T_vec_s16, NULL, }, "xx", &T_cc24f, 2, FALSE, FALSE, 0, "vec_any_ne:13", "*vcmpequh.", CODE_FOR_j_24_f_fxx_simple, B_UID(334) };
+static const struct builtin B14_vec_any_ne = { { &T_vec_s32, &T_vec_b32, NULL, }, "xx", &T_cc24f, 2, FALSE, FALSE, 0, "vec_any_ne:14", "*vcmpequw.", CODE_FOR_j_24_f_fxx_simple, B_UID(335) };
+static const struct builtin B15_vec_any_ne = { { &T_vec_s32, &T_vec_s32, NULL, }, "xx", &T_cc24f, 2, FALSE, FALSE, 0, "vec_any_ne:15", "*vcmpequw.", CODE_FOR_j_24_f_fxx_simple, B_UID(336) };
+static const struct builtin B16_vec_any_ne = { { &T_vec_s8, &T_vec_b8, NULL, }, "xx", &T_cc24f, 2, FALSE, FALSE, 0, "vec_any_ne:16", "*vcmpequb.", CODE_FOR_j_24_f_fxx_simple, B_UID(337) };
+static const struct builtin B17_vec_any_ne = { { &T_vec_s8, &T_vec_s8, NULL, }, "xx", &T_cc24f, 2, FALSE, FALSE, 0, "vec_any_ne:17", "*vcmpequb.", CODE_FOR_j_24_f_fxx_simple, B_UID(338) };
+static const struct builtin B18_vec_any_ne = { { &T_vec_u16, &T_vec_b16, NULL, }, "xx", &T_cc24f, 2, FALSE, FALSE, 0, "vec_any_ne:18", "*vcmpequh.", CODE_FOR_j_24_f_fxx_simple, B_UID(339) };
+static const struct builtin B19_vec_any_ne = { { &T_vec_u16, &T_vec_u16, NULL, }, "xx", &T_cc24f, 2, FALSE, FALSE, 0, "vec_any_ne:19", "*vcmpequh.", CODE_FOR_j_24_f_fxx_simple, B_UID(340) };
+static const struct builtin B20_vec_any_ne = { { &T_vec_u32, &T_vec_b32, NULL, }, "xx", &T_cc24f, 2, FALSE, FALSE, 0, "vec_any_ne:20", "*vcmpequw.", CODE_FOR_j_24_f_fxx_simple, B_UID(341) };
+static const struct builtin B21_vec_any_ne = { { &T_vec_u32, &T_vec_u32, NULL, }, "xx", &T_cc24f, 2, FALSE, FALSE, 0, "vec_any_ne:21", "*vcmpequw.", CODE_FOR_j_24_f_fxx_simple, B_UID(342) };
+static const struct builtin B22_vec_any_ne = { { &T_vec_u8, &T_vec_b8, NULL, }, "xx", &T_cc24f, 2, FALSE, FALSE, 0, "vec_any_ne:22", "*vcmpequb.", CODE_FOR_j_24_f_fxx_simple, B_UID(343) };
+static const struct builtin B23_vec_any_ne = { { &T_vec_u8, &T_vec_u8, NULL, }, "xx", &T_cc24f, 2, FALSE, FALSE, 0, "vec_any_ne:23", "*vcmpequb.", CODE_FOR_j_24_f_fxx_simple, B_UID(344) };
+static const struct builtin B_vec_any_nge = { { &T_vec_f32, &T_vec_f32, NULL, }, "xx", &T_cc24f, 2, FALSE, FALSE, 0, "vec_any_nge", "*vcmpgefp.", CODE_FOR_j_24_f_fxx_simple, B_UID(345) };
+static const struct builtin B_vec_any_ngt = { { &T_vec_f32, &T_vec_f32, NULL, }, "xx", &T_cc24f, 2, FALSE, FALSE, 0, "vec_any_ngt", "*vcmpgtfp.", CODE_FOR_j_24_f_fxx_simple, B_UID(346) };
+static const struct builtin B_vec_any_nle = { { &T_vec_f32, &T_vec_f32, NULL, }, "xx", &T_cc24fr, 2, FALSE, FALSE, 0, "vec_any_nle", "*vcmpgefp.", CODE_FOR_j_24_f_frxx_simple, B_UID(347) };
+static const struct builtin B_vec_any_nlt = { { &T_vec_f32, &T_vec_f32, NULL, }, "xx", &T_cc24fr, 2, FALSE, FALSE, 0, "vec_any_nlt", "*vcmpgtfp.", CODE_FOR_j_24_f_frxx_simple, B_UID(348) };
+static const struct builtin B_vec_any_numeric = { { &T_vec_f32, NULL, NULL, }, "x", &T_cc26fd, 1, FALSE, FALSE, 0, "vec_any_numeric", "*vcmpeqfp.", CODE_FOR_j_26_f_fx_simple, B_UID(349) };
+static const struct builtin B_vec_any_out = { { &T_vec_f32, &T_vec_f32, NULL, }, "xx", &T_cc26f, 2, FALSE, FALSE, 0, "vec_any_out", "*vcmpbfp.", CODE_FOR_j_26_f_fxx_simple, B_UID(350) };
+static const struct builtin B_vec_vavgsh = { { &T_vec_s16, &T_vec_s16, NULL, }, "xx", &T_vec_s16, 2, FALSE, FALSE, 2, "vec_vavgsh", "*vavgsh", CODE_FOR_xfxx_simple, B_UID(351) };
+static const struct builtin B_vec_vavgsw = { { &T_vec_s32, &T_vec_s32, NULL, }, "xx", &T_vec_s32, 2, FALSE, FALSE, 2, "vec_vavgsw", "*vavgsw", CODE_FOR_xfxx_simple, B_UID(352) };
+static const struct builtin B_vec_vavgsb = { { &T_vec_s8, &T_vec_s8, NULL, }, "xx", &T_vec_s8, 2, FALSE, FALSE, 2, "vec_vavgsb", "*vavgsb", CODE_FOR_xfxx_simple, B_UID(353) };
+static const struct builtin B_vec_vavguh = { { &T_vec_u16, &T_vec_u16, NULL, }, "xx", &T_vec_u16, 2, FALSE, FALSE, 2, "vec_vavguh", "*vavguh", CODE_FOR_xfxx_simple, B_UID(354) };
+static const struct builtin B_vec_vavguw = { { &T_vec_u32, &T_vec_u32, NULL, }, "xx", &T_vec_u32, 2, FALSE, FALSE, 2, "vec_vavguw", "*vavguw", CODE_FOR_xfxx_simple, B_UID(355) };
+static const struct builtin B_vec_vavgub = { { &T_vec_u8, &T_vec_u8, NULL, }, "xx", &T_vec_u8, 2, FALSE, FALSE, 2, "vec_vavgub", "*vavgub", CODE_FOR_xfxx_simple, B_UID(356) };
+static const struct builtin B_vec_vrfip = { { &T_vec_f32, NULL, NULL, }, "x", &T_vec_f32, 1, FALSE, FALSE, 0, "vec_vrfip", "*vrfip", CODE_FOR_xfx_fp, B_UID(357) };
+static const struct builtin B_vec_vcmpbfp = { { &T_vec_f32, &T_vec_f32, NULL, }, "xx", &T_vec_s32, 2, FALSE, FALSE, 0, "vec_vcmpbfp", "*vcmpbfp", CODE_FOR_xfxx_simple, B_UID(358) };
+static const struct builtin B_vec_vcmpeqfp = { { &T_vec_f32, &T_vec_f32, NULL, }, "xx", &T_vec_b32, 2, FALSE, FALSE, 7, "vec_vcmpeqfp", "*vcmpeqfp", CODE_FOR_xfxx_simple, B_UID(359) };
+static const struct builtin B1_vec_vcmpequh = { { &T_vec_s16, &T_vec_s16, NULL, }, "xx", &T_vec_b16, 2, FALSE, FALSE, 7, "vec_vcmpequh:1", "*vcmpequh", CODE_FOR_xfxx_simple, B_UID(360) };
+static const struct builtin B1_vec_vcmpequw = { { &T_vec_s32, &T_vec_s32, NULL, }, "xx", &T_vec_b32, 2, FALSE, FALSE, 7, "vec_vcmpequw:1", "*vcmpequw", CODE_FOR_xfxx_simple, B_UID(361) };
+static const struct builtin B1_vec_vcmpequb = { { &T_vec_s8, &T_vec_s8, NULL, }, "xx", &T_vec_b8, 2, FALSE, FALSE, 7, "vec_vcmpequb:1", "*vcmpequb", CODE_FOR_xfxx_simple, B_UID(362) };
+static const struct builtin B2_vec_vcmpequh = { { &T_vec_u16, &T_vec_u16, NULL, }, "xx", &T_vec_b16, 2, FALSE, FALSE, 7, "vec_vcmpequh:2", "*vcmpequh", CODE_FOR_xfxx_simple, B_UID(363) };
+static const struct builtin B2_vec_vcmpequw = { { &T_vec_u32, &T_vec_u32, NULL, }, "xx", &T_vec_b32, 2, FALSE, FALSE, 7, "vec_vcmpequw:2", "*vcmpequw", CODE_FOR_xfxx_simple, B_UID(364) };
+static const struct builtin B2_vec_vcmpequb = { { &T_vec_u8, &T_vec_u8, NULL, }, "xx", &T_vec_b8, 2, FALSE, FALSE, 7, "vec_vcmpequb:2", "*vcmpequb", CODE_FOR_xfxx_simple, B_UID(365) };
+static const struct builtin B_vec_vcmpgefp = { { &T_vec_f32, &T_vec_f32, NULL, }, "xx", &T_vec_b32, 2, FALSE, FALSE, 0, "vec_vcmpgefp", "*vcmpgefp", CODE_FOR_xfxx_simple, B_UID(366) };
+static const struct builtin B_vec_vcmpgtfp = { { &T_vec_f32, &T_vec_f32, NULL, }, "xx", &T_vec_b32, 2, FALSE, FALSE, 0, "vec_vcmpgtfp", "*vcmpgtfp", CODE_FOR_xfxx_simple, B_UID(367) };
+static const struct builtin B_vec_vcmpgtsh = { { &T_vec_s16, &T_vec_s16, NULL, }, "xx", &T_vec_b16, 2, FALSE, FALSE, 0, "vec_vcmpgtsh", "*vcmpgtsh", CODE_FOR_xfxx_simple, B_UID(368) };
+static const struct builtin B_vec_vcmpgtsw = { { &T_vec_s32, &T_vec_s32, NULL, }, "xx", &T_vec_b32, 2, FALSE, FALSE, 0, "vec_vcmpgtsw", "*vcmpgtsw", CODE_FOR_xfxx_simple, B_UID(369) };
+static const struct builtin B_vec_vcmpgtsb = { { &T_vec_s8, &T_vec_s8, NULL, }, "xx", &T_vec_b8, 2, FALSE, FALSE, 0, "vec_vcmpgtsb", "*vcmpgtsb", CODE_FOR_xfxx_simple, B_UID(370) };
+static const struct builtin B_vec_vcmpgtuh = { { &T_vec_u16, &T_vec_u16, NULL, }, "xx", &T_vec_b16, 2, FALSE, FALSE, 0, "vec_vcmpgtuh", "*vcmpgtuh", CODE_FOR_xfxx_simple, B_UID(371) };
+static const struct builtin B_vec_vcmpgtuw = { { &T_vec_u32, &T_vec_u32, NULL, }, "xx", &T_vec_b32, 2, FALSE, FALSE, 0, "vec_vcmpgtuw", "*vcmpgtuw", CODE_FOR_xfxx_simple, B_UID(372) };
+static const struct builtin B_vec_vcmpgtub = { { &T_vec_u8, &T_vec_u8, NULL, }, "xx", &T_vec_b8, 2, FALSE, FALSE, 0, "vec_vcmpgtub", "*vcmpgtub", CODE_FOR_xfxx_simple, B_UID(373) };
+static const struct builtin B_vec_cmple = { { &T_vec_f32, &T_vec_f32, NULL, }, "xx", &T_vec_b32, 2, FALSE, FALSE, 10, "vec_cmple", "*vcmpgefp", CODE_FOR_xfxx_simple, B_UID(374) };
+static const struct builtin B1_vec_cmplt = { { &T_vec_f32, &T_vec_f32, NULL, }, "xx", &T_vec_b32, 2, FALSE, FALSE, 10, "vec_cmplt:1", "*vcmpgtfp", CODE_FOR_xfxx_simple, B_UID(375) };
+static const struct builtin B2_vec_cmplt = { { &T_vec_s16, &T_vec_s16, NULL, }, "xx", &T_vec_b16, 2, FALSE, FALSE, 10, "vec_cmplt:2", "*vcmpgtsh", CODE_FOR_xfxx_simple, B_UID(376) };
+static const struct builtin B3_vec_cmplt = { { &T_vec_s32, &T_vec_s32, NULL, }, "xx", &T_vec_b32, 2, FALSE, FALSE, 10, "vec_cmplt:3", "*vcmpgtsw", CODE_FOR_xfxx_simple, B_UID(377) };
+static const struct builtin B4_vec_cmplt = { { &T_vec_s8, &T_vec_s8, NULL, }, "xx", &T_vec_b8, 2, FALSE, FALSE, 10, "vec_cmplt:4", "*vcmpgtsb", CODE_FOR_xfxx_simple, B_UID(378) };
+static const struct builtin B5_vec_cmplt = { { &T_vec_u16, &T_vec_u16, NULL, }, "xx", &T_vec_b16, 2, FALSE, FALSE, 10, "vec_cmplt:5", "*vcmpgtuh", CODE_FOR_xfxx_simple, B_UID(379) };
+static const struct builtin B6_vec_cmplt = { { &T_vec_u32, &T_vec_u32, NULL, }, "xx", &T_vec_b32, 2, FALSE, FALSE, 10, "vec_cmplt:6", "*vcmpgtuw", CODE_FOR_xfxx_simple, B_UID(380) };
+static const struct builtin B7_vec_cmplt = { { &T_vec_u8, &T_vec_u8, NULL, }, "xx", &T_vec_b8, 2, FALSE, FALSE, 10, "vec_cmplt:7", "*vcmpgtub", CODE_FOR_xfxx_simple, B_UID(381) };
+static const struct builtin B_vec_vcfsx = { { &T_vec_s32, &T_immed_u5, NULL, }, "xB", &T_vec_f32, 2, FALSE, FALSE, 0, "vec_vcfsx", "*vcfsx", CODE_FOR_xfxB_fp, B_UID(382) };
+static const struct builtin B_vec_vcfux = { { &T_vec_u32, &T_immed_u5, NULL, }, "xB", &T_vec_f32, 2, FALSE, FALSE, 0, "vec_vcfux", "*vcfux", CODE_FOR_xfxB_fp, B_UID(383) };
+static const struct builtin B_vec_vctsxs = { { &T_vec_f32, &T_immed_u5, NULL, }, "xB", &T_vec_s32, 2, FALSE, FALSE, 0, "vec_vctsxs", "*vctsxs", CODE_FOR_xfxB_fp, B_UID(384) };
+static const struct builtin B_vec_vctuxs = { { &T_vec_f32, &T_immed_u5, NULL, }, "xB", &T_vec_u32, 2, FALSE, FALSE, 0, "vec_vctuxs", "*vctuxs", CODE_FOR_xfxB_fp, B_UID(385) };
+static const struct builtin B_vec_dss = { { &T_immed_u2, NULL, NULL, }, "D", &T_volatile_void, 1, FALSE, FALSE, 0, "vec_dss", "*dss", CODE_FOR_vlfD_load, B_UID(386) };
+static const struct builtin B_vec_dssall = { { NULL, NULL, NULL, }, "", &T_volatile_void, 0, FALSE, FALSE, 0, "vec_dssall", "*dssall", CODE_FOR_vlf_load, B_UID(387) };
+static const struct builtin B1_vec_dst = { { &T_const_float_ptr, &T_int, &T_immed_u2, }, "iiD", &T_volatile_void, 3, TRUE, FALSE, 0, "vec_dst:1", "*dst", CODE_FOR_vlfiiD_load, B_UID(388) };
+static const struct builtin B2_vec_dst = { { &T_const_int_ptr, &T_int, &T_immed_u2, }, "iiD", &T_volatile_void, 3, TRUE, FALSE, 0, "vec_dst:2", "*dst", CODE_FOR_vlfiiD_load, B_UID(389) };
+static const struct builtin B3_vec_dst = { { &T_const_long_ptr, &T_int, &T_immed_u2, }, "iiD", &T_volatile_void, 3, TRUE, FALSE, 0, "vec_dst:3", "*dst", CODE_FOR_vlfiiD_load, B_UID(390) };
+static const struct builtin B4_vec_dst = { { &T_const_short_ptr, &T_int, &T_immed_u2, }, "iiD", &T_volatile_void, 3, TRUE, FALSE, 0, "vec_dst:4", "*dst", CODE_FOR_vlfiiD_load, B_UID(391) };
+static const struct builtin B5_vec_dst = { { &T_const_signed_char_ptr, &T_int, &T_immed_u2, }, "iiD", &T_volatile_void, 3, TRUE, FALSE, 0, "vec_dst:5", "*dst", CODE_FOR_vlfiiD_load, B_UID(392) };
+static const struct builtin B6_vec_dst = { { &T_const_unsigned_char_ptr, &T_int, &T_immed_u2, }, "iiD", &T_volatile_void, 3, TRUE, FALSE, 0, "vec_dst:6", "*dst", CODE_FOR_vlfiiD_load, B_UID(393) };
+static const struct builtin B7_vec_dst = { { &T_const_unsigned_int_ptr, &T_int, &T_immed_u2, }, "iiD", &T_volatile_void, 3, TRUE, FALSE, 0, "vec_dst:7", "*dst", CODE_FOR_vlfiiD_load, B_UID(394) };
+static const struct builtin B8_vec_dst = { { &T_const_unsigned_long_ptr, &T_int, &T_immed_u2, }, "iiD", &T_volatile_void, 3, TRUE, FALSE, 0, "vec_dst:8", "*dst", CODE_FOR_vlfiiD_load, B_UID(395) };
+static const struct builtin B9_vec_dst = { { &T_const_unsigned_short_ptr, &T_int, &T_immed_u2, }, "iiD", &T_volatile_void, 3, TRUE, FALSE, 0, "vec_dst:9", "*dst", CODE_FOR_vlfiiD_load, B_UID(396) };
+static const struct builtin B10_vec_dst = { { &T_const_vec_b16_ptr, &T_int, &T_immed_u2, }, "iiD", &T_volatile_void, 3, TRUE, FALSE, 0, "vec_dst:10", "*dst", CODE_FOR_vlfiiD_load, B_UID(397) };
+static const struct builtin B11_vec_dst = { { &T_const_vec_b32_ptr, &T_int, &T_immed_u2, }, "iiD", &T_volatile_void, 3, TRUE, FALSE, 0, "vec_dst:11", "*dst", CODE_FOR_vlfiiD_load, B_UID(398) };
+static const struct builtin B12_vec_dst = { { &T_const_vec_b8_ptr, &T_int, &T_immed_u2, }, "iiD", &T_volatile_void, 3, TRUE, FALSE, 0, "vec_dst:12", "*dst", CODE_FOR_vlfiiD_load, B_UID(399) };
+static const struct builtin B13_vec_dst = { { &T_const_vec_f32_ptr, &T_int, &T_immed_u2, }, "iiD", &T_volatile_void, 3, TRUE, FALSE, 0, "vec_dst:13", "*dst", CODE_FOR_vlfiiD_load, B_UID(400) };
+static const struct builtin B14_vec_dst = { { &T_const_vec_p16_ptr, &T_int, &T_immed_u2, }, "iiD", &T_volatile_void, 3, TRUE, FALSE, 0, "vec_dst:14", "*dst", CODE_FOR_vlfiiD_load, B_UID(401) };
+static const struct builtin B15_vec_dst = { { &T_const_vec_s16_ptr, &T_int, &T_immed_u2, }, "iiD", &T_volatile_void, 3, TRUE, FALSE, 0, "vec_dst:15", "*dst", CODE_FOR_vlfiiD_load, B_UID(402) };
+static const struct builtin B16_vec_dst = { { &T_const_vec_s32_ptr, &T_int, &T_immed_u2, }, "iiD", &T_volatile_void, 3, TRUE, FALSE, 0, "vec_dst:16", "*dst", CODE_FOR_vlfiiD_load, B_UID(403) };
+static const struct builtin B17_vec_dst = { { &T_const_vec_s8_ptr, &T_int, &T_immed_u2, }, "iiD", &T_volatile_void, 3, TRUE, FALSE, 0, "vec_dst:17", "*dst", CODE_FOR_vlfiiD_load, B_UID(404) };
+static const struct builtin B18_vec_dst = { { &T_const_vec_u16_ptr, &T_int, &T_immed_u2, }, "iiD", &T_volatile_void, 3, TRUE, FALSE, 0, "vec_dst:18", "*dst", CODE_FOR_vlfiiD_load, B_UID(405) };
+static const struct builtin B19_vec_dst = { { &T_const_vec_u32_ptr, &T_int, &T_immed_u2, }, "iiD", &T_volatile_void, 3, TRUE, FALSE, 0, "vec_dst:19", "*dst", CODE_FOR_vlfiiD_load, B_UID(406) };
+static const struct builtin B20_vec_dst = { { &T_const_vec_u8_ptr, &T_int, &T_immed_u2, }, "iiD", &T_volatile_void, 3, TRUE, FALSE, 0, "vec_dst:20", "*dst", CODE_FOR_vlfiiD_load, B_UID(407) };
+static const struct builtin B1_vec_dstst = { { &T_const_float_ptr, &T_int, &T_immed_u2, }, "iiD", &T_volatile_void, 3, TRUE, FALSE, 0, "vec_dstst:1", "*dstst", CODE_FOR_vlfiiD_load, B_UID(408) };
+static const struct builtin B2_vec_dstst = { { &T_const_int_ptr, &T_int, &T_immed_u2, }, "iiD", &T_volatile_void, 3, TRUE, FALSE, 0, "vec_dstst:2", "*dstst", CODE_FOR_vlfiiD_load, B_UID(409) };
+static const struct builtin B3_vec_dstst = { { &T_const_long_ptr, &T_int, &T_immed_u2, }, "iiD", &T_volatile_void, 3, TRUE, FALSE, 0, "vec_dstst:3", "*dstst", CODE_FOR_vlfiiD_load, B_UID(410) };
+static const struct builtin B4_vec_dstst = { { &T_const_short_ptr, &T_int, &T_immed_u2, }, "iiD", &T_volatile_void, 3, TRUE, FALSE, 0, "vec_dstst:4", "*dstst", CODE_FOR_vlfiiD_load, B_UID(411) };
+static const struct builtin B5_vec_dstst = { { &T_const_signed_char_ptr, &T_int, &T_immed_u2, }, "iiD", &T_volatile_void, 3, TRUE, FALSE, 0, "vec_dstst:5", "*dstst", CODE_FOR_vlfiiD_load, B_UID(412) };
+static const struct builtin B6_vec_dstst = { { &T_const_unsigned_char_ptr, &T_int, &T_immed_u2, }, "iiD", &T_volatile_void, 3, TRUE, FALSE, 0, "vec_dstst:6", "*dstst", CODE_FOR_vlfiiD_load, B_UID(413) };
+static const struct builtin B7_vec_dstst = { { &T_const_unsigned_int_ptr, &T_int, &T_immed_u2, }, "iiD", &T_volatile_void, 3, TRUE, FALSE, 0, "vec_dstst:7", "*dstst", CODE_FOR_vlfiiD_load, B_UID(414) };
+static const struct builtin B8_vec_dstst = { { &T_const_unsigned_long_ptr, &T_int, &T_immed_u2, }, "iiD", &T_volatile_void, 3, TRUE, FALSE, 0, "vec_dstst:8", "*dstst", CODE_FOR_vlfiiD_load, B_UID(415) };
+static const struct builtin B9_vec_dstst = { { &T_const_unsigned_short_ptr, &T_int, &T_immed_u2, }, "iiD", &T_volatile_void, 3, TRUE, FALSE, 0, "vec_dstst:9", "*dstst", CODE_FOR_vlfiiD_load, B_UID(416) };
+static const struct builtin B10_vec_dstst = { { &T_const_vec_b16_ptr, &T_int, &T_immed_u2, }, "iiD", &T_volatile_void, 3, TRUE, FALSE, 0, "vec_dstst:10", "*dstst", CODE_FOR_vlfiiD_load, B_UID(417) };
+static const struct builtin B11_vec_dstst = { { &T_const_vec_b32_ptr, &T_int, &T_immed_u2, }, "iiD", &T_volatile_void, 3, TRUE, FALSE, 0, "vec_dstst:11", "*dstst", CODE_FOR_vlfiiD_load, B_UID(418) };
+static const struct builtin B12_vec_dstst = { { &T_const_vec_b8_ptr, &T_int, &T_immed_u2, }, "iiD", &T_volatile_void, 3, TRUE, FALSE, 0, "vec_dstst:12", "*dstst", CODE_FOR_vlfiiD_load, B_UID(419) };
+static const struct builtin B13_vec_dstst = { { &T_const_vec_f32_ptr, &T_int, &T_immed_u2, }, "iiD", &T_volatile_void, 3, TRUE, FALSE, 0, "vec_dstst:13", "*dstst", CODE_FOR_vlfiiD_load, B_UID(420) };
+static const struct builtin B14_vec_dstst = { { &T_const_vec_p16_ptr, &T_int, &T_immed_u2, }, "iiD", &T_volatile_void, 3, TRUE, FALSE, 0, "vec_dstst:14", "*dstst", CODE_FOR_vlfiiD_load, B_UID(421) };
+static const struct builtin B15_vec_dstst = { { &T_const_vec_s16_ptr, &T_int, &T_immed_u2, }, "iiD", &T_volatile_void, 3, TRUE, FALSE, 0, "vec_dstst:15", "*dstst", CODE_FOR_vlfiiD_load, B_UID(422) };
+static const struct builtin B16_vec_dstst = { { &T_const_vec_s32_ptr, &T_int, &T_immed_u2, }, "iiD", &T_volatile_void, 3, TRUE, FALSE, 0, "vec_dstst:16", "*dstst", CODE_FOR_vlfiiD_load, B_UID(423) };
+static const struct builtin B17_vec_dstst = { { &T_const_vec_s8_ptr, &T_int, &T_immed_u2, }, "iiD", &T_volatile_void, 3, TRUE, FALSE, 0, "vec_dstst:17", "*dstst", CODE_FOR_vlfiiD_load, B_UID(424) };
+static const struct builtin B18_vec_dstst = { { &T_const_vec_u16_ptr, &T_int, &T_immed_u2, }, "iiD", &T_volatile_void, 3, TRUE, FALSE, 0, "vec_dstst:18", "*dstst", CODE_FOR_vlfiiD_load, B_UID(425) };
+static const struct builtin B19_vec_dstst = { { &T_const_vec_u32_ptr, &T_int, &T_immed_u2, }, "iiD", &T_volatile_void, 3, TRUE, FALSE, 0, "vec_dstst:19", "*dstst", CODE_FOR_vlfiiD_load, B_UID(426) };
+static const struct builtin B20_vec_dstst = { { &T_const_vec_u8_ptr, &T_int, &T_immed_u2, }, "iiD", &T_volatile_void, 3, TRUE, FALSE, 0, "vec_dstst:20", "*dstst", CODE_FOR_vlfiiD_load, B_UID(427) };
+static const struct builtin B1_vec_dststt = { { &T_const_float_ptr, &T_int, &T_immed_u2, }, "iiD", &T_volatile_void, 3, TRUE, FALSE, 0, "vec_dststt:1", "*dststt", CODE_FOR_vlfiiD_load, B_UID(428) };
+static const struct builtin B2_vec_dststt = { { &T_const_int_ptr, &T_int, &T_immed_u2, }, "iiD", &T_volatile_void, 3, TRUE, FALSE, 0, "vec_dststt:2", "*dststt", CODE_FOR_vlfiiD_load, B_UID(429) };
+static const struct builtin B3_vec_dststt = { { &T_const_long_ptr, &T_int, &T_immed_u2, }, "iiD", &T_volatile_void, 3, TRUE, FALSE, 0, "vec_dststt:3", "*dststt", CODE_FOR_vlfiiD_load, B_UID(430) };
+static const struct builtin B4_vec_dststt = { { &T_const_short_ptr, &T_int, &T_immed_u2, }, "iiD", &T_volatile_void, 3, TRUE, FALSE, 0, "vec_dststt:4", "*dststt", CODE_FOR_vlfiiD_load, B_UID(431) };
+static const struct builtin B5_vec_dststt = { { &T_const_signed_char_ptr, &T_int, &T_immed_u2, }, "iiD", &T_volatile_void, 3, TRUE, FALSE, 0, "vec_dststt:5", "*dststt", CODE_FOR_vlfiiD_load, B_UID(432) };
+static const struct builtin B6_vec_dststt = { { &T_const_unsigned_char_ptr, &T_int, &T_immed_u2, }, "iiD", &T_volatile_void, 3, TRUE, FALSE, 0, "vec_dststt:6", "*dststt", CODE_FOR_vlfiiD_load, B_UID(433) };
+static const struct builtin B7_vec_dststt = { { &T_const_unsigned_int_ptr, &T_int, &T_immed_u2, }, "iiD", &T_volatile_void, 3, TRUE, FALSE, 0, "vec_dststt:7", "*dststt", CODE_FOR_vlfiiD_load, B_UID(434) };
+static const struct builtin B8_vec_dststt = { { &T_const_unsigned_long_ptr, &T_int, &T_immed_u2, }, "iiD", &T_volatile_void, 3, TRUE, FALSE, 0, "vec_dststt:8", "*dststt", CODE_FOR_vlfiiD_load, B_UID(435) };
+static const struct builtin B9_vec_dststt = { { &T_const_unsigned_short_ptr, &T_int, &T_immed_u2, }, "iiD", &T_volatile_void, 3, TRUE, FALSE, 0, "vec_dststt:9", "*dststt", CODE_FOR_vlfiiD_load, B_UID(436) };
+static const struct builtin B10_vec_dststt = { { &T_const_vec_b16_ptr, &T_int, &T_immed_u2, }, "iiD", &T_volatile_void, 3, TRUE, FALSE, 0, "vec_dststt:10", "*dststt", CODE_FOR_vlfiiD_load, B_UID(437) };
+static const struct builtin B11_vec_dststt = { { &T_const_vec_b32_ptr, &T_int, &T_immed_u2, }, "iiD", &T_volatile_void, 3, TRUE, FALSE, 0, "vec_dststt:11", "*dststt", CODE_FOR_vlfiiD_load, B_UID(438) };
+static const struct builtin B12_vec_dststt = { { &T_const_vec_b8_ptr, &T_int, &T_immed_u2, }, "iiD", &T_volatile_void, 3, TRUE, FALSE, 0, "vec_dststt:12", "*dststt", CODE_FOR_vlfiiD_load, B_UID(439) };
+static const struct builtin B13_vec_dststt = { { &T_const_vec_f32_ptr, &T_int, &T_immed_u2, }, "iiD", &T_volatile_void, 3, TRUE, FALSE, 0, "vec_dststt:13", "*dststt", CODE_FOR_vlfiiD_load, B_UID(440) };
+static const struct builtin B14_vec_dststt = { { &T_const_vec_p16_ptr, &T_int, &T_immed_u2, }, "iiD", &T_volatile_void, 3, TRUE, FALSE, 0, "vec_dststt:14", "*dststt", CODE_FOR_vlfiiD_load, B_UID(441) };
+static const struct builtin B15_vec_dststt = { { &T_const_vec_s16_ptr, &T_int, &T_immed_u2, }, "iiD", &T_volatile_void, 3, TRUE, FALSE, 0, "vec_dststt:15", "*dststt", CODE_FOR_vlfiiD_load, B_UID(442) };
+static const struct builtin B16_vec_dststt = { { &T_const_vec_s32_ptr, &T_int, &T_immed_u2, }, "iiD", &T_volatile_void, 3, TRUE, FALSE, 0, "vec_dststt:16", "*dststt", CODE_FOR_vlfiiD_load, B_UID(443) };
+static const struct builtin B17_vec_dststt = { { &T_const_vec_s8_ptr, &T_int, &T_immed_u2, }, "iiD", &T_volatile_void, 3, TRUE, FALSE, 0, "vec_dststt:17", "*dststt", CODE_FOR_vlfiiD_load, B_UID(444) };
+static const struct builtin B18_vec_dststt = { { &T_const_vec_u16_ptr, &T_int, &T_immed_u2, }, "iiD", &T_volatile_void, 3, TRUE, FALSE, 0, "vec_dststt:18", "*dststt", CODE_FOR_vlfiiD_load, B_UID(445) };
+static const struct builtin B19_vec_dststt = { { &T_const_vec_u32_ptr, &T_int, &T_immed_u2, }, "iiD", &T_volatile_void, 3, TRUE, FALSE, 0, "vec_dststt:19", "*dststt", CODE_FOR_vlfiiD_load, B_UID(446) };
+static const struct builtin B20_vec_dststt = { { &T_const_vec_u8_ptr, &T_int, &T_immed_u2, }, "iiD", &T_volatile_void, 3, TRUE, FALSE, 0, "vec_dststt:20", "*dststt", CODE_FOR_vlfiiD_load, B_UID(447) };
+static const struct builtin B1_vec_dstt = { { &T_const_float_ptr, &T_int, &T_immed_u2, }, "iiD", &T_volatile_void, 3, TRUE, FALSE, 0, "vec_dstt:1", "*dstt", CODE_FOR_vlfiiD_load, B_UID(448) };
+static const struct builtin B2_vec_dstt = { { &T_const_int_ptr, &T_int, &T_immed_u2, }, "iiD", &T_volatile_void, 3, TRUE, FALSE, 0, "vec_dstt:2", "*dstt", CODE_FOR_vlfiiD_load, B_UID(449) };
+static const struct builtin B3_vec_dstt = { { &T_const_long_ptr, &T_int, &T_immed_u2, }, "iiD", &T_volatile_void, 3, TRUE, FALSE, 0, "vec_dstt:3", "*dstt", CODE_FOR_vlfiiD_load, B_UID(450) };
+static const struct builtin B4_vec_dstt = { { &T_const_short_ptr, &T_int, &T_immed_u2, }, "iiD", &T_volatile_void, 3, TRUE, FALSE, 0, "vec_dstt:4", "*dstt", CODE_FOR_vlfiiD_load, B_UID(451) };
+static const struct builtin B5_vec_dstt = { { &T_const_signed_char_ptr, &T_int, &T_immed_u2, }, "iiD", &T_volatile_void, 3, TRUE, FALSE, 0, "vec_dstt:5", "*dstt", CODE_FOR_vlfiiD_load, B_UID(452) };
+static const struct builtin B6_vec_dstt = { { &T_const_unsigned_char_ptr, &T_int, &T_immed_u2, }, "iiD", &T_volatile_void, 3, TRUE, FALSE, 0, "vec_dstt:6", "*dstt", CODE_FOR_vlfiiD_load, B_UID(453) };
+static const struct builtin B7_vec_dstt = { { &T_const_unsigned_int_ptr, &T_int, &T_immed_u2, }, "iiD", &T_volatile_void, 3, TRUE, FALSE, 0, "vec_dstt:7", "*dstt", CODE_FOR_vlfiiD_load, B_UID(454) };
+static const struct builtin B8_vec_dstt = { { &T_const_unsigned_long_ptr, &T_int, &T_immed_u2, }, "iiD", &T_volatile_void, 3, TRUE, FALSE, 0, "vec_dstt:8", "*dstt", CODE_FOR_vlfiiD_load, B_UID(455) };
+static const struct builtin B9_vec_dstt = { { &T_const_unsigned_short_ptr, &T_int, &T_immed_u2, }, "iiD", &T_volatile_void, 3, TRUE, FALSE, 0, "vec_dstt:9", "*dstt", CODE_FOR_vlfiiD_load, B_UID(456) };
+static const struct builtin B10_vec_dstt = { { &T_const_vec_b16_ptr, &T_int, &T_immed_u2, }, "iiD", &T_volatile_void, 3, TRUE, FALSE, 0, "vec_dstt:10", "*dstt", CODE_FOR_vlfiiD_load, B_UID(457) };
+static const struct builtin B11_vec_dstt = { { &T_const_vec_b32_ptr, &T_int, &T_immed_u2, }, "iiD", &T_volatile_void, 3, TRUE, FALSE, 0, "vec_dstt:11", "*dstt", CODE_FOR_vlfiiD_load, B_UID(458) };
+static const struct builtin B12_vec_dstt = { { &T_const_vec_b8_ptr, &T_int, &T_immed_u2, }, "iiD", &T_volatile_void, 3, TRUE, FALSE, 0, "vec_dstt:12", "*dstt", CODE_FOR_vlfiiD_load, B_UID(459) };
+static const struct builtin B13_vec_dstt = { { &T_const_vec_f32_ptr, &T_int, &T_immed_u2, }, "iiD", &T_volatile_void, 3, TRUE, FALSE, 0, "vec_dstt:13", "*dstt", CODE_FOR_vlfiiD_load, B_UID(460) };
+static const struct builtin B14_vec_dstt = { { &T_const_vec_p16_ptr, &T_int, &T_immed_u2, }, "iiD", &T_volatile_void, 3, TRUE, FALSE, 0, "vec_dstt:14", "*dstt", CODE_FOR_vlfiiD_load, B_UID(461) };
+static const struct builtin B15_vec_dstt = { { &T_const_vec_s16_ptr, &T_int, &T_immed_u2, }, "iiD", &T_volatile_void, 3, TRUE, FALSE, 0, "vec_dstt:15", "*dstt", CODE_FOR_vlfiiD_load, B_UID(462) };
+static const struct builtin B16_vec_dstt = { { &T_const_vec_s32_ptr, &T_int, &T_immed_u2, }, "iiD", &T_volatile_void, 3, TRUE, FALSE, 0, "vec_dstt:16", "*dstt", CODE_FOR_vlfiiD_load, B_UID(463) };
+static const struct builtin B17_vec_dstt = { { &T_const_vec_s8_ptr, &T_int, &T_immed_u2, }, "iiD", &T_volatile_void, 3, TRUE, FALSE, 0, "vec_dstt:17", "*dstt", CODE_FOR_vlfiiD_load, B_UID(464) };
+static const struct builtin B18_vec_dstt = { { &T_const_vec_u16_ptr, &T_int, &T_immed_u2, }, "iiD", &T_volatile_void, 3, TRUE, FALSE, 0, "vec_dstt:18", "*dstt", CODE_FOR_vlfiiD_load, B_UID(465) };
+static const struct builtin B19_vec_dstt = { { &T_const_vec_u32_ptr, &T_int, &T_immed_u2, }, "iiD", &T_volatile_void, 3, TRUE, FALSE, 0, "vec_dstt:19", "*dstt", CODE_FOR_vlfiiD_load, B_UID(466) };
+static const struct builtin B20_vec_dstt = { { &T_const_vec_u8_ptr, &T_int, &T_immed_u2, }, "iiD", &T_volatile_void, 3, TRUE, FALSE, 0, "vec_dstt:20", "*dstt", CODE_FOR_vlfiiD_load, B_UID(467) };
+static const struct builtin B_vec_vexptefp = { { &T_vec_f32, NULL, NULL, }, "x", &T_vec_f32, 1, FALSE, FALSE, 0, "vec_vexptefp", "*vexptefp", CODE_FOR_xfx_fp, B_UID(468) };
+static const struct builtin B_vec_vrfim = { { &T_vec_f32, NULL, NULL, }, "x", &T_vec_f32, 1, FALSE, FALSE, 0, "vec_vrfim", "*vrfim", CODE_FOR_xfx_fp, B_UID(469) };
+static const struct builtin B1_vec_lvx = { { &T_int, &T_const_float_ptr, NULL, }, "ii", &T_vec_f32, 2, TRUE, FALSE, 0, "vec_lvx:1", "*lvx", CODE_FOR_xlfii_load, B_UID(470) };
+static const struct builtin B2_vec_lvx = { { &T_int, &T_const_int_ptr, NULL, }, "ii", &T_vec_s32, 2, TRUE, FALSE, 0, "vec_lvx:2", "*lvx", CODE_FOR_xlfii_load, B_UID(471) };
+static const struct builtin B3_vec_lvx = { { &T_int, &T_const_long_ptr, NULL, }, "ii", &T_vec_s32, 2, TRUE, FALSE, 0, "vec_lvx:3", "*lvx", CODE_FOR_xlfii_load, B_UID(472) };
+static const struct builtin B4_vec_lvx = { { &T_int, &T_const_short_ptr, NULL, }, "ii", &T_vec_s16, 2, TRUE, FALSE, 0, "vec_lvx:4", "*lvx", CODE_FOR_xlfii_load, B_UID(473) };
+static const struct builtin B5_vec_lvx = { { &T_int, &T_const_signed_char_ptr, NULL, }, "ii", &T_vec_s8, 2, TRUE, FALSE, 0, "vec_lvx:5", "*lvx", CODE_FOR_xlfii_load, B_UID(474) };
+static const struct builtin B6_vec_lvx = { { &T_int, &T_const_unsigned_char_ptr, NULL, }, "ii", &T_vec_u8, 2, TRUE, FALSE, 0, "vec_lvx:6", "*lvx", CODE_FOR_xlfii_load, B_UID(475) };
+static const struct builtin B7_vec_lvx = { { &T_int, &T_const_unsigned_int_ptr, NULL, }, "ii", &T_vec_u32, 2, TRUE, FALSE, 0, "vec_lvx:7", "*lvx", CODE_FOR_xlfii_load, B_UID(476) };
+static const struct builtin B8_vec_lvx = { { &T_int, &T_const_unsigned_long_ptr, NULL, }, "ii", &T_vec_u32, 2, TRUE, FALSE, 0, "vec_lvx:8", "*lvx", CODE_FOR_xlfii_load, B_UID(477) };
+static const struct builtin B9_vec_lvx = { { &T_int, &T_const_unsigned_short_ptr, NULL, }, "ii", &T_vec_u16, 2, TRUE, FALSE, 0, "vec_lvx:9", "*lvx", CODE_FOR_xlfii_load, B_UID(478) };
+static const struct builtin B10_vec_lvx = { { &T_int, &T_const_vec_b16_ptr, NULL, }, "ii", &T_vec_b16, 2, TRUE, FALSE, 0, "vec_lvx:10", "*lvx", CODE_FOR_xlfii_load, B_UID(479) };
+static const struct builtin B11_vec_lvx = { { &T_int, &T_const_vec_b32_ptr, NULL, }, "ii", &T_vec_b32, 2, TRUE, FALSE, 0, "vec_lvx:11", "*lvx", CODE_FOR_xlfii_load, B_UID(480) };
+static const struct builtin B12_vec_lvx = { { &T_int, &T_const_vec_b8_ptr, NULL, }, "ii", &T_vec_b8, 2, TRUE, FALSE, 0, "vec_lvx:12", "*lvx", CODE_FOR_xlfii_load, B_UID(481) };
+static const struct builtin B13_vec_lvx = { { &T_int, &T_const_vec_f32_ptr, NULL, }, "ii", &T_vec_f32, 2, TRUE, FALSE, 0, "vec_lvx:13", "*lvx", CODE_FOR_xlfii_load, B_UID(482) };
+static const struct builtin B14_vec_lvx = { { &T_int, &T_const_vec_p16_ptr, NULL, }, "ii", &T_vec_p16, 2, TRUE, FALSE, 0, "vec_lvx:14", "*lvx", CODE_FOR_xlfii_load, B_UID(483) };
+static const struct builtin B15_vec_lvx = { { &T_int, &T_const_vec_s16_ptr, NULL, }, "ii", &T_vec_s16, 2, TRUE, FALSE, 0, "vec_lvx:15", "*lvx", CODE_FOR_xlfii_load, B_UID(484) };
+static const struct builtin B16_vec_lvx = { { &T_int, &T_const_vec_s32_ptr, NULL, }, "ii", &T_vec_s32, 2, TRUE, FALSE, 0, "vec_lvx:16", "*lvx", CODE_FOR_xlfii_load, B_UID(485) };
+static const struct builtin B17_vec_lvx = { { &T_int, &T_const_vec_s8_ptr, NULL, }, "ii", &T_vec_s8, 2, TRUE, FALSE, 0, "vec_lvx:17", "*lvx", CODE_FOR_xlfii_load, B_UID(486) };
+static const struct builtin B18_vec_lvx = { { &T_int, &T_const_vec_u16_ptr, NULL, }, "ii", &T_vec_u16, 2, TRUE, FALSE, 0, "vec_lvx:18", "*lvx", CODE_FOR_xlfii_load, B_UID(487) };
+static const struct builtin B19_vec_lvx = { { &T_int, &T_const_vec_u32_ptr, NULL, }, "ii", &T_vec_u32, 2, TRUE, FALSE, 0, "vec_lvx:19", "*lvx", CODE_FOR_xlfii_load, B_UID(488) };
+static const struct builtin B20_vec_lvx = { { &T_int, &T_const_vec_u8_ptr, NULL, }, "ii", &T_vec_u8, 2, TRUE, FALSE, 0, "vec_lvx:20", "*lvx", CODE_FOR_xlfii_load, B_UID(489) };
+static const struct builtin B1_vec_lvewx = { { &T_int, &T_const_float_ptr, NULL, }, "ii", &T_vec_f32, 2, TRUE, FALSE, 0, "vec_lvewx:1", "*lvewx", CODE_FOR_xlfii_load, B_UID(490) };
+static const struct builtin B2_vec_lvewx = { { &T_int, &T_const_int_ptr, NULL, }, "ii", &T_vec_s32, 2, TRUE, FALSE, 0, "vec_lvewx:2", "*lvewx", CODE_FOR_xlfii_load, B_UID(491) };
+static const struct builtin B3_vec_lvewx = { { &T_int, &T_const_long_ptr, NULL, }, "ii", &T_vec_s32, 2, TRUE, FALSE, 0, "vec_lvewx:3", "*lvewx", CODE_FOR_xlfii_load, B_UID(492) };
+static const struct builtin B1_vec_lvehx = { { &T_int, &T_const_short_ptr, NULL, }, "ii", &T_vec_s16, 2, TRUE, FALSE, 0, "vec_lvehx:1", "*lvehx", CODE_FOR_xlfii_load, B_UID(493) };
+static const struct builtin B1_vec_lvebx = { { &T_int, &T_const_signed_char_ptr, NULL, }, "ii", &T_vec_s8, 2, TRUE, FALSE, 0, "vec_lvebx:1", "*lvebx", CODE_FOR_xlfii_load, B_UID(494) };
+static const struct builtin B2_vec_lvebx = { { &T_int, &T_const_unsigned_char_ptr, NULL, }, "ii", &T_vec_u8, 2, TRUE, FALSE, 0, "vec_lvebx:2", "*lvebx", CODE_FOR_xlfii_load, B_UID(495) };
+static const struct builtin B4_vec_lvewx = { { &T_int, &T_const_unsigned_int_ptr, NULL, }, "ii", &T_vec_u32, 2, TRUE, FALSE, 0, "vec_lvewx:4", "*lvewx", CODE_FOR_xlfii_load, B_UID(496) };
+static const struct builtin B5_vec_lvewx = { { &T_int, &T_const_unsigned_long_ptr, NULL, }, "ii", &T_vec_u32, 2, TRUE, FALSE, 0, "vec_lvewx:5", "*lvewx", CODE_FOR_xlfii_load, B_UID(497) };
+static const struct builtin B2_vec_lvehx = { { &T_int, &T_const_unsigned_short_ptr, NULL, }, "ii", &T_vec_u16, 2, TRUE, FALSE, 0, "vec_lvehx:2", "*lvehx", CODE_FOR_xlfii_load, B_UID(498) };
+static const struct builtin B1_vec_lvxl = { { &T_int, &T_const_float_ptr, NULL, }, "ii", &T_vec_f32, 2, TRUE, FALSE, 0, "vec_lvxl:1", "*lvxl", CODE_FOR_xlfii_load, B_UID(499) };
+static const struct builtin B2_vec_lvxl = { { &T_int, &T_const_int_ptr, NULL, }, "ii", &T_vec_s32, 2, TRUE, FALSE, 0, "vec_lvxl:2", "*lvxl", CODE_FOR_xlfii_load, B_UID(500) };
+static const struct builtin B3_vec_lvxl = { { &T_int, &T_const_long_ptr, NULL, }, "ii", &T_vec_s32, 2, TRUE, FALSE, 0, "vec_lvxl:3", "*lvxl", CODE_FOR_xlfii_load, B_UID(501) };
+static const struct builtin B4_vec_lvxl = { { &T_int, &T_const_short_ptr, NULL, }, "ii", &T_vec_s16, 2, TRUE, FALSE, 0, "vec_lvxl:4", "*lvxl", CODE_FOR_xlfii_load, B_UID(502) };
+static const struct builtin B5_vec_lvxl = { { &T_int, &T_const_signed_char_ptr, NULL, }, "ii", &T_vec_s8, 2, TRUE, FALSE, 0, "vec_lvxl:5", "*lvxl", CODE_FOR_xlfii_load, B_UID(503) };
+static const struct builtin B6_vec_lvxl = { { &T_int, &T_const_unsigned_char_ptr, NULL, }, "ii", &T_vec_u8, 2, TRUE, FALSE, 0, "vec_lvxl:6", "*lvxl", CODE_FOR_xlfii_load, B_UID(504) };
+static const struct builtin B7_vec_lvxl = { { &T_int, &T_const_unsigned_int_ptr, NULL, }, "ii", &T_vec_u32, 2, TRUE, FALSE, 0, "vec_lvxl:7", "*lvxl", CODE_FOR_xlfii_load, B_UID(505) };
+static const struct builtin B8_vec_lvxl = { { &T_int, &T_const_unsigned_long_ptr, NULL, }, "ii", &T_vec_u32, 2, TRUE, FALSE, 0, "vec_lvxl:8", "*lvxl", CODE_FOR_xlfii_load, B_UID(506) };
+static const struct builtin B9_vec_lvxl = { { &T_int, &T_const_unsigned_short_ptr, NULL, }, "ii", &T_vec_u16, 2, TRUE, FALSE, 0, "vec_lvxl:9", "*lvxl", CODE_FOR_xlfii_load, B_UID(507) };
+static const struct builtin B10_vec_lvxl = { { &T_int, &T_const_vec_b16_ptr, NULL, }, "ii", &T_vec_b16, 2, TRUE, FALSE, 0, "vec_lvxl:10", "*lvxl", CODE_FOR_xlfii_load, B_UID(508) };
+static const struct builtin B11_vec_lvxl = { { &T_int, &T_const_vec_b32_ptr, NULL, }, "ii", &T_vec_b32, 2, TRUE, FALSE, 0, "vec_lvxl:11", "*lvxl", CODE_FOR_xlfii_load, B_UID(509) };
+static const struct builtin B12_vec_lvxl = { { &T_int, &T_const_vec_b8_ptr, NULL, }, "ii", &T_vec_b8, 2, TRUE, FALSE, 0, "vec_lvxl:12", "*lvxl", CODE_FOR_xlfii_load, B_UID(510) };
+static const struct builtin B13_vec_lvxl = { { &T_int, &T_const_vec_f32_ptr, NULL, }, "ii", &T_vec_f32, 2, TRUE, FALSE, 0, "vec_lvxl:13", "*lvxl", CODE_FOR_xlfii_load, B_UID(511) };
+static const struct builtin B14_vec_lvxl = { { &T_int, &T_const_vec_p16_ptr, NULL, }, "ii", &T_vec_p16, 2, TRUE, FALSE, 0, "vec_lvxl:14", "*lvxl", CODE_FOR_xlfii_load, B_UID(512) };
+static const struct builtin B15_vec_lvxl = { { &T_int, &T_const_vec_s16_ptr, NULL, }, "ii", &T_vec_s16, 2, TRUE, FALSE, 0, "vec_lvxl:15", "*lvxl", CODE_FOR_xlfii_load, B_UID(513) };
+static const struct builtin B16_vec_lvxl = { { &T_int, &T_const_vec_s32_ptr, NULL, }, "ii", &T_vec_s32, 2, TRUE, FALSE, 0, "vec_lvxl:16", "*lvxl", CODE_FOR_xlfii_load, B_UID(514) };
+static const struct builtin B17_vec_lvxl = { { &T_int, &T_const_vec_s8_ptr, NULL, }, "ii", &T_vec_s8, 2, TRUE, FALSE, 0, "vec_lvxl:17", "*lvxl", CODE_FOR_xlfii_load, B_UID(515) };
+static const struct builtin B18_vec_lvxl = { { &T_int, &T_const_vec_u16_ptr, NULL, }, "ii", &T_vec_u16, 2, TRUE, FALSE, 0, "vec_lvxl:18", "*lvxl", CODE_FOR_xlfii_load, B_UID(516) };
+static const struct builtin B19_vec_lvxl = { { &T_int, &T_const_vec_u32_ptr, NULL, }, "ii", &T_vec_u32, 2, TRUE, FALSE, 0, "vec_lvxl:19", "*lvxl", CODE_FOR_xlfii_load, B_UID(517) };
+static const struct builtin B20_vec_lvxl = { { &T_int, &T_const_vec_u8_ptr, NULL, }, "ii", &T_vec_u8, 2, TRUE, FALSE, 0, "vec_lvxl:20", "*lvxl", CODE_FOR_xlfii_load, B_UID(518) };
+static const struct builtin B_vec_vlogefp = { { &T_vec_f32, NULL, NULL, }, "x", &T_vec_f32, 1, FALSE, FALSE, 0, "vec_vlogefp", "*vlogefp", CODE_FOR_xfx_fp, B_UID(519) };
+static const struct builtin B1_vec_lvsl = { { &T_int, &T_const_volatile_float_ptr, NULL, }, "ii", &T_vec_u8, 2, TRUE, TRUE, 8, "vec_lvsl:1", "*lvsl", CODE_FOR_xfii_load, B_UID(520) };
+static const struct builtin B2_vec_lvsl = { { &T_int, &T_const_volatile_int_ptr, NULL, }, "ii", &T_vec_u8, 2, TRUE, TRUE, 8, "vec_lvsl:2", "*lvsl", CODE_FOR_xfii_load, B_UID(521) };
+static const struct builtin B3_vec_lvsl = { { &T_int, &T_const_volatile_long_ptr, NULL, }, "ii", &T_vec_u8, 2, TRUE, TRUE, 8, "vec_lvsl:3", "*lvsl", CODE_FOR_xfii_load, B_UID(522) };
+static const struct builtin B4_vec_lvsl = { { &T_int, &T_const_volatile_short_ptr, NULL, }, "ii", &T_vec_u8, 2, TRUE, TRUE, 8, "vec_lvsl:4", "*lvsl", CODE_FOR_xfii_load, B_UID(523) };
+static const struct builtin B5_vec_lvsl = { { &T_int, &T_const_volatile_signed_char_ptr, NULL, }, "ii", &T_vec_u8, 2, TRUE, TRUE, 8, "vec_lvsl:5", "*lvsl", CODE_FOR_xfii_load, B_UID(524) };
+static const struct builtin B6_vec_lvsl = { { &T_int, &T_const_volatile_unsigned_char_ptr, NULL, }, "ii", &T_vec_u8, 2, TRUE, TRUE, 8, "vec_lvsl:6", "*lvsl", CODE_FOR_xfii_load, B_UID(525) };
+static const struct builtin B7_vec_lvsl = { { &T_int, &T_const_volatile_unsigned_int_ptr, NULL, }, "ii", &T_vec_u8, 2, TRUE, TRUE, 8, "vec_lvsl:7", "*lvsl", CODE_FOR_xfii_load, B_UID(526) };
+static const struct builtin B8_vec_lvsl = { { &T_int, &T_const_volatile_unsigned_long_ptr, NULL, }, "ii", &T_vec_u8, 2, TRUE, TRUE, 8, "vec_lvsl:8", "*lvsl", CODE_FOR_xfii_load, B_UID(527) };
+static const struct builtin B9_vec_lvsl = { { &T_int, &T_const_volatile_unsigned_short_ptr, NULL, }, "ii", &T_vec_u8, 2, TRUE, TRUE, 8, "vec_lvsl:9", "*lvsl", CODE_FOR_xfii_load, B_UID(528) };
+static const struct builtin B1_vec_lvsr = { { &T_int, &T_const_volatile_float_ptr, NULL, }, "ii", &T_vec_u8, 2, TRUE, TRUE, 9, "vec_lvsr:1", "*lvsr", CODE_FOR_xfii_load, B_UID(529) };
+static const struct builtin B2_vec_lvsr = { { &T_int, &T_const_volatile_int_ptr, NULL, }, "ii", &T_vec_u8, 2, TRUE, TRUE, 9, "vec_lvsr:2", "*lvsr", CODE_FOR_xfii_load, B_UID(530) };
+static const struct builtin B3_vec_lvsr = { { &T_int, &T_const_volatile_long_ptr, NULL, }, "ii", &T_vec_u8, 2, TRUE, TRUE, 9, "vec_lvsr:3", "*lvsr", CODE_FOR_xfii_load, B_UID(531) };
+static const struct builtin B4_vec_lvsr = { { &T_int, &T_const_volatile_short_ptr, NULL, }, "ii", &T_vec_u8, 2, TRUE, TRUE, 9, "vec_lvsr:4", "*lvsr", CODE_FOR_xfii_load, B_UID(532) };
+static const struct builtin B5_vec_lvsr = { { &T_int, &T_const_volatile_signed_char_ptr, NULL, }, "ii", &T_vec_u8, 2, TRUE, TRUE, 9, "vec_lvsr:5", "*lvsr", CODE_FOR_xfii_load, B_UID(533) };
+static const struct builtin B6_vec_lvsr = { { &T_int, &T_const_volatile_unsigned_char_ptr, NULL, }, "ii", &T_vec_u8, 2, TRUE, TRUE, 9, "vec_lvsr:6", "*lvsr", CODE_FOR_xfii_load, B_UID(534) };
+static const struct builtin B7_vec_lvsr = { { &T_int, &T_const_volatile_unsigned_int_ptr, NULL, }, "ii", &T_vec_u8, 2, TRUE, TRUE, 9, "vec_lvsr:7", "*lvsr", CODE_FOR_xfii_load, B_UID(535) };
+static const struct builtin B8_vec_lvsr = { { &T_int, &T_const_volatile_unsigned_long_ptr, NULL, }, "ii", &T_vec_u8, 2, TRUE, TRUE, 9, "vec_lvsr:8", "*lvsr", CODE_FOR_xfii_load, B_UID(536) };
+static const struct builtin B9_vec_lvsr = { { &T_int, &T_const_volatile_unsigned_short_ptr, NULL, }, "ii", &T_vec_u8, 2, TRUE, TRUE, 9, "vec_lvsr:9", "*lvsr", CODE_FOR_xfii_load, B_UID(537) };
+static const struct builtin B_vec_vmaddfp = { { &T_vec_f32, &T_vec_f32, &T_vec_f32, }, "xxx", &T_vec_f32, 3, FALSE, FALSE, 0, "vec_vmaddfp", "*vmaddfp", CODE_FOR_xfxxx_fp, B_UID(538) };
+static const struct builtin B_vec_vmhaddshs = { { &T_vec_s16, &T_vec_s16, &T_vec_s16, }, "xxx", &T_vec_s16, 3, FALSE, FALSE, 0, "vec_vmhaddshs", "*vmhaddshs", CODE_FOR_xfxxx_complex, B_UID(539) };
+static const struct builtin B1_vec_vmaxsh = { { &T_vec_b16, &T_vec_s16, NULL, }, "xx", &T_vec_s16, 2, FALSE, FALSE, 2, "vec_vmaxsh:1", "*vmaxsh", CODE_FOR_xfxx_simple, B_UID(540) };
+static const struct builtin B1_vec_vmaxuh = { { &T_vec_b16, &T_vec_u16, NULL, }, "xx", &T_vec_u16, 2, FALSE, FALSE, 2, "vec_vmaxuh:1", "*vmaxuh", CODE_FOR_xfxx_simple, B_UID(541) };
+static const struct builtin B1_vec_vmaxsw = { { &T_vec_b32, &T_vec_s32, NULL, }, "xx", &T_vec_s32, 2, FALSE, FALSE, 2, "vec_vmaxsw:1", "*vmaxsw", CODE_FOR_xfxx_simple, B_UID(542) };
+static const struct builtin B1_vec_vmaxuw = { { &T_vec_b32, &T_vec_u32, NULL, }, "xx", &T_vec_u32, 2, FALSE, FALSE, 2, "vec_vmaxuw:1", "*vmaxuw", CODE_FOR_xfxx_simple, B_UID(543) };
+static const struct builtin B1_vec_vmaxsb = { { &T_vec_b8, &T_vec_s8, NULL, }, "xx", &T_vec_s8, 2, FALSE, FALSE, 2, "vec_vmaxsb:1", "*vmaxsb", CODE_FOR_xfxx_simple, B_UID(544) };
+static const struct builtin B1_vec_vmaxub = { { &T_vec_b8, &T_vec_u8, NULL, }, "xx", &T_vec_u8, 2, FALSE, FALSE, 2, "vec_vmaxub:1", "*vmaxub", CODE_FOR_xfxx_simple, B_UID(545) };
+static const struct builtin B_vec_vmaxfp = { { &T_vec_f32, &T_vec_f32, NULL, }, "xx", &T_vec_f32, 2, FALSE, FALSE, 2, "vec_vmaxfp", "*vmaxfp", CODE_FOR_xfxx_simple, B_UID(546) };
+static const struct builtin B2_vec_vmaxsh = { { &T_vec_s16, &T_vec_b16, NULL, }, "xx", &T_vec_s16, 2, FALSE, FALSE, 2, "vec_vmaxsh:2", "*vmaxsh", CODE_FOR_xfxx_simple, B_UID(547) };
+static const struct builtin B3_vec_vmaxsh = { { &T_vec_s16, &T_vec_s16, NULL, }, "xx", &T_vec_s16, 2, FALSE, FALSE, 2, "vec_vmaxsh:3", "*vmaxsh", CODE_FOR_xfxx_simple, B_UID(548) };
+static const struct builtin B2_vec_vmaxsw = { { &T_vec_s32, &T_vec_b32, NULL, }, "xx", &T_vec_s32, 2, FALSE, FALSE, 2, "vec_vmaxsw:2", "*vmaxsw", CODE_FOR_xfxx_simple, B_UID(549) };
+static const struct builtin B3_vec_vmaxsw = { { &T_vec_s32, &T_vec_s32, NULL, }, "xx", &T_vec_s32, 2, FALSE, FALSE, 2, "vec_vmaxsw:3", "*vmaxsw", CODE_FOR_xfxx_simple, B_UID(550) };
+static const struct builtin B2_vec_vmaxsb = { { &T_vec_s8, &T_vec_b8, NULL, }, "xx", &T_vec_s8, 2, FALSE, FALSE, 2, "vec_vmaxsb:2", "*vmaxsb", CODE_FOR_xfxx_simple, B_UID(551) };
+static const struct builtin B3_vec_vmaxsb = { { &T_vec_s8, &T_vec_s8, NULL, }, "xx", &T_vec_s8, 2, FALSE, FALSE, 2, "vec_vmaxsb:3", "*vmaxsb", CODE_FOR_xfxx_simple, B_UID(552) };
+static const struct builtin B2_vec_vmaxuh = { { &T_vec_u16, &T_vec_b16, NULL, }, "xx", &T_vec_u16, 2, FALSE, FALSE, 2, "vec_vmaxuh:2", "*vmaxuh", CODE_FOR_xfxx_simple, B_UID(553) };
+static const struct builtin B3_vec_vmaxuh = { { &T_vec_u16, &T_vec_u16, NULL, }, "xx", &T_vec_u16, 2, FALSE, FALSE, 2, "vec_vmaxuh:3", "*vmaxuh", CODE_FOR_xfxx_simple, B_UID(554) };
+static const struct builtin B2_vec_vmaxuw = { { &T_vec_u32, &T_vec_b32, NULL, }, "xx", &T_vec_u32, 2, FALSE, FALSE, 2, "vec_vmaxuw:2", "*vmaxuw", CODE_FOR_xfxx_simple, B_UID(555) };
+static const struct builtin B3_vec_vmaxuw = { { &T_vec_u32, &T_vec_u32, NULL, }, "xx", &T_vec_u32, 2, FALSE, FALSE, 2, "vec_vmaxuw:3", "*vmaxuw", CODE_FOR_xfxx_simple, B_UID(556) };
+static const struct builtin B2_vec_vmaxub = { { &T_vec_u8, &T_vec_b8, NULL, }, "xx", &T_vec_u8, 2, FALSE, FALSE, 2, "vec_vmaxub:2", "*vmaxub", CODE_FOR_xfxx_simple, B_UID(557) };
+static const struct builtin B3_vec_vmaxub = { { &T_vec_u8, &T_vec_u8, NULL, }, "xx", &T_vec_u8, 2, FALSE, FALSE, 2, "vec_vmaxub:3", "*vmaxub", CODE_FOR_xfxx_simple, B_UID(558) };
+static const struct builtin B1_vec_vmrghh = { { &T_vec_b16, &T_vec_b16, NULL, }, "xx", &T_vec_b16, 2, FALSE, FALSE, 0, "vec_vmrghh:1", "*vmrghh", CODE_FOR_xfxx_perm, B_UID(559) };
+static const struct builtin B1_vec_vmrghw = { { &T_vec_b32, &T_vec_b32, NULL, }, "xx", &T_vec_b32, 2, FALSE, FALSE, 0, "vec_vmrghw:1", "*vmrghw", CODE_FOR_xfxx_perm, B_UID(560) };
+static const struct builtin B1_vec_vmrghb = { { &T_vec_b8, &T_vec_b8, NULL, }, "xx", &T_vec_b8, 2, FALSE, FALSE, 0, "vec_vmrghb:1", "*vmrghb", CODE_FOR_xfxx_perm, B_UID(561) };
+static const struct builtin B2_vec_vmrghw = { { &T_vec_f32, &T_vec_f32, NULL, }, "xx", &T_vec_f32, 2, FALSE, FALSE, 0, "vec_vmrghw:2", "*vmrghw", CODE_FOR_xfxx_perm, B_UID(562) };
+static const struct builtin B2_vec_vmrghh = { { &T_vec_p16, &T_vec_p16, NULL, }, "xx", &T_vec_p16, 2, FALSE, FALSE, 0, "vec_vmrghh:2", "*vmrghh", CODE_FOR_xfxx_perm, B_UID(563) };
+static const struct builtin B3_vec_vmrghh = { { &T_vec_s16, &T_vec_s16, NULL, }, "xx", &T_vec_s16, 2, FALSE, FALSE, 0, "vec_vmrghh:3", "*vmrghh", CODE_FOR_xfxx_perm, B_UID(564) };
+static const struct builtin B3_vec_vmrghw = { { &T_vec_s32, &T_vec_s32, NULL, }, "xx", &T_vec_s32, 2, FALSE, FALSE, 0, "vec_vmrghw:3", "*vmrghw", CODE_FOR_xfxx_perm, B_UID(565) };
+static const struct builtin B2_vec_vmrghb = { { &T_vec_s8, &T_vec_s8, NULL, }, "xx", &T_vec_s8, 2, FALSE, FALSE, 0, "vec_vmrghb:2", "*vmrghb", CODE_FOR_xfxx_perm, B_UID(566) };
+static const struct builtin B4_vec_vmrghh = { { &T_vec_u16, &T_vec_u16, NULL, }, "xx", &T_vec_u16, 2, FALSE, FALSE, 0, "vec_vmrghh:4", "*vmrghh", CODE_FOR_xfxx_perm, B_UID(567) };
+static const struct builtin B4_vec_vmrghw = { { &T_vec_u32, &T_vec_u32, NULL, }, "xx", &T_vec_u32, 2, FALSE, FALSE, 0, "vec_vmrghw:4", "*vmrghw", CODE_FOR_xfxx_perm, B_UID(568) };
+static const struct builtin B3_vec_vmrghb = { { &T_vec_u8, &T_vec_u8, NULL, }, "xx", &T_vec_u8, 2, FALSE, FALSE, 0, "vec_vmrghb:3", "*vmrghb", CODE_FOR_xfxx_perm, B_UID(569) };
+static const struct builtin B1_vec_vmrglh = { { &T_vec_b16, &T_vec_b16, NULL, }, "xx", &T_vec_b16, 2, FALSE, FALSE, 0, "vec_vmrglh:1", "*vmrglh", CODE_FOR_xfxx_perm, B_UID(570) };
+static const struct builtin B1_vec_vmrglw = { { &T_vec_b32, &T_vec_b32, NULL, }, "xx", &T_vec_b32, 2, FALSE, FALSE, 0, "vec_vmrglw:1", "*vmrglw", CODE_FOR_xfxx_perm, B_UID(571) };
+static const struct builtin B1_vec_vmrglb = { { &T_vec_b8, &T_vec_b8, NULL, }, "xx", &T_vec_b8, 2, FALSE, FALSE, 0, "vec_vmrglb:1", "*vmrglb", CODE_FOR_xfxx_perm, B_UID(572) };
+static const struct builtin B2_vec_vmrglw = { { &T_vec_f32, &T_vec_f32, NULL, }, "xx", &T_vec_f32, 2, FALSE, FALSE, 0, "vec_vmrglw:2", "*vmrglw", CODE_FOR_xfxx_perm, B_UID(573) };
+static const struct builtin B2_vec_vmrglh = { { &T_vec_p16, &T_vec_p16, NULL, }, "xx", &T_vec_p16, 2, FALSE, FALSE, 0, "vec_vmrglh:2", "*vmrglh", CODE_FOR_xfxx_perm, B_UID(574) };
+static const struct builtin B3_vec_vmrglh = { { &T_vec_s16, &T_vec_s16, NULL, }, "xx", &T_vec_s16, 2, FALSE, FALSE, 0, "vec_vmrglh:3", "*vmrglh", CODE_FOR_xfxx_perm, B_UID(575) };
+static const struct builtin B3_vec_vmrglw = { { &T_vec_s32, &T_vec_s32, NULL, }, "xx", &T_vec_s32, 2, FALSE, FALSE, 0, "vec_vmrglw:3", "*vmrglw", CODE_FOR_xfxx_perm, B_UID(576) };
+static const struct builtin B2_vec_vmrglb = { { &T_vec_s8, &T_vec_s8, NULL, }, "xx", &T_vec_s8, 2, FALSE, FALSE, 0, "vec_vmrglb:2", "*vmrglb", CODE_FOR_xfxx_perm, B_UID(577) };
+static const struct builtin B4_vec_vmrglh = { { &T_vec_u16, &T_vec_u16, NULL, }, "xx", &T_vec_u16, 2, FALSE, FALSE, 0, "vec_vmrglh:4", "*vmrglh", CODE_FOR_xfxx_perm, B_UID(578) };
+static const struct builtin B4_vec_vmrglw = { { &T_vec_u32, &T_vec_u32, NULL, }, "xx", &T_vec_u32, 2, FALSE, FALSE, 0, "vec_vmrglw:4", "*vmrglw", CODE_FOR_xfxx_perm, B_UID(579) };
+static const struct builtin B3_vec_vmrglb = { { &T_vec_u8, &T_vec_u8, NULL, }, "xx", &T_vec_u8, 2, FALSE, FALSE, 0, "vec_vmrglb:3", "*vmrglb", CODE_FOR_xfxx_perm, B_UID(580) };
+static const struct builtin B_vec_mfvscr = { { NULL, NULL, NULL, }, "", &T_volatile_vec_u16, 0, FALSE, FALSE, 0, "vec_mfvscr", "*mfvscr", CODE_FOR_vxf_fxu, B_UID(581) };
+static const struct builtin B1_vec_vminsh = { { &T_vec_b16, &T_vec_s16, NULL, }, "xx", &T_vec_s16, 2, FALSE, FALSE, 2, "vec_vminsh:1", "*vminsh", CODE_FOR_xfxx_simple, B_UID(582) };
+static const struct builtin B1_vec_vminuh = { { &T_vec_b16, &T_vec_u16, NULL, }, "xx", &T_vec_u16, 2, FALSE, FALSE, 2, "vec_vminuh:1", "*vminuh", CODE_FOR_xfxx_simple, B_UID(583) };
+static const struct builtin B1_vec_vminsw = { { &T_vec_b32, &T_vec_s32, NULL, }, "xx", &T_vec_s32, 2, FALSE, FALSE, 2, "vec_vminsw:1", "*vminsw", CODE_FOR_xfxx_simple, B_UID(584) };
+static const struct builtin B1_vec_vminuw = { { &T_vec_b32, &T_vec_u32, NULL, }, "xx", &T_vec_u32, 2, FALSE, FALSE, 2, "vec_vminuw:1", "*vminuw", CODE_FOR_xfxx_simple, B_UID(585) };
+static const struct builtin B1_vec_vminsb = { { &T_vec_b8, &T_vec_s8, NULL, }, "xx", &T_vec_s8, 2, FALSE, FALSE, 2, "vec_vminsb:1", "*vminsb", CODE_FOR_xfxx_simple, B_UID(586) };
+static const struct builtin B1_vec_vminub = { { &T_vec_b8, &T_vec_u8, NULL, }, "xx", &T_vec_u8, 2, FALSE, FALSE, 2, "vec_vminub:1", "*vminub", CODE_FOR_xfxx_simple, B_UID(587) };
+static const struct builtin B_vec_vminfp = { { &T_vec_f32, &T_vec_f32, NULL, }, "xx", &T_vec_f32, 2, FALSE, FALSE, 2, "vec_vminfp", "*vminfp", CODE_FOR_xfxx_simple, B_UID(588) };
+static const struct builtin B2_vec_vminsh = { { &T_vec_s16, &T_vec_b16, NULL, }, "xx", &T_vec_s16, 2, FALSE, FALSE, 2, "vec_vminsh:2", "*vminsh", CODE_FOR_xfxx_simple, B_UID(589) };
+static const struct builtin B3_vec_vminsh = { { &T_vec_s16, &T_vec_s16, NULL, }, "xx", &T_vec_s16, 2, FALSE, FALSE, 2, "vec_vminsh:3", "*vminsh", CODE_FOR_xfxx_simple, B_UID(590) };
+static const struct builtin B2_vec_vminsw = { { &T_vec_s32, &T_vec_b32, NULL, }, "xx", &T_vec_s32, 2, FALSE, FALSE, 2, "vec_vminsw:2", "*vminsw", CODE_FOR_xfxx_simple, B_UID(591) };
+static const struct builtin B3_vec_vminsw = { { &T_vec_s32, &T_vec_s32, NULL, }, "xx", &T_vec_s32, 2, FALSE, FALSE, 2, "vec_vminsw:3", "*vminsw", CODE_FOR_xfxx_simple, B_UID(592) };
+static const struct builtin B2_vec_vminsb = { { &T_vec_s8, &T_vec_b8, NULL, }, "xx", &T_vec_s8, 2, FALSE, FALSE, 2, "vec_vminsb:2", "*vminsb", CODE_FOR_xfxx_simple, B_UID(593) };
+static const struct builtin B3_vec_vminsb = { { &T_vec_s8, &T_vec_s8, NULL, }, "xx", &T_vec_s8, 2, FALSE, FALSE, 2, "vec_vminsb:3", "*vminsb", CODE_FOR_xfxx_simple, B_UID(594) };
+static const struct builtin B2_vec_vminuh = { { &T_vec_u16, &T_vec_b16, NULL, }, "xx", &T_vec_u16, 2, FALSE, FALSE, 2, "vec_vminuh:2", "*vminuh", CODE_FOR_xfxx_simple, B_UID(595) };
+static const struct builtin B3_vec_vminuh = { { &T_vec_u16, &T_vec_u16, NULL, }, "xx", &T_vec_u16, 2, FALSE, FALSE, 2, "vec_vminuh:3", "*vminuh", CODE_FOR_xfxx_simple, B_UID(596) };
+static const struct builtin B2_vec_vminuw = { { &T_vec_u32, &T_vec_b32, NULL, }, "xx", &T_vec_u32, 2, FALSE, FALSE, 2, "vec_vminuw:2", "*vminuw", CODE_FOR_xfxx_simple, B_UID(597) };
+static const struct builtin B3_vec_vminuw = { { &T_vec_u32, &T_vec_u32, NULL, }, "xx", &T_vec_u32, 2, FALSE, FALSE, 2, "vec_vminuw:3", "*vminuw", CODE_FOR_xfxx_simple, B_UID(598) };
+static const struct builtin B2_vec_vminub = { { &T_vec_u8, &T_vec_b8, NULL, }, "xx", &T_vec_u8, 2, FALSE, FALSE, 2, "vec_vminub:2", "*vminub", CODE_FOR_xfxx_simple, B_UID(599) };
+static const struct builtin B3_vec_vminub = { { &T_vec_u8, &T_vec_u8, NULL, }, "xx", &T_vec_u8, 2, FALSE, FALSE, 2, "vec_vminub:3", "*vminub", CODE_FOR_xfxx_simple, B_UID(600) };
+static const struct builtin B1_vec_vmladduhm = { { &T_vec_s16, &T_vec_s16, &T_vec_s16, }, "xxx", &T_vec_s16, 3, FALSE, FALSE, 0, "vec_vmladduhm:1", "*vmladduhm", CODE_FOR_xfxxx_complex, B_UID(601) };
+static const struct builtin B2_vec_vmladduhm = { { &T_vec_s16, &T_vec_u16, &T_vec_u16, }, "xxx", &T_vec_s16, 3, FALSE, FALSE, 0, "vec_vmladduhm:2", "*vmladduhm", CODE_FOR_xfxxx_complex, B_UID(602) };
+static const struct builtin B3_vec_vmladduhm = { { &T_vec_u16, &T_vec_s16, &T_vec_s16, }, "xxx", &T_vec_s16, 3, FALSE, FALSE, 0, "vec_vmladduhm:3", "*vmladduhm", CODE_FOR_xfxxx_complex, B_UID(603) };
+static const struct builtin B4_vec_vmladduhm = { { &T_vec_u16, &T_vec_u16, &T_vec_u16, }, "xxx", &T_vec_u16, 3, FALSE, FALSE, 0, "vec_vmladduhm:4", "*vmladduhm", CODE_FOR_xfxxx_complex, B_UID(604) };
+static const struct builtin B_vec_vmhraddshs = { { &T_vec_s16, &T_vec_s16, &T_vec_s16, }, "xxx", &T_vec_s16, 3, FALSE, FALSE, 0, "vec_vmhraddshs", "*vmhraddshs", CODE_FOR_xfxxx_complex, B_UID(605) };
+static const struct builtin B_vec_vmsumshm = { { &T_vec_s16, &T_vec_s16, &T_vec_s32, }, "xxx", &T_vec_s32, 3, FALSE, FALSE, 0, "vec_vmsumshm", "*vmsumshm", CODE_FOR_xfxxx_complex, B_UID(606) };
+static const struct builtin B_vec_vmsummbm = { { &T_vec_s8, &T_vec_u8, &T_vec_s32, }, "xxx", &T_vec_s32, 3, FALSE, FALSE, 0, "vec_vmsummbm", "*vmsummbm", CODE_FOR_xfxxx_complex, B_UID(607) };
+static const struct builtin B_vec_vmsumuhm = { { &T_vec_u16, &T_vec_u16, &T_vec_u32, }, "xxx", &T_vec_u32, 3, FALSE, FALSE, 0, "vec_vmsumuhm", "*vmsumuhm", CODE_FOR_xfxxx_complex, B_UID(608) };
+static const struct builtin B_vec_vmsumubm = { { &T_vec_u8, &T_vec_u8, &T_vec_u32, }, "xxx", &T_vec_u32, 3, FALSE, FALSE, 0, "vec_vmsumubm", "*vmsumubm", CODE_FOR_xfxxx_complex, B_UID(609) };
+static const struct builtin B_vec_vmsumshs = { { &T_vec_s16, &T_vec_s16, &T_vec_s32, }, "xxx", &T_vec_s32, 3, FALSE, FALSE, 0, "vec_vmsumshs", "*vmsumshs", CODE_FOR_xfxxx_complex, B_UID(610) };
+static const struct builtin B_vec_vmsumuhs = { { &T_vec_u16, &T_vec_u16, &T_vec_u32, }, "xxx", &T_vec_u32, 3, FALSE, FALSE, 0, "vec_vmsumuhs", "*vmsumuhs", CODE_FOR_xfxxx_complex, B_UID(611) };
+static const struct builtin B1_vec_mtvscr = { { &T_vec_b16, NULL, NULL, }, "x", &T_volatile_void, 1, FALSE, FALSE, 0, "vec_mtvscr:1", "*mtvscr", CODE_FOR_vfx_fxu, B_UID(612) };
+static const struct builtin B2_vec_mtvscr = { { &T_vec_b32, NULL, NULL, }, "x", &T_volatile_void, 1, FALSE, FALSE, 0, "vec_mtvscr:2", "*mtvscr", CODE_FOR_vfx_fxu, B_UID(613) };
+static const struct builtin B3_vec_mtvscr = { { &T_vec_b8, NULL, NULL, }, "x", &T_volatile_void, 1, FALSE, FALSE, 0, "vec_mtvscr:3", "*mtvscr", CODE_FOR_vfx_fxu, B_UID(614) };
+static const struct builtin B4_vec_mtvscr = { { &T_vec_p16, NULL, NULL, }, "x", &T_volatile_void, 1, FALSE, FALSE, 0, "vec_mtvscr:4", "*mtvscr", CODE_FOR_vfx_fxu, B_UID(615) };
+static const struct builtin B5_vec_mtvscr = { { &T_vec_s16, NULL, NULL, }, "x", &T_volatile_void, 1, FALSE, FALSE, 0, "vec_mtvscr:5", "*mtvscr", CODE_FOR_vfx_fxu, B_UID(616) };
+static const struct builtin B6_vec_mtvscr = { { &T_vec_s32, NULL, NULL, }, "x", &T_volatile_void, 1, FALSE, FALSE, 0, "vec_mtvscr:6", "*mtvscr", CODE_FOR_vfx_fxu, B_UID(617) };
+static const struct builtin B7_vec_mtvscr = { { &T_vec_s8, NULL, NULL, }, "x", &T_volatile_void, 1, FALSE, FALSE, 0, "vec_mtvscr:7", "*mtvscr", CODE_FOR_vfx_fxu, B_UID(618) };
+static const struct builtin B8_vec_mtvscr = { { &T_vec_u16, NULL, NULL, }, "x", &T_volatile_void, 1, FALSE, FALSE, 0, "vec_mtvscr:8", "*mtvscr", CODE_FOR_vfx_fxu, B_UID(619) };
+static const struct builtin B9_vec_mtvscr = { { &T_vec_u32, NULL, NULL, }, "x", &T_volatile_void, 1, FALSE, FALSE, 0, "vec_mtvscr:9", "*mtvscr", CODE_FOR_vfx_fxu, B_UID(620) };
+static const struct builtin B10_vec_mtvscr = { { &T_vec_u8, NULL, NULL, }, "x", &T_volatile_void, 1, FALSE, FALSE, 0, "vec_mtvscr:10", "*mtvscr", CODE_FOR_vfx_fxu, B_UID(621) };
+static const struct builtin B_vec_vmulesh = { { &T_vec_s16, &T_vec_s16, NULL, }, "xx", &T_vec_s32, 2, FALSE, FALSE, 0, "vec_vmulesh", "*vmulesh", CODE_FOR_xfxx_complex, B_UID(622) };
+static const struct builtin B_vec_vmulesb = { { &T_vec_s8, &T_vec_s8, NULL, }, "xx", &T_vec_s16, 2, FALSE, FALSE, 0, "vec_vmulesb", "*vmulesb", CODE_FOR_xfxx_complex, B_UID(623) };
+static const struct builtin B_vec_vmuleuh = { { &T_vec_u16, &T_vec_u16, NULL, }, "xx", &T_vec_u32, 2, FALSE, FALSE, 0, "vec_vmuleuh", "*vmuleuh", CODE_FOR_xfxx_complex, B_UID(624) };
+static const struct builtin B_vec_vmuleub = { { &T_vec_u8, &T_vec_u8, NULL, }, "xx", &T_vec_u16, 2, FALSE, FALSE, 0, "vec_vmuleub", "*vmuleub", CODE_FOR_xfxx_complex, B_UID(625) };
+static const struct builtin B_vec_vmulosh = { { &T_vec_s16, &T_vec_s16, NULL, }, "xx", &T_vec_s32, 2, FALSE, FALSE, 0, "vec_vmulosh", "*vmulosh", CODE_FOR_xfxx_complex, B_UID(626) };
+static const struct builtin B_vec_vmulosb = { { &T_vec_s8, &T_vec_s8, NULL, }, "xx", &T_vec_s16, 2, FALSE, FALSE, 0, "vec_vmulosb", "*vmulosb", CODE_FOR_xfxx_complex, B_UID(627) };
+static const struct builtin B_vec_vmulouh = { { &T_vec_u16, &T_vec_u16, NULL, }, "xx", &T_vec_u32, 2, FALSE, FALSE, 0, "vec_vmulouh", "*vmulouh", CODE_FOR_xfxx_complex, B_UID(628) };
+static const struct builtin B_vec_vmuloub = { { &T_vec_u8, &T_vec_u8, NULL, }, "xx", &T_vec_u16, 2, FALSE, FALSE, 0, "vec_vmuloub", "*vmuloub", CODE_FOR_xfxx_complex, B_UID(629) };
+static const struct builtin B_vec_vnmsubfp = { { &T_vec_f32, &T_vec_f32, &T_vec_f32, }, "xxx", &T_vec_f32, 3, FALSE, FALSE, 0, "vec_vnmsubfp", "*vnmsubfp", CODE_FOR_xfxxx_fp, B_UID(630) };
+static const struct builtin B1_vec_vnor = { { &T_vec_b16, &T_vec_b16, NULL, }, "xx", &T_vec_b16, 2, FALSE, FALSE, 0, "vec_vnor:1", "*vnor", CODE_FOR_xfxx_simple, B_UID(631) };
+static const struct builtin B2_vec_vnor = { { &T_vec_b32, &T_vec_b32, NULL, }, "xx", &T_vec_b32, 2, FALSE, FALSE, 0, "vec_vnor:2", "*vnor", CODE_FOR_xfxx_simple, B_UID(632) };
+static const struct builtin B3_vec_vnor = { { &T_vec_b8, &T_vec_b8, NULL, }, "xx", &T_vec_b8, 2, FALSE, FALSE, 0, "vec_vnor:3", "*vnor", CODE_FOR_xfxx_simple, B_UID(633) };
+static const struct builtin B4_vec_vnor = { { &T_vec_f32, &T_vec_f32, NULL, }, "xx", &T_vec_f32, 2, FALSE, FALSE, 0, "vec_vnor:4", "*vnor", CODE_FOR_xfxx_simple, B_UID(634) };
+static const struct builtin B5_vec_vnor = { { &T_vec_s16, &T_vec_s16, NULL, }, "xx", &T_vec_s16, 2, FALSE, FALSE, 0, "vec_vnor:5", "*vnor", CODE_FOR_xfxx_simple, B_UID(635) };
+static const struct builtin B6_vec_vnor = { { &T_vec_s32, &T_vec_s32, NULL, }, "xx", &T_vec_s32, 2, FALSE, FALSE, 0, "vec_vnor:6", "*vnor", CODE_FOR_xfxx_simple, B_UID(636) };
+static const struct builtin B7_vec_vnor = { { &T_vec_s8, &T_vec_s8, NULL, }, "xx", &T_vec_s8, 2, FALSE, FALSE, 0, "vec_vnor:7", "*vnor", CODE_FOR_xfxx_simple, B_UID(637) };
+static const struct builtin B8_vec_vnor = { { &T_vec_u16, &T_vec_u16, NULL, }, "xx", &T_vec_u16, 2, FALSE, FALSE, 0, "vec_vnor:8", "*vnor", CODE_FOR_xfxx_simple, B_UID(638) };
+static const struct builtin B9_vec_vnor = { { &T_vec_u32, &T_vec_u32, NULL, }, "xx", &T_vec_u32, 2, FALSE, FALSE, 0, "vec_vnor:9", "*vnor", CODE_FOR_xfxx_simple, B_UID(639) };
+static const struct builtin B10_vec_vnor = { { &T_vec_u8, &T_vec_u8, NULL, }, "xx", &T_vec_u8, 2, FALSE, FALSE, 0, "vec_vnor:10", "*vnor", CODE_FOR_xfxx_simple, B_UID(640) };
+static const struct builtin B1_vec_vor = { { &T_vec_b16, &T_vec_b16, NULL, }, "xx", &T_vec_b16, 2, FALSE, FALSE, 2, "vec_vor:1", "*vor", CODE_FOR_xfxx_simple, B_UID(641) };
+static const struct builtin B2_vec_vor = { { &T_vec_b16, &T_vec_s16, NULL, }, "xx", &T_vec_s16, 2, FALSE, FALSE, 2, "vec_vor:2", "*vor", CODE_FOR_xfxx_simple, B_UID(642) };
+static const struct builtin B3_vec_vor = { { &T_vec_b16, &T_vec_u16, NULL, }, "xx", &T_vec_u16, 2, FALSE, FALSE, 2, "vec_vor:3", "*vor", CODE_FOR_xfxx_simple, B_UID(643) };
+static const struct builtin B4_vec_vor = { { &T_vec_b32, &T_vec_b32, NULL, }, "xx", &T_vec_b32, 2, FALSE, FALSE, 2, "vec_vor:4", "*vor", CODE_FOR_xfxx_simple, B_UID(644) };
+static const struct builtin B5_vec_vor = { { &T_vec_b32, &T_vec_f32, NULL, }, "xx", &T_vec_f32, 2, FALSE, FALSE, 2, "vec_vor:5", "*vor", CODE_FOR_xfxx_simple, B_UID(645) };
+static const struct builtin B6_vec_vor = { { &T_vec_b32, &T_vec_s32, NULL, }, "xx", &T_vec_s32, 2, FALSE, FALSE, 2, "vec_vor:6", "*vor", CODE_FOR_xfxx_simple, B_UID(646) };
+static const struct builtin B7_vec_vor = { { &T_vec_b32, &T_vec_u32, NULL, }, "xx", &T_vec_u32, 2, FALSE, FALSE, 2, "vec_vor:7", "*vor", CODE_FOR_xfxx_simple, B_UID(647) };
+static const struct builtin B8_vec_vor = { { &T_vec_b8, &T_vec_b8, NULL, }, "xx", &T_vec_b8, 2, FALSE, FALSE, 2, "vec_vor:8", "*vor", CODE_FOR_xfxx_simple, B_UID(648) };
+static const struct builtin B9_vec_vor = { { &T_vec_b8, &T_vec_s8, NULL, }, "xx", &T_vec_s8, 2, FALSE, FALSE, 2, "vec_vor:9", "*vor", CODE_FOR_xfxx_simple, B_UID(649) };
+static const struct builtin B10_vec_vor = { { &T_vec_b8, &T_vec_u8, NULL, }, "xx", &T_vec_u8, 2, FALSE, FALSE, 2, "vec_vor:10", "*vor", CODE_FOR_xfxx_simple, B_UID(650) };
+static const struct builtin B11_vec_vor = { { &T_vec_f32, &T_vec_b32, NULL, }, "xx", &T_vec_f32, 2, FALSE, FALSE, 2, "vec_vor:11", "*vor", CODE_FOR_xfxx_simple, B_UID(651) };
+static const struct builtin B12_vec_vor = { { &T_vec_f32, &T_vec_f32, NULL, }, "xx", &T_vec_f32, 2, FALSE, FALSE, 2, "vec_vor:12", "*vor", CODE_FOR_xfxx_simple, B_UID(652) };
+static const struct builtin B13_vec_vor = { { &T_vec_s16, &T_vec_b16, NULL, }, "xx", &T_vec_s16, 2, FALSE, FALSE, 2, "vec_vor:13", "*vor", CODE_FOR_xfxx_simple, B_UID(653) };
+static const struct builtin B14_vec_vor = { { &T_vec_s16, &T_vec_s16, NULL, }, "xx", &T_vec_s16, 2, FALSE, FALSE, 2, "vec_vor:14", "*vor", CODE_FOR_xfxx_simple, B_UID(654) };
+static const struct builtin B15_vec_vor = { { &T_vec_s32, &T_vec_b32, NULL, }, "xx", &T_vec_s32, 2, FALSE, FALSE, 2, "vec_vor:15", "*vor", CODE_FOR_xfxx_simple, B_UID(655) };
+static const struct builtin B16_vec_vor = { { &T_vec_s32, &T_vec_s32, NULL, }, "xx", &T_vec_s32, 2, FALSE, FALSE, 2, "vec_vor:16", "*vor", CODE_FOR_xfxx_simple, B_UID(656) };
+static const struct builtin B17_vec_vor = { { &T_vec_s8, &T_vec_b8, NULL, }, "xx", &T_vec_s8, 2, FALSE, FALSE, 2, "vec_vor:17", "*vor", CODE_FOR_xfxx_simple, B_UID(657) };
+static const struct builtin B18_vec_vor = { { &T_vec_s8, &T_vec_s8, NULL, }, "xx", &T_vec_s8, 2, FALSE, FALSE, 2, "vec_vor:18", "*vor", CODE_FOR_xfxx_simple, B_UID(658) };
+static const struct builtin B19_vec_vor = { { &T_vec_u16, &T_vec_b16, NULL, }, "xx", &T_vec_u16, 2, FALSE, FALSE, 2, "vec_vor:19", "*vor", CODE_FOR_xfxx_simple, B_UID(659) };
+static const struct builtin B20_vec_vor = { { &T_vec_u16, &T_vec_u16, NULL, }, "xx", &T_vec_u16, 2, FALSE, FALSE, 2, "vec_vor:20", "*vor", CODE_FOR_xfxx_simple, B_UID(660) };
+static const struct builtin B21_vec_vor = { { &T_vec_u32, &T_vec_b32, NULL, }, "xx", &T_vec_u32, 2, FALSE, FALSE, 2, "vec_vor:21", "*vor", CODE_FOR_xfxx_simple, B_UID(661) };
+static const struct builtin B22_vec_vor = { { &T_vec_u32, &T_vec_u32, NULL, }, "xx", &T_vec_u32, 2, FALSE, FALSE, 2, "vec_vor:22", "*vor", CODE_FOR_xfxx_simple, B_UID(662) };
+static const struct builtin B23_vec_vor = { { &T_vec_u8, &T_vec_b8, NULL, }, "xx", &T_vec_u8, 2, FALSE, FALSE, 2, "vec_vor:23", "*vor", CODE_FOR_xfxx_simple, B_UID(663) };
+static const struct builtin B24_vec_vor = { { &T_vec_u8, &T_vec_u8, NULL, }, "xx", &T_vec_u8, 2, FALSE, FALSE, 2, "vec_vor:24", "*vor", CODE_FOR_xfxx_simple, B_UID(664) };
+static const struct builtin B1_vec_vpkuhum = { { &T_vec_b16, &T_vec_b16, NULL, }, "xx", &T_vec_b8, 2, FALSE, FALSE, 0, "vec_vpkuhum:1", "*vpkuhum", CODE_FOR_xfxx_perm, B_UID(665) };
+static const struct builtin B1_vec_vpkuwum = { { &T_vec_b32, &T_vec_b32, NULL, }, "xx", &T_vec_b16, 2, FALSE, FALSE, 0, "vec_vpkuwum:1", "*vpkuwum", CODE_FOR_xfxx_perm, B_UID(666) };
+static const struct builtin B2_vec_vpkuhum = { { &T_vec_s16, &T_vec_s16, NULL, }, "xx", &T_vec_s8, 2, FALSE, FALSE, 0, "vec_vpkuhum:2", "*vpkuhum", CODE_FOR_xfxx_perm, B_UID(667) };
+static const struct builtin B2_vec_vpkuwum = { { &T_vec_s32, &T_vec_s32, NULL, }, "xx", &T_vec_s16, 2, FALSE, FALSE, 0, "vec_vpkuwum:2", "*vpkuwum", CODE_FOR_xfxx_perm, B_UID(668) };
+static const struct builtin B3_vec_vpkuhum = { { &T_vec_u16, &T_vec_u16, NULL, }, "xx", &T_vec_u8, 2, FALSE, FALSE, 0, "vec_vpkuhum:3", "*vpkuhum", CODE_FOR_xfxx_perm, B_UID(669) };
+static const struct builtin B3_vec_vpkuwum = { { &T_vec_u32, &T_vec_u32, NULL, }, "xx", &T_vec_u16, 2, FALSE, FALSE, 0, "vec_vpkuwum:3", "*vpkuwum", CODE_FOR_xfxx_perm, B_UID(670) };
+static const struct builtin B_vec_vpkpx = { { &T_vec_u32, &T_vec_u32, NULL, }, "xx", &T_vec_p16, 2, FALSE, FALSE, 0, "vec_vpkpx", "*vpkpx", CODE_FOR_xfxx_perm, B_UID(671) };
+static const struct builtin B_vec_vpkshss = { { &T_vec_s16, &T_vec_s16, NULL, }, "xx", &T_vec_s8, 2, FALSE, FALSE, 0, "vec_vpkshss", "*vpkshss", CODE_FOR_xfxx_perm, B_UID(672) };
+static const struct builtin B_vec_vpkswss = { { &T_vec_s32, &T_vec_s32, NULL, }, "xx", &T_vec_s16, 2, FALSE, FALSE, 0, "vec_vpkswss", "*vpkswss", CODE_FOR_xfxx_perm, B_UID(673) };
+static const struct builtin B_vec_vpkuhus = { { &T_vec_u16, &T_vec_u16, NULL, }, "xx", &T_vec_u8, 2, FALSE, FALSE, 0, "vec_vpkuhus", "*vpkuhus", CODE_FOR_xfxx_perm, B_UID(674) };
+static const struct builtin B_vec_vpkuwus = { { &T_vec_u32, &T_vec_u32, NULL, }, "xx", &T_vec_u16, 2, FALSE, FALSE, 0, "vec_vpkuwus", "*vpkuwus", CODE_FOR_xfxx_perm, B_UID(675) };
+static const struct builtin B_vec_vpkshus = { { &T_vec_s16, &T_vec_s16, NULL, }, "xx", &T_vec_u8, 2, FALSE, FALSE, 0, "vec_vpkshus", "*vpkshus", CODE_FOR_xfxx_perm, B_UID(676) };
+static const struct builtin B_vec_vpkswus = { { &T_vec_s32, &T_vec_s32, NULL, }, "xx", &T_vec_u16, 2, FALSE, FALSE, 0, "vec_vpkswus", "*vpkswus", CODE_FOR_xfxx_perm, B_UID(677) };
+static const struct builtin B1_vec_vperm = { { &T_vec_b16, &T_vec_b16, &T_vec_u8, }, "xxx", &T_vec_b16, 3, FALSE, FALSE, 0, "vec_vperm:1", "*vperm", CODE_FOR_xfxxx_perm, B_UID(678) };
+static const struct builtin B2_vec_vperm = { { &T_vec_b32, &T_vec_b32, &T_vec_u8, }, "xxx", &T_vec_b32, 3, FALSE, FALSE, 0, "vec_vperm:2", "*vperm", CODE_FOR_xfxxx_perm, B_UID(679) };
+static const struct builtin B3_vec_vperm = { { &T_vec_b8, &T_vec_b8, &T_vec_u8, }, "xxx", &T_vec_b8, 3, FALSE, FALSE, 0, "vec_vperm:3", "*vperm", CODE_FOR_xfxxx_perm, B_UID(680) };
+static const struct builtin B4_vec_vperm = { { &T_vec_f32, &T_vec_f32, &T_vec_u8, }, "xxx", &T_vec_f32, 3, FALSE, FALSE, 0, "vec_vperm:4", "*vperm", CODE_FOR_xfxxx_perm, B_UID(681) };
+static const struct builtin B5_vec_vperm = { { &T_vec_p16, &T_vec_p16, &T_vec_u8, }, "xxx", &T_vec_p16, 3, FALSE, FALSE, 0, "vec_vperm:5", "*vperm", CODE_FOR_xfxxx_perm, B_UID(682) };
+static const struct builtin B6_vec_vperm = { { &T_vec_s16, &T_vec_s16, &T_vec_u8, }, "xxx", &T_vec_s16, 3, FALSE, FALSE, 0, "vec_vperm:6", "*vperm", CODE_FOR_xfxxx_perm, B_UID(683) };
+static const struct builtin B7_vec_vperm = { { &T_vec_s32, &T_vec_s32, &T_vec_u8, }, "xxx", &T_vec_s32, 3, FALSE, FALSE, 0, "vec_vperm:7", "*vperm", CODE_FOR_xfxxx_perm, B_UID(684) };
+static const struct builtin B8_vec_vperm = { { &T_vec_s8, &T_vec_s8, &T_vec_u8, }, "xxx", &T_vec_s8, 3, FALSE, FALSE, 0, "vec_vperm:8", "*vperm", CODE_FOR_xfxxx_perm, B_UID(685) };
+static const struct builtin B9_vec_vperm = { { &T_vec_u16, &T_vec_u16, &T_vec_u8, }, "xxx", &T_vec_u16, 3, FALSE, FALSE, 0, "vec_vperm:9", "*vperm", CODE_FOR_xfxxx_perm, B_UID(686) };
+static const struct builtin B10_vec_vperm = { { &T_vec_u32, &T_vec_u32, &T_vec_u8, }, "xxx", &T_vec_u32, 3, FALSE, FALSE, 0, "vec_vperm:10", "*vperm", CODE_FOR_xfxxx_perm, B_UID(687) };
+static const struct builtin B11_vec_vperm = { { &T_vec_u8, &T_vec_u8, &T_vec_u8, }, "xxx", &T_vec_u8, 3, FALSE, FALSE, 0, "vec_vperm:11", "*vperm", CODE_FOR_xfxxx_perm, B_UID(688) };
+static const struct builtin B_vec_vrefp = { { &T_vec_f32, NULL, NULL, }, "x", &T_vec_f32, 1, FALSE, FALSE, 0, "vec_vrefp", "*vrefp", CODE_FOR_xfx_fp, B_UID(689) };
+static const struct builtin B1_vec_vrlh = { { &T_vec_s16, &T_vec_u16, NULL, }, "xx", &T_vec_s16, 2, FALSE, FALSE, 0, "vec_vrlh:1", "*vrlh", CODE_FOR_xfxx_simple, B_UID(690) };
+static const struct builtin B1_vec_vrlw = { { &T_vec_s32, &T_vec_u32, NULL, }, "xx", &T_vec_s32, 2, FALSE, FALSE, 0, "vec_vrlw:1", "*vrlw", CODE_FOR_xfxx_simple, B_UID(691) };
+static const struct builtin B1_vec_vrlb = { { &T_vec_s8, &T_vec_u8, NULL, }, "xx", &T_vec_s8, 2, FALSE, FALSE, 0, "vec_vrlb:1", "*vrlb", CODE_FOR_xfxx_simple, B_UID(692) };
+static const struct builtin B2_vec_vrlh = { { &T_vec_u16, &T_vec_u16, NULL, }, "xx", &T_vec_u16, 2, FALSE, FALSE, 0, "vec_vrlh:2", "*vrlh", CODE_FOR_xfxx_simple, B_UID(693) };
+static const struct builtin B2_vec_vrlw = { { &T_vec_u32, &T_vec_u32, NULL, }, "xx", &T_vec_u32, 2, FALSE, FALSE, 0, "vec_vrlw:2", "*vrlw", CODE_FOR_xfxx_simple, B_UID(694) };
+static const struct builtin B2_vec_vrlb = { { &T_vec_u8, &T_vec_u8, NULL, }, "xx", &T_vec_u8, 2, FALSE, FALSE, 0, "vec_vrlb:2", "*vrlb", CODE_FOR_xfxx_simple, B_UID(695) };
+static const struct builtin B_vec_vrfin = { { &T_vec_f32, NULL, NULL, }, "x", &T_vec_f32, 1, FALSE, FALSE, 0, "vec_vrfin", "*vrfin", CODE_FOR_xfx_fp, B_UID(696) };
+static const struct builtin B_vec_vrsqrtefp = { { &T_vec_f32, NULL, NULL, }, "x", &T_vec_f32, 1, FALSE, FALSE, 0, "vec_vrsqrtefp", "*vrsqrtefp", CODE_FOR_xfx_fp, B_UID(697) };
+static const struct builtin B1_vec_vsel = { { &T_vec_b16, &T_vec_b16, &T_vec_b16, }, "xxx", &T_vec_b16, 3, FALSE, FALSE, 0, "vec_vsel:1", "*vsel", CODE_FOR_xfxxx_simple, B_UID(698) };
+static const struct builtin B2_vec_vsel = { { &T_vec_b16, &T_vec_b16, &T_vec_u16, }, "xxx", &T_vec_b16, 3, FALSE, FALSE, 0, "vec_vsel:2", "*vsel", CODE_FOR_xfxxx_simple, B_UID(699) };
+static const struct builtin B3_vec_vsel = { { &T_vec_b32, &T_vec_b32, &T_vec_b32, }, "xxx", &T_vec_b32, 3, FALSE, FALSE, 0, "vec_vsel:3", "*vsel", CODE_FOR_xfxxx_simple, B_UID(700) };
+static const struct builtin B4_vec_vsel = { { &T_vec_b32, &T_vec_b32, &T_vec_u32, }, "xxx", &T_vec_b32, 3, FALSE, FALSE, 0, "vec_vsel:4", "*vsel", CODE_FOR_xfxxx_simple, B_UID(701) };
+static const struct builtin B5_vec_vsel = { { &T_vec_b8, &T_vec_b8, &T_vec_b8, }, "xxx", &T_vec_b8, 3, FALSE, FALSE, 0, "vec_vsel:5", "*vsel", CODE_FOR_xfxxx_simple, B_UID(702) };
+static const struct builtin B6_vec_vsel = { { &T_vec_b8, &T_vec_b8, &T_vec_u8, }, "xxx", &T_vec_b8, 3, FALSE, FALSE, 0, "vec_vsel:6", "*vsel", CODE_FOR_xfxxx_simple, B_UID(703) };
+static const struct builtin B7_vec_vsel = { { &T_vec_f32, &T_vec_f32, &T_vec_b32, }, "xxx", &T_vec_f32, 3, FALSE, FALSE, 0, "vec_vsel:7", "*vsel", CODE_FOR_xfxxx_simple, B_UID(704) };
+static const struct builtin B8_vec_vsel = { { &T_vec_f32, &T_vec_f32, &T_vec_u32, }, "xxx", &T_vec_f32, 3, FALSE, FALSE, 0, "vec_vsel:8", "*vsel", CODE_FOR_xfxxx_simple, B_UID(705) };
+static const struct builtin B9_vec_vsel = { { &T_vec_s16, &T_vec_s16, &T_vec_b16, }, "xxx", &T_vec_s16, 3, FALSE, FALSE, 0, "vec_vsel:9", "*vsel", CODE_FOR_xfxxx_simple, B_UID(706) };
+static const struct builtin B10_vec_vsel = { { &T_vec_s16, &T_vec_s16, &T_vec_u16, }, "xxx", &T_vec_s16, 3, FALSE, FALSE, 0, "vec_vsel:10", "*vsel", CODE_FOR_xfxxx_simple, B_UID(707) };
+static const struct builtin B11_vec_vsel = { { &T_vec_s32, &T_vec_s32, &T_vec_b32, }, "xxx", &T_vec_s32, 3, FALSE, FALSE, 0, "vec_vsel:11", "*vsel", CODE_FOR_xfxxx_simple, B_UID(708) };
+static const struct builtin B12_vec_vsel = { { &T_vec_s32, &T_vec_s32, &T_vec_u32, }, "xxx", &T_vec_s32, 3, FALSE, FALSE, 0, "vec_vsel:12", "*vsel", CODE_FOR_xfxxx_simple, B_UID(709) };
+static const struct builtin B13_vec_vsel = { { &T_vec_s8, &T_vec_s8, &T_vec_b8, }, "xxx", &T_vec_s8, 3, FALSE, FALSE, 0, "vec_vsel:13", "*vsel", CODE_FOR_xfxxx_simple, B_UID(710) };
+static const struct builtin B14_vec_vsel = { { &T_vec_s8, &T_vec_s8, &T_vec_u8, }, "xxx", &T_vec_s8, 3, FALSE, FALSE, 0, "vec_vsel:14", "*vsel", CODE_FOR_xfxxx_simple, B_UID(711) };
+static const struct builtin B15_vec_vsel = { { &T_vec_u16, &T_vec_u16, &T_vec_b16, }, "xxx", &T_vec_u16, 3, FALSE, FALSE, 0, "vec_vsel:15", "*vsel", CODE_FOR_xfxxx_simple, B_UID(712) };
+static const struct builtin B16_vec_vsel = { { &T_vec_u16, &T_vec_u16, &T_vec_u16, }, "xxx", &T_vec_u16, 3, FALSE, FALSE, 0, "vec_vsel:16", "*vsel", CODE_FOR_xfxxx_simple, B_UID(713) };
+static const struct builtin B17_vec_vsel = { { &T_vec_u32, &T_vec_u32, &T_vec_b32, }, "xxx", &T_vec_u32, 3, FALSE, FALSE, 0, "vec_vsel:17", "*vsel", CODE_FOR_xfxxx_simple, B_UID(714) };
+static const struct builtin B18_vec_vsel = { { &T_vec_u32, &T_vec_u32, &T_vec_u32, }, "xxx", &T_vec_u32, 3, FALSE, FALSE, 0, "vec_vsel:18", "*vsel", CODE_FOR_xfxxx_simple, B_UID(715) };
+static const struct builtin B19_vec_vsel = { { &T_vec_u8, &T_vec_u8, &T_vec_b8, }, "xxx", &T_vec_u8, 3, FALSE, FALSE, 0, "vec_vsel:19", "*vsel", CODE_FOR_xfxxx_simple, B_UID(716) };
+static const struct builtin B20_vec_vsel = { { &T_vec_u8, &T_vec_u8, &T_vec_u8, }, "xxx", &T_vec_u8, 3, FALSE, FALSE, 0, "vec_vsel:20", "*vsel", CODE_FOR_xfxxx_simple, B_UID(717) };
+static const struct builtin B1_vec_vslh = { { &T_vec_s16, &T_vec_u16, NULL, }, "xx", &T_vec_s16, 2, FALSE, FALSE, 0, "vec_vslh:1", "*vslh", CODE_FOR_xfxx_simple, B_UID(718) };
+static const struct builtin B1_vec_vslw = { { &T_vec_s32, &T_vec_u32, NULL, }, "xx", &T_vec_s32, 2, FALSE, FALSE, 0, "vec_vslw:1", "*vslw", CODE_FOR_xfxx_simple, B_UID(719) };
+static const struct builtin B1_vec_vslb = { { &T_vec_s8, &T_vec_u8, NULL, }, "xx", &T_vec_s8, 2, FALSE, FALSE, 0, "vec_vslb:1", "*vslb", CODE_FOR_xfxx_simple, B_UID(720) };
+static const struct builtin B2_vec_vslh = { { &T_vec_u16, &T_vec_u16, NULL, }, "xx", &T_vec_u16, 2, FALSE, FALSE, 0, "vec_vslh:2", "*vslh", CODE_FOR_xfxx_simple, B_UID(721) };
+static const struct builtin B2_vec_vslw = { { &T_vec_u32, &T_vec_u32, NULL, }, "xx", &T_vec_u32, 2, FALSE, FALSE, 0, "vec_vslw:2", "*vslw", CODE_FOR_xfxx_simple, B_UID(722) };
+static const struct builtin B2_vec_vslb = { { &T_vec_u8, &T_vec_u8, NULL, }, "xx", &T_vec_u8, 2, FALSE, FALSE, 0, "vec_vslb:2", "*vslb", CODE_FOR_xfxx_simple, B_UID(723) };
+static const struct builtin B1_vec_vsldoi = { { &T_vec_b16, &T_vec_b16, &T_immed_u4, }, "xxC", &T_vec_b16, 3, FALSE, FALSE, 3, "vec_vsldoi:1", "*vsldoi", CODE_FOR_xfxxC_perm, B_UID(724) };
+static const struct builtin B2_vec_vsldoi = { { &T_vec_b32, &T_vec_b32, &T_immed_u4, }, "xxC", &T_vec_b32, 3, FALSE, FALSE, 3, "vec_vsldoi:2", "*vsldoi", CODE_FOR_xfxxC_perm, B_UID(725) };
+static const struct builtin B3_vec_vsldoi = { { &T_vec_b8, &T_vec_b8, &T_immed_u4, }, "xxC", &T_vec_b8, 3, FALSE, FALSE, 3, "vec_vsldoi:3", "*vsldoi", CODE_FOR_xfxxC_perm, B_UID(726) };
+static const struct builtin B4_vec_vsldoi = { { &T_vec_f32, &T_vec_f32, &T_immed_u4, }, "xxC", &T_vec_f32, 3, FALSE, FALSE, 3, "vec_vsldoi:4", "*vsldoi", CODE_FOR_xfxxC_perm, B_UID(727) };
+static const struct builtin B5_vec_vsldoi = { { &T_vec_p16, &T_vec_p16, &T_immed_u4, }, "xxC", &T_vec_p16, 3, FALSE, FALSE, 3, "vec_vsldoi:5", "*vsldoi", CODE_FOR_xfxxC_perm, B_UID(728) };
+static const struct builtin B6_vec_vsldoi = { { &T_vec_s16, &T_vec_s16, &T_immed_u4, }, "xxC", &T_vec_s16, 3, FALSE, FALSE, 3, "vec_vsldoi:6", "*vsldoi", CODE_FOR_xfxxC_perm, B_UID(729) };
+static const struct builtin B7_vec_vsldoi = { { &T_vec_s32, &T_vec_s32, &T_immed_u4, }, "xxC", &T_vec_s32, 3, FALSE, FALSE, 3, "vec_vsldoi:7", "*vsldoi", CODE_FOR_xfxxC_perm, B_UID(730) };
+static const struct builtin B8_vec_vsldoi = { { &T_vec_s8, &T_vec_s8, &T_immed_u4, }, "xxC", &T_vec_s8, 3, FALSE, FALSE, 3, "vec_vsldoi:8", "*vsldoi", CODE_FOR_xfxxC_perm, B_UID(731) };
+static const struct builtin B9_vec_vsldoi = { { &T_vec_u16, &T_vec_u16, &T_immed_u4, }, "xxC", &T_vec_u16, 3, FALSE, FALSE, 3, "vec_vsldoi:9", "*vsldoi", CODE_FOR_xfxxC_perm, B_UID(732) };
+static const struct builtin B10_vec_vsldoi = { { &T_vec_u32, &T_vec_u32, &T_immed_u4, }, "xxC", &T_vec_u32, 3, FALSE, FALSE, 3, "vec_vsldoi:10", "*vsldoi", CODE_FOR_xfxxC_perm, B_UID(733) };
+static const struct builtin B11_vec_vsldoi = { { &T_vec_u8, &T_vec_u8, &T_immed_u4, }, "xxC", &T_vec_u8, 3, FALSE, FALSE, 3, "vec_vsldoi:11", "*vsldoi", CODE_FOR_xfxxC_perm, B_UID(734) };
+static const struct builtin B1_vec_vsl = { { &T_vec_b16, &T_vec_u16, NULL, }, "xx", &T_vec_b16, 2, FALSE, FALSE, 0, "vec_vsl:1", "*vsl", CODE_FOR_xfxx_simple, B_UID(735) };
+static const struct builtin B2_vec_vsl = { { &T_vec_b16, &T_vec_u32, NULL, }, "xx", &T_vec_b16, 2, FALSE, FALSE, 0, "vec_vsl:2", "*vsl", CODE_FOR_xfxx_simple, B_UID(736) };
+static const struct builtin B3_vec_vsl = { { &T_vec_b16, &T_vec_u8, NULL, }, "xx", &T_vec_b16, 2, FALSE, FALSE, 0, "vec_vsl:3", "*vsl", CODE_FOR_xfxx_simple, B_UID(737) };
+static const struct builtin B4_vec_vsl = { { &T_vec_b32, &T_vec_u16, NULL, }, "xx", &T_vec_b32, 2, FALSE, FALSE, 0, "vec_vsl:4", "*vsl", CODE_FOR_xfxx_simple, B_UID(738) };
+static const struct builtin B5_vec_vsl = { { &T_vec_b32, &T_vec_u32, NULL, }, "xx", &T_vec_b32, 2, FALSE, FALSE, 0, "vec_vsl:5", "*vsl", CODE_FOR_xfxx_simple, B_UID(739) };
+static const struct builtin B6_vec_vsl = { { &T_vec_b32, &T_vec_u8, NULL, }, "xx", &T_vec_b32, 2, FALSE, FALSE, 0, "vec_vsl:6", "*vsl", CODE_FOR_xfxx_simple, B_UID(740) };
+static const struct builtin B7_vec_vsl = { { &T_vec_b8, &T_vec_u16, NULL, }, "xx", &T_vec_b8, 2, FALSE, FALSE, 0, "vec_vsl:7", "*vsl", CODE_FOR_xfxx_simple, B_UID(741) };
+static const struct builtin B8_vec_vsl = { { &T_vec_b8, &T_vec_u32, NULL, }, "xx", &T_vec_b8, 2, FALSE, FALSE, 0, "vec_vsl:8", "*vsl", CODE_FOR_xfxx_simple, B_UID(742) };
+static const struct builtin B9_vec_vsl = { { &T_vec_b8, &T_vec_u8, NULL, }, "xx", &T_vec_b8, 2, FALSE, FALSE, 0, "vec_vsl:9", "*vsl", CODE_FOR_xfxx_simple, B_UID(743) };
+static const struct builtin B10_vec_vsl = { { &T_vec_p16, &T_vec_u16, NULL, }, "xx", &T_vec_p16, 2, FALSE, FALSE, 0, "vec_vsl:10", "*vsl", CODE_FOR_xfxx_simple, B_UID(744) };
+static const struct builtin B11_vec_vsl = { { &T_vec_p16, &T_vec_u32, NULL, }, "xx", &T_vec_p16, 2, FALSE, FALSE, 0, "vec_vsl:11", "*vsl", CODE_FOR_xfxx_simple, B_UID(745) };
+static const struct builtin B12_vec_vsl = { { &T_vec_p16, &T_vec_u8, NULL, }, "xx", &T_vec_p16, 2, FALSE, FALSE, 0, "vec_vsl:12", "*vsl", CODE_FOR_xfxx_simple, B_UID(746) };
+static const struct builtin B13_vec_vsl = { { &T_vec_s16, &T_vec_u16, NULL, }, "xx", &T_vec_s16, 2, FALSE, FALSE, 0, "vec_vsl:13", "*vsl", CODE_FOR_xfxx_simple, B_UID(747) };
+static const struct builtin B14_vec_vsl = { { &T_vec_s16, &T_vec_u32, NULL, }, "xx", &T_vec_s16, 2, FALSE, FALSE, 0, "vec_vsl:14", "*vsl", CODE_FOR_xfxx_simple, B_UID(748) };
+static const struct builtin B15_vec_vsl = { { &T_vec_s16, &T_vec_u8, NULL, }, "xx", &T_vec_s16, 2, FALSE, FALSE, 0, "vec_vsl:15", "*vsl", CODE_FOR_xfxx_simple, B_UID(749) };
+static const struct builtin B16_vec_vsl = { { &T_vec_s32, &T_vec_u16, NULL, }, "xx", &T_vec_s32, 2, FALSE, FALSE, 0, "vec_vsl:16", "*vsl", CODE_FOR_xfxx_simple, B_UID(750) };
+static const struct builtin B17_vec_vsl = { { &T_vec_s32, &T_vec_u32, NULL, }, "xx", &T_vec_s32, 2, FALSE, FALSE, 0, "vec_vsl:17", "*vsl", CODE_FOR_xfxx_simple, B_UID(751) };
+static const struct builtin B18_vec_vsl = { { &T_vec_s32, &T_vec_u8, NULL, }, "xx", &T_vec_s32, 2, FALSE, FALSE, 0, "vec_vsl:18", "*vsl", CODE_FOR_xfxx_simple, B_UID(752) };
+static const struct builtin B19_vec_vsl = { { &T_vec_s8, &T_vec_u16, NULL, }, "xx", &T_vec_s8, 2, FALSE, FALSE, 0, "vec_vsl:19", "*vsl", CODE_FOR_xfxx_simple, B_UID(753) };
+static const struct builtin B20_vec_vsl = { { &T_vec_s8, &T_vec_u32, NULL, }, "xx", &T_vec_s8, 2, FALSE, FALSE, 0, "vec_vsl:20", "*vsl", CODE_FOR_xfxx_simple, B_UID(754) };
+static const struct builtin B21_vec_vsl = { { &T_vec_s8, &T_vec_u8, NULL, }, "xx", &T_vec_s8, 2, FALSE, FALSE, 0, "vec_vsl:21", "*vsl", CODE_FOR_xfxx_simple, B_UID(755) };
+static const struct builtin B22_vec_vsl = { { &T_vec_u16, &T_vec_u16, NULL, }, "xx", &T_vec_u16, 2, FALSE, FALSE, 0, "vec_vsl:22", "*vsl", CODE_FOR_xfxx_simple, B_UID(756) };
+static const struct builtin B23_vec_vsl = { { &T_vec_u16, &T_vec_u32, NULL, }, "xx", &T_vec_u16, 2, FALSE, FALSE, 0, "vec_vsl:23", "*vsl", CODE_FOR_xfxx_simple, B_UID(757) };
+static const struct builtin B24_vec_vsl = { { &T_vec_u16, &T_vec_u8, NULL, }, "xx", &T_vec_u16, 2, FALSE, FALSE, 0, "vec_vsl:24", "*vsl", CODE_FOR_xfxx_simple, B_UID(758) };
+static const struct builtin B25_vec_vsl = { { &T_vec_u32, &T_vec_u16, NULL, }, "xx", &T_vec_u32, 2, FALSE, FALSE, 0, "vec_vsl:25", "*vsl", CODE_FOR_xfxx_simple, B_UID(759) };
+static const struct builtin B26_vec_vsl = { { &T_vec_u32, &T_vec_u32, NULL, }, "xx", &T_vec_u32, 2, FALSE, FALSE, 0, "vec_vsl:26", "*vsl", CODE_FOR_xfxx_simple, B_UID(760) };
+static const struct builtin B27_vec_vsl = { { &T_vec_u32, &T_vec_u8, NULL, }, "xx", &T_vec_u32, 2, FALSE, FALSE, 0, "vec_vsl:27", "*vsl", CODE_FOR_xfxx_simple, B_UID(761) };
+static const struct builtin B28_vec_vsl = { { &T_vec_u8, &T_vec_u16, NULL, }, "xx", &T_vec_u8, 2, FALSE, FALSE, 0, "vec_vsl:28", "*vsl", CODE_FOR_xfxx_simple, B_UID(762) };
+static const struct builtin B29_vec_vsl = { { &T_vec_u8, &T_vec_u32, NULL, }, "xx", &T_vec_u8, 2, FALSE, FALSE, 0, "vec_vsl:29", "*vsl", CODE_FOR_xfxx_simple, B_UID(763) };
+static const struct builtin B30_vec_vsl = { { &T_vec_u8, &T_vec_u8, NULL, }, "xx", &T_vec_u8, 2, FALSE, FALSE, 0, "vec_vsl:30", "*vsl", CODE_FOR_xfxx_simple, B_UID(764) };
+static const struct builtin B1_vec_vslo = { { &T_vec_f32, &T_vec_s8, NULL, }, "xx", &T_vec_f32, 2, FALSE, FALSE, 0, "vec_vslo:1", "*vslo", CODE_FOR_xfxx_perm_bug, B_UID(765) };
+static const struct builtin B2_vec_vslo = { { &T_vec_f32, &T_vec_u8, NULL, }, "xx", &T_vec_f32, 2, FALSE, FALSE, 0, "vec_vslo:2", "*vslo", CODE_FOR_xfxx_perm_bug, B_UID(766) };
+static const struct builtin B3_vec_vslo = { { &T_vec_p16, &T_vec_s8, NULL, }, "xx", &T_vec_p16, 2, FALSE, FALSE, 0, "vec_vslo:3", "*vslo", CODE_FOR_xfxx_perm_bug, B_UID(767) };
+static const struct builtin B4_vec_vslo = { { &T_vec_p16, &T_vec_u8, NULL, }, "xx", &T_vec_p16, 2, FALSE, FALSE, 0, "vec_vslo:4", "*vslo", CODE_FOR_xfxx_perm_bug, B_UID(768) };
+static const struct builtin B5_vec_vslo = { { &T_vec_s16, &T_vec_s8, NULL, }, "xx", &T_vec_s16, 2, FALSE, FALSE, 0, "vec_vslo:5", "*vslo", CODE_FOR_xfxx_perm_bug, B_UID(769) };
+static const struct builtin B6_vec_vslo = { { &T_vec_s16, &T_vec_u8, NULL, }, "xx", &T_vec_s16, 2, FALSE, FALSE, 0, "vec_vslo:6", "*vslo", CODE_FOR_xfxx_perm_bug, B_UID(770) };
+static const struct builtin B7_vec_vslo = { { &T_vec_s32, &T_vec_s8, NULL, }, "xx", &T_vec_s32, 2, FALSE, FALSE, 0, "vec_vslo:7", "*vslo", CODE_FOR_xfxx_perm_bug, B_UID(771) };
+static const struct builtin B8_vec_vslo = { { &T_vec_s32, &T_vec_u8, NULL, }, "xx", &T_vec_s32, 2, FALSE, FALSE, 0, "vec_vslo:8", "*vslo", CODE_FOR_xfxx_perm_bug, B_UID(772) };
+static const struct builtin B9_vec_vslo = { { &T_vec_s8, &T_vec_s8, NULL, }, "xx", &T_vec_s8, 2, FALSE, FALSE, 0, "vec_vslo:9", "*vslo", CODE_FOR_xfxx_perm_bug, B_UID(773) };
+static const struct builtin B10_vec_vslo = { { &T_vec_s8, &T_vec_u8, NULL, }, "xx", &T_vec_s8, 2, FALSE, FALSE, 0, "vec_vslo:10", "*vslo", CODE_FOR_xfxx_perm_bug, B_UID(774) };
+static const struct builtin B11_vec_vslo = { { &T_vec_u16, &T_vec_s8, NULL, }, "xx", &T_vec_u16, 2, FALSE, FALSE, 0, "vec_vslo:11", "*vslo", CODE_FOR_xfxx_perm_bug, B_UID(775) };
+static const struct builtin B12_vec_vslo = { { &T_vec_u16, &T_vec_u8, NULL, }, "xx", &T_vec_u16, 2, FALSE, FALSE, 0, "vec_vslo:12", "*vslo", CODE_FOR_xfxx_perm_bug, B_UID(776) };
+static const struct builtin B13_vec_vslo = { { &T_vec_u32, &T_vec_s8, NULL, }, "xx", &T_vec_u32, 2, FALSE, FALSE, 0, "vec_vslo:13", "*vslo", CODE_FOR_xfxx_perm_bug, B_UID(777) };
+static const struct builtin B14_vec_vslo = { { &T_vec_u32, &T_vec_u8, NULL, }, "xx", &T_vec_u32, 2, FALSE, FALSE, 0, "vec_vslo:14", "*vslo", CODE_FOR_xfxx_perm_bug, B_UID(778) };
+static const struct builtin B15_vec_vslo = { { &T_vec_u8, &T_vec_s8, NULL, }, "xx", &T_vec_u8, 2, FALSE, FALSE, 0, "vec_vslo:15", "*vslo", CODE_FOR_xfxx_perm_bug, B_UID(779) };
+static const struct builtin B16_vec_vslo = { { &T_vec_u8, &T_vec_u8, NULL, }, "xx", &T_vec_u8, 2, FALSE, FALSE, 0, "vec_vslo:16", "*vslo", CODE_FOR_xfxx_perm_bug, B_UID(780) };
+static const struct builtin B1_vec_vsplth = { { &T_vec_b16, &T_immed_u5, NULL, }, "xB", &T_vec_b16, 2, FALSE, FALSE, 0, "vec_vsplth:1", "*vsplth", CODE_FOR_xfxB_perm, B_UID(781) };
+static const struct builtin B1_vec_vspltw = { { &T_vec_b32, &T_immed_u5, NULL, }, "xB", &T_vec_b32, 2, FALSE, FALSE, 0, "vec_vspltw:1", "*vspltw", CODE_FOR_xfxB_perm, B_UID(782) };
+static const struct builtin B1_vec_vspltb = { { &T_vec_b8, &T_immed_u5, NULL, }, "xB", &T_vec_b8, 2, FALSE, FALSE, 0, "vec_vspltb:1", "*vspltb", CODE_FOR_xfxB_perm, B_UID(783) };
+static const struct builtin B2_vec_vspltw = { { &T_vec_f32, &T_immed_u5, NULL, }, "xB", &T_vec_f32, 2, FALSE, FALSE, 0, "vec_vspltw:2", "*vspltw", CODE_FOR_xfxB_perm, B_UID(784) };
+static const struct builtin B2_vec_vsplth = { { &T_vec_p16, &T_immed_u5, NULL, }, "xB", &T_vec_p16, 2, FALSE, FALSE, 0, "vec_vsplth:2", "*vsplth", CODE_FOR_xfxB_perm, B_UID(785) };
+static const struct builtin B3_vec_vsplth = { { &T_vec_s16, &T_immed_u5, NULL, }, "xB", &T_vec_s16, 2, FALSE, FALSE, 0, "vec_vsplth:3", "*vsplth", CODE_FOR_xfxB_perm, B_UID(786) };
+static const struct builtin B3_vec_vspltw = { { &T_vec_s32, &T_immed_u5, NULL, }, "xB", &T_vec_s32, 2, FALSE, FALSE, 0, "vec_vspltw:3", "*vspltw", CODE_FOR_xfxB_perm, B_UID(787) };
+static const struct builtin B2_vec_vspltb = { { &T_vec_s8, &T_immed_u5, NULL, }, "xB", &T_vec_s8, 2, FALSE, FALSE, 0, "vec_vspltb:2", "*vspltb", CODE_FOR_xfxB_perm, B_UID(788) };
+static const struct builtin B4_vec_vsplth = { { &T_vec_u16, &T_immed_u5, NULL, }, "xB", &T_vec_u16, 2, FALSE, FALSE, 0, "vec_vsplth:4", "*vsplth", CODE_FOR_xfxB_perm, B_UID(789) };
+static const struct builtin B4_vec_vspltw = { { &T_vec_u32, &T_immed_u5, NULL, }, "xB", &T_vec_u32, 2, FALSE, FALSE, 0, "vec_vspltw:4", "*vspltw", CODE_FOR_xfxB_perm, B_UID(790) };
+static const struct builtin B3_vec_vspltb = { { &T_vec_u8, &T_immed_u5, NULL, }, "xB", &T_vec_u8, 2, FALSE, FALSE, 0, "vec_vspltb:3", "*vspltb", CODE_FOR_xfxB_perm, B_UID(791) };
+static const struct builtin B_vec_vspltish = { { &T_immed_s5, NULL, NULL, }, "A", &T_vec_s16, 1, FALSE, FALSE, 5, "vec_vspltish", "*vspltish", CODE_FOR_xfA_perm, B_UID(792) };
+static const struct builtin B_vec_vspltisw = { { &T_immed_s5, NULL, NULL, }, "A", &T_vec_s32, 1, FALSE, FALSE, 6, "vec_vspltisw", "*vspltisw", CODE_FOR_xfA_perm, B_UID(793) };
+static const struct builtin B_vec_vspltisb = { { &T_immed_s5, NULL, NULL, }, "A", &T_vec_s8, 1, FALSE, FALSE, 4, "vec_vspltisb", "*vspltisb", CODE_FOR_xfA_perm, B_UID(794) };
+static const struct builtin B_vec_splat_u16 = { { &T_immed_s5, NULL, NULL, }, "A", &T_vec_u16, 1, FALSE, FALSE, 5, "vec_splat_u16", "*vspltish", CODE_FOR_xfA_perm, B_UID(795) };
+static const struct builtin B_vec_splat_u32 = { { &T_immed_s5, NULL, NULL, }, "A", &T_vec_u32, 1, FALSE, FALSE, 6, "vec_splat_u32", "*vspltisw", CODE_FOR_xfA_perm, B_UID(796) };
+static const struct builtin B_vec_splat_u8 = { { &T_immed_s5, NULL, NULL, }, "A", &T_vec_u8, 1, FALSE, FALSE, 4, "vec_splat_u8", "*vspltisb", CODE_FOR_xfA_perm, B_UID(797) };
+static const struct builtin B1_vec_vsrh = { { &T_vec_s16, &T_vec_u16, NULL, }, "xx", &T_vec_s16, 2, FALSE, FALSE, 0, "vec_vsrh:1", "*vsrh", CODE_FOR_xfxx_simple, B_UID(798) };
+static const struct builtin B1_vec_vsrw = { { &T_vec_s32, &T_vec_u32, NULL, }, "xx", &T_vec_s32, 2, FALSE, FALSE, 0, "vec_vsrw:1", "*vsrw", CODE_FOR_xfxx_simple, B_UID(799) };
+static const struct builtin B1_vec_vsrb = { { &T_vec_s8, &T_vec_u8, NULL, }, "xx", &T_vec_s8, 2, FALSE, FALSE, 0, "vec_vsrb:1", "*vsrb", CODE_FOR_xfxx_simple, B_UID(800) };
+static const struct builtin B2_vec_vsrh = { { &T_vec_u16, &T_vec_u16, NULL, }, "xx", &T_vec_u16, 2, FALSE, FALSE, 0, "vec_vsrh:2", "*vsrh", CODE_FOR_xfxx_simple, B_UID(801) };
+static const struct builtin B2_vec_vsrw = { { &T_vec_u32, &T_vec_u32, NULL, }, "xx", &T_vec_u32, 2, FALSE, FALSE, 0, "vec_vsrw:2", "*vsrw", CODE_FOR_xfxx_simple, B_UID(802) };
+static const struct builtin B2_vec_vsrb = { { &T_vec_u8, &T_vec_u8, NULL, }, "xx", &T_vec_u8, 2, FALSE, FALSE, 0, "vec_vsrb:2", "*vsrb", CODE_FOR_xfxx_simple, B_UID(803) };
+static const struct builtin B1_vec_vsrah = { { &T_vec_s16, &T_vec_u16, NULL, }, "xx", &T_vec_s16, 2, FALSE, FALSE, 0, "vec_vsrah:1", "*vsrah", CODE_FOR_xfxx_simple, B_UID(804) };
+static const struct builtin B1_vec_vsraw = { { &T_vec_s32, &T_vec_u32, NULL, }, "xx", &T_vec_s32, 2, FALSE, FALSE, 0, "vec_vsraw:1", "*vsraw", CODE_FOR_xfxx_simple, B_UID(805) };
+static const struct builtin B1_vec_vsrab = { { &T_vec_s8, &T_vec_u8, NULL, }, "xx", &T_vec_s8, 2, FALSE, FALSE, 0, "vec_vsrab:1", "*vsrab", CODE_FOR_xfxx_simple, B_UID(806) };
+static const struct builtin B2_vec_vsrah = { { &T_vec_u16, &T_vec_u16, NULL, }, "xx", &T_vec_u16, 2, FALSE, FALSE, 0, "vec_vsrah:2", "*vsrah", CODE_FOR_xfxx_simple, B_UID(807) };
+static const struct builtin B2_vec_vsraw = { { &T_vec_u32, &T_vec_u32, NULL, }, "xx", &T_vec_u32, 2, FALSE, FALSE, 0, "vec_vsraw:2", "*vsraw", CODE_FOR_xfxx_simple, B_UID(808) };
+static const struct builtin B2_vec_vsrab = { { &T_vec_u8, &T_vec_u8, NULL, }, "xx", &T_vec_u8, 2, FALSE, FALSE, 0, "vec_vsrab:2", "*vsrab", CODE_FOR_xfxx_simple, B_UID(809) };
+static const struct builtin B1_vec_vsr = { { &T_vec_b16, &T_vec_u16, NULL, }, "xx", &T_vec_b16, 2, FALSE, FALSE, 0, "vec_vsr:1", "*vsr", CODE_FOR_xfxx_simple, B_UID(810) };
+static const struct builtin B2_vec_vsr = { { &T_vec_b16, &T_vec_u32, NULL, }, "xx", &T_vec_b16, 2, FALSE, FALSE, 0, "vec_vsr:2", "*vsr", CODE_FOR_xfxx_simple, B_UID(811) };
+static const struct builtin B3_vec_vsr = { { &T_vec_b16, &T_vec_u8, NULL, }, "xx", &T_vec_b16, 2, FALSE, FALSE, 0, "vec_vsr:3", "*vsr", CODE_FOR_xfxx_simple, B_UID(812) };
+static const struct builtin B4_vec_vsr = { { &T_vec_b32, &T_vec_u16, NULL, }, "xx", &T_vec_b32, 2, FALSE, FALSE, 0, "vec_vsr:4", "*vsr", CODE_FOR_xfxx_simple, B_UID(813) };
+static const struct builtin B5_vec_vsr = { { &T_vec_b32, &T_vec_u32, NULL, }, "xx", &T_vec_b32, 2, FALSE, FALSE, 0, "vec_vsr:5", "*vsr", CODE_FOR_xfxx_simple, B_UID(814) };
+static const struct builtin B6_vec_vsr = { { &T_vec_b32, &T_vec_u8, NULL, }, "xx", &T_vec_b32, 2, FALSE, FALSE, 0, "vec_vsr:6", "*vsr", CODE_FOR_xfxx_simple, B_UID(815) };
+static const struct builtin B7_vec_vsr = { { &T_vec_b8, &T_vec_u16, NULL, }, "xx", &T_vec_b8, 2, FALSE, FALSE, 0, "vec_vsr:7", "*vsr", CODE_FOR_xfxx_simple, B_UID(816) };
+static const struct builtin B8_vec_vsr = { { &T_vec_b8, &T_vec_u32, NULL, }, "xx", &T_vec_b8, 2, FALSE, FALSE, 0, "vec_vsr:8", "*vsr", CODE_FOR_xfxx_simple, B_UID(817) };
+static const struct builtin B9_vec_vsr = { { &T_vec_b8, &T_vec_u8, NULL, }, "xx", &T_vec_b8, 2, FALSE, FALSE, 0, "vec_vsr:9", "*vsr", CODE_FOR_xfxx_simple, B_UID(818) };
+static const struct builtin B10_vec_vsr = { { &T_vec_p16, &T_vec_u16, NULL, }, "xx", &T_vec_p16, 2, FALSE, FALSE, 0, "vec_vsr:10", "*vsr", CODE_FOR_xfxx_simple, B_UID(819) };
+static const struct builtin B11_vec_vsr = { { &T_vec_p16, &T_vec_u32, NULL, }, "xx", &T_vec_p16, 2, FALSE, FALSE, 0, "vec_vsr:11", "*vsr", CODE_FOR_xfxx_simple, B_UID(820) };
+static const struct builtin B12_vec_vsr = { { &T_vec_p16, &T_vec_u8, NULL, }, "xx", &T_vec_p16, 2, FALSE, FALSE, 0, "vec_vsr:12", "*vsr", CODE_FOR_xfxx_simple, B_UID(821) };
+static const struct builtin B13_vec_vsr = { { &T_vec_s16, &T_vec_u16, NULL, }, "xx", &T_vec_s16, 2, FALSE, FALSE, 0, "vec_vsr:13", "*vsr", CODE_FOR_xfxx_simple, B_UID(822) };
+static const struct builtin B14_vec_vsr = { { &T_vec_s16, &T_vec_u32, NULL, }, "xx", &T_vec_s16, 2, FALSE, FALSE, 0, "vec_vsr:14", "*vsr", CODE_FOR_xfxx_simple, B_UID(823) };
+static const struct builtin B15_vec_vsr = { { &T_vec_s16, &T_vec_u8, NULL, }, "xx", &T_vec_s16, 2, FALSE, FALSE, 0, "vec_vsr:15", "*vsr", CODE_FOR_xfxx_simple, B_UID(824) };
+static const struct builtin B16_vec_vsr = { { &T_vec_s32, &T_vec_u16, NULL, }, "xx", &T_vec_s32, 2, FALSE, FALSE, 0, "vec_vsr:16", "*vsr", CODE_FOR_xfxx_simple, B_UID(825) };
+static const struct builtin B17_vec_vsr = { { &T_vec_s32, &T_vec_u32, NULL, }, "xx", &T_vec_s32, 2, FALSE, FALSE, 0, "vec_vsr:17", "*vsr", CODE_FOR_xfxx_simple, B_UID(826) };
+static const struct builtin B18_vec_vsr = { { &T_vec_s32, &T_vec_u8, NULL, }, "xx", &T_vec_s32, 2, FALSE, FALSE, 0, "vec_vsr:18", "*vsr", CODE_FOR_xfxx_simple, B_UID(827) };
+static const struct builtin B19_vec_vsr = { { &T_vec_s8, &T_vec_u16, NULL, }, "xx", &T_vec_s8, 2, FALSE, FALSE, 0, "vec_vsr:19", "*vsr", CODE_FOR_xfxx_simple, B_UID(828) };
+static const struct builtin B20_vec_vsr = { { &T_vec_s8, &T_vec_u32, NULL, }, "xx", &T_vec_s8, 2, FALSE, FALSE, 0, "vec_vsr:20", "*vsr", CODE_FOR_xfxx_simple, B_UID(829) };
+static const struct builtin B21_vec_vsr = { { &T_vec_s8, &T_vec_u8, NULL, }, "xx", &T_vec_s8, 2, FALSE, FALSE, 0, "vec_vsr:21", "*vsr", CODE_FOR_xfxx_simple, B_UID(830) };
+static const struct builtin B22_vec_vsr = { { &T_vec_u16, &T_vec_u16, NULL, }, "xx", &T_vec_u16, 2, FALSE, FALSE, 0, "vec_vsr:22", "*vsr", CODE_FOR_xfxx_simple, B_UID(831) };
+static const struct builtin B23_vec_vsr = { { &T_vec_u16, &T_vec_u32, NULL, }, "xx", &T_vec_u16, 2, FALSE, FALSE, 0, "vec_vsr:23", "*vsr", CODE_FOR_xfxx_simple, B_UID(832) };
+static const struct builtin B24_vec_vsr = { { &T_vec_u16, &T_vec_u8, NULL, }, "xx", &T_vec_u16, 2, FALSE, FALSE, 0, "vec_vsr:24", "*vsr", CODE_FOR_xfxx_simple, B_UID(833) };
+static const struct builtin B25_vec_vsr = { { &T_vec_u32, &T_vec_u16, NULL, }, "xx", &T_vec_u32, 2, FALSE, FALSE, 0, "vec_vsr:25", "*vsr", CODE_FOR_xfxx_simple, B_UID(834) };
+static const struct builtin B26_vec_vsr = { { &T_vec_u32, &T_vec_u32, NULL, }, "xx", &T_vec_u32, 2, FALSE, FALSE, 0, "vec_vsr:26", "*vsr", CODE_FOR_xfxx_simple, B_UID(835) };
+static const struct builtin B27_vec_vsr = { { &T_vec_u32, &T_vec_u8, NULL, }, "xx", &T_vec_u32, 2, FALSE, FALSE, 0, "vec_vsr:27", "*vsr", CODE_FOR_xfxx_simple, B_UID(836) };
+static const struct builtin B28_vec_vsr = { { &T_vec_u8, &T_vec_u16, NULL, }, "xx", &T_vec_u8, 2, FALSE, FALSE, 0, "vec_vsr:28", "*vsr", CODE_FOR_xfxx_simple, B_UID(837) };
+static const struct builtin B29_vec_vsr = { { &T_vec_u8, &T_vec_u32, NULL, }, "xx", &T_vec_u8, 2, FALSE, FALSE, 0, "vec_vsr:29", "*vsr", CODE_FOR_xfxx_simple, B_UID(838) };
+static const struct builtin B30_vec_vsr = { { &T_vec_u8, &T_vec_u8, NULL, }, "xx", &T_vec_u8, 2, FALSE, FALSE, 0, "vec_vsr:30", "*vsr", CODE_FOR_xfxx_simple, B_UID(839) };
+static const struct builtin B1_vec_vsro = { { &T_vec_f32, &T_vec_s8, NULL, }, "xx", &T_vec_f32, 2, FALSE, FALSE, 0, "vec_vsro:1", "*vsro", CODE_FOR_xfxx_perm_bug, B_UID(840) };
+static const struct builtin B2_vec_vsro = { { &T_vec_f32, &T_vec_u8, NULL, }, "xx", &T_vec_f32, 2, FALSE, FALSE, 0, "vec_vsro:2", "*vsro", CODE_FOR_xfxx_perm_bug, B_UID(841) };
+static const struct builtin B3_vec_vsro = { { &T_vec_p16, &T_vec_s8, NULL, }, "xx", &T_vec_p16, 2, FALSE, FALSE, 0, "vec_vsro:3", "*vsro", CODE_FOR_xfxx_perm_bug, B_UID(842) };
+static const struct builtin B4_vec_vsro = { { &T_vec_p16, &T_vec_u8, NULL, }, "xx", &T_vec_p16, 2, FALSE, FALSE, 0, "vec_vsro:4", "*vsro", CODE_FOR_xfxx_perm_bug, B_UID(843) };
+static const struct builtin B5_vec_vsro = { { &T_vec_s16, &T_vec_s8, NULL, }, "xx", &T_vec_s16, 2, FALSE, FALSE, 0, "vec_vsro:5", "*vsro", CODE_FOR_xfxx_perm_bug, B_UID(844) };
+static const struct builtin B6_vec_vsro = { { &T_vec_s16, &T_vec_u8, NULL, }, "xx", &T_vec_s16, 2, FALSE, FALSE, 0, "vec_vsro:6", "*vsro", CODE_FOR_xfxx_perm_bug, B_UID(845) };
+static const struct builtin B7_vec_vsro = { { &T_vec_s32, &T_vec_s8, NULL, }, "xx", &T_vec_s32, 2, FALSE, FALSE, 0, "vec_vsro:7", "*vsro", CODE_FOR_xfxx_perm_bug, B_UID(846) };
+static const struct builtin B8_vec_vsro = { { &T_vec_s32, &T_vec_u8, NULL, }, "xx", &T_vec_s32, 2, FALSE, FALSE, 0, "vec_vsro:8", "*vsro", CODE_FOR_xfxx_perm_bug, B_UID(847) };
+static const struct builtin B9_vec_vsro = { { &T_vec_s8, &T_vec_s8, NULL, }, "xx", &T_vec_s8, 2, FALSE, FALSE, 0, "vec_vsro:9", "*vsro", CODE_FOR_xfxx_perm_bug, B_UID(848) };
+static const struct builtin B10_vec_vsro = { { &T_vec_s8, &T_vec_u8, NULL, }, "xx", &T_vec_s8, 2, FALSE, FALSE, 0, "vec_vsro:10", "*vsro", CODE_FOR_xfxx_perm_bug, B_UID(849) };
+static const struct builtin B11_vec_vsro = { { &T_vec_u16, &T_vec_s8, NULL, }, "xx", &T_vec_u16, 2, FALSE, FALSE, 0, "vec_vsro:11", "*vsro", CODE_FOR_xfxx_perm_bug, B_UID(850) };
+static const struct builtin B12_vec_vsro = { { &T_vec_u16, &T_vec_u8, NULL, }, "xx", &T_vec_u16, 2, FALSE, FALSE, 0, "vec_vsro:12", "*vsro", CODE_FOR_xfxx_perm_bug, B_UID(851) };
+static const struct builtin B13_vec_vsro = { { &T_vec_u32, &T_vec_s8, NULL, }, "xx", &T_vec_u32, 2, FALSE, FALSE, 0, "vec_vsro:13", "*vsro", CODE_FOR_xfxx_perm_bug, B_UID(852) };
+static const struct builtin B14_vec_vsro = { { &T_vec_u32, &T_vec_u8, NULL, }, "xx", &T_vec_u32, 2, FALSE, FALSE, 0, "vec_vsro:14", "*vsro", CODE_FOR_xfxx_perm_bug, B_UID(853) };
+static const struct builtin B15_vec_vsro = { { &T_vec_u8, &T_vec_s8, NULL, }, "xx", &T_vec_u8, 2, FALSE, FALSE, 0, "vec_vsro:15", "*vsro", CODE_FOR_xfxx_perm_bug, B_UID(854) };
+static const struct builtin B16_vec_vsro = { { &T_vec_u8, &T_vec_u8, NULL, }, "xx", &T_vec_u8, 2, FALSE, FALSE, 0, "vec_vsro:16", "*vsro", CODE_FOR_xfxx_perm_bug, B_UID(855) };
+static const struct builtin B1_vec_stvx = { { &T_vec_b16, &T_int, &T_short_ptr, }, "xii", &T_void, 3, FALSE, FALSE, 0, "vec_stvx:1", "*stvx", CODE_FOR_sfxii_store, B_UID(856) };
+static const struct builtin B2_vec_stvx = { { &T_vec_b16, &T_int, &T_unsigned_short_ptr, }, "xii", &T_void, 3, FALSE, FALSE, 0, "vec_stvx:2", "*stvx", CODE_FOR_sfxii_store, B_UID(857) };
+static const struct builtin B3_vec_stvx = { { &T_vec_b16, &T_int, &T_vec_b16_ptr, }, "xii", &T_void, 3, FALSE, FALSE, 0, "vec_stvx:3", "*stvx", CODE_FOR_sfxii_store, B_UID(858) };
+static const struct builtin B4_vec_stvx = { { &T_vec_b32, &T_int, &T_int_ptr, }, "xii", &T_void, 3, FALSE, FALSE, 0, "vec_stvx:4", "*stvx", CODE_FOR_sfxii_store, B_UID(859) };
+static const struct builtin B5_vec_stvx = { { &T_vec_b32, &T_int, &T_long_ptr, }, "xii", &T_void, 3, FALSE, FALSE, 0, "vec_stvx:5", "*stvx", CODE_FOR_sfxii_store, B_UID(860) };
+static const struct builtin B6_vec_stvx = { { &T_vec_b32, &T_int, &T_unsigned_int_ptr, }, "xii", &T_void, 3, FALSE, FALSE, 0, "vec_stvx:6", "*stvx", CODE_FOR_sfxii_store, B_UID(861) };
+static const struct builtin B7_vec_stvx = { { &T_vec_b32, &T_int, &T_unsigned_long_ptr, }, "xii", &T_void, 3, FALSE, FALSE, 0, "vec_stvx:7", "*stvx", CODE_FOR_sfxii_store, B_UID(862) };
+static const struct builtin B8_vec_stvx = { { &T_vec_b32, &T_int, &T_vec_b32_ptr, }, "xii", &T_void, 3, FALSE, FALSE, 0, "vec_stvx:8", "*stvx", CODE_FOR_sfxii_store, B_UID(863) };
+static const struct builtin B9_vec_stvx = { { &T_vec_b8, &T_int, &T_signed_char_ptr, }, "xii", &T_void, 3, FALSE, FALSE, 0, "vec_stvx:9", "*stvx", CODE_FOR_sfxii_store, B_UID(864) };
+static const struct builtin B10_vec_stvx = { { &T_vec_b8, &T_int, &T_unsigned_char_ptr, }, "xii", &T_void, 3, FALSE, FALSE, 0, "vec_stvx:10", "*stvx", CODE_FOR_sfxii_store, B_UID(865) };
+static const struct builtin B11_vec_stvx = { { &T_vec_b8, &T_int, &T_vec_b8_ptr, }, "xii", &T_void, 3, FALSE, FALSE, 0, "vec_stvx:11", "*stvx", CODE_FOR_sfxii_store, B_UID(866) };
+static const struct builtin B12_vec_stvx = { { &T_vec_f32, &T_int, &T_float_ptr, }, "xii", &T_void, 3, FALSE, FALSE, 0, "vec_stvx:12", "*stvx", CODE_FOR_sfxii_store, B_UID(867) };
+static const struct builtin B13_vec_stvx = { { &T_vec_f32, &T_int, &T_vec_f32_ptr, }, "xii", &T_void, 3, FALSE, FALSE, 0, "vec_stvx:13", "*stvx", CODE_FOR_sfxii_store, B_UID(868) };
+static const struct builtin B14_vec_stvx = { { &T_vec_p16, &T_int, &T_short_ptr, }, "xii", &T_void, 3, FALSE, FALSE, 0, "vec_stvx:14", "*stvx", CODE_FOR_sfxii_store, B_UID(869) };
+static const struct builtin B15_vec_stvx = { { &T_vec_p16, &T_int, &T_unsigned_short_ptr, }, "xii", &T_void, 3, FALSE, FALSE, 0, "vec_stvx:15", "*stvx", CODE_FOR_sfxii_store, B_UID(870) };
+static const struct builtin B16_vec_stvx = { { &T_vec_p16, &T_int, &T_vec_p16_ptr, }, "xii", &T_void, 3, FALSE, FALSE, 0, "vec_stvx:16", "*stvx", CODE_FOR_sfxii_store, B_UID(871) };
+static const struct builtin B17_vec_stvx = { { &T_vec_s16, &T_int, &T_short_ptr, }, "xii", &T_void, 3, FALSE, FALSE, 0, "vec_stvx:17", "*stvx", CODE_FOR_sfxii_store, B_UID(872) };
+static const struct builtin B18_vec_stvx = { { &T_vec_s16, &T_int, &T_vec_s16_ptr, }, "xii", &T_void, 3, FALSE, FALSE, 0, "vec_stvx:18", "*stvx", CODE_FOR_sfxii_store, B_UID(873) };
+static const struct builtin B19_vec_stvx = { { &T_vec_s32, &T_int, &T_int_ptr, }, "xii", &T_void, 3, FALSE, FALSE, 0, "vec_stvx:19", "*stvx", CODE_FOR_sfxii_store, B_UID(874) };
+static const struct builtin B20_vec_stvx = { { &T_vec_s32, &T_int, &T_long_ptr, }, "xii", &T_void, 3, FALSE, FALSE, 0, "vec_stvx:20", "*stvx", CODE_FOR_sfxii_store, B_UID(875) };
+static const struct builtin B21_vec_stvx = { { &T_vec_s32, &T_int, &T_vec_s32_ptr, }, "xii", &T_void, 3, FALSE, FALSE, 0, "vec_stvx:21", "*stvx", CODE_FOR_sfxii_store, B_UID(876) };
+static const struct builtin B22_vec_stvx = { { &T_vec_s8, &T_int, &T_signed_char_ptr, }, "xii", &T_void, 3, FALSE, FALSE, 0, "vec_stvx:22", "*stvx", CODE_FOR_sfxii_store, B_UID(877) };
+static const struct builtin B23_vec_stvx = { { &T_vec_s8, &T_int, &T_vec_s8_ptr, }, "xii", &T_void, 3, FALSE, FALSE, 0, "vec_stvx:23", "*stvx", CODE_FOR_sfxii_store, B_UID(878) };
+static const struct builtin B24_vec_stvx = { { &T_vec_u16, &T_int, &T_unsigned_short_ptr, }, "xii", &T_void, 3, FALSE, FALSE, 0, "vec_stvx:24", "*stvx", CODE_FOR_sfxii_store, B_UID(879) };
+static const struct builtin B25_vec_stvx = { { &T_vec_u16, &T_int, &T_vec_u16_ptr, }, "xii", &T_void, 3, FALSE, FALSE, 0, "vec_stvx:25", "*stvx", CODE_FOR_sfxii_store, B_UID(880) };
+static const struct builtin B26_vec_stvx = { { &T_vec_u32, &T_int, &T_unsigned_int_ptr, }, "xii", &T_void, 3, FALSE, FALSE, 0, "vec_stvx:26", "*stvx", CODE_FOR_sfxii_store, B_UID(881) };
+static const struct builtin B27_vec_stvx = { { &T_vec_u32, &T_int, &T_unsigned_long_ptr, }, "xii", &T_void, 3, FALSE, FALSE, 0, "vec_stvx:27", "*stvx", CODE_FOR_sfxii_store, B_UID(882) };
+static const struct builtin B28_vec_stvx = { { &T_vec_u32, &T_int, &T_vec_u32_ptr, }, "xii", &T_void, 3, FALSE, FALSE, 0, "vec_stvx:28", "*stvx", CODE_FOR_sfxii_store, B_UID(883) };
+static const struct builtin B29_vec_stvx = { { &T_vec_u8, &T_int, &T_unsigned_char_ptr, }, "xii", &T_void, 3, FALSE, FALSE, 0, "vec_stvx:29", "*stvx", CODE_FOR_sfxii_store, B_UID(884) };
+static const struct builtin B30_vec_stvx = { { &T_vec_u8, &T_int, &T_vec_u8_ptr, }, "xii", &T_void, 3, FALSE, FALSE, 0, "vec_stvx:30", "*stvx", CODE_FOR_sfxii_store, B_UID(885) };
+static const struct builtin B1_vec_stvebx = { { &T_vec_b16, &T_int, &T_short_ptr, }, "xii", &T_void, 3, FALSE, FALSE, 0, "vec_stvebx:1", "*stvebx", CODE_FOR_sfxii_store, B_UID(886) };
+static const struct builtin B2_vec_stvebx = { { &T_vec_b16, &T_int, &T_unsigned_short_ptr, }, "xii", &T_void, 3, FALSE, FALSE, 0, "vec_stvebx:2", "*stvebx", CODE_FOR_sfxii_store, B_UID(887) };
+static const struct builtin B1_vec_stvewx = { { &T_vec_b32, &T_int, &T_int_ptr, }, "xii", &T_void, 3, FALSE, FALSE, 0, "vec_stvewx:1", "*stvewx", CODE_FOR_sfxii_store, B_UID(888) };
+static const struct builtin B2_vec_stvewx = { { &T_vec_b32, &T_int, &T_long_ptr, }, "xii", &T_void, 3, FALSE, FALSE, 0, "vec_stvewx:2", "*stvewx", CODE_FOR_sfxii_store, B_UID(889) };
+static const struct builtin B3_vec_stvewx = { { &T_vec_b32, &T_int, &T_unsigned_int_ptr, }, "xii", &T_void, 3, FALSE, FALSE, 0, "vec_stvewx:3", "*stvewx", CODE_FOR_sfxii_store, B_UID(890) };
+static const struct builtin B4_vec_stvewx = { { &T_vec_b32, &T_int, &T_unsigned_long_ptr, }, "xii", &T_void, 3, FALSE, FALSE, 0, "vec_stvewx:4", "*stvewx", CODE_FOR_sfxii_store, B_UID(891) };
+static const struct builtin B3_vec_stvebx = { { &T_vec_b8, &T_int, &T_signed_char_ptr, }, "xii", &T_void, 3, FALSE, FALSE, 0, "vec_stvebx:3", "*stvebx", CODE_FOR_sfxii_store, B_UID(892) };
+static const struct builtin B4_vec_stvebx = { { &T_vec_b8, &T_int, &T_unsigned_char_ptr, }, "xii", &T_void, 3, FALSE, FALSE, 0, "vec_stvebx:4", "*stvebx", CODE_FOR_sfxii_store, B_UID(893) };
+static const struct builtin B5_vec_stvewx = { { &T_vec_f32, &T_int, &T_float_ptr, }, "xii", &T_void, 3, FALSE, FALSE, 0, "vec_stvewx:5", "*stvewx", CODE_FOR_sfxii_store, B_UID(894) };
+static const struct builtin B1_vec_stvehx = { { &T_vec_p16, &T_int, &T_short_ptr, }, "xii", &T_void, 3, FALSE, FALSE, 0, "vec_stvehx:1", "*stvehx", CODE_FOR_sfxii_store, B_UID(895) };
+static const struct builtin B2_vec_stvehx = { { &T_vec_p16, &T_int, &T_unsigned_short_ptr, }, "xii", &T_void, 3, FALSE, FALSE, 0, "vec_stvehx:2", "*stvehx", CODE_FOR_sfxii_store, B_UID(896) };
+static const struct builtin B3_vec_stvehx = { { &T_vec_s16, &T_int, &T_short_ptr, }, "xii", &T_void, 3, FALSE, FALSE, 0, "vec_stvehx:3", "*stvehx", CODE_FOR_sfxii_store, B_UID(897) };
+static const struct builtin B6_vec_stvewx = { { &T_vec_s32, &T_int, &T_int_ptr, }, "xii", &T_void, 3, FALSE, FALSE, 0, "vec_stvewx:6", "*stvewx", CODE_FOR_sfxii_store, B_UID(898) };
+static const struct builtin B7_vec_stvewx = { { &T_vec_s32, &T_int, &T_long_ptr, }, "xii", &T_void, 3, FALSE, FALSE, 0, "vec_stvewx:7", "*stvewx", CODE_FOR_sfxii_store, B_UID(899) };
+static const struct builtin B5_vec_stvebx = { { &T_vec_s8, &T_int, &T_signed_char_ptr, }, "xii", &T_void, 3, FALSE, FALSE, 0, "vec_stvebx:5", "*stvebx", CODE_FOR_sfxii_store, B_UID(900) };
+static const struct builtin B4_vec_stvehx = { { &T_vec_u16, &T_int, &T_unsigned_short_ptr, }, "xii", &T_void, 3, FALSE, FALSE, 0, "vec_stvehx:4", "*stvehx", CODE_FOR_sfxii_store, B_UID(901) };
+static const struct builtin B8_vec_stvewx = { { &T_vec_u32, &T_int, &T_unsigned_int_ptr, }, "xii", &T_void, 3, FALSE, FALSE, 0, "vec_stvewx:8", "*stvewx", CODE_FOR_sfxii_store, B_UID(902) };
+static const struct builtin B9_vec_stvewx = { { &T_vec_u32, &T_int, &T_unsigned_long_ptr, }, "xii", &T_void, 3, FALSE, FALSE, 0, "vec_stvewx:9", "*stvewx", CODE_FOR_sfxii_store, B_UID(903) };
+static const struct builtin B6_vec_stvebx = { { &T_vec_u8, &T_int, &T_unsigned_char_ptr, }, "xii", &T_void, 3, FALSE, FALSE, 0, "vec_stvebx:6", "*stvebx", CODE_FOR_sfxii_store, B_UID(904) };
+static const struct builtin B1_vec_stvxl = { { &T_vec_b16, &T_int, &T_short_ptr, }, "xii", &T_void, 3, FALSE, FALSE, 0, "vec_stvxl:1", "*stvxl", CODE_FOR_sfxii_store, B_UID(905) };
+static const struct builtin B2_vec_stvxl = { { &T_vec_b16, &T_int, &T_unsigned_short_ptr, }, "xii", &T_void, 3, FALSE, FALSE, 0, "vec_stvxl:2", "*stvxl", CODE_FOR_sfxii_store, B_UID(906) };
+static const struct builtin B3_vec_stvxl = { { &T_vec_b16, &T_int, &T_vec_b16_ptr, }, "xii", &T_void, 3, FALSE, FALSE, 0, "vec_stvxl:3", "*stvxl", CODE_FOR_sfxii_store, B_UID(907) };
+static const struct builtin B4_vec_stvxl = { { &T_vec_b32, &T_int, &T_int_ptr, }, "xii", &T_void, 3, FALSE, FALSE, 0, "vec_stvxl:4", "*stvxl", CODE_FOR_sfxii_store, B_UID(908) };
+static const struct builtin B5_vec_stvxl = { { &T_vec_b32, &T_int, &T_long_ptr, }, "xii", &T_void, 3, FALSE, FALSE, 0, "vec_stvxl:5", "*stvxl", CODE_FOR_sfxii_store, B_UID(909) };
+static const struct builtin B6_vec_stvxl = { { &T_vec_b32, &T_int, &T_unsigned_int_ptr, }, "xii", &T_void, 3, FALSE, FALSE, 0, "vec_stvxl:6", "*stvxl", CODE_FOR_sfxii_store, B_UID(910) };
+static const struct builtin B7_vec_stvxl = { { &T_vec_b32, &T_int, &T_unsigned_long_ptr, }, "xii", &T_void, 3, FALSE, FALSE, 0, "vec_stvxl:7", "*stvxl", CODE_FOR_sfxii_store, B_UID(911) };
+static const struct builtin B8_vec_stvxl = { { &T_vec_b32, &T_int, &T_vec_b32_ptr, }, "xii", &T_void, 3, FALSE, FALSE, 0, "vec_stvxl:8", "*stvxl", CODE_FOR_sfxii_store, B_UID(912) };
+static const struct builtin B9_vec_stvxl = { { &T_vec_b8, &T_int, &T_signed_char_ptr, }, "xii", &T_void, 3, FALSE, FALSE, 0, "vec_stvxl:9", "*stvxl", CODE_FOR_sfxii_store, B_UID(913) };
+static const struct builtin B10_vec_stvxl = { { &T_vec_b8, &T_int, &T_unsigned_char_ptr, }, "xii", &T_void, 3, FALSE, FALSE, 0, "vec_stvxl:10", "*stvxl", CODE_FOR_sfxii_store, B_UID(914) };
+static const struct builtin B11_vec_stvxl = { { &T_vec_b8, &T_int, &T_vec_b8_ptr, }, "xii", &T_void, 3, FALSE, FALSE, 0, "vec_stvxl:11", "*stvxl", CODE_FOR_sfxii_store, B_UID(915) };
+static const struct builtin B12_vec_stvxl = { { &T_vec_f32, &T_int, &T_float_ptr, }, "xii", &T_void, 3, FALSE, FALSE, 0, "vec_stvxl:12", "*stvxl", CODE_FOR_sfxii_store, B_UID(916) };
+static const struct builtin B13_vec_stvxl = { { &T_vec_f32, &T_int, &T_vec_f32_ptr, }, "xii", &T_void, 3, FALSE, FALSE, 0, "vec_stvxl:13", "*stvxl", CODE_FOR_sfxii_store, B_UID(917) };
+static const struct builtin B14_vec_stvxl = { { &T_vec_p16, &T_int, &T_short_ptr, }, "xii", &T_void, 3, FALSE, FALSE, 0, "vec_stvxl:14", "*stvxl", CODE_FOR_sfxii_store, B_UID(918) };
+static const struct builtin B15_vec_stvxl = { { &T_vec_p16, &T_int, &T_unsigned_short_ptr, }, "xii", &T_void, 3, FALSE, FALSE, 0, "vec_stvxl:15", "*stvxl", CODE_FOR_sfxii_store, B_UID(919) };
+static const struct builtin B16_vec_stvxl = { { &T_vec_p16, &T_int, &T_vec_p16_ptr, }, "xii", &T_void, 3, FALSE, FALSE, 0, "vec_stvxl:16", "*stvxl", CODE_FOR_sfxii_store, B_UID(920) };
+static const struct builtin B17_vec_stvxl = { { &T_vec_s16, &T_int, &T_short_ptr, }, "xii", &T_void, 3, FALSE, FALSE, 0, "vec_stvxl:17", "*stvxl", CODE_FOR_sfxii_store, B_UID(921) };
+static const struct builtin B18_vec_stvxl = { { &T_vec_s16, &T_int, &T_vec_s16_ptr, }, "xii", &T_void, 3, FALSE, FALSE, 0, "vec_stvxl:18", "*stvxl", CODE_FOR_sfxii_store, B_UID(922) };
+static const struct builtin B19_vec_stvxl = { { &T_vec_s32, &T_int, &T_int_ptr, }, "xii", &T_void, 3, FALSE, FALSE, 0, "vec_stvxl:19", "*stvxl", CODE_FOR_sfxii_store, B_UID(923) };
+static const struct builtin B20_vec_stvxl = { { &T_vec_s32, &T_int, &T_long_ptr, }, "xii", &T_void, 3, FALSE, FALSE, 0, "vec_stvxl:20", "*stvxl", CODE_FOR_sfxii_store, B_UID(924) };
+static const struct builtin B21_vec_stvxl = { { &T_vec_s32, &T_int, &T_vec_s32_ptr, }, "xii", &T_void, 3, FALSE, FALSE, 0, "vec_stvxl:21", "*stvxl", CODE_FOR_sfxii_store, B_UID(925) };
+static const struct builtin B22_vec_stvxl = { { &T_vec_s8, &T_int, &T_signed_char_ptr, }, "xii", &T_void, 3, FALSE, FALSE, 0, "vec_stvxl:22", "*stvxl", CODE_FOR_sfxii_store, B_UID(926) };
+static const struct builtin B23_vec_stvxl = { { &T_vec_s8, &T_int, &T_vec_s8_ptr, }, "xii", &T_void, 3, FALSE, FALSE, 0, "vec_stvxl:23", "*stvxl", CODE_FOR_sfxii_store, B_UID(927) };
+static const struct builtin B24_vec_stvxl = { { &T_vec_u16, &T_int, &T_unsigned_short_ptr, }, "xii", &T_void, 3, FALSE, FALSE, 0, "vec_stvxl:24", "*stvxl", CODE_FOR_sfxii_store, B_UID(928) };
+static const struct builtin B25_vec_stvxl = { { &T_vec_u16, &T_int, &T_vec_u16_ptr, }, "xii", &T_void, 3, FALSE, FALSE, 0, "vec_stvxl:25", "*stvxl", CODE_FOR_sfxii_store, B_UID(929) };
+static const struct builtin B26_vec_stvxl = { { &T_vec_u32, &T_int, &T_unsigned_int_ptr, }, "xii", &T_void, 3, FALSE, FALSE, 0, "vec_stvxl:26", "*stvxl", CODE_FOR_sfxii_store, B_UID(930) };
+static const struct builtin B27_vec_stvxl = { { &T_vec_u32, &T_int, &T_unsigned_long_ptr, }, "xii", &T_void, 3, FALSE, FALSE, 0, "vec_stvxl:27", "*stvxl", CODE_FOR_sfxii_store, B_UID(931) };
+static const struct builtin B28_vec_stvxl = { { &T_vec_u32, &T_int, &T_vec_u32_ptr, }, "xii", &T_void, 3, FALSE, FALSE, 0, "vec_stvxl:28", "*stvxl", CODE_FOR_sfxii_store, B_UID(932) };
+static const struct builtin B29_vec_stvxl = { { &T_vec_u8, &T_int, &T_unsigned_char_ptr, }, "xii", &T_void, 3, FALSE, FALSE, 0, "vec_stvxl:29", "*stvxl", CODE_FOR_sfxii_store, B_UID(933) };
+static const struct builtin B30_vec_stvxl = { { &T_vec_u8, &T_int, &T_vec_u8_ptr, }, "xii", &T_void, 3, FALSE, FALSE, 0, "vec_stvxl:30", "*stvxl", CODE_FOR_sfxii_store, B_UID(934) };
+static const struct builtin B1_vec_vsubuhm = { { &T_vec_b16, &T_vec_s16, NULL, }, "xx", &T_vec_s16, 2, FALSE, FALSE, 1, "vec_vsubuhm:1", "*vsubuhm", CODE_FOR_xfxx_simple, B_UID(935) };
+static const struct builtin B2_vec_vsubuhm = { { &T_vec_b16, &T_vec_u16, NULL, }, "xx", &T_vec_u16, 2, FALSE, FALSE, 1, "vec_vsubuhm:2", "*vsubuhm", CODE_FOR_xfxx_simple, B_UID(936) };
+static const struct builtin B1_vec_vsubuwm = { { &T_vec_b32, &T_vec_s32, NULL, }, "xx", &T_vec_s32, 2, FALSE, FALSE, 1, "vec_vsubuwm:1", "*vsubuwm", CODE_FOR_xfxx_simple, B_UID(937) };
+static const struct builtin B2_vec_vsubuwm = { { &T_vec_b32, &T_vec_u32, NULL, }, "xx", &T_vec_u32, 2, FALSE, FALSE, 1, "vec_vsubuwm:2", "*vsubuwm", CODE_FOR_xfxx_simple, B_UID(938) };
+static const struct builtin B1_vec_vsububm = { { &T_vec_b8, &T_vec_s8, NULL, }, "xx", &T_vec_s8, 2, FALSE, FALSE, 1, "vec_vsububm:1", "*vsububm", CODE_FOR_xfxx_simple, B_UID(939) };
+static const struct builtin B2_vec_vsububm = { { &T_vec_b8, &T_vec_u8, NULL, }, "xx", &T_vec_u8, 2, FALSE, FALSE, 1, "vec_vsububm:2", "*vsububm", CODE_FOR_xfxx_simple, B_UID(940) };
+static const struct builtin B_vec_vsubfp = { { &T_vec_f32, &T_vec_f32, NULL, }, "xx", &T_vec_f32, 2, FALSE, FALSE, 1, "vec_vsubfp", "*vsubfp", CODE_FOR_xfxx_fp, B_UID(941) };
+static const struct builtin B3_vec_vsubuhm = { { &T_vec_s16, &T_vec_b16, NULL, }, "xx", &T_vec_s16, 2, FALSE, FALSE, 1, "vec_vsubuhm:3", "*vsubuhm", CODE_FOR_xfxx_simple, B_UID(942) };
+static const struct builtin B4_vec_vsubuhm = { { &T_vec_s16, &T_vec_s16, NULL, }, "xx", &T_vec_s16, 2, FALSE, FALSE, 1, "vec_vsubuhm:4", "*vsubuhm", CODE_FOR_xfxx_simple, B_UID(943) };
+static const struct builtin B3_vec_vsubuwm = { { &T_vec_s32, &T_vec_b32, NULL, }, "xx", &T_vec_s32, 2, FALSE, FALSE, 1, "vec_vsubuwm:3", "*vsubuwm", CODE_FOR_xfxx_simple, B_UID(944) };
+static const struct builtin B4_vec_vsubuwm = { { &T_vec_s32, &T_vec_s32, NULL, }, "xx", &T_vec_s32, 2, FALSE, FALSE, 1, "vec_vsubuwm:4", "*vsubuwm", CODE_FOR_xfxx_simple, B_UID(945) };
+static const struct builtin B3_vec_vsububm = { { &T_vec_s8, &T_vec_b8, NULL, }, "xx", &T_vec_s8, 2, FALSE, FALSE, 1, "vec_vsububm:3", "*vsububm", CODE_FOR_xfxx_simple, B_UID(946) };
+static const struct builtin B4_vec_vsububm = { { &T_vec_s8, &T_vec_s8, NULL, }, "xx", &T_vec_s8, 2, FALSE, FALSE, 1, "vec_vsububm:4", "*vsububm", CODE_FOR_xfxx_simple, B_UID(947) };
+static const struct builtin B5_vec_vsubuhm = { { &T_vec_u16, &T_vec_b16, NULL, }, "xx", &T_vec_u16, 2, FALSE, FALSE, 1, "vec_vsubuhm:5", "*vsubuhm", CODE_FOR_xfxx_simple, B_UID(948) };
+static const struct builtin B6_vec_vsubuhm = { { &T_vec_u16, &T_vec_u16, NULL, }, "xx", &T_vec_u16, 2, FALSE, FALSE, 1, "vec_vsubuhm:6", "*vsubuhm", CODE_FOR_xfxx_simple, B_UID(949) };
+static const struct builtin B5_vec_vsubuwm = { { &T_vec_u32, &T_vec_b32, NULL, }, "xx", &T_vec_u32, 2, FALSE, FALSE, 1, "vec_vsubuwm:5", "*vsubuwm", CODE_FOR_xfxx_simple, B_UID(950) };
+static const struct builtin B6_vec_vsubuwm = { { &T_vec_u32, &T_vec_u32, NULL, }, "xx", &T_vec_u32, 2, FALSE, FALSE, 1, "vec_vsubuwm:6", "*vsubuwm", CODE_FOR_xfxx_simple, B_UID(951) };
+static const struct builtin B5_vec_vsububm = { { &T_vec_u8, &T_vec_b8, NULL, }, "xx", &T_vec_u8, 2, FALSE, FALSE, 1, "vec_vsububm:5", "*vsububm", CODE_FOR_xfxx_simple, B_UID(952) };
+static const struct builtin B6_vec_vsububm = { { &T_vec_u8, &T_vec_u8, NULL, }, "xx", &T_vec_u8, 2, FALSE, FALSE, 1, "vec_vsububm:6", "*vsububm", CODE_FOR_xfxx_simple, B_UID(953) };
+static const struct builtin B_vec_vsubcuw = { { &T_vec_u32, &T_vec_u32, NULL, }, "xx", &T_vec_u32, 2, FALSE, FALSE, 0, "vec_vsubcuw", "*vsubcuw", CODE_FOR_xfxx_simple, B_UID(954) };
+static const struct builtin B1_vec_vsubshs = { { &T_vec_b16, &T_vec_s16, NULL, }, "xx", &T_vec_s16, 2, FALSE, FALSE, 1, "vec_vsubshs:1", "*vsubshs", CODE_FOR_xfxx_simple, B_UID(955) };
+static const struct builtin B1_vec_vsubuhs = { { &T_vec_b16, &T_vec_u16, NULL, }, "xx", &T_vec_u16, 2, FALSE, FALSE, 1, "vec_vsubuhs:1", "*vsubuhs", CODE_FOR_xfxx_simple, B_UID(956) };
+static const struct builtin B1_vec_vsubsws = { { &T_vec_b32, &T_vec_s32, NULL, }, "xx", &T_vec_s32, 2, FALSE, FALSE, 1, "vec_vsubsws:1", "*vsubsws", CODE_FOR_xfxx_simple, B_UID(957) };
+static const struct builtin B1_vec_vsubuws = { { &T_vec_b32, &T_vec_u32, NULL, }, "xx", &T_vec_u32, 2, FALSE, FALSE, 1, "vec_vsubuws:1", "*vsubuws", CODE_FOR_xfxx_simple, B_UID(958) };
+static const struct builtin B1_vec_vsubsbs = { { &T_vec_b8, &T_vec_s8, NULL, }, "xx", &T_vec_s8, 2, FALSE, FALSE, 1, "vec_vsubsbs:1", "*vsubsbs", CODE_FOR_xfxx_simple, B_UID(959) };
+static const struct builtin B1_vec_vsububs = { { &T_vec_b8, &T_vec_u8, NULL, }, "xx", &T_vec_u8, 2, FALSE, FALSE, 1, "vec_vsububs:1", "*vsububs", CODE_FOR_xfxx_simple, B_UID(960) };
+static const struct builtin B2_vec_vsubshs = { { &T_vec_s16, &T_vec_b16, NULL, }, "xx", &T_vec_s16, 2, FALSE, FALSE, 1, "vec_vsubshs:2", "*vsubshs", CODE_FOR_xfxx_simple, B_UID(961) };
+static const struct builtin B3_vec_vsubshs = { { &T_vec_s16, &T_vec_s16, NULL, }, "xx", &T_vec_s16, 2, FALSE, FALSE, 1, "vec_vsubshs:3", "*vsubshs", CODE_FOR_xfxx_simple, B_UID(962) };
+static const struct builtin B2_vec_vsubsws = { { &T_vec_s32, &T_vec_b32, NULL, }, "xx", &T_vec_s32, 2, FALSE, FALSE, 1, "vec_vsubsws:2", "*vsubsws", CODE_FOR_xfxx_simple, B_UID(963) };
+static const struct builtin B3_vec_vsubsws = { { &T_vec_s32, &T_vec_s32, NULL, }, "xx", &T_vec_s32, 2, FALSE, FALSE, 1, "vec_vsubsws:3", "*vsubsws", CODE_FOR_xfxx_simple, B_UID(964) };
+static const struct builtin B2_vec_vsubsbs = { { &T_vec_s8, &T_vec_b8, NULL, }, "xx", &T_vec_s8, 2, FALSE, FALSE, 1, "vec_vsubsbs:2", "*vsubsbs", CODE_FOR_xfxx_simple, B_UID(965) };
+static const struct builtin B3_vec_vsubsbs = { { &T_vec_s8, &T_vec_s8, NULL, }, "xx", &T_vec_s8, 2, FALSE, FALSE, 1, "vec_vsubsbs:3", "*vsubsbs", CODE_FOR_xfxx_simple, B_UID(966) };
+static const struct builtin B2_vec_vsubuhs = { { &T_vec_u16, &T_vec_b16, NULL, }, "xx", &T_vec_u16, 2, FALSE, FALSE, 1, "vec_vsubuhs:2", "*vsubuhs", CODE_FOR_xfxx_simple, B_UID(967) };
+static const struct builtin B3_vec_vsubuhs = { { &T_vec_u16, &T_vec_u16, NULL, }, "xx", &T_vec_u16, 2, FALSE, FALSE, 1, "vec_vsubuhs:3", "*vsubuhs", CODE_FOR_xfxx_simple, B_UID(968) };
+static const struct builtin B2_vec_vsubuws = { { &T_vec_u32, &T_vec_b32, NULL, }, "xx", &T_vec_u32, 2, FALSE, FALSE, 1, "vec_vsubuws:2", "*vsubuws", CODE_FOR_xfxx_simple, B_UID(969) };
+static const struct builtin B3_vec_vsubuws = { { &T_vec_u32, &T_vec_u32, NULL, }, "xx", &T_vec_u32, 2, FALSE, FALSE, 1, "vec_vsubuws:3", "*vsubuws", CODE_FOR_xfxx_simple, B_UID(970) };
+static const struct builtin B2_vec_vsububs = { { &T_vec_u8, &T_vec_b8, NULL, }, "xx", &T_vec_u8, 2, FALSE, FALSE, 1, "vec_vsububs:2", "*vsububs", CODE_FOR_xfxx_simple, B_UID(971) };
+static const struct builtin B3_vec_vsububs = { { &T_vec_u8, &T_vec_u8, NULL, }, "xx", &T_vec_u8, 2, FALSE, FALSE, 1, "vec_vsububs:3", "*vsububs", CODE_FOR_xfxx_simple, B_UID(972) };
+static const struct builtin B_vec_vsum2sws = { { &T_vec_s32, &T_vec_s32, NULL, }, "xx", &T_vec_s32, 2, FALSE, FALSE, 0, "vec_vsum2sws", "*vsum2sws", CODE_FOR_xfxx_complex, B_UID(973) };
+static const struct builtin B_vec_vsum4shs = { { &T_vec_s16, &T_vec_s32, NULL, }, "xx", &T_vec_s32, 2, FALSE, FALSE, 0, "vec_vsum4shs", "*vsum4shs", CODE_FOR_xfxx_complex, B_UID(974) };
+static const struct builtin B_vec_vsum4sbs = { { &T_vec_s8, &T_vec_s32, NULL, }, "xx", &T_vec_s32, 2, FALSE, FALSE, 0, "vec_vsum4sbs", "*vsum4sbs", CODE_FOR_xfxx_complex, B_UID(975) };
+static const struct builtin B_vec_vsum4ubs = { { &T_vec_u8, &T_vec_u32, NULL, }, "xx", &T_vec_u32, 2, FALSE, FALSE, 0, "vec_vsum4ubs", "*vsum4ubs", CODE_FOR_xfxx_complex, B_UID(976) };
+static const struct builtin B_vec_vsumsws = { { &T_vec_s32, &T_vec_s32, NULL, }, "xx", &T_vec_s32, 2, FALSE, FALSE, 0, "vec_vsumsws", "*vsumsws", CODE_FOR_xfxx_complex, B_UID(977) };
+static const struct builtin B_vec_vrfiz = { { &T_vec_f32, NULL, NULL, }, "x", &T_vec_f32, 1, FALSE, FALSE, 0, "vec_vrfiz", "*vrfiz", CODE_FOR_xfx_fp, B_UID(978) };
+static const struct builtin B1_vec_unpack2sh = { { &T_vec_u16, &T_vec_u16, NULL, }, "xx", &T_vec_s32, 2, FALSE, FALSE, 0, "vec_unpack2sh:1", "*vmrghh", CODE_FOR_xfxx_perm, B_UID(979) };
+static const struct builtin B2_vec_unpack2sh = { { &T_vec_u8, &T_vec_u8, NULL, }, "xx", &T_vec_s16, 2, FALSE, FALSE, 0, "vec_unpack2sh:2", "*vmrghb", CODE_FOR_xfxx_perm, B_UID(980) };
+static const struct builtin B1_vec_unpack2sl = { { &T_vec_u16, &T_vec_u16, NULL, }, "xx", &T_vec_s32, 2, FALSE, FALSE, 0, "vec_unpack2sl:1", "*vmrglh", CODE_FOR_xfxx_perm, B_UID(981) };
+static const struct builtin B2_vec_unpack2sl = { { &T_vec_u8, &T_vec_u8, NULL, }, "xx", &T_vec_s16, 2, FALSE, FALSE, 0, "vec_unpack2sl:2", "*vmrglb", CODE_FOR_xfxx_perm, B_UID(982) };
+static const struct builtin B1_vec_unpack2uh = { { &T_vec_u16, &T_vec_u16, NULL, }, "xx", &T_vec_u32, 2, FALSE, FALSE, 0, "vec_unpack2uh:1", "*vmrghh", CODE_FOR_xfxx_perm, B_UID(983) };
+static const struct builtin B2_vec_unpack2uh = { { &T_vec_u8, &T_vec_u8, NULL, }, "xx", &T_vec_u16, 2, FALSE, FALSE, 0, "vec_unpack2uh:2", "*vmrghb", CODE_FOR_xfxx_perm, B_UID(984) };
+static const struct builtin B1_vec_unpack2ul = { { &T_vec_u16, &T_vec_u16, NULL, }, "xx", &T_vec_u32, 2, FALSE, FALSE, 0, "vec_unpack2ul:1", "*vmrglh", CODE_FOR_xfxx_perm, B_UID(985) };
+static const struct builtin B2_vec_unpack2ul = { { &T_vec_u8, &T_vec_u8, NULL, }, "xx", &T_vec_u16, 2, FALSE, FALSE, 0, "vec_unpack2ul:2", "*vmrglb", CODE_FOR_xfxx_perm, B_UID(986) };
+static const struct builtin B1_vec_vupkhsh = { { &T_vec_b16, NULL, NULL, }, "x", &T_vec_b32, 1, FALSE, FALSE, 0, "vec_vupkhsh:1", "*vupkhsh", CODE_FOR_xfx_perm, B_UID(987) };
+static const struct builtin B1_vec_vupkhsb = { { &T_vec_b8, NULL, NULL, }, "x", &T_vec_b16, 1, FALSE, FALSE, 0, "vec_vupkhsb:1", "*vupkhsb", CODE_FOR_xfx_perm, B_UID(988) };
+static const struct builtin B_vec_vupkhpx = { { &T_vec_p16, NULL, NULL, }, "x", &T_vec_u32, 1, FALSE, FALSE, 0, "vec_vupkhpx", "*vupkhpx", CODE_FOR_xfx_perm, B_UID(989) };
+static const struct builtin B2_vec_vupkhsh = { { &T_vec_s16, NULL, NULL, }, "x", &T_vec_s32, 1, FALSE, FALSE, 0, "vec_vupkhsh:2", "*vupkhsh", CODE_FOR_xfx_perm, B_UID(990) };
+static const struct builtin B2_vec_vupkhsb = { { &T_vec_s8, NULL, NULL, }, "x", &T_vec_s16, 1, FALSE, FALSE, 0, "vec_vupkhsb:2", "*vupkhsb", CODE_FOR_xfx_perm, B_UID(991) };
+static const struct builtin B1_vec_vupklsh = { { &T_vec_b16, NULL, NULL, }, "x", &T_vec_b32, 1, FALSE, FALSE, 0, "vec_vupklsh:1", "*vupklsh", CODE_FOR_xfx_perm, B_UID(992) };
+static const struct builtin B1_vec_vupklsb = { { &T_vec_b8, NULL, NULL, }, "x", &T_vec_b16, 1, FALSE, FALSE, 0, "vec_vupklsb:1", "*vupklsb", CODE_FOR_xfx_perm, B_UID(993) };
+static const struct builtin B_vec_vupklpx = { { &T_vec_p16, NULL, NULL, }, "x", &T_vec_u32, 1, FALSE, FALSE, 0, "vec_vupklpx", "*vupklpx", CODE_FOR_xfx_perm, B_UID(994) };
+static const struct builtin B2_vec_vupklsh = { { &T_vec_s16, NULL, NULL, }, "x", &T_vec_s32, 1, FALSE, FALSE, 0, "vec_vupklsh:2", "*vupklsh", CODE_FOR_xfx_perm, B_UID(995) };
+static const struct builtin B2_vec_vupklsb = { { &T_vec_s8, NULL, NULL, }, "x", &T_vec_s16, 1, FALSE, FALSE, 0, "vec_vupklsb:2", "*vupklsb", CODE_FOR_xfx_perm, B_UID(996) };
+static const struct builtin B1_vec_vxor = { { &T_vec_b16, &T_vec_b16, NULL, }, "xx", &T_vec_b16, 2, FALSE, FALSE, 1, "vec_vxor:1", "*vxor", CODE_FOR_xfxx_simple, B_UID(997) };
+static const struct builtin B2_vec_vxor = { { &T_vec_b16, &T_vec_s16, NULL, }, "xx", &T_vec_s16, 2, FALSE, FALSE, 1, "vec_vxor:2", "*vxor", CODE_FOR_xfxx_simple, B_UID(998) };
+static const struct builtin B3_vec_vxor = { { &T_vec_b16, &T_vec_u16, NULL, }, "xx", &T_vec_u16, 2, FALSE, FALSE, 1, "vec_vxor:3", "*vxor", CODE_FOR_xfxx_simple, B_UID(999) };
+static const struct builtin B4_vec_vxor = { { &T_vec_b32, &T_vec_b32, NULL, }, "xx", &T_vec_b32, 2, FALSE, FALSE, 1, "vec_vxor:4", "*vxor", CODE_FOR_xfxx_simple, B_UID(1000) };
+static const struct builtin B5_vec_vxor = { { &T_vec_b32, &T_vec_f32, NULL, }, "xx", &T_vec_f32, 2, FALSE, FALSE, 1, "vec_vxor:5", "*vxor", CODE_FOR_xfxx_simple, B_UID(1001) };
+static const struct builtin B6_vec_vxor = { { &T_vec_b32, &T_vec_s32, NULL, }, "xx", &T_vec_s32, 2, FALSE, FALSE, 1, "vec_vxor:6", "*vxor", CODE_FOR_xfxx_simple, B_UID(1002) };
+static const struct builtin B7_vec_vxor = { { &T_vec_b32, &T_vec_u32, NULL, }, "xx", &T_vec_u32, 2, FALSE, FALSE, 1, "vec_vxor:7", "*vxor", CODE_FOR_xfxx_simple, B_UID(1003) };
+static const struct builtin B8_vec_vxor = { { &T_vec_b8, &T_vec_b8, NULL, }, "xx", &T_vec_b8, 2, FALSE, FALSE, 1, "vec_vxor:8", "*vxor", CODE_FOR_xfxx_simple, B_UID(1004) };
+static const struct builtin B9_vec_vxor = { { &T_vec_b8, &T_vec_s8, NULL, }, "xx", &T_vec_s8, 2, FALSE, FALSE, 1, "vec_vxor:9", "*vxor", CODE_FOR_xfxx_simple, B_UID(1005) };
+static const struct builtin B10_vec_vxor = { { &T_vec_b8, &T_vec_u8, NULL, }, "xx", &T_vec_u8, 2, FALSE, FALSE, 1, "vec_vxor:10", "*vxor", CODE_FOR_xfxx_simple, B_UID(1006) };
+static const struct builtin B11_vec_vxor = { { &T_vec_f32, &T_vec_b32, NULL, }, "xx", &T_vec_f32, 2, FALSE, FALSE, 1, "vec_vxor:11", "*vxor", CODE_FOR_xfxx_simple, B_UID(1007) };
+static const struct builtin B12_vec_vxor = { { &T_vec_f32, &T_vec_f32, NULL, }, "xx", &T_vec_f32, 2, FALSE, FALSE, 1, "vec_vxor:12", "*vxor", CODE_FOR_xfxx_simple, B_UID(1008) };
+static const struct builtin B13_vec_vxor = { { &T_vec_s16, &T_vec_b16, NULL, }, "xx", &T_vec_s16, 2, FALSE, FALSE, 1, "vec_vxor:13", "*vxor", CODE_FOR_xfxx_simple, B_UID(1009) };
+static const struct builtin B14_vec_vxor = { { &T_vec_s16, &T_vec_s16, NULL, }, "xx", &T_vec_s16, 2, FALSE, FALSE, 1, "vec_vxor:14", "*vxor", CODE_FOR_xfxx_simple, B_UID(1010) };
+static const struct builtin B15_vec_vxor = { { &T_vec_s32, &T_vec_b32, NULL, }, "xx", &T_vec_s32, 2, FALSE, FALSE, 1, "vec_vxor:15", "*vxor", CODE_FOR_xfxx_simple, B_UID(1011) };
+static const struct builtin B16_vec_vxor = { { &T_vec_s32, &T_vec_s32, NULL, }, "xx", &T_vec_s32, 2, FALSE, FALSE, 1, "vec_vxor:16", "*vxor", CODE_FOR_xfxx_simple, B_UID(1012) };
+static const struct builtin B17_vec_vxor = { { &T_vec_s8, &T_vec_b8, NULL, }, "xx", &T_vec_s8, 2, FALSE, FALSE, 1, "vec_vxor:17", "*vxor", CODE_FOR_xfxx_simple, B_UID(1013) };
+static const struct builtin B18_vec_vxor = { { &T_vec_s8, &T_vec_s8, NULL, }, "xx", &T_vec_s8, 2, FALSE, FALSE, 1, "vec_vxor:18", "*vxor", CODE_FOR_xfxx_simple, B_UID(1014) };
+static const struct builtin B19_vec_vxor = { { &T_vec_u16, &T_vec_b16, NULL, }, "xx", &T_vec_u16, 2, FALSE, FALSE, 1, "vec_vxor:19", "*vxor", CODE_FOR_xfxx_simple, B_UID(1015) };
+static const struct builtin B20_vec_vxor = { { &T_vec_u16, &T_vec_u16, NULL, }, "xx", &T_vec_u16, 2, FALSE, FALSE, 1, "vec_vxor:20", "*vxor", CODE_FOR_xfxx_simple, B_UID(1016) };
+static const struct builtin B21_vec_vxor = { { &T_vec_u32, &T_vec_b32, NULL, }, "xx", &T_vec_u32, 2, FALSE, FALSE, 1, "vec_vxor:21", "*vxor", CODE_FOR_xfxx_simple, B_UID(1017) };
+static const struct builtin B22_vec_vxor = { { &T_vec_u32, &T_vec_u32, NULL, }, "xx", &T_vec_u32, 2, FALSE, FALSE, 1, "vec_vxor:22", "*vxor", CODE_FOR_xfxx_simple, B_UID(1018) };
+static const struct builtin B23_vec_vxor = { { &T_vec_u8, &T_vec_b8, NULL, }, "xx", &T_vec_u8, 2, FALSE, FALSE, 1, "vec_vxor:23", "*vxor", CODE_FOR_xfxx_simple, B_UID(1019) };
+static const struct builtin B24_vec_vxor = { { &T_vec_u8, &T_vec_u8, NULL, }, "xx", &T_vec_u8, 2, FALSE, FALSE, 1, "vec_vxor:24", "*vxor", CODE_FOR_xfxx_simple, B_UID(1020) };
+#define LAST_B_UID B_UID(1021)
+
+const struct builtin * const Builtin[] = {
+ &B1_vec_abs,
+ &B2_vec_abs,
+ &B3_vec_abs,
+ &B4_vec_abs,
+ &B1_vec_abss,
+ &B2_vec_abss,
+ &B3_vec_abss,
+ &B1_vec_vadduhm,
+ &B2_vec_vadduhm,
+ &B1_vec_vadduwm,
+ &B2_vec_vadduwm,
+ &B1_vec_vaddubm,
+ &B2_vec_vaddubm,
+ &B_vec_vaddfp,
+ &B3_vec_vadduhm,
+ &B4_vec_vadduhm,
+ &B3_vec_vadduwm,
+ &B4_vec_vadduwm,
+ &B3_vec_vaddubm,
+ &B4_vec_vaddubm,
+ &B5_vec_vadduhm,
+ &B6_vec_vadduhm,
+ &B5_vec_vadduwm,
+ &B6_vec_vadduwm,
+ &B5_vec_vaddubm,
+ &B6_vec_vaddubm,
+ &B_vec_vaddcuw,
+ &B1_vec_vaddshs,
+ &B1_vec_vadduhs,
+ &B1_vec_vaddsws,
+ &B1_vec_vadduws,
+ &B1_vec_vaddsbs,
+ &B1_vec_vaddubs,
+ &B2_vec_vaddshs,
+ &B3_vec_vaddshs,
+ &B2_vec_vaddsws,
+ &B3_vec_vaddsws,
+ &B2_vec_vaddsbs,
+ &B3_vec_vaddsbs,
+ &B2_vec_vadduhs,
+ &B3_vec_vadduhs,
+ &B2_vec_vadduws,
+ &B3_vec_vadduws,
+ &B2_vec_vaddubs,
+ &B3_vec_vaddubs,
+ &B1_vec_all_eq,
+ &B2_vec_all_eq,
+ &B3_vec_all_eq,
+ &B4_vec_all_eq,
+ &B5_vec_all_eq,
+ &B6_vec_all_eq,
+ &B7_vec_all_eq,
+ &B8_vec_all_eq,
+ &B9_vec_all_eq,
+ &B10_vec_all_eq,
+ &B11_vec_all_eq,
+ &B12_vec_all_eq,
+ &B13_vec_all_eq,
+ &B14_vec_all_eq,
+ &B15_vec_all_eq,
+ &B16_vec_all_eq,
+ &B17_vec_all_eq,
+ &B18_vec_all_eq,
+ &B19_vec_all_eq,
+ &B20_vec_all_eq,
+ &B21_vec_all_eq,
+ &B22_vec_all_eq,
+ &B23_vec_all_eq,
+ &B1_vec_all_ge,
+ &B2_vec_all_ge,
+ &B3_vec_all_ge,
+ &B4_vec_all_ge,
+ &B5_vec_all_ge,
+ &B6_vec_all_ge,
+ &B7_vec_all_ge,
+ &B8_vec_all_ge,
+ &B9_vec_all_ge,
+ &B10_vec_all_ge,
+ &B11_vec_all_ge,
+ &B12_vec_all_ge,
+ &B13_vec_all_ge,
+ &B14_vec_all_ge,
+ &B15_vec_all_ge,
+ &B16_vec_all_ge,
+ &B17_vec_all_ge,
+ &B18_vec_all_ge,
+ &B19_vec_all_ge,
+ &B1_vec_all_gt,
+ &B2_vec_all_gt,
+ &B3_vec_all_gt,
+ &B4_vec_all_gt,
+ &B5_vec_all_gt,
+ &B6_vec_all_gt,
+ &B7_vec_all_gt,
+ &B8_vec_all_gt,
+ &B9_vec_all_gt,
+ &B10_vec_all_gt,
+ &B11_vec_all_gt,
+ &B12_vec_all_gt,
+ &B13_vec_all_gt,
+ &B14_vec_all_gt,
+ &B15_vec_all_gt,
+ &B16_vec_all_gt,
+ &B17_vec_all_gt,
+ &B18_vec_all_gt,
+ &B19_vec_all_gt,
+ &B_vec_all_in,
+ &B1_vec_all_le,
+ &B2_vec_all_le,
+ &B3_vec_all_le,
+ &B4_vec_all_le,
+ &B5_vec_all_le,
+ &B6_vec_all_le,
+ &B7_vec_all_le,
+ &B8_vec_all_le,
+ &B9_vec_all_le,
+ &B10_vec_all_le,
+ &B11_vec_all_le,
+ &B12_vec_all_le,
+ &B13_vec_all_le,
+ &B14_vec_all_le,
+ &B15_vec_all_le,
+ &B16_vec_all_le,
+ &B17_vec_all_le,
+ &B18_vec_all_le,
+ &B19_vec_all_le,
+ &B1_vec_all_lt,
+ &B2_vec_all_lt,
+ &B3_vec_all_lt,
+ &B4_vec_all_lt,
+ &B5_vec_all_lt,
+ &B6_vec_all_lt,
+ &B7_vec_all_lt,
+ &B8_vec_all_lt,
+ &B9_vec_all_lt,
+ &B10_vec_all_lt,
+ &B11_vec_all_lt,
+ &B12_vec_all_lt,
+ &B13_vec_all_lt,
+ &B14_vec_all_lt,
+ &B15_vec_all_lt,
+ &B16_vec_all_lt,
+ &B17_vec_all_lt,
+ &B18_vec_all_lt,
+ &B19_vec_all_lt,
+ &B_vec_all_nan,
+ &B1_vec_all_ne,
+ &B2_vec_all_ne,
+ &B3_vec_all_ne,
+ &B4_vec_all_ne,
+ &B5_vec_all_ne,
+ &B6_vec_all_ne,
+ &B7_vec_all_ne,
+ &B8_vec_all_ne,
+ &B9_vec_all_ne,
+ &B10_vec_all_ne,
+ &B11_vec_all_ne,
+ &B12_vec_all_ne,
+ &B13_vec_all_ne,
+ &B14_vec_all_ne,
+ &B15_vec_all_ne,
+ &B16_vec_all_ne,
+ &B17_vec_all_ne,
+ &B18_vec_all_ne,
+ &B19_vec_all_ne,
+ &B20_vec_all_ne,
+ &B21_vec_all_ne,
+ &B22_vec_all_ne,
+ &B23_vec_all_ne,
+ &B_vec_all_nge,
+ &B_vec_all_ngt,
+ &B_vec_all_nle,
+ &B_vec_all_nlt,
+ &B_vec_all_numeric,
+ &B1_vec_vand,
+ &B2_vec_vand,
+ &B3_vec_vand,
+ &B4_vec_vand,
+ &B5_vec_vand,
+ &B6_vec_vand,
+ &B7_vec_vand,
+ &B8_vec_vand,
+ &B9_vec_vand,
+ &B10_vec_vand,
+ &B11_vec_vand,
+ &B12_vec_vand,
+ &B13_vec_vand,
+ &B14_vec_vand,
+ &B15_vec_vand,
+ &B16_vec_vand,
+ &B17_vec_vand,
+ &B18_vec_vand,
+ &B19_vec_vand,
+ &B20_vec_vand,
+ &B21_vec_vand,
+ &B22_vec_vand,
+ &B23_vec_vand,
+ &B24_vec_vand,
+ &B1_vec_vandc,
+ &B2_vec_vandc,
+ &B3_vec_vandc,
+ &B4_vec_vandc,
+ &B5_vec_vandc,
+ &B6_vec_vandc,
+ &B7_vec_vandc,
+ &B8_vec_vandc,
+ &B9_vec_vandc,
+ &B10_vec_vandc,
+ &B11_vec_vandc,
+ &B12_vec_vandc,
+ &B13_vec_vandc,
+ &B14_vec_vandc,
+ &B15_vec_vandc,
+ &B16_vec_vandc,
+ &B17_vec_vandc,
+ &B18_vec_vandc,
+ &B19_vec_vandc,
+ &B20_vec_vandc,
+ &B21_vec_vandc,
+ &B22_vec_vandc,
+ &B23_vec_vandc,
+ &B24_vec_vandc,
+ &B1_vec_any_eq,
+ &B2_vec_any_eq,
+ &B3_vec_any_eq,
+ &B4_vec_any_eq,
+ &B5_vec_any_eq,
+ &B6_vec_any_eq,
+ &B7_vec_any_eq,
+ &B8_vec_any_eq,
+ &B9_vec_any_eq,
+ &B10_vec_any_eq,
+ &B11_vec_any_eq,
+ &B12_vec_any_eq,
+ &B13_vec_any_eq,
+ &B14_vec_any_eq,
+ &B15_vec_any_eq,
+ &B16_vec_any_eq,
+ &B17_vec_any_eq,
+ &B18_vec_any_eq,
+ &B19_vec_any_eq,
+ &B20_vec_any_eq,
+ &B21_vec_any_eq,
+ &B22_vec_any_eq,
+ &B23_vec_any_eq,
+ &B1_vec_any_ge,
+ &B2_vec_any_ge,
+ &B3_vec_any_ge,
+ &B4_vec_any_ge,
+ &B5_vec_any_ge,
+ &B6_vec_any_ge,
+ &B7_vec_any_ge,
+ &B8_vec_any_ge,
+ &B9_vec_any_ge,
+ &B10_vec_any_ge,
+ &B11_vec_any_ge,
+ &B12_vec_any_ge,
+ &B13_vec_any_ge,
+ &B14_vec_any_ge,
+ &B15_vec_any_ge,
+ &B16_vec_any_ge,
+ &B17_vec_any_ge,
+ &B18_vec_any_ge,
+ &B19_vec_any_ge,
+ &B1_vec_any_gt,
+ &B2_vec_any_gt,
+ &B3_vec_any_gt,
+ &B4_vec_any_gt,
+ &B5_vec_any_gt,
+ &B6_vec_any_gt,
+ &B7_vec_any_gt,
+ &B8_vec_any_gt,
+ &B9_vec_any_gt,
+ &B10_vec_any_gt,
+ &B11_vec_any_gt,
+ &B12_vec_any_gt,
+ &B13_vec_any_gt,
+ &B14_vec_any_gt,
+ &B15_vec_any_gt,
+ &B16_vec_any_gt,
+ &B17_vec_any_gt,
+ &B18_vec_any_gt,
+ &B19_vec_any_gt,
+ &B1_vec_any_le,
+ &B2_vec_any_le,
+ &B3_vec_any_le,
+ &B4_vec_any_le,
+ &B5_vec_any_le,
+ &B6_vec_any_le,
+ &B7_vec_any_le,
+ &B8_vec_any_le,
+ &B9_vec_any_le,
+ &B10_vec_any_le,
+ &B11_vec_any_le,
+ &B12_vec_any_le,
+ &B13_vec_any_le,
+ &B14_vec_any_le,
+ &B15_vec_any_le,
+ &B16_vec_any_le,
+ &B17_vec_any_le,
+ &B18_vec_any_le,
+ &B19_vec_any_le,
+ &B1_vec_any_lt,
+ &B2_vec_any_lt,
+ &B3_vec_any_lt,
+ &B4_vec_any_lt,
+ &B5_vec_any_lt,
+ &B6_vec_any_lt,
+ &B7_vec_any_lt,
+ &B8_vec_any_lt,
+ &B9_vec_any_lt,
+ &B10_vec_any_lt,
+ &B11_vec_any_lt,
+ &B12_vec_any_lt,
+ &B13_vec_any_lt,
+ &B14_vec_any_lt,
+ &B15_vec_any_lt,
+ &B16_vec_any_lt,
+ &B17_vec_any_lt,
+ &B18_vec_any_lt,
+ &B19_vec_any_lt,
+ &B_vec_any_nan,
+ &B1_vec_any_ne,
+ &B2_vec_any_ne,
+ &B3_vec_any_ne,
+ &B4_vec_any_ne,
+ &B5_vec_any_ne,
+ &B6_vec_any_ne,
+ &B7_vec_any_ne,
+ &B8_vec_any_ne,
+ &B9_vec_any_ne,
+ &B10_vec_any_ne,
+ &B11_vec_any_ne,
+ &B12_vec_any_ne,
+ &B13_vec_any_ne,
+ &B14_vec_any_ne,
+ &B15_vec_any_ne,
+ &B16_vec_any_ne,
+ &B17_vec_any_ne,
+ &B18_vec_any_ne,
+ &B19_vec_any_ne,
+ &B20_vec_any_ne,
+ &B21_vec_any_ne,
+ &B22_vec_any_ne,
+ &B23_vec_any_ne,
+ &B_vec_any_nge,
+ &B_vec_any_ngt,
+ &B_vec_any_nle,
+ &B_vec_any_nlt,
+ &B_vec_any_numeric,
+ &B_vec_any_out,
+ &B_vec_vavgsh,
+ &B_vec_vavgsw,
+ &B_vec_vavgsb,
+ &B_vec_vavguh,
+ &B_vec_vavguw,
+ &B_vec_vavgub,
+ &B_vec_vrfip,
+ &B_vec_vcmpbfp,
+ &B_vec_vcmpeqfp,
+ &B1_vec_vcmpequh,
+ &B1_vec_vcmpequw,
+ &B1_vec_vcmpequb,
+ &B2_vec_vcmpequh,
+ &B2_vec_vcmpequw,
+ &B2_vec_vcmpequb,
+ &B_vec_vcmpgefp,
+ &B_vec_vcmpgtfp,
+ &B_vec_vcmpgtsh,
+ &B_vec_vcmpgtsw,
+ &B_vec_vcmpgtsb,
+ &B_vec_vcmpgtuh,
+ &B_vec_vcmpgtuw,
+ &B_vec_vcmpgtub,
+ &B_vec_cmple,
+ &B1_vec_cmplt,
+ &B2_vec_cmplt,
+ &B3_vec_cmplt,
+ &B4_vec_cmplt,
+ &B5_vec_cmplt,
+ &B6_vec_cmplt,
+ &B7_vec_cmplt,
+ &B_vec_vcfsx,
+ &B_vec_vcfux,
+ &B_vec_vctsxs,
+ &B_vec_vctuxs,
+ &B_vec_dss,
+ &B_vec_dssall,
+ &B1_vec_dst,
+ &B2_vec_dst,
+ &B3_vec_dst,
+ &B4_vec_dst,
+ &B5_vec_dst,
+ &B6_vec_dst,
+ &B7_vec_dst,
+ &B8_vec_dst,
+ &B9_vec_dst,
+ &B10_vec_dst,
+ &B11_vec_dst,
+ &B12_vec_dst,
+ &B13_vec_dst,
+ &B14_vec_dst,
+ &B15_vec_dst,
+ &B16_vec_dst,
+ &B17_vec_dst,
+ &B18_vec_dst,
+ &B19_vec_dst,
+ &B20_vec_dst,
+ &B1_vec_dstst,
+ &B2_vec_dstst,
+ &B3_vec_dstst,
+ &B4_vec_dstst,
+ &B5_vec_dstst,
+ &B6_vec_dstst,
+ &B7_vec_dstst,
+ &B8_vec_dstst,
+ &B9_vec_dstst,
+ &B10_vec_dstst,
+ &B11_vec_dstst,
+ &B12_vec_dstst,
+ &B13_vec_dstst,
+ &B14_vec_dstst,
+ &B15_vec_dstst,
+ &B16_vec_dstst,
+ &B17_vec_dstst,
+ &B18_vec_dstst,
+ &B19_vec_dstst,
+ &B20_vec_dstst,
+ &B1_vec_dststt,
+ &B2_vec_dststt,
+ &B3_vec_dststt,
+ &B4_vec_dststt,
+ &B5_vec_dststt,
+ &B6_vec_dststt,
+ &B7_vec_dststt,
+ &B8_vec_dststt,
+ &B9_vec_dststt,
+ &B10_vec_dststt,
+ &B11_vec_dststt,
+ &B12_vec_dststt,
+ &B13_vec_dststt,
+ &B14_vec_dststt,
+ &B15_vec_dststt,
+ &B16_vec_dststt,
+ &B17_vec_dststt,
+ &B18_vec_dststt,
+ &B19_vec_dststt,
+ &B20_vec_dststt,
+ &B1_vec_dstt,
+ &B2_vec_dstt,
+ &B3_vec_dstt,
+ &B4_vec_dstt,
+ &B5_vec_dstt,
+ &B6_vec_dstt,
+ &B7_vec_dstt,
+ &B8_vec_dstt,
+ &B9_vec_dstt,
+ &B10_vec_dstt,
+ &B11_vec_dstt,
+ &B12_vec_dstt,
+ &B13_vec_dstt,
+ &B14_vec_dstt,
+ &B15_vec_dstt,
+ &B16_vec_dstt,
+ &B17_vec_dstt,
+ &B18_vec_dstt,
+ &B19_vec_dstt,
+ &B20_vec_dstt,
+ &B_vec_vexptefp,
+ &B_vec_vrfim,
+ &B1_vec_lvx,
+ &B2_vec_lvx,
+ &B3_vec_lvx,
+ &B4_vec_lvx,
+ &B5_vec_lvx,
+ &B6_vec_lvx,
+ &B7_vec_lvx,
+ &B8_vec_lvx,
+ &B9_vec_lvx,
+ &B10_vec_lvx,
+ &B11_vec_lvx,
+ &B12_vec_lvx,
+ &B13_vec_lvx,
+ &B14_vec_lvx,
+ &B15_vec_lvx,
+ &B16_vec_lvx,
+ &B17_vec_lvx,
+ &B18_vec_lvx,
+ &B19_vec_lvx,
+ &B20_vec_lvx,
+ &B1_vec_lvewx,
+ &B2_vec_lvewx,
+ &B3_vec_lvewx,
+ &B1_vec_lvehx,
+ &B1_vec_lvebx,
+ &B2_vec_lvebx,
+ &B4_vec_lvewx,
+ &B5_vec_lvewx,
+ &B2_vec_lvehx,
+ &B1_vec_lvxl,
+ &B2_vec_lvxl,
+ &B3_vec_lvxl,
+ &B4_vec_lvxl,
+ &B5_vec_lvxl,
+ &B6_vec_lvxl,
+ &B7_vec_lvxl,
+ &B8_vec_lvxl,
+ &B9_vec_lvxl,
+ &B10_vec_lvxl,
+ &B11_vec_lvxl,
+ &B12_vec_lvxl,
+ &B13_vec_lvxl,
+ &B14_vec_lvxl,
+ &B15_vec_lvxl,
+ &B16_vec_lvxl,
+ &B17_vec_lvxl,
+ &B18_vec_lvxl,
+ &B19_vec_lvxl,
+ &B20_vec_lvxl,
+ &B_vec_vlogefp,
+ &B1_vec_lvsl,
+ &B2_vec_lvsl,
+ &B3_vec_lvsl,
+ &B4_vec_lvsl,
+ &B5_vec_lvsl,
+ &B6_vec_lvsl,
+ &B7_vec_lvsl,
+ &B8_vec_lvsl,
+ &B9_vec_lvsl,
+ &B1_vec_lvsr,
+ &B2_vec_lvsr,
+ &B3_vec_lvsr,
+ &B4_vec_lvsr,
+ &B5_vec_lvsr,
+ &B6_vec_lvsr,
+ &B7_vec_lvsr,
+ &B8_vec_lvsr,
+ &B9_vec_lvsr,
+ &B_vec_vmaddfp,
+ &B_vec_vmhaddshs,
+ &B1_vec_vmaxsh,
+ &B1_vec_vmaxuh,
+ &B1_vec_vmaxsw,
+ &B1_vec_vmaxuw,
+ &B1_vec_vmaxsb,
+ &B1_vec_vmaxub,
+ &B_vec_vmaxfp,
+ &B2_vec_vmaxsh,
+ &B3_vec_vmaxsh,
+ &B2_vec_vmaxsw,
+ &B3_vec_vmaxsw,
+ &B2_vec_vmaxsb,
+ &B3_vec_vmaxsb,
+ &B2_vec_vmaxuh,
+ &B3_vec_vmaxuh,
+ &B2_vec_vmaxuw,
+ &B3_vec_vmaxuw,
+ &B2_vec_vmaxub,
+ &B3_vec_vmaxub,
+ &B1_vec_vmrghh,
+ &B1_vec_vmrghw,
+ &B1_vec_vmrghb,
+ &B2_vec_vmrghw,
+ &B2_vec_vmrghh,
+ &B3_vec_vmrghh,
+ &B3_vec_vmrghw,
+ &B2_vec_vmrghb,
+ &B4_vec_vmrghh,
+ &B4_vec_vmrghw,
+ &B3_vec_vmrghb,
+ &B1_vec_vmrglh,
+ &B1_vec_vmrglw,
+ &B1_vec_vmrglb,
+ &B2_vec_vmrglw,
+ &B2_vec_vmrglh,
+ &B3_vec_vmrglh,
+ &B3_vec_vmrglw,
+ &B2_vec_vmrglb,
+ &B4_vec_vmrglh,
+ &B4_vec_vmrglw,
+ &B3_vec_vmrglb,
+ &B_vec_mfvscr,
+ &B1_vec_vminsh,
+ &B1_vec_vminuh,
+ &B1_vec_vminsw,
+ &B1_vec_vminuw,
+ &B1_vec_vminsb,
+ &B1_vec_vminub,
+ &B_vec_vminfp,
+ &B2_vec_vminsh,
+ &B3_vec_vminsh,
+ &B2_vec_vminsw,
+ &B3_vec_vminsw,
+ &B2_vec_vminsb,
+ &B3_vec_vminsb,
+ &B2_vec_vminuh,
+ &B3_vec_vminuh,
+ &B2_vec_vminuw,
+ &B3_vec_vminuw,
+ &B2_vec_vminub,
+ &B3_vec_vminub,
+ &B1_vec_vmladduhm,
+ &B2_vec_vmladduhm,
+ &B3_vec_vmladduhm,
+ &B4_vec_vmladduhm,
+ &B_vec_vmhraddshs,
+ &B_vec_vmsumshm,
+ &B_vec_vmsummbm,
+ &B_vec_vmsumuhm,
+ &B_vec_vmsumubm,
+ &B_vec_vmsumshs,
+ &B_vec_vmsumuhs,
+ &B1_vec_mtvscr,
+ &B2_vec_mtvscr,
+ &B3_vec_mtvscr,
+ &B4_vec_mtvscr,
+ &B5_vec_mtvscr,
+ &B6_vec_mtvscr,
+ &B7_vec_mtvscr,
+ &B8_vec_mtvscr,
+ &B9_vec_mtvscr,
+ &B10_vec_mtvscr,
+ &B_vec_vmulesh,
+ &B_vec_vmulesb,
+ &B_vec_vmuleuh,
+ &B_vec_vmuleub,
+ &B_vec_vmulosh,
+ &B_vec_vmulosb,
+ &B_vec_vmulouh,
+ &B_vec_vmuloub,
+ &B_vec_vnmsubfp,
+ &B1_vec_vnor,
+ &B2_vec_vnor,
+ &B3_vec_vnor,
+ &B4_vec_vnor,
+ &B5_vec_vnor,
+ &B6_vec_vnor,
+ &B7_vec_vnor,
+ &B8_vec_vnor,
+ &B9_vec_vnor,
+ &B10_vec_vnor,
+ &B1_vec_vor,
+ &B2_vec_vor,
+ &B3_vec_vor,
+ &B4_vec_vor,
+ &B5_vec_vor,
+ &B6_vec_vor,
+ &B7_vec_vor,
+ &B8_vec_vor,
+ &B9_vec_vor,
+ &B10_vec_vor,
+ &B11_vec_vor,
+ &B12_vec_vor,
+ &B13_vec_vor,
+ &B14_vec_vor,
+ &B15_vec_vor,
+ &B16_vec_vor,
+ &B17_vec_vor,
+ &B18_vec_vor,
+ &B19_vec_vor,
+ &B20_vec_vor,
+ &B21_vec_vor,
+ &B22_vec_vor,
+ &B23_vec_vor,
+ &B24_vec_vor,
+ &B1_vec_vpkuhum,
+ &B1_vec_vpkuwum,
+ &B2_vec_vpkuhum,
+ &B2_vec_vpkuwum,
+ &B3_vec_vpkuhum,
+ &B3_vec_vpkuwum,
+ &B_vec_vpkpx,
+ &B_vec_vpkshss,
+ &B_vec_vpkswss,
+ &B_vec_vpkuhus,
+ &B_vec_vpkuwus,
+ &B_vec_vpkshus,
+ &B_vec_vpkswus,
+ &B1_vec_vperm,
+ &B2_vec_vperm,
+ &B3_vec_vperm,
+ &B4_vec_vperm,
+ &B5_vec_vperm,
+ &B6_vec_vperm,
+ &B7_vec_vperm,
+ &B8_vec_vperm,
+ &B9_vec_vperm,
+ &B10_vec_vperm,
+ &B11_vec_vperm,
+ &B_vec_vrefp,
+ &B1_vec_vrlh,
+ &B1_vec_vrlw,
+ &B1_vec_vrlb,
+ &B2_vec_vrlh,
+ &B2_vec_vrlw,
+ &B2_vec_vrlb,
+ &B_vec_vrfin,
+ &B_vec_vrsqrtefp,
+ &B1_vec_vsel,
+ &B2_vec_vsel,
+ &B3_vec_vsel,
+ &B4_vec_vsel,
+ &B5_vec_vsel,
+ &B6_vec_vsel,
+ &B7_vec_vsel,
+ &B8_vec_vsel,
+ &B9_vec_vsel,
+ &B10_vec_vsel,
+ &B11_vec_vsel,
+ &B12_vec_vsel,
+ &B13_vec_vsel,
+ &B14_vec_vsel,
+ &B15_vec_vsel,
+ &B16_vec_vsel,
+ &B17_vec_vsel,
+ &B18_vec_vsel,
+ &B19_vec_vsel,
+ &B20_vec_vsel,
+ &B1_vec_vslh,
+ &B1_vec_vslw,
+ &B1_vec_vslb,
+ &B2_vec_vslh,
+ &B2_vec_vslw,
+ &B2_vec_vslb,
+ &B1_vec_vsldoi,
+ &B2_vec_vsldoi,
+ &B3_vec_vsldoi,
+ &B4_vec_vsldoi,
+ &B5_vec_vsldoi,
+ &B6_vec_vsldoi,
+ &B7_vec_vsldoi,
+ &B8_vec_vsldoi,
+ &B9_vec_vsldoi,
+ &B10_vec_vsldoi,
+ &B11_vec_vsldoi,
+ &B1_vec_vsl,
+ &B2_vec_vsl,
+ &B3_vec_vsl,
+ &B4_vec_vsl,
+ &B5_vec_vsl,
+ &B6_vec_vsl,
+ &B7_vec_vsl,
+ &B8_vec_vsl,
+ &B9_vec_vsl,
+ &B10_vec_vsl,
+ &B11_vec_vsl,
+ &B12_vec_vsl,
+ &B13_vec_vsl,
+ &B14_vec_vsl,
+ &B15_vec_vsl,
+ &B16_vec_vsl,
+ &B17_vec_vsl,
+ &B18_vec_vsl,
+ &B19_vec_vsl,
+ &B20_vec_vsl,
+ &B21_vec_vsl,
+ &B22_vec_vsl,
+ &B23_vec_vsl,
+ &B24_vec_vsl,
+ &B25_vec_vsl,
+ &B26_vec_vsl,
+ &B27_vec_vsl,
+ &B28_vec_vsl,
+ &B29_vec_vsl,
+ &B30_vec_vsl,
+ &B1_vec_vslo,
+ &B2_vec_vslo,
+ &B3_vec_vslo,
+ &B4_vec_vslo,
+ &B5_vec_vslo,
+ &B6_vec_vslo,
+ &B7_vec_vslo,
+ &B8_vec_vslo,
+ &B9_vec_vslo,
+ &B10_vec_vslo,
+ &B11_vec_vslo,
+ &B12_vec_vslo,
+ &B13_vec_vslo,
+ &B14_vec_vslo,
+ &B15_vec_vslo,
+ &B16_vec_vslo,
+ &B1_vec_vsplth,
+ &B1_vec_vspltw,
+ &B1_vec_vspltb,
+ &B2_vec_vspltw,
+ &B2_vec_vsplth,
+ &B3_vec_vsplth,
+ &B3_vec_vspltw,
+ &B2_vec_vspltb,
+ &B4_vec_vsplth,
+ &B4_vec_vspltw,
+ &B3_vec_vspltb,
+ &B_vec_vspltish,
+ &B_vec_vspltisw,
+ &B_vec_vspltisb,
+ &B_vec_splat_u16,
+ &B_vec_splat_u32,
+ &B_vec_splat_u8,
+ &B1_vec_vsrh,
+ &B1_vec_vsrw,
+ &B1_vec_vsrb,
+ &B2_vec_vsrh,
+ &B2_vec_vsrw,
+ &B2_vec_vsrb,
+ &B1_vec_vsrah,
+ &B1_vec_vsraw,
+ &B1_vec_vsrab,
+ &B2_vec_vsrah,
+ &B2_vec_vsraw,
+ &B2_vec_vsrab,
+ &B1_vec_vsr,
+ &B2_vec_vsr,
+ &B3_vec_vsr,
+ &B4_vec_vsr,
+ &B5_vec_vsr,
+ &B6_vec_vsr,
+ &B7_vec_vsr,
+ &B8_vec_vsr,
+ &B9_vec_vsr,
+ &B10_vec_vsr,
+ &B11_vec_vsr,
+ &B12_vec_vsr,
+ &B13_vec_vsr,
+ &B14_vec_vsr,
+ &B15_vec_vsr,
+ &B16_vec_vsr,
+ &B17_vec_vsr,
+ &B18_vec_vsr,
+ &B19_vec_vsr,
+ &B20_vec_vsr,
+ &B21_vec_vsr,
+ &B22_vec_vsr,
+ &B23_vec_vsr,
+ &B24_vec_vsr,
+ &B25_vec_vsr,
+ &B26_vec_vsr,
+ &B27_vec_vsr,
+ &B28_vec_vsr,
+ &B29_vec_vsr,
+ &B30_vec_vsr,
+ &B1_vec_vsro,
+ &B2_vec_vsro,
+ &B3_vec_vsro,
+ &B4_vec_vsro,
+ &B5_vec_vsro,
+ &B6_vec_vsro,
+ &B7_vec_vsro,
+ &B8_vec_vsro,
+ &B9_vec_vsro,
+ &B10_vec_vsro,
+ &B11_vec_vsro,
+ &B12_vec_vsro,
+ &B13_vec_vsro,
+ &B14_vec_vsro,
+ &B15_vec_vsro,
+ &B16_vec_vsro,
+ &B1_vec_stvx,
+ &B2_vec_stvx,
+ &B3_vec_stvx,
+ &B4_vec_stvx,
+ &B5_vec_stvx,
+ &B6_vec_stvx,
+ &B7_vec_stvx,
+ &B8_vec_stvx,
+ &B9_vec_stvx,
+ &B10_vec_stvx,
+ &B11_vec_stvx,
+ &B12_vec_stvx,
+ &B13_vec_stvx,
+ &B14_vec_stvx,
+ &B15_vec_stvx,
+ &B16_vec_stvx,
+ &B17_vec_stvx,
+ &B18_vec_stvx,
+ &B19_vec_stvx,
+ &B20_vec_stvx,
+ &B21_vec_stvx,
+ &B22_vec_stvx,
+ &B23_vec_stvx,
+ &B24_vec_stvx,
+ &B25_vec_stvx,
+ &B26_vec_stvx,
+ &B27_vec_stvx,
+ &B28_vec_stvx,
+ &B29_vec_stvx,
+ &B30_vec_stvx,
+ &B1_vec_stvebx,
+ &B2_vec_stvebx,
+ &B1_vec_stvewx,
+ &B2_vec_stvewx,
+ &B3_vec_stvewx,
+ &B4_vec_stvewx,
+ &B3_vec_stvebx,
+ &B4_vec_stvebx,
+ &B5_vec_stvewx,
+ &B1_vec_stvehx,
+ &B2_vec_stvehx,
+ &B3_vec_stvehx,
+ &B6_vec_stvewx,
+ &B7_vec_stvewx,
+ &B5_vec_stvebx,
+ &B4_vec_stvehx,
+ &B8_vec_stvewx,
+ &B9_vec_stvewx,
+ &B6_vec_stvebx,
+ &B1_vec_stvxl,
+ &B2_vec_stvxl,
+ &B3_vec_stvxl,
+ &B4_vec_stvxl,
+ &B5_vec_stvxl,
+ &B6_vec_stvxl,
+ &B7_vec_stvxl,
+ &B8_vec_stvxl,
+ &B9_vec_stvxl,
+ &B10_vec_stvxl,
+ &B11_vec_stvxl,
+ &B12_vec_stvxl,
+ &B13_vec_stvxl,
+ &B14_vec_stvxl,
+ &B15_vec_stvxl,
+ &B16_vec_stvxl,
+ &B17_vec_stvxl,
+ &B18_vec_stvxl,
+ &B19_vec_stvxl,
+ &B20_vec_stvxl,
+ &B21_vec_stvxl,
+ &B22_vec_stvxl,
+ &B23_vec_stvxl,
+ &B24_vec_stvxl,
+ &B25_vec_stvxl,
+ &B26_vec_stvxl,
+ &B27_vec_stvxl,
+ &B28_vec_stvxl,
+ &B29_vec_stvxl,
+ &B30_vec_stvxl,
+ &B1_vec_vsubuhm,
+ &B2_vec_vsubuhm,
+ &B1_vec_vsubuwm,
+ &B2_vec_vsubuwm,
+ &B1_vec_vsububm,
+ &B2_vec_vsububm,
+ &B_vec_vsubfp,
+ &B3_vec_vsubuhm,
+ &B4_vec_vsubuhm,
+ &B3_vec_vsubuwm,
+ &B4_vec_vsubuwm,
+ &B3_vec_vsububm,
+ &B4_vec_vsububm,
+ &B5_vec_vsubuhm,
+ &B6_vec_vsubuhm,
+ &B5_vec_vsubuwm,
+ &B6_vec_vsubuwm,
+ &B5_vec_vsububm,
+ &B6_vec_vsububm,
+ &B_vec_vsubcuw,
+ &B1_vec_vsubshs,
+ &B1_vec_vsubuhs,
+ &B1_vec_vsubsws,
+ &B1_vec_vsubuws,
+ &B1_vec_vsubsbs,
+ &B1_vec_vsububs,
+ &B2_vec_vsubshs,
+ &B3_vec_vsubshs,
+ &B2_vec_vsubsws,
+ &B3_vec_vsubsws,
+ &B2_vec_vsubsbs,
+ &B3_vec_vsubsbs,
+ &B2_vec_vsubuhs,
+ &B3_vec_vsubuhs,
+ &B2_vec_vsubuws,
+ &B3_vec_vsubuws,
+ &B2_vec_vsububs,
+ &B3_vec_vsububs,
+ &B_vec_vsum2sws,
+ &B_vec_vsum4shs,
+ &B_vec_vsum4sbs,
+ &B_vec_vsum4ubs,
+ &B_vec_vsumsws,
+ &B_vec_vrfiz,
+ &B1_vec_unpack2sh,
+ &B2_vec_unpack2sh,
+ &B1_vec_unpack2sl,
+ &B2_vec_unpack2sl,
+ &B1_vec_unpack2uh,
+ &B2_vec_unpack2uh,
+ &B1_vec_unpack2ul,
+ &B2_vec_unpack2ul,
+ &B1_vec_vupkhsh,
+ &B1_vec_vupkhsb,
+ &B_vec_vupkhpx,
+ &B2_vec_vupkhsh,
+ &B2_vec_vupkhsb,
+ &B1_vec_vupklsh,
+ &B1_vec_vupklsb,
+ &B_vec_vupklpx,
+ &B2_vec_vupklsh,
+ &B2_vec_vupklsb,
+ &B1_vec_vxor,
+ &B2_vec_vxor,
+ &B3_vec_vxor,
+ &B4_vec_vxor,
+ &B5_vec_vxor,
+ &B6_vec_vxor,
+ &B7_vec_vxor,
+ &B8_vec_vxor,
+ &B9_vec_vxor,
+ &B10_vec_vxor,
+ &B11_vec_vxor,
+ &B12_vec_vxor,
+ &B13_vec_vxor,
+ &B14_vec_vxor,
+ &B15_vec_vxor,
+ &B16_vec_vxor,
+ &B17_vec_vxor,
+ &B18_vec_vxor,
+ &B19_vec_vxor,
+ &B20_vec_vxor,
+ &B21_vec_vxor,
+ &B22_vec_vxor,
+ &B23_vec_vxor,
+ &B24_vec_vxor,
+};
+
+static const struct builtin *const O_vec_abs[4] = {
+ &B1_vec_abs,
+ &B2_vec_abs,
+ &B3_vec_abs,
+ &B4_vec_abs,
+};
+static const struct builtin *const O_vec_abss[3] = {
+ &B1_vec_abss,
+ &B2_vec_abss,
+ &B3_vec_abss,
+};
+static const struct builtin *const O_vec_add[19] = {
+ &B1_vec_vadduhm,
+ &B2_vec_vadduhm,
+ &B1_vec_vadduwm,
+ &B2_vec_vadduwm,
+ &B1_vec_vaddubm,
+ &B2_vec_vaddubm,
+ &B_vec_vaddfp,
+ &B3_vec_vadduhm,
+ &B4_vec_vadduhm,
+ &B3_vec_vadduwm,
+ &B4_vec_vadduwm,
+ &B3_vec_vaddubm,
+ &B4_vec_vaddubm,
+ &B5_vec_vadduhm,
+ &B6_vec_vadduhm,
+ &B5_vec_vadduwm,
+ &B6_vec_vadduwm,
+ &B5_vec_vaddubm,
+ &B6_vec_vaddubm,
+};
+static const struct builtin *const O_vec_addc[1] = {
+ &B_vec_vaddcuw,
+};
+static const struct builtin *const O_vec_adds[18] = {
+ &B1_vec_vaddshs,
+ &B1_vec_vadduhs,
+ &B1_vec_vaddsws,
+ &B1_vec_vadduws,
+ &B1_vec_vaddsbs,
+ &B1_vec_vaddubs,
+ &B2_vec_vaddshs,
+ &B3_vec_vaddshs,
+ &B2_vec_vaddsws,
+ &B3_vec_vaddsws,
+ &B2_vec_vaddsbs,
+ &B3_vec_vaddsbs,
+ &B2_vec_vadduhs,
+ &B3_vec_vadduhs,
+ &B2_vec_vadduws,
+ &B3_vec_vadduws,
+ &B2_vec_vaddubs,
+ &B3_vec_vaddubs,
+};
+static const struct builtin *const O_vec_all_eq[23] = {
+ &B1_vec_all_eq,
+ &B2_vec_all_eq,
+ &B3_vec_all_eq,
+ &B4_vec_all_eq,
+ &B5_vec_all_eq,
+ &B6_vec_all_eq,
+ &B7_vec_all_eq,
+ &B8_vec_all_eq,
+ &B9_vec_all_eq,
+ &B10_vec_all_eq,
+ &B11_vec_all_eq,
+ &B12_vec_all_eq,
+ &B13_vec_all_eq,
+ &B14_vec_all_eq,
+ &B15_vec_all_eq,
+ &B16_vec_all_eq,
+ &B17_vec_all_eq,
+ &B18_vec_all_eq,
+ &B19_vec_all_eq,
+ &B20_vec_all_eq,
+ &B21_vec_all_eq,
+ &B22_vec_all_eq,
+ &B23_vec_all_eq,
+};
+static const struct builtin *const O_vec_all_ge[19] = {
+ &B1_vec_all_ge,
+ &B2_vec_all_ge,
+ &B3_vec_all_ge,
+ &B4_vec_all_ge,
+ &B5_vec_all_ge,
+ &B6_vec_all_ge,
+ &B7_vec_all_ge,
+ &B8_vec_all_ge,
+ &B9_vec_all_ge,
+ &B10_vec_all_ge,
+ &B11_vec_all_ge,
+ &B12_vec_all_ge,
+ &B13_vec_all_ge,
+ &B14_vec_all_ge,
+ &B15_vec_all_ge,
+ &B16_vec_all_ge,
+ &B17_vec_all_ge,
+ &B18_vec_all_ge,
+ &B19_vec_all_ge,
+};
+static const struct builtin *const O_vec_all_gt[19] = {
+ &B1_vec_all_gt,
+ &B2_vec_all_gt,
+ &B3_vec_all_gt,
+ &B4_vec_all_gt,
+ &B5_vec_all_gt,
+ &B6_vec_all_gt,
+ &B7_vec_all_gt,
+ &B8_vec_all_gt,
+ &B9_vec_all_gt,
+ &B10_vec_all_gt,
+ &B11_vec_all_gt,
+ &B12_vec_all_gt,
+ &B13_vec_all_gt,
+ &B14_vec_all_gt,
+ &B15_vec_all_gt,
+ &B16_vec_all_gt,
+ &B17_vec_all_gt,
+ &B18_vec_all_gt,
+ &B19_vec_all_gt,
+};
+static const struct builtin *const O_vec_all_in[1] = {
+ &B_vec_all_in,
+};
+static const struct builtin *const O_vec_all_le[19] = {
+ &B1_vec_all_le,
+ &B2_vec_all_le,
+ &B3_vec_all_le,
+ &B4_vec_all_le,
+ &B5_vec_all_le,
+ &B6_vec_all_le,
+ &B7_vec_all_le,
+ &B8_vec_all_le,
+ &B9_vec_all_le,
+ &B10_vec_all_le,
+ &B11_vec_all_le,
+ &B12_vec_all_le,
+ &B13_vec_all_le,
+ &B14_vec_all_le,
+ &B15_vec_all_le,
+ &B16_vec_all_le,
+ &B17_vec_all_le,
+ &B18_vec_all_le,
+ &B19_vec_all_le,
+};
+static const struct builtin *const O_vec_all_lt[19] = {
+ &B1_vec_all_lt,
+ &B2_vec_all_lt,
+ &B3_vec_all_lt,
+ &B4_vec_all_lt,
+ &B5_vec_all_lt,
+ &B6_vec_all_lt,
+ &B7_vec_all_lt,
+ &B8_vec_all_lt,
+ &B9_vec_all_lt,
+ &B10_vec_all_lt,
+ &B11_vec_all_lt,
+ &B12_vec_all_lt,
+ &B13_vec_all_lt,
+ &B14_vec_all_lt,
+ &B15_vec_all_lt,
+ &B16_vec_all_lt,
+ &B17_vec_all_lt,
+ &B18_vec_all_lt,
+ &B19_vec_all_lt,
+};
+static const struct builtin *const O_vec_all_nan[1] = {
+ &B_vec_all_nan,
+};
+static const struct builtin *const O_vec_all_ne[23] = {
+ &B1_vec_all_ne,
+ &B2_vec_all_ne,
+ &B3_vec_all_ne,
+ &B4_vec_all_ne,
+ &B5_vec_all_ne,
+ &B6_vec_all_ne,
+ &B7_vec_all_ne,
+ &B8_vec_all_ne,
+ &B9_vec_all_ne,
+ &B10_vec_all_ne,
+ &B11_vec_all_ne,
+ &B12_vec_all_ne,
+ &B13_vec_all_ne,
+ &B14_vec_all_ne,
+ &B15_vec_all_ne,
+ &B16_vec_all_ne,
+ &B17_vec_all_ne,
+ &B18_vec_all_ne,
+ &B19_vec_all_ne,
+ &B20_vec_all_ne,
+ &B21_vec_all_ne,
+ &B22_vec_all_ne,
+ &B23_vec_all_ne,
+};
+static const struct builtin *const O_vec_all_nge[1] = {
+ &B_vec_all_nge,
+};
+static const struct builtin *const O_vec_all_ngt[1] = {
+ &B_vec_all_ngt,
+};
+static const struct builtin *const O_vec_all_nle[1] = {
+ &B_vec_all_nle,
+};
+static const struct builtin *const O_vec_all_nlt[1] = {
+ &B_vec_all_nlt,
+};
+static const struct builtin *const O_vec_all_numeric[1] = {
+ &B_vec_all_numeric,
+};
+static const struct builtin *const O_vec_and[24] = {
+ &B1_vec_vand,
+ &B2_vec_vand,
+ &B3_vec_vand,
+ &B4_vec_vand,
+ &B5_vec_vand,
+ &B6_vec_vand,
+ &B7_vec_vand,
+ &B8_vec_vand,
+ &B9_vec_vand,
+ &B10_vec_vand,
+ &B11_vec_vand,
+ &B12_vec_vand,
+ &B13_vec_vand,
+ &B14_vec_vand,
+ &B15_vec_vand,
+ &B16_vec_vand,
+ &B17_vec_vand,
+ &B18_vec_vand,
+ &B19_vec_vand,
+ &B20_vec_vand,
+ &B21_vec_vand,
+ &B22_vec_vand,
+ &B23_vec_vand,
+ &B24_vec_vand,
+};
+static const struct builtin *const O_vec_andc[24] = {
+ &B1_vec_vandc,
+ &B2_vec_vandc,
+ &B3_vec_vandc,
+ &B4_vec_vandc,
+ &B5_vec_vandc,
+ &B6_vec_vandc,
+ &B7_vec_vandc,
+ &B8_vec_vandc,
+ &B9_vec_vandc,
+ &B10_vec_vandc,
+ &B11_vec_vandc,
+ &B12_vec_vandc,
+ &B13_vec_vandc,
+ &B14_vec_vandc,
+ &B15_vec_vandc,
+ &B16_vec_vandc,
+ &B17_vec_vandc,
+ &B18_vec_vandc,
+ &B19_vec_vandc,
+ &B20_vec_vandc,
+ &B21_vec_vandc,
+ &B22_vec_vandc,
+ &B23_vec_vandc,
+ &B24_vec_vandc,
+};
+static const struct builtin *const O_vec_any_eq[23] = {
+ &B1_vec_any_eq,
+ &B2_vec_any_eq,
+ &B3_vec_any_eq,
+ &B4_vec_any_eq,
+ &B5_vec_any_eq,
+ &B6_vec_any_eq,
+ &B7_vec_any_eq,
+ &B8_vec_any_eq,
+ &B9_vec_any_eq,
+ &B10_vec_any_eq,
+ &B11_vec_any_eq,
+ &B12_vec_any_eq,
+ &B13_vec_any_eq,
+ &B14_vec_any_eq,
+ &B15_vec_any_eq,
+ &B16_vec_any_eq,
+ &B17_vec_any_eq,
+ &B18_vec_any_eq,
+ &B19_vec_any_eq,
+ &B20_vec_any_eq,
+ &B21_vec_any_eq,
+ &B22_vec_any_eq,
+ &B23_vec_any_eq,
+};
+static const struct builtin *const O_vec_any_ge[19] = {
+ &B1_vec_any_ge,
+ &B2_vec_any_ge,
+ &B3_vec_any_ge,
+ &B4_vec_any_ge,
+ &B5_vec_any_ge,
+ &B6_vec_any_ge,
+ &B7_vec_any_ge,
+ &B8_vec_any_ge,
+ &B9_vec_any_ge,
+ &B10_vec_any_ge,
+ &B11_vec_any_ge,
+ &B12_vec_any_ge,
+ &B13_vec_any_ge,
+ &B14_vec_any_ge,
+ &B15_vec_any_ge,
+ &B16_vec_any_ge,
+ &B17_vec_any_ge,
+ &B18_vec_any_ge,
+ &B19_vec_any_ge,
+};
+static const struct builtin *const O_vec_any_gt[19] = {
+ &B1_vec_any_gt,
+ &B2_vec_any_gt,
+ &B3_vec_any_gt,
+ &B4_vec_any_gt,
+ &B5_vec_any_gt,
+ &B6_vec_any_gt,
+ &B7_vec_any_gt,
+ &B8_vec_any_gt,
+ &B9_vec_any_gt,
+ &B10_vec_any_gt,
+ &B11_vec_any_gt,
+ &B12_vec_any_gt,
+ &B13_vec_any_gt,
+ &B14_vec_any_gt,
+ &B15_vec_any_gt,
+ &B16_vec_any_gt,
+ &B17_vec_any_gt,
+ &B18_vec_any_gt,
+ &B19_vec_any_gt,
+};
+static const struct builtin *const O_vec_any_le[19] = {
+ &B1_vec_any_le,
+ &B2_vec_any_le,
+ &B3_vec_any_le,
+ &B4_vec_any_le,
+ &B5_vec_any_le,
+ &B6_vec_any_le,
+ &B7_vec_any_le,
+ &B8_vec_any_le,
+ &B9_vec_any_le,
+ &B10_vec_any_le,
+ &B11_vec_any_le,
+ &B12_vec_any_le,
+ &B13_vec_any_le,
+ &B14_vec_any_le,
+ &B15_vec_any_le,
+ &B16_vec_any_le,
+ &B17_vec_any_le,
+ &B18_vec_any_le,
+ &B19_vec_any_le,
+};
+static const struct builtin *const O_vec_any_lt[19] = {
+ &B1_vec_any_lt,
+ &B2_vec_any_lt,
+ &B3_vec_any_lt,
+ &B4_vec_any_lt,
+ &B5_vec_any_lt,
+ &B6_vec_any_lt,
+ &B7_vec_any_lt,
+ &B8_vec_any_lt,
+ &B9_vec_any_lt,
+ &B10_vec_any_lt,
+ &B11_vec_any_lt,
+ &B12_vec_any_lt,
+ &B13_vec_any_lt,
+ &B14_vec_any_lt,
+ &B15_vec_any_lt,
+ &B16_vec_any_lt,
+ &B17_vec_any_lt,
+ &B18_vec_any_lt,
+ &B19_vec_any_lt,
+};
+static const struct builtin *const O_vec_any_nan[1] = {
+ &B_vec_any_nan,
+};
+static const struct builtin *const O_vec_any_ne[23] = {
+ &B1_vec_any_ne,
+ &B2_vec_any_ne,
+ &B3_vec_any_ne,
+ &B4_vec_any_ne,
+ &B5_vec_any_ne,
+ &B6_vec_any_ne,
+ &B7_vec_any_ne,
+ &B8_vec_any_ne,
+ &B9_vec_any_ne,
+ &B10_vec_any_ne,
+ &B11_vec_any_ne,
+ &B12_vec_any_ne,
+ &B13_vec_any_ne,
+ &B14_vec_any_ne,
+ &B15_vec_any_ne,
+ &B16_vec_any_ne,
+ &B17_vec_any_ne,
+ &B18_vec_any_ne,
+ &B19_vec_any_ne,
+ &B20_vec_any_ne,
+ &B21_vec_any_ne,
+ &B22_vec_any_ne,
+ &B23_vec_any_ne,
+};
+static const struct builtin *const O_vec_any_nge[1] = {
+ &B_vec_any_nge,
+};
+static const struct builtin *const O_vec_any_ngt[1] = {
+ &B_vec_any_ngt,
+};
+static const struct builtin *const O_vec_any_nle[1] = {
+ &B_vec_any_nle,
+};
+static const struct builtin *const O_vec_any_nlt[1] = {
+ &B_vec_any_nlt,
+};
+static const struct builtin *const O_vec_any_numeric[1] = {
+ &B_vec_any_numeric,
+};
+static const struct builtin *const O_vec_any_out[1] = {
+ &B_vec_any_out,
+};
+static const struct builtin *const O_vec_avg[6] = {
+ &B_vec_vavgsh,
+ &B_vec_vavgsw,
+ &B_vec_vavgsb,
+ &B_vec_vavguh,
+ &B_vec_vavguw,
+ &B_vec_vavgub,
+};
+static const struct builtin *const O_vec_ceil[1] = {
+ &B_vec_vrfip,
+};
+static const struct builtin *const O_vec_cmpb[1] = {
+ &B_vec_vcmpbfp,
+};
+static const struct builtin *const O_vec_cmpeq[7] = {
+ &B_vec_vcmpeqfp,
+ &B1_vec_vcmpequh,
+ &B1_vec_vcmpequw,
+ &B1_vec_vcmpequb,
+ &B2_vec_vcmpequh,
+ &B2_vec_vcmpequw,
+ &B2_vec_vcmpequb,
+};
+static const struct builtin *const O_vec_cmpge[1] = {
+ &B_vec_vcmpgefp,
+};
+static const struct builtin *const O_vec_cmpgt[7] = {
+ &B_vec_vcmpgtfp,
+ &B_vec_vcmpgtsh,
+ &B_vec_vcmpgtsw,
+ &B_vec_vcmpgtsb,
+ &B_vec_vcmpgtuh,
+ &B_vec_vcmpgtuw,
+ &B_vec_vcmpgtub,
+};
+static const struct builtin *const O_vec_cmple[1] = {
+ &B_vec_cmple,
+};
+static const struct builtin *const O_vec_cmplt[7] = {
+ &B1_vec_cmplt,
+ &B2_vec_cmplt,
+ &B3_vec_cmplt,
+ &B4_vec_cmplt,
+ &B5_vec_cmplt,
+ &B6_vec_cmplt,
+ &B7_vec_cmplt,
+};
+static const struct builtin *const O_vec_ctf[2] = {
+ &B_vec_vcfsx,
+ &B_vec_vcfux,
+};
+static const struct builtin *const O_vec_cts[1] = {
+ &B_vec_vctsxs,
+};
+static const struct builtin *const O_vec_ctu[1] = {
+ &B_vec_vctuxs,
+};
+static const struct builtin *const O_vec_dss[1] = {
+ &B_vec_dss,
+};
+static const struct builtin *const O_vec_dssall[1] = {
+ &B_vec_dssall,
+};
+static const struct builtin *const O_vec_dst[20] = {
+ &B1_vec_dst,
+ &B2_vec_dst,
+ &B3_vec_dst,
+ &B4_vec_dst,
+ &B5_vec_dst,
+ &B6_vec_dst,
+ &B7_vec_dst,
+ &B8_vec_dst,
+ &B9_vec_dst,
+ &B10_vec_dst,
+ &B11_vec_dst,
+ &B12_vec_dst,
+ &B13_vec_dst,
+ &B14_vec_dst,
+ &B15_vec_dst,
+ &B16_vec_dst,
+ &B17_vec_dst,
+ &B18_vec_dst,
+ &B19_vec_dst,
+ &B20_vec_dst,
+};
+static const struct builtin *const O_vec_dstst[20] = {
+ &B1_vec_dstst,
+ &B2_vec_dstst,
+ &B3_vec_dstst,
+ &B4_vec_dstst,
+ &B5_vec_dstst,
+ &B6_vec_dstst,
+ &B7_vec_dstst,
+ &B8_vec_dstst,
+ &B9_vec_dstst,
+ &B10_vec_dstst,
+ &B11_vec_dstst,
+ &B12_vec_dstst,
+ &B13_vec_dstst,
+ &B14_vec_dstst,
+ &B15_vec_dstst,
+ &B16_vec_dstst,
+ &B17_vec_dstst,
+ &B18_vec_dstst,
+ &B19_vec_dstst,
+ &B20_vec_dstst,
+};
+static const struct builtin *const O_vec_dststt[20] = {
+ &B1_vec_dststt,
+ &B2_vec_dststt,
+ &B3_vec_dststt,
+ &B4_vec_dststt,
+ &B5_vec_dststt,
+ &B6_vec_dststt,
+ &B7_vec_dststt,
+ &B8_vec_dststt,
+ &B9_vec_dststt,
+ &B10_vec_dststt,
+ &B11_vec_dststt,
+ &B12_vec_dststt,
+ &B13_vec_dststt,
+ &B14_vec_dststt,
+ &B15_vec_dststt,
+ &B16_vec_dststt,
+ &B17_vec_dststt,
+ &B18_vec_dststt,
+ &B19_vec_dststt,
+ &B20_vec_dststt,
+};
+static const struct builtin *const O_vec_dstt[20] = {
+ &B1_vec_dstt,
+ &B2_vec_dstt,
+ &B3_vec_dstt,
+ &B4_vec_dstt,
+ &B5_vec_dstt,
+ &B6_vec_dstt,
+ &B7_vec_dstt,
+ &B8_vec_dstt,
+ &B9_vec_dstt,
+ &B10_vec_dstt,
+ &B11_vec_dstt,
+ &B12_vec_dstt,
+ &B13_vec_dstt,
+ &B14_vec_dstt,
+ &B15_vec_dstt,
+ &B16_vec_dstt,
+ &B17_vec_dstt,
+ &B18_vec_dstt,
+ &B19_vec_dstt,
+ &B20_vec_dstt,
+};
+static const struct builtin *const O_vec_expte[1] = {
+ &B_vec_vexptefp,
+};
+static const struct builtin *const O_vec_floor[1] = {
+ &B_vec_vrfim,
+};
+static const struct builtin *const O_vec_ld[20] = {
+ &B1_vec_lvx,
+ &B2_vec_lvx,
+ &B3_vec_lvx,
+ &B4_vec_lvx,
+ &B5_vec_lvx,
+ &B6_vec_lvx,
+ &B7_vec_lvx,
+ &B8_vec_lvx,
+ &B9_vec_lvx,
+ &B10_vec_lvx,
+ &B11_vec_lvx,
+ &B12_vec_lvx,
+ &B13_vec_lvx,
+ &B14_vec_lvx,
+ &B15_vec_lvx,
+ &B16_vec_lvx,
+ &B17_vec_lvx,
+ &B18_vec_lvx,
+ &B19_vec_lvx,
+ &B20_vec_lvx,
+};
+static const struct builtin *const O_vec_lde[9] = {
+ &B1_vec_lvewx,
+ &B2_vec_lvewx,
+ &B3_vec_lvewx,
+ &B1_vec_lvehx,
+ &B1_vec_lvebx,
+ &B2_vec_lvebx,
+ &B4_vec_lvewx,
+ &B5_vec_lvewx,
+ &B2_vec_lvehx,
+};
+static const struct builtin *const O_vec_ldl[20] = {
+ &B1_vec_lvxl,
+ &B2_vec_lvxl,
+ &B3_vec_lvxl,
+ &B4_vec_lvxl,
+ &B5_vec_lvxl,
+ &B6_vec_lvxl,
+ &B7_vec_lvxl,
+ &B8_vec_lvxl,
+ &B9_vec_lvxl,
+ &B10_vec_lvxl,
+ &B11_vec_lvxl,
+ &B12_vec_lvxl,
+ &B13_vec_lvxl,
+ &B14_vec_lvxl,
+ &B15_vec_lvxl,
+ &B16_vec_lvxl,
+ &B17_vec_lvxl,
+ &B18_vec_lvxl,
+ &B19_vec_lvxl,
+ &B20_vec_lvxl,
+};
+static const struct builtin *const O_vec_loge[1] = {
+ &B_vec_vlogefp,
+};
+static const struct builtin *const O_vec_lvebx[2] = {
+ &B1_vec_lvebx,
+ &B2_vec_lvebx,
+};
+static const struct builtin *const O_vec_lvehx[2] = {
+ &B1_vec_lvehx,
+ &B2_vec_lvehx,
+};
+static const struct builtin *const O_vec_lvewx[5] = {
+ &B1_vec_lvewx,
+ &B2_vec_lvewx,
+ &B3_vec_lvewx,
+ &B4_vec_lvewx,
+ &B5_vec_lvewx,
+};
+static const struct builtin *const O_vec_lvsl[9] = {
+ &B1_vec_lvsl,
+ &B2_vec_lvsl,
+ &B3_vec_lvsl,
+ &B4_vec_lvsl,
+ &B5_vec_lvsl,
+ &B6_vec_lvsl,
+ &B7_vec_lvsl,
+ &B8_vec_lvsl,
+ &B9_vec_lvsl,
+};
+static const struct builtin *const O_vec_lvsr[9] = {
+ &B1_vec_lvsr,
+ &B2_vec_lvsr,
+ &B3_vec_lvsr,
+ &B4_vec_lvsr,
+ &B5_vec_lvsr,
+ &B6_vec_lvsr,
+ &B7_vec_lvsr,
+ &B8_vec_lvsr,
+ &B9_vec_lvsr,
+};
+static const struct builtin *const O_vec_lvx[20] = {
+ &B1_vec_lvx,
+ &B2_vec_lvx,
+ &B3_vec_lvx,
+ &B4_vec_lvx,
+ &B5_vec_lvx,
+ &B6_vec_lvx,
+ &B7_vec_lvx,
+ &B8_vec_lvx,
+ &B9_vec_lvx,
+ &B10_vec_lvx,
+ &B11_vec_lvx,
+ &B12_vec_lvx,
+ &B13_vec_lvx,
+ &B14_vec_lvx,
+ &B15_vec_lvx,
+ &B16_vec_lvx,
+ &B17_vec_lvx,
+ &B18_vec_lvx,
+ &B19_vec_lvx,
+ &B20_vec_lvx,
+};
+static const struct builtin *const O_vec_lvxl[20] = {
+ &B1_vec_lvxl,
+ &B2_vec_lvxl,
+ &B3_vec_lvxl,
+ &B4_vec_lvxl,
+ &B5_vec_lvxl,
+ &B6_vec_lvxl,
+ &B7_vec_lvxl,
+ &B8_vec_lvxl,
+ &B9_vec_lvxl,
+ &B10_vec_lvxl,
+ &B11_vec_lvxl,
+ &B12_vec_lvxl,
+ &B13_vec_lvxl,
+ &B14_vec_lvxl,
+ &B15_vec_lvxl,
+ &B16_vec_lvxl,
+ &B17_vec_lvxl,
+ &B18_vec_lvxl,
+ &B19_vec_lvxl,
+ &B20_vec_lvxl,
+};
+static const struct builtin *const O_vec_madd[1] = {
+ &B_vec_vmaddfp,
+};
+static const struct builtin *const O_vec_madds[1] = {
+ &B_vec_vmhaddshs,
+};
+static const struct builtin *const O_vec_max[19] = {
+ &B1_vec_vmaxsh,
+ &B1_vec_vmaxuh,
+ &B1_vec_vmaxsw,
+ &B1_vec_vmaxuw,
+ &B1_vec_vmaxsb,
+ &B1_vec_vmaxub,
+ &B_vec_vmaxfp,
+ &B2_vec_vmaxsh,
+ &B3_vec_vmaxsh,
+ &B2_vec_vmaxsw,
+ &B3_vec_vmaxsw,
+ &B2_vec_vmaxsb,
+ &B3_vec_vmaxsb,
+ &B2_vec_vmaxuh,
+ &B3_vec_vmaxuh,
+ &B2_vec_vmaxuw,
+ &B3_vec_vmaxuw,
+ &B2_vec_vmaxub,
+ &B3_vec_vmaxub,
+};
+static const struct builtin *const O_vec_mergeh[11] = {
+ &B1_vec_vmrghh,
+ &B1_vec_vmrghw,
+ &B1_vec_vmrghb,
+ &B2_vec_vmrghw,
+ &B2_vec_vmrghh,
+ &B3_vec_vmrghh,
+ &B3_vec_vmrghw,
+ &B2_vec_vmrghb,
+ &B4_vec_vmrghh,
+ &B4_vec_vmrghw,
+ &B3_vec_vmrghb,
+};
+static const struct builtin *const O_vec_mergel[11] = {
+ &B1_vec_vmrglh,
+ &B1_vec_vmrglw,
+ &B1_vec_vmrglb,
+ &B2_vec_vmrglw,
+ &B2_vec_vmrglh,
+ &B3_vec_vmrglh,
+ &B3_vec_vmrglw,
+ &B2_vec_vmrglb,
+ &B4_vec_vmrglh,
+ &B4_vec_vmrglw,
+ &B3_vec_vmrglb,
+};
+static const struct builtin *const O_vec_mfvscr[1] = {
+ &B_vec_mfvscr,
+};
+static const struct builtin *const O_vec_min[19] = {
+ &B1_vec_vminsh,
+ &B1_vec_vminuh,
+ &B1_vec_vminsw,
+ &B1_vec_vminuw,
+ &B1_vec_vminsb,
+ &B1_vec_vminub,
+ &B_vec_vminfp,
+ &B2_vec_vminsh,
+ &B3_vec_vminsh,
+ &B2_vec_vminsw,
+ &B3_vec_vminsw,
+ &B2_vec_vminsb,
+ &B3_vec_vminsb,
+ &B2_vec_vminuh,
+ &B3_vec_vminuh,
+ &B2_vec_vminuw,
+ &B3_vec_vminuw,
+ &B2_vec_vminub,
+ &B3_vec_vminub,
+};
+static const struct builtin *const O_vec_mladd[4] = {
+ &B1_vec_vmladduhm,
+ &B2_vec_vmladduhm,
+ &B3_vec_vmladduhm,
+ &B4_vec_vmladduhm,
+};
+static const struct builtin *const O_vec_mradds[1] = {
+ &B_vec_vmhraddshs,
+};
+static const struct builtin *const O_vec_msum[4] = {
+ &B_vec_vmsumshm,
+ &B_vec_vmsummbm,
+ &B_vec_vmsumuhm,
+ &B_vec_vmsumubm,
+};
+static const struct builtin *const O_vec_msums[2] = {
+ &B_vec_vmsumshs,
+ &B_vec_vmsumuhs,
+};
+static const struct builtin *const O_vec_mtvscr[10] = {
+ &B1_vec_mtvscr,
+ &B2_vec_mtvscr,
+ &B3_vec_mtvscr,
+ &B4_vec_mtvscr,
+ &B5_vec_mtvscr,
+ &B6_vec_mtvscr,
+ &B7_vec_mtvscr,
+ &B8_vec_mtvscr,
+ &B9_vec_mtvscr,
+ &B10_vec_mtvscr,
+};
+static const struct builtin *const O_vec_mule[4] = {
+ &B_vec_vmulesh,
+ &B_vec_vmulesb,
+ &B_vec_vmuleuh,
+ &B_vec_vmuleub,
+};
+static const struct builtin *const O_vec_mulo[4] = {
+ &B_vec_vmulosh,
+ &B_vec_vmulosb,
+ &B_vec_vmulouh,
+ &B_vec_vmuloub,
+};
+static const struct builtin *const O_vec_nmsub[1] = {
+ &B_vec_vnmsubfp,
+};
+static const struct builtin *const O_vec_nor[10] = {
+ &B1_vec_vnor,
+ &B2_vec_vnor,
+ &B3_vec_vnor,
+ &B4_vec_vnor,
+ &B5_vec_vnor,
+ &B6_vec_vnor,
+ &B7_vec_vnor,
+ &B8_vec_vnor,
+ &B9_vec_vnor,
+ &B10_vec_vnor,
+};
+static const struct builtin *const O_vec_or[24] = {
+ &B1_vec_vor,
+ &B2_vec_vor,
+ &B3_vec_vor,
+ &B4_vec_vor,
+ &B5_vec_vor,
+ &B6_vec_vor,
+ &B7_vec_vor,
+ &B8_vec_vor,
+ &B9_vec_vor,
+ &B10_vec_vor,
+ &B11_vec_vor,
+ &B12_vec_vor,
+ &B13_vec_vor,
+ &B14_vec_vor,
+ &B15_vec_vor,
+ &B16_vec_vor,
+ &B17_vec_vor,
+ &B18_vec_vor,
+ &B19_vec_vor,
+ &B20_vec_vor,
+ &B21_vec_vor,
+ &B22_vec_vor,
+ &B23_vec_vor,
+ &B24_vec_vor,
+};
+static const struct builtin *const O_vec_pack[6] = {
+ &B1_vec_vpkuhum,
+ &B1_vec_vpkuwum,
+ &B2_vec_vpkuhum,
+ &B2_vec_vpkuwum,
+ &B3_vec_vpkuhum,
+ &B3_vec_vpkuwum,
+};
+static const struct builtin *const O_vec_packpx[1] = {
+ &B_vec_vpkpx,
+};
+static const struct builtin *const O_vec_packs[4] = {
+ &B_vec_vpkshss,
+ &B_vec_vpkswss,
+ &B_vec_vpkuhus,
+ &B_vec_vpkuwus,
+};
+static const struct builtin *const O_vec_packsu[4] = {
+ &B_vec_vpkshus,
+ &B_vec_vpkswus,
+ &B_vec_vpkuhus,
+ &B_vec_vpkuwus,
+};
+static const struct builtin *const O_vec_perm[11] = {
+ &B1_vec_vperm,
+ &B2_vec_vperm,
+ &B3_vec_vperm,
+ &B4_vec_vperm,
+ &B5_vec_vperm,
+ &B6_vec_vperm,
+ &B7_vec_vperm,
+ &B8_vec_vperm,
+ &B9_vec_vperm,
+ &B10_vec_vperm,
+ &B11_vec_vperm,
+};
+static const struct builtin *const O_vec_re[1] = {
+ &B_vec_vrefp,
+};
+static const struct builtin *const O_vec_rl[6] = {
+ &B1_vec_vrlh,
+ &B1_vec_vrlw,
+ &B1_vec_vrlb,
+ &B2_vec_vrlh,
+ &B2_vec_vrlw,
+ &B2_vec_vrlb,
+};
+static const struct builtin *const O_vec_round[1] = {
+ &B_vec_vrfin,
+};
+static const struct builtin *const O_vec_rsqrte[1] = {
+ &B_vec_vrsqrtefp,
+};
+static const struct builtin *const O_vec_sel[20] = {
+ &B1_vec_vsel,
+ &B2_vec_vsel,
+ &B3_vec_vsel,
+ &B4_vec_vsel,
+ &B5_vec_vsel,
+ &B6_vec_vsel,
+ &B7_vec_vsel,
+ &B8_vec_vsel,
+ &B9_vec_vsel,
+ &B10_vec_vsel,
+ &B11_vec_vsel,
+ &B12_vec_vsel,
+ &B13_vec_vsel,
+ &B14_vec_vsel,
+ &B15_vec_vsel,
+ &B16_vec_vsel,
+ &B17_vec_vsel,
+ &B18_vec_vsel,
+ &B19_vec_vsel,
+ &B20_vec_vsel,
+};
+static const struct builtin *const O_vec_sl[6] = {
+ &B1_vec_vslh,
+ &B1_vec_vslw,
+ &B1_vec_vslb,
+ &B2_vec_vslh,
+ &B2_vec_vslw,
+ &B2_vec_vslb,
+};
+static const struct builtin *const O_vec_sld[11] = {
+ &B1_vec_vsldoi,
+ &B2_vec_vsldoi,
+ &B3_vec_vsldoi,
+ &B4_vec_vsldoi,
+ &B5_vec_vsldoi,
+ &B6_vec_vsldoi,
+ &B7_vec_vsldoi,
+ &B8_vec_vsldoi,
+ &B9_vec_vsldoi,
+ &B10_vec_vsldoi,
+ &B11_vec_vsldoi,
+};
+static const struct builtin *const O_vec_sll[30] = {
+ &B1_vec_vsl,
+ &B2_vec_vsl,
+ &B3_vec_vsl,
+ &B4_vec_vsl,
+ &B5_vec_vsl,
+ &B6_vec_vsl,
+ &B7_vec_vsl,
+ &B8_vec_vsl,
+ &B9_vec_vsl,
+ &B10_vec_vsl,
+ &B11_vec_vsl,
+ &B12_vec_vsl,
+ &B13_vec_vsl,
+ &B14_vec_vsl,
+ &B15_vec_vsl,
+ &B16_vec_vsl,
+ &B17_vec_vsl,
+ &B18_vec_vsl,
+ &B19_vec_vsl,
+ &B20_vec_vsl,
+ &B21_vec_vsl,
+ &B22_vec_vsl,
+ &B23_vec_vsl,
+ &B24_vec_vsl,
+ &B25_vec_vsl,
+ &B26_vec_vsl,
+ &B27_vec_vsl,
+ &B28_vec_vsl,
+ &B29_vec_vsl,
+ &B30_vec_vsl,
+};
+static const struct builtin *const O_vec_slo[16] = {
+ &B1_vec_vslo,
+ &B2_vec_vslo,
+ &B3_vec_vslo,
+ &B4_vec_vslo,
+ &B5_vec_vslo,
+ &B6_vec_vslo,
+ &B7_vec_vslo,
+ &B8_vec_vslo,
+ &B9_vec_vslo,
+ &B10_vec_vslo,
+ &B11_vec_vslo,
+ &B12_vec_vslo,
+ &B13_vec_vslo,
+ &B14_vec_vslo,
+ &B15_vec_vslo,
+ &B16_vec_vslo,
+};
+static const struct builtin *const O_vec_splat[11] = {
+ &B1_vec_vsplth,
+ &B1_vec_vspltw,
+ &B1_vec_vspltb,
+ &B2_vec_vspltw,
+ &B2_vec_vsplth,
+ &B3_vec_vsplth,
+ &B3_vec_vspltw,
+ &B2_vec_vspltb,
+ &B4_vec_vsplth,
+ &B4_vec_vspltw,
+ &B3_vec_vspltb,
+};
+static const struct builtin *const O_vec_splat_s16[1] = {
+ &B_vec_vspltish,
+};
+static const struct builtin *const O_vec_splat_s32[1] = {
+ &B_vec_vspltisw,
+};
+static const struct builtin *const O_vec_splat_s8[1] = {
+ &B_vec_vspltisb,
+};
+static const struct builtin *const O_vec_splat_u16[1] = {
+ &B_vec_splat_u16,
+};
+static const struct builtin *const O_vec_splat_u32[1] = {
+ &B_vec_splat_u32,
+};
+static const struct builtin *const O_vec_splat_u8[1] = {
+ &B_vec_splat_u8,
+};
+static const struct builtin *const O_vec_sr[6] = {
+ &B1_vec_vsrh,
+ &B1_vec_vsrw,
+ &B1_vec_vsrb,
+ &B2_vec_vsrh,
+ &B2_vec_vsrw,
+ &B2_vec_vsrb,
+};
+static const struct builtin *const O_vec_sra[6] = {
+ &B1_vec_vsrah,
+ &B1_vec_vsraw,
+ &B1_vec_vsrab,
+ &B2_vec_vsrah,
+ &B2_vec_vsraw,
+ &B2_vec_vsrab,
+};
+static const struct builtin *const O_vec_srl[30] = {
+ &B1_vec_vsr,
+ &B2_vec_vsr,
+ &B3_vec_vsr,
+ &B4_vec_vsr,
+ &B5_vec_vsr,
+ &B6_vec_vsr,
+ &B7_vec_vsr,
+ &B8_vec_vsr,
+ &B9_vec_vsr,
+ &B10_vec_vsr,
+ &B11_vec_vsr,
+ &B12_vec_vsr,
+ &B13_vec_vsr,
+ &B14_vec_vsr,
+ &B15_vec_vsr,
+ &B16_vec_vsr,
+ &B17_vec_vsr,
+ &B18_vec_vsr,
+ &B19_vec_vsr,
+ &B20_vec_vsr,
+ &B21_vec_vsr,
+ &B22_vec_vsr,
+ &B23_vec_vsr,
+ &B24_vec_vsr,
+ &B25_vec_vsr,
+ &B26_vec_vsr,
+ &B27_vec_vsr,
+ &B28_vec_vsr,
+ &B29_vec_vsr,
+ &B30_vec_vsr,
+};
+static const struct builtin *const O_vec_sro[16] = {
+ &B1_vec_vsro,
+ &B2_vec_vsro,
+ &B3_vec_vsro,
+ &B4_vec_vsro,
+ &B5_vec_vsro,
+ &B6_vec_vsro,
+ &B7_vec_vsro,
+ &B8_vec_vsro,
+ &B9_vec_vsro,
+ &B10_vec_vsro,
+ &B11_vec_vsro,
+ &B12_vec_vsro,
+ &B13_vec_vsro,
+ &B14_vec_vsro,
+ &B15_vec_vsro,
+ &B16_vec_vsro,
+};
+static const struct builtin *const O_vec_st[30] = {
+ &B1_vec_stvx,
+ &B2_vec_stvx,
+ &B3_vec_stvx,
+ &B4_vec_stvx,
+ &B5_vec_stvx,
+ &B6_vec_stvx,
+ &B7_vec_stvx,
+ &B8_vec_stvx,
+ &B9_vec_stvx,
+ &B10_vec_stvx,
+ &B11_vec_stvx,
+ &B12_vec_stvx,
+ &B13_vec_stvx,
+ &B14_vec_stvx,
+ &B15_vec_stvx,
+ &B16_vec_stvx,
+ &B17_vec_stvx,
+ &B18_vec_stvx,
+ &B19_vec_stvx,
+ &B20_vec_stvx,
+ &B21_vec_stvx,
+ &B22_vec_stvx,
+ &B23_vec_stvx,
+ &B24_vec_stvx,
+ &B25_vec_stvx,
+ &B26_vec_stvx,
+ &B27_vec_stvx,
+ &B28_vec_stvx,
+ &B29_vec_stvx,
+ &B30_vec_stvx,
+};
+static const struct builtin *const O_vec_ste[19] = {
+ &B1_vec_stvebx,
+ &B2_vec_stvebx,
+ &B1_vec_stvewx,
+ &B2_vec_stvewx,
+ &B3_vec_stvewx,
+ &B4_vec_stvewx,
+ &B3_vec_stvebx,
+ &B4_vec_stvebx,
+ &B5_vec_stvewx,
+ &B1_vec_stvehx,
+ &B2_vec_stvehx,
+ &B3_vec_stvehx,
+ &B6_vec_stvewx,
+ &B7_vec_stvewx,
+ &B5_vec_stvebx,
+ &B4_vec_stvehx,
+ &B8_vec_stvewx,
+ &B9_vec_stvewx,
+ &B6_vec_stvebx,
+};
+static const struct builtin *const O_vec_stl[30] = {
+ &B1_vec_stvxl,
+ &B2_vec_stvxl,
+ &B3_vec_stvxl,
+ &B4_vec_stvxl,
+ &B5_vec_stvxl,
+ &B6_vec_stvxl,
+ &B7_vec_stvxl,
+ &B8_vec_stvxl,
+ &B9_vec_stvxl,
+ &B10_vec_stvxl,
+ &B11_vec_stvxl,
+ &B12_vec_stvxl,
+ &B13_vec_stvxl,
+ &B14_vec_stvxl,
+ &B15_vec_stvxl,
+ &B16_vec_stvxl,
+ &B17_vec_stvxl,
+ &B18_vec_stvxl,
+ &B19_vec_stvxl,
+ &B20_vec_stvxl,
+ &B21_vec_stvxl,
+ &B22_vec_stvxl,
+ &B23_vec_stvxl,
+ &B24_vec_stvxl,
+ &B25_vec_stvxl,
+ &B26_vec_stvxl,
+ &B27_vec_stvxl,
+ &B28_vec_stvxl,
+ &B29_vec_stvxl,
+ &B30_vec_stvxl,
+};
+static const struct builtin *const O_vec_stvebx[6] = {
+ &B1_vec_stvebx,
+ &B2_vec_stvebx,
+ &B3_vec_stvebx,
+ &B4_vec_stvebx,
+ &B5_vec_stvebx,
+ &B6_vec_stvebx,
+};
+static const struct builtin *const O_vec_stvehx[4] = {
+ &B1_vec_stvehx,
+ &B2_vec_stvehx,
+ &B3_vec_stvehx,
+ &B4_vec_stvehx,
+};
+static const struct builtin *const O_vec_stvewx[9] = {
+ &B1_vec_stvewx,
+ &B2_vec_stvewx,
+ &B3_vec_stvewx,
+ &B4_vec_stvewx,
+ &B5_vec_stvewx,
+ &B6_vec_stvewx,
+ &B7_vec_stvewx,
+ &B8_vec_stvewx,
+ &B9_vec_stvewx,
+};
+static const struct builtin *const O_vec_stvx[30] = {
+ &B1_vec_stvx,
+ &B2_vec_stvx,
+ &B3_vec_stvx,
+ &B4_vec_stvx,
+ &B5_vec_stvx,
+ &B6_vec_stvx,
+ &B7_vec_stvx,
+ &B8_vec_stvx,
+ &B9_vec_stvx,
+ &B10_vec_stvx,
+ &B11_vec_stvx,
+ &B12_vec_stvx,
+ &B13_vec_stvx,
+ &B14_vec_stvx,
+ &B15_vec_stvx,
+ &B16_vec_stvx,
+ &B17_vec_stvx,
+ &B18_vec_stvx,
+ &B19_vec_stvx,
+ &B20_vec_stvx,
+ &B21_vec_stvx,
+ &B22_vec_stvx,
+ &B23_vec_stvx,
+ &B24_vec_stvx,
+ &B25_vec_stvx,
+ &B26_vec_stvx,
+ &B27_vec_stvx,
+ &B28_vec_stvx,
+ &B29_vec_stvx,
+ &B30_vec_stvx,
+};
+static const struct builtin *const O_vec_stvxl[30] = {
+ &B1_vec_stvxl,
+ &B2_vec_stvxl,
+ &B3_vec_stvxl,
+ &B4_vec_stvxl,
+ &B5_vec_stvxl,
+ &B6_vec_stvxl,
+ &B7_vec_stvxl,
+ &B8_vec_stvxl,
+ &B9_vec_stvxl,
+ &B10_vec_stvxl,
+ &B11_vec_stvxl,
+ &B12_vec_stvxl,
+ &B13_vec_stvxl,
+ &B14_vec_stvxl,
+ &B15_vec_stvxl,
+ &B16_vec_stvxl,
+ &B17_vec_stvxl,
+ &B18_vec_stvxl,
+ &B19_vec_stvxl,
+ &B20_vec_stvxl,
+ &B21_vec_stvxl,
+ &B22_vec_stvxl,
+ &B23_vec_stvxl,
+ &B24_vec_stvxl,
+ &B25_vec_stvxl,
+ &B26_vec_stvxl,
+ &B27_vec_stvxl,
+ &B28_vec_stvxl,
+ &B29_vec_stvxl,
+ &B30_vec_stvxl,
+};
+static const struct builtin *const O_vec_sub[19] = {
+ &B1_vec_vsubuhm,
+ &B2_vec_vsubuhm,
+ &B1_vec_vsubuwm,
+ &B2_vec_vsubuwm,
+ &B1_vec_vsububm,
+ &B2_vec_vsububm,
+ &B_vec_vsubfp,
+ &B3_vec_vsubuhm,
+ &B4_vec_vsubuhm,
+ &B3_vec_vsubuwm,
+ &B4_vec_vsubuwm,
+ &B3_vec_vsububm,
+ &B4_vec_vsububm,
+ &B5_vec_vsubuhm,
+ &B6_vec_vsubuhm,
+ &B5_vec_vsubuwm,
+ &B6_vec_vsubuwm,
+ &B5_vec_vsububm,
+ &B6_vec_vsububm,
+};
+static const struct builtin *const O_vec_subc[1] = {
+ &B_vec_vsubcuw,
+};
+static const struct builtin *const O_vec_subs[18] = {
+ &B1_vec_vsubshs,
+ &B1_vec_vsubuhs,
+ &B1_vec_vsubsws,
+ &B1_vec_vsubuws,
+ &B1_vec_vsubsbs,
+ &B1_vec_vsububs,
+ &B2_vec_vsubshs,
+ &B3_vec_vsubshs,
+ &B2_vec_vsubsws,
+ &B3_vec_vsubsws,
+ &B2_vec_vsubsbs,
+ &B3_vec_vsubsbs,
+ &B2_vec_vsubuhs,
+ &B3_vec_vsubuhs,
+ &B2_vec_vsubuws,
+ &B3_vec_vsubuws,
+ &B2_vec_vsububs,
+ &B3_vec_vsububs,
+};
+static const struct builtin *const O_vec_sum2s[1] = {
+ &B_vec_vsum2sws,
+};
+static const struct builtin *const O_vec_sum4s[3] = {
+ &B_vec_vsum4shs,
+ &B_vec_vsum4sbs,
+ &B_vec_vsum4ubs,
+};
+static const struct builtin *const O_vec_sums[1] = {
+ &B_vec_vsumsws,
+};
+static const struct builtin *const O_vec_trunc[1] = {
+ &B_vec_vrfiz,
+};
+static const struct builtin *const O_vec_unpack2sh[2] = {
+ &B1_vec_unpack2sh,
+ &B2_vec_unpack2sh,
+};
+static const struct builtin *const O_vec_unpack2sl[2] = {
+ &B1_vec_unpack2sl,
+ &B2_vec_unpack2sl,
+};
+static const struct builtin *const O_vec_unpack2uh[2] = {
+ &B1_vec_unpack2uh,
+ &B2_vec_unpack2uh,
+};
+static const struct builtin *const O_vec_unpack2ul[2] = {
+ &B1_vec_unpack2ul,
+ &B2_vec_unpack2ul,
+};
+static const struct builtin *const O_vec_unpackh[5] = {
+ &B1_vec_vupkhsh,
+ &B1_vec_vupkhsb,
+ &B_vec_vupkhpx,
+ &B2_vec_vupkhsh,
+ &B2_vec_vupkhsb,
+};
+static const struct builtin *const O_vec_unpackl[5] = {
+ &B1_vec_vupklsh,
+ &B1_vec_vupklsb,
+ &B_vec_vupklpx,
+ &B2_vec_vupklsh,
+ &B2_vec_vupklsb,
+};
+static const struct builtin *const O_vec_vaddcuw[1] = {
+ &B_vec_vaddcuw,
+};
+static const struct builtin *const O_vec_vaddfp[1] = {
+ &B_vec_vaddfp,
+};
+static const struct builtin *const O_vec_vaddsbs[3] = {
+ &B1_vec_vaddsbs,
+ &B2_vec_vaddsbs,
+ &B3_vec_vaddsbs,
+};
+static const struct builtin *const O_vec_vaddshs[3] = {
+ &B1_vec_vaddshs,
+ &B2_vec_vaddshs,
+ &B3_vec_vaddshs,
+};
+static const struct builtin *const O_vec_vaddsws[3] = {
+ &B1_vec_vaddsws,
+ &B2_vec_vaddsws,
+ &B3_vec_vaddsws,
+};
+static const struct builtin *const O_vec_vaddubm[6] = {
+ &B1_vec_vaddubm,
+ &B2_vec_vaddubm,
+ &B3_vec_vaddubm,
+ &B4_vec_vaddubm,
+ &B5_vec_vaddubm,
+ &B6_vec_vaddubm,
+};
+static const struct builtin *const O_vec_vaddubs[3] = {
+ &B1_vec_vaddubs,
+ &B2_vec_vaddubs,
+ &B3_vec_vaddubs,
+};
+static const struct builtin *const O_vec_vadduhm[6] = {
+ &B1_vec_vadduhm,
+ &B2_vec_vadduhm,
+ &B3_vec_vadduhm,
+ &B4_vec_vadduhm,
+ &B5_vec_vadduhm,
+ &B6_vec_vadduhm,
+};
+static const struct builtin *const O_vec_vadduhs[3] = {
+ &B1_vec_vadduhs,
+ &B2_vec_vadduhs,
+ &B3_vec_vadduhs,
+};
+static const struct builtin *const O_vec_vadduwm[6] = {
+ &B1_vec_vadduwm,
+ &B2_vec_vadduwm,
+ &B3_vec_vadduwm,
+ &B4_vec_vadduwm,
+ &B5_vec_vadduwm,
+ &B6_vec_vadduwm,
+};
+static const struct builtin *const O_vec_vadduws[3] = {
+ &B1_vec_vadduws,
+ &B2_vec_vadduws,
+ &B3_vec_vadduws,
+};
+static const struct builtin *const O_vec_vand[24] = {
+ &B1_vec_vand,
+ &B2_vec_vand,
+ &B3_vec_vand,
+ &B4_vec_vand,
+ &B5_vec_vand,
+ &B6_vec_vand,
+ &B7_vec_vand,
+ &B8_vec_vand,
+ &B9_vec_vand,
+ &B10_vec_vand,
+ &B11_vec_vand,
+ &B12_vec_vand,
+ &B13_vec_vand,
+ &B14_vec_vand,
+ &B15_vec_vand,
+ &B16_vec_vand,
+ &B17_vec_vand,
+ &B18_vec_vand,
+ &B19_vec_vand,
+ &B20_vec_vand,
+ &B21_vec_vand,
+ &B22_vec_vand,
+ &B23_vec_vand,
+ &B24_vec_vand,
+};
+static const struct builtin *const O_vec_vandc[24] = {
+ &B1_vec_vandc,
+ &B2_vec_vandc,
+ &B3_vec_vandc,
+ &B4_vec_vandc,
+ &B5_vec_vandc,
+ &B6_vec_vandc,
+ &B7_vec_vandc,
+ &B8_vec_vandc,
+ &B9_vec_vandc,
+ &B10_vec_vandc,
+ &B11_vec_vandc,
+ &B12_vec_vandc,
+ &B13_vec_vandc,
+ &B14_vec_vandc,
+ &B15_vec_vandc,
+ &B16_vec_vandc,
+ &B17_vec_vandc,
+ &B18_vec_vandc,
+ &B19_vec_vandc,
+ &B20_vec_vandc,
+ &B21_vec_vandc,
+ &B22_vec_vandc,
+ &B23_vec_vandc,
+ &B24_vec_vandc,
+};
+static const struct builtin *const O_vec_vavgsb[1] = {
+ &B_vec_vavgsb,
+};
+static const struct builtin *const O_vec_vavgsh[1] = {
+ &B_vec_vavgsh,
+};
+static const struct builtin *const O_vec_vavgsw[1] = {
+ &B_vec_vavgsw,
+};
+static const struct builtin *const O_vec_vavgub[1] = {
+ &B_vec_vavgub,
+};
+static const struct builtin *const O_vec_vavguh[1] = {
+ &B_vec_vavguh,
+};
+static const struct builtin *const O_vec_vavguw[1] = {
+ &B_vec_vavguw,
+};
+static const struct builtin *const O_vec_vcfsx[1] = {
+ &B_vec_vcfsx,
+};
+static const struct builtin *const O_vec_vcfux[1] = {
+ &B_vec_vcfux,
+};
+static const struct builtin *const O_vec_vcmpbfp[1] = {
+ &B_vec_vcmpbfp,
+};
+static const struct builtin *const O_vec_vcmpeqfp[1] = {
+ &B_vec_vcmpeqfp,
+};
+static const struct builtin *const O_vec_vcmpequb[2] = {
+ &B1_vec_vcmpequb,
+ &B2_vec_vcmpequb,
+};
+static const struct builtin *const O_vec_vcmpequh[2] = {
+ &B1_vec_vcmpequh,
+ &B2_vec_vcmpequh,
+};
+static const struct builtin *const O_vec_vcmpequw[2] = {
+ &B1_vec_vcmpequw,
+ &B2_vec_vcmpequw,
+};
+static const struct builtin *const O_vec_vcmpgefp[1] = {
+ &B_vec_vcmpgefp,
+};
+static const struct builtin *const O_vec_vcmpgtfp[1] = {
+ &B_vec_vcmpgtfp,
+};
+static const struct builtin *const O_vec_vcmpgtsb[1] = {
+ &B_vec_vcmpgtsb,
+};
+static const struct builtin *const O_vec_vcmpgtsh[1] = {
+ &B_vec_vcmpgtsh,
+};
+static const struct builtin *const O_vec_vcmpgtsw[1] = {
+ &B_vec_vcmpgtsw,
+};
+static const struct builtin *const O_vec_vcmpgtub[1] = {
+ &B_vec_vcmpgtub,
+};
+static const struct builtin *const O_vec_vcmpgtuh[1] = {
+ &B_vec_vcmpgtuh,
+};
+static const struct builtin *const O_vec_vcmpgtuw[1] = {
+ &B_vec_vcmpgtuw,
+};
+static const struct builtin *const O_vec_vctsxs[1] = {
+ &B_vec_vctsxs,
+};
+static const struct builtin *const O_vec_vctuxs[1] = {
+ &B_vec_vctuxs,
+};
+static const struct builtin *const O_vec_vexptefp[1] = {
+ &B_vec_vexptefp,
+};
+static const struct builtin *const O_vec_vlogefp[1] = {
+ &B_vec_vlogefp,
+};
+static const struct builtin *const O_vec_vmaddfp[1] = {
+ &B_vec_vmaddfp,
+};
+static const struct builtin *const O_vec_vmaxfp[1] = {
+ &B_vec_vmaxfp,
+};
+static const struct builtin *const O_vec_vmaxsb[3] = {
+ &B1_vec_vmaxsb,
+ &B2_vec_vmaxsb,
+ &B3_vec_vmaxsb,
+};
+static const struct builtin *const O_vec_vmaxsh[3] = {
+ &B1_vec_vmaxsh,
+ &B2_vec_vmaxsh,
+ &B3_vec_vmaxsh,
+};
+static const struct builtin *const O_vec_vmaxsw[3] = {
+ &B1_vec_vmaxsw,
+ &B2_vec_vmaxsw,
+ &B3_vec_vmaxsw,
+};
+static const struct builtin *const O_vec_vmaxub[3] = {
+ &B1_vec_vmaxub,
+ &B2_vec_vmaxub,
+ &B3_vec_vmaxub,
+};
+static const struct builtin *const O_vec_vmaxuh[3] = {
+ &B1_vec_vmaxuh,
+ &B2_vec_vmaxuh,
+ &B3_vec_vmaxuh,
+};
+static const struct builtin *const O_vec_vmaxuw[3] = {
+ &B1_vec_vmaxuw,
+ &B2_vec_vmaxuw,
+ &B3_vec_vmaxuw,
+};
+static const struct builtin *const O_vec_vmhaddshs[1] = {
+ &B_vec_vmhaddshs,
+};
+static const struct builtin *const O_vec_vmhraddshs[1] = {
+ &B_vec_vmhraddshs,
+};
+static const struct builtin *const O_vec_vminfp[1] = {
+ &B_vec_vminfp,
+};
+static const struct builtin *const O_vec_vminsb[3] = {
+ &B1_vec_vminsb,
+ &B2_vec_vminsb,
+ &B3_vec_vminsb,
+};
+static const struct builtin *const O_vec_vminsh[3] = {
+ &B1_vec_vminsh,
+ &B2_vec_vminsh,
+ &B3_vec_vminsh,
+};
+static const struct builtin *const O_vec_vminsw[3] = {
+ &B1_vec_vminsw,
+ &B2_vec_vminsw,
+ &B3_vec_vminsw,
+};
+static const struct builtin *const O_vec_vminub[3] = {
+ &B1_vec_vminub,
+ &B2_vec_vminub,
+ &B3_vec_vminub,
+};
+static const struct builtin *const O_vec_vminuh[3] = {
+ &B1_vec_vminuh,
+ &B2_vec_vminuh,
+ &B3_vec_vminuh,
+};
+static const struct builtin *const O_vec_vminuw[3] = {
+ &B1_vec_vminuw,
+ &B2_vec_vminuw,
+ &B3_vec_vminuw,
+};
+static const struct builtin *const O_vec_vmladduhm[4] = {
+ &B1_vec_vmladduhm,
+ &B2_vec_vmladduhm,
+ &B3_vec_vmladduhm,
+ &B4_vec_vmladduhm,
+};
+static const struct builtin *const O_vec_vmrghb[3] = {
+ &B1_vec_vmrghb,
+ &B2_vec_vmrghb,
+ &B3_vec_vmrghb,
+};
+static const struct builtin *const O_vec_vmrghh[4] = {
+ &B1_vec_vmrghh,
+ &B2_vec_vmrghh,
+ &B3_vec_vmrghh,
+ &B4_vec_vmrghh,
+};
+static const struct builtin *const O_vec_vmrghw[4] = {
+ &B1_vec_vmrghw,
+ &B2_vec_vmrghw,
+ &B3_vec_vmrghw,
+ &B4_vec_vmrghw,
+};
+static const struct builtin *const O_vec_vmrglb[3] = {
+ &B1_vec_vmrglb,
+ &B2_vec_vmrglb,
+ &B3_vec_vmrglb,
+};
+static const struct builtin *const O_vec_vmrglh[4] = {
+ &B1_vec_vmrglh,
+ &B2_vec_vmrglh,
+ &B3_vec_vmrglh,
+ &B4_vec_vmrglh,
+};
+static const struct builtin *const O_vec_vmrglw[4] = {
+ &B1_vec_vmrglw,
+ &B2_vec_vmrglw,
+ &B3_vec_vmrglw,
+ &B4_vec_vmrglw,
+};
+static const struct builtin *const O_vec_vmsummbm[1] = {
+ &B_vec_vmsummbm,
+};
+static const struct builtin *const O_vec_vmsumshm[1] = {
+ &B_vec_vmsumshm,
+};
+static const struct builtin *const O_vec_vmsumshs[1] = {
+ &B_vec_vmsumshs,
+};
+static const struct builtin *const O_vec_vmsumubm[1] = {
+ &B_vec_vmsumubm,
+};
+static const struct builtin *const O_vec_vmsumuhm[1] = {
+ &B_vec_vmsumuhm,
+};
+static const struct builtin *const O_vec_vmsumuhs[1] = {
+ &B_vec_vmsumuhs,
+};
+static const struct builtin *const O_vec_vmulesb[1] = {
+ &B_vec_vmulesb,
+};
+static const struct builtin *const O_vec_vmulesh[1] = {
+ &B_vec_vmulesh,
+};
+static const struct builtin *const O_vec_vmuleub[1] = {
+ &B_vec_vmuleub,
+};
+static const struct builtin *const O_vec_vmuleuh[1] = {
+ &B_vec_vmuleuh,
+};
+static const struct builtin *const O_vec_vmulosb[1] = {
+ &B_vec_vmulosb,
+};
+static const struct builtin *const O_vec_vmulosh[1] = {
+ &B_vec_vmulosh,
+};
+static const struct builtin *const O_vec_vmuloub[1] = {
+ &B_vec_vmuloub,
+};
+static const struct builtin *const O_vec_vmulouh[1] = {
+ &B_vec_vmulouh,
+};
+static const struct builtin *const O_vec_vnmsubfp[1] = {
+ &B_vec_vnmsubfp,
+};
+static const struct builtin *const O_vec_vnor[10] = {
+ &B1_vec_vnor,
+ &B2_vec_vnor,
+ &B3_vec_vnor,
+ &B4_vec_vnor,
+ &B5_vec_vnor,
+ &B6_vec_vnor,
+ &B7_vec_vnor,
+ &B8_vec_vnor,
+ &B9_vec_vnor,
+ &B10_vec_vnor,
+};
+static const struct builtin *const O_vec_vor[24] = {
+ &B1_vec_vor,
+ &B2_vec_vor,
+ &B3_vec_vor,
+ &B4_vec_vor,
+ &B5_vec_vor,
+ &B6_vec_vor,
+ &B7_vec_vor,
+ &B8_vec_vor,
+ &B9_vec_vor,
+ &B10_vec_vor,
+ &B11_vec_vor,
+ &B12_vec_vor,
+ &B13_vec_vor,
+ &B14_vec_vor,
+ &B15_vec_vor,
+ &B16_vec_vor,
+ &B17_vec_vor,
+ &B18_vec_vor,
+ &B19_vec_vor,
+ &B20_vec_vor,
+ &B21_vec_vor,
+ &B22_vec_vor,
+ &B23_vec_vor,
+ &B24_vec_vor,
+};
+static const struct builtin *const O_vec_vperm[11] = {
+ &B1_vec_vperm,
+ &B2_vec_vperm,
+ &B3_vec_vperm,
+ &B4_vec_vperm,
+ &B5_vec_vperm,
+ &B6_vec_vperm,
+ &B7_vec_vperm,
+ &B8_vec_vperm,
+ &B9_vec_vperm,
+ &B10_vec_vperm,
+ &B11_vec_vperm,
+};
+static const struct builtin *const O_vec_vpkpx[1] = {
+ &B_vec_vpkpx,
+};
+static const struct builtin *const O_vec_vpkshss[1] = {
+ &B_vec_vpkshss,
+};
+static const struct builtin *const O_vec_vpkshus[1] = {
+ &B_vec_vpkshus,
+};
+static const struct builtin *const O_vec_vpkswss[1] = {
+ &B_vec_vpkswss,
+};
+static const struct builtin *const O_vec_vpkswus[1] = {
+ &B_vec_vpkswus,
+};
+static const struct builtin *const O_vec_vpkuhum[3] = {
+ &B1_vec_vpkuhum,
+ &B2_vec_vpkuhum,
+ &B3_vec_vpkuhum,
+};
+static const struct builtin *const O_vec_vpkuhus[1] = {
+ &B_vec_vpkuhus,
+};
+static const struct builtin *const O_vec_vpkuwum[3] = {
+ &B1_vec_vpkuwum,
+ &B2_vec_vpkuwum,
+ &B3_vec_vpkuwum,
+};
+static const struct builtin *const O_vec_vpkuwus[1] = {
+ &B_vec_vpkuwus,
+};
+static const struct builtin *const O_vec_vrefp[1] = {
+ &B_vec_vrefp,
+};
+static const struct builtin *const O_vec_vrfim[1] = {
+ &B_vec_vrfim,
+};
+static const struct builtin *const O_vec_vrfin[1] = {
+ &B_vec_vrfin,
+};
+static const struct builtin *const O_vec_vrfip[1] = {
+ &B_vec_vrfip,
+};
+static const struct builtin *const O_vec_vrfiz[1] = {
+ &B_vec_vrfiz,
+};
+static const struct builtin *const O_vec_vrlb[2] = {
+ &B1_vec_vrlb,
+ &B2_vec_vrlb,
+};
+static const struct builtin *const O_vec_vrlh[2] = {
+ &B1_vec_vrlh,
+ &B2_vec_vrlh,
+};
+static const struct builtin *const O_vec_vrlw[2] = {
+ &B1_vec_vrlw,
+ &B2_vec_vrlw,
+};
+static const struct builtin *const O_vec_vrsqrtefp[1] = {
+ &B_vec_vrsqrtefp,
+};
+static const struct builtin *const O_vec_vsel[20] = {
+ &B1_vec_vsel,
+ &B2_vec_vsel,
+ &B3_vec_vsel,
+ &B4_vec_vsel,
+ &B5_vec_vsel,
+ &B6_vec_vsel,
+ &B7_vec_vsel,
+ &B8_vec_vsel,
+ &B9_vec_vsel,
+ &B10_vec_vsel,
+ &B11_vec_vsel,
+ &B12_vec_vsel,
+ &B13_vec_vsel,
+ &B14_vec_vsel,
+ &B15_vec_vsel,
+ &B16_vec_vsel,
+ &B17_vec_vsel,
+ &B18_vec_vsel,
+ &B19_vec_vsel,
+ &B20_vec_vsel,
+};
+static const struct builtin *const O_vec_vsl[30] = {
+ &B1_vec_vsl,
+ &B2_vec_vsl,
+ &B3_vec_vsl,
+ &B4_vec_vsl,
+ &B5_vec_vsl,
+ &B6_vec_vsl,
+ &B7_vec_vsl,
+ &B8_vec_vsl,
+ &B9_vec_vsl,
+ &B10_vec_vsl,
+ &B11_vec_vsl,
+ &B12_vec_vsl,
+ &B13_vec_vsl,
+ &B14_vec_vsl,
+ &B15_vec_vsl,
+ &B16_vec_vsl,
+ &B17_vec_vsl,
+ &B18_vec_vsl,
+ &B19_vec_vsl,
+ &B20_vec_vsl,
+ &B21_vec_vsl,
+ &B22_vec_vsl,
+ &B23_vec_vsl,
+ &B24_vec_vsl,
+ &B25_vec_vsl,
+ &B26_vec_vsl,
+ &B27_vec_vsl,
+ &B28_vec_vsl,
+ &B29_vec_vsl,
+ &B30_vec_vsl,
+};
+static const struct builtin *const O_vec_vslb[2] = {
+ &B1_vec_vslb,
+ &B2_vec_vslb,
+};
+static const struct builtin *const O_vec_vsldoi[11] = {
+ &B1_vec_vsldoi,
+ &B2_vec_vsldoi,
+ &B3_vec_vsldoi,
+ &B4_vec_vsldoi,
+ &B5_vec_vsldoi,
+ &B6_vec_vsldoi,
+ &B7_vec_vsldoi,
+ &B8_vec_vsldoi,
+ &B9_vec_vsldoi,
+ &B10_vec_vsldoi,
+ &B11_vec_vsldoi,
+};
+static const struct builtin *const O_vec_vslh[2] = {
+ &B1_vec_vslh,
+ &B2_vec_vslh,
+};
+static const struct builtin *const O_vec_vslo[16] = {
+ &B1_vec_vslo,
+ &B2_vec_vslo,
+ &B3_vec_vslo,
+ &B4_vec_vslo,
+ &B5_vec_vslo,
+ &B6_vec_vslo,
+ &B7_vec_vslo,
+ &B8_vec_vslo,
+ &B9_vec_vslo,
+ &B10_vec_vslo,
+ &B11_vec_vslo,
+ &B12_vec_vslo,
+ &B13_vec_vslo,
+ &B14_vec_vslo,
+ &B15_vec_vslo,
+ &B16_vec_vslo,
+};
+static const struct builtin *const O_vec_vslw[2] = {
+ &B1_vec_vslw,
+ &B2_vec_vslw,
+};
+static const struct builtin *const O_vec_vspltb[3] = {
+ &B1_vec_vspltb,
+ &B2_vec_vspltb,
+ &B3_vec_vspltb,
+};
+static const struct builtin *const O_vec_vsplth[4] = {
+ &B1_vec_vsplth,
+ &B2_vec_vsplth,
+ &B3_vec_vsplth,
+ &B4_vec_vsplth,
+};
+static const struct builtin *const O_vec_vspltisb[1] = {
+ &B_vec_vspltisb,
+};
+static const struct builtin *const O_vec_vspltish[1] = {
+ &B_vec_vspltish,
+};
+static const struct builtin *const O_vec_vspltisw[1] = {
+ &B_vec_vspltisw,
+};
+static const struct builtin *const O_vec_vspltw[4] = {
+ &B1_vec_vspltw,
+ &B2_vec_vspltw,
+ &B3_vec_vspltw,
+ &B4_vec_vspltw,
+};
+static const struct builtin *const O_vec_vsr[30] = {
+ &B1_vec_vsr,
+ &B2_vec_vsr,
+ &B3_vec_vsr,
+ &B4_vec_vsr,
+ &B5_vec_vsr,
+ &B6_vec_vsr,
+ &B7_vec_vsr,
+ &B8_vec_vsr,
+ &B9_vec_vsr,
+ &B10_vec_vsr,
+ &B11_vec_vsr,
+ &B12_vec_vsr,
+ &B13_vec_vsr,
+ &B14_vec_vsr,
+ &B15_vec_vsr,
+ &B16_vec_vsr,
+ &B17_vec_vsr,
+ &B18_vec_vsr,
+ &B19_vec_vsr,
+ &B20_vec_vsr,
+ &B21_vec_vsr,
+ &B22_vec_vsr,
+ &B23_vec_vsr,
+ &B24_vec_vsr,
+ &B25_vec_vsr,
+ &B26_vec_vsr,
+ &B27_vec_vsr,
+ &B28_vec_vsr,
+ &B29_vec_vsr,
+ &B30_vec_vsr,
+};
+static const struct builtin *const O_vec_vsrab[2] = {
+ &B1_vec_vsrab,
+ &B2_vec_vsrab,
+};
+static const struct builtin *const O_vec_vsrah[2] = {
+ &B1_vec_vsrah,
+ &B2_vec_vsrah,
+};
+static const struct builtin *const O_vec_vsraw[2] = {
+ &B1_vec_vsraw,
+ &B2_vec_vsraw,
+};
+static const struct builtin *const O_vec_vsrb[2] = {
+ &B1_vec_vsrb,
+ &B2_vec_vsrb,
+};
+static const struct builtin *const O_vec_vsrh[2] = {
+ &B1_vec_vsrh,
+ &B2_vec_vsrh,
+};
+static const struct builtin *const O_vec_vsro[16] = {
+ &B1_vec_vsro,
+ &B2_vec_vsro,
+ &B3_vec_vsro,
+ &B4_vec_vsro,
+ &B5_vec_vsro,
+ &B6_vec_vsro,
+ &B7_vec_vsro,
+ &B8_vec_vsro,
+ &B9_vec_vsro,
+ &B10_vec_vsro,
+ &B11_vec_vsro,
+ &B12_vec_vsro,
+ &B13_vec_vsro,
+ &B14_vec_vsro,
+ &B15_vec_vsro,
+ &B16_vec_vsro,
+};
+static const struct builtin *const O_vec_vsrw[2] = {
+ &B1_vec_vsrw,
+ &B2_vec_vsrw,
+};
+static const struct builtin *const O_vec_vsubcuw[1] = {
+ &B_vec_vsubcuw,
+};
+static const struct builtin *const O_vec_vsubfp[1] = {
+ &B_vec_vsubfp,
+};
+static const struct builtin *const O_vec_vsubsbs[3] = {
+ &B1_vec_vsubsbs,
+ &B2_vec_vsubsbs,
+ &B3_vec_vsubsbs,
+};
+static const struct builtin *const O_vec_vsubshs[3] = {
+ &B1_vec_vsubshs,
+ &B2_vec_vsubshs,
+ &B3_vec_vsubshs,
+};
+static const struct builtin *const O_vec_vsubsws[3] = {
+ &B1_vec_vsubsws,
+ &B2_vec_vsubsws,
+ &B3_vec_vsubsws,
+};
+static const struct builtin *const O_vec_vsububm[6] = {
+ &B1_vec_vsububm,
+ &B2_vec_vsububm,
+ &B3_vec_vsububm,
+ &B4_vec_vsububm,
+ &B5_vec_vsububm,
+ &B6_vec_vsububm,
+};
+static const struct builtin *const O_vec_vsububs[3] = {
+ &B1_vec_vsububs,
+ &B2_vec_vsububs,
+ &B3_vec_vsububs,
+};
+static const struct builtin *const O_vec_vsubuhm[6] = {
+ &B1_vec_vsubuhm,
+ &B2_vec_vsubuhm,
+ &B3_vec_vsubuhm,
+ &B4_vec_vsubuhm,
+ &B5_vec_vsubuhm,
+ &B6_vec_vsubuhm,
+};
+static const struct builtin *const O_vec_vsubuhs[3] = {
+ &B1_vec_vsubuhs,
+ &B2_vec_vsubuhs,
+ &B3_vec_vsubuhs,
+};
+static const struct builtin *const O_vec_vsubuwm[6] = {
+ &B1_vec_vsubuwm,
+ &B2_vec_vsubuwm,
+ &B3_vec_vsubuwm,
+ &B4_vec_vsubuwm,
+ &B5_vec_vsubuwm,
+ &B6_vec_vsubuwm,
+};
+static const struct builtin *const O_vec_vsubuws[3] = {
+ &B1_vec_vsubuws,
+ &B2_vec_vsubuws,
+ &B3_vec_vsubuws,
+};
+static const struct builtin *const O_vec_vsum2sws[1] = {
+ &B_vec_vsum2sws,
+};
+static const struct builtin *const O_vec_vsum4sbs[1] = {
+ &B_vec_vsum4sbs,
+};
+static const struct builtin *const O_vec_vsum4shs[1] = {
+ &B_vec_vsum4shs,
+};
+static const struct builtin *const O_vec_vsum4ubs[1] = {
+ &B_vec_vsum4ubs,
+};
+static const struct builtin *const O_vec_vsumsws[1] = {
+ &B_vec_vsumsws,
+};
+static const struct builtin *const O_vec_vupkhpx[1] = {
+ &B_vec_vupkhpx,
+};
+static const struct builtin *const O_vec_vupkhsb[2] = {
+ &B1_vec_vupkhsb,
+ &B2_vec_vupkhsb,
+};
+static const struct builtin *const O_vec_vupkhsh[2] = {
+ &B1_vec_vupkhsh,
+ &B2_vec_vupkhsh,
+};
+static const struct builtin *const O_vec_vupklpx[1] = {
+ &B_vec_vupklpx,
+};
+static const struct builtin *const O_vec_vupklsb[2] = {
+ &B1_vec_vupklsb,
+ &B2_vec_vupklsb,
+};
+static const struct builtin *const O_vec_vupklsh[2] = {
+ &B1_vec_vupklsh,
+ &B2_vec_vupklsh,
+};
+static const struct builtin *const O_vec_vxor[24] = {
+ &B1_vec_vxor,
+ &B2_vec_vxor,
+ &B3_vec_vxor,
+ &B4_vec_vxor,
+ &B5_vec_vxor,
+ &B6_vec_vxor,
+ &B7_vec_vxor,
+ &B8_vec_vxor,
+ &B9_vec_vxor,
+ &B10_vec_vxor,
+ &B11_vec_vxor,
+ &B12_vec_vxor,
+ &B13_vec_vxor,
+ &B14_vec_vxor,
+ &B15_vec_vxor,
+ &B16_vec_vxor,
+ &B17_vec_vxor,
+ &B18_vec_vxor,
+ &B19_vec_vxor,
+ &B20_vec_vxor,
+ &B21_vec_vxor,
+ &B22_vec_vxor,
+ &B23_vec_vxor,
+ &B24_vec_vxor,
+};
+static const struct builtin *const O_vec_xor[24] = {
+ &B1_vec_vxor,
+ &B2_vec_vxor,
+ &B3_vec_vxor,
+ &B4_vec_vxor,
+ &B5_vec_vxor,
+ &B6_vec_vxor,
+ &B7_vec_vxor,
+ &B8_vec_vxor,
+ &B9_vec_vxor,
+ &B10_vec_vxor,
+ &B11_vec_vxor,
+ &B12_vec_vxor,
+ &B13_vec_vxor,
+ &B14_vec_vxor,
+ &B15_vec_vxor,
+ &B16_vec_vxor,
+ &B17_vec_vxor,
+ &B18_vec_vxor,
+ &B19_vec_vxor,
+ &B20_vec_vxor,
+ &B21_vec_vxor,
+ &B22_vec_vxor,
+ &B23_vec_vxor,
+ &B24_vec_vxor,
+};
+
+const struct overloadx Overload[] = {
+ { "vec_abs", 4, 1, O_vec_abs, O_UID(0) },
+ { "vec_abss", 3, 1, O_vec_abss, O_UID(1) },
+ { "vec_add", 19, 2, O_vec_add, O_UID(2) },
+ { "vec_addc", 1, 2, O_vec_addc, O_UID(3) },
+ { "vec_adds", 18, 2, O_vec_adds, O_UID(4) },
+ { "vec_all_eq", 23, 2, O_vec_all_eq, O_UID(5) },
+ { "vec_all_ge", 19, 2, O_vec_all_ge, O_UID(6) },
+ { "vec_all_gt", 19, 2, O_vec_all_gt, O_UID(7) },
+ { "vec_all_in", 1, 2, O_vec_all_in, O_UID(8) },
+ { "vec_all_le", 19, 2, O_vec_all_le, O_UID(9) },
+ { "vec_all_lt", 19, 2, O_vec_all_lt, O_UID(10) },
+ { "vec_all_nan", 1, 1, O_vec_all_nan, O_UID(11) },
+ { "vec_all_ne", 23, 2, O_vec_all_ne, O_UID(12) },
+ { "vec_all_nge", 1, 2, O_vec_all_nge, O_UID(13) },
+ { "vec_all_ngt", 1, 2, O_vec_all_ngt, O_UID(14) },
+ { "vec_all_nle", 1, 2, O_vec_all_nle, O_UID(15) },
+ { "vec_all_nlt", 1, 2, O_vec_all_nlt, O_UID(16) },
+ { "vec_all_numeric", 1, 1, O_vec_all_numeric, O_UID(17) },
+ { "vec_and", 24, 2, O_vec_and, O_UID(18) },
+ { "vec_andc", 24, 2, O_vec_andc, O_UID(19) },
+ { "vec_any_eq", 23, 2, O_vec_any_eq, O_UID(20) },
+ { "vec_any_ge", 19, 2, O_vec_any_ge, O_UID(21) },
+ { "vec_any_gt", 19, 2, O_vec_any_gt, O_UID(22) },
+ { "vec_any_le", 19, 2, O_vec_any_le, O_UID(23) },
+ { "vec_any_lt", 19, 2, O_vec_any_lt, O_UID(24) },
+ { "vec_any_nan", 1, 1, O_vec_any_nan, O_UID(25) },
+ { "vec_any_ne", 23, 2, O_vec_any_ne, O_UID(26) },
+ { "vec_any_nge", 1, 2, O_vec_any_nge, O_UID(27) },
+ { "vec_any_ngt", 1, 2, O_vec_any_ngt, O_UID(28) },
+ { "vec_any_nle", 1, 2, O_vec_any_nle, O_UID(29) },
+ { "vec_any_nlt", 1, 2, O_vec_any_nlt, O_UID(30) },
+ { "vec_any_numeric", 1, 1, O_vec_any_numeric, O_UID(31) },
+ { "vec_any_out", 1, 2, O_vec_any_out, O_UID(32) },
+ { "vec_avg", 6, 2, O_vec_avg, O_UID(33) },
+ { "vec_ceil", 1, 1, O_vec_ceil, O_UID(34) },
+ { "vec_cmpb", 1, 2, O_vec_cmpb, O_UID(35) },
+ { "vec_cmpeq", 7, 2, O_vec_cmpeq, O_UID(36) },
+ { "vec_cmpge", 1, 2, O_vec_cmpge, O_UID(37) },
+ { "vec_cmpgt", 7, 2, O_vec_cmpgt, O_UID(38) },
+ { "vec_cmple", 1, 2, O_vec_cmple, O_UID(39) },
+ { "vec_cmplt", 7, 2, O_vec_cmplt, O_UID(40) },
+ { "vec_ctf", 2, 2, O_vec_ctf, O_UID(41) },
+ { "vec_cts", 1, 2, O_vec_cts, O_UID(42) },
+ { "vec_ctu", 1, 2, O_vec_ctu, O_UID(43) },
+ { "vec_dss", 1, 1, O_vec_dss, O_UID(44) },
+ { "vec_dssall", 1, 0, O_vec_dssall, O_UID(45) },
+ { "vec_dst", 20, 3, O_vec_dst, O_UID(46) },
+ { "vec_dstst", 20, 3, O_vec_dstst, O_UID(47) },
+ { "vec_dststt", 20, 3, O_vec_dststt, O_UID(48) },
+ { "vec_dstt", 20, 3, O_vec_dstt, O_UID(49) },
+ { "vec_expte", 1, 1, O_vec_expte, O_UID(50) },
+ { "vec_floor", 1, 1, O_vec_floor, O_UID(51) },
+ { "vec_ld", 20, 2, O_vec_ld, O_UID(52) },
+ { "vec_lde", 9, 2, O_vec_lde, O_UID(53) },
+ { "vec_ldl", 20, 2, O_vec_ldl, O_UID(54) },
+ { "vec_loge", 1, 1, O_vec_loge, O_UID(55) },
+ { "vec_lvebx", 2, 2, O_vec_lvebx, O_UID(56) },
+ { "vec_lvehx", 2, 2, O_vec_lvehx, O_UID(57) },
+ { "vec_lvewx", 5, 2, O_vec_lvewx, O_UID(58) },
+ { "vec_lvsl", 9, 2, O_vec_lvsl, O_UID(59) },
+ { "vec_lvsr", 9, 2, O_vec_lvsr, O_UID(60) },
+ { "vec_lvx", 20, 2, O_vec_lvx, O_UID(61) },
+ { "vec_lvxl", 20, 2, O_vec_lvxl, O_UID(62) },
+ { "vec_madd", 1, 3, O_vec_madd, O_UID(63) },
+ { "vec_madds", 1, 3, O_vec_madds, O_UID(64) },
+ { "vec_max", 19, 2, O_vec_max, O_UID(65) },
+ { "vec_mergeh", 11, 2, O_vec_mergeh, O_UID(66) },
+ { "vec_mergel", 11, 2, O_vec_mergel, O_UID(67) },
+ { "vec_mfvscr", 1, 0, O_vec_mfvscr, O_UID(68) },
+ { "vec_min", 19, 2, O_vec_min, O_UID(69) },
+ { "vec_mladd", 4, 3, O_vec_mladd, O_UID(70) },
+ { "vec_mradds", 1, 3, O_vec_mradds, O_UID(71) },
+ { "vec_msum", 4, 3, O_vec_msum, O_UID(72) },
+ { "vec_msums", 2, 3, O_vec_msums, O_UID(73) },
+ { "vec_mtvscr", 10, 1, O_vec_mtvscr, O_UID(74) },
+ { "vec_mule", 4, 2, O_vec_mule, O_UID(75) },
+ { "vec_mulo", 4, 2, O_vec_mulo, O_UID(76) },
+ { "vec_nmsub", 1, 3, O_vec_nmsub, O_UID(77) },
+ { "vec_nor", 10, 2, O_vec_nor, O_UID(78) },
+ { "vec_or", 24, 2, O_vec_or, O_UID(79) },
+ { "vec_pack", 6, 2, O_vec_pack, O_UID(80) },
+ { "vec_packpx", 1, 2, O_vec_packpx, O_UID(81) },
+ { "vec_packs", 4, 2, O_vec_packs, O_UID(82) },
+ { "vec_packsu", 4, 2, O_vec_packsu, O_UID(83) },
+ { "vec_perm", 11, 3, O_vec_perm, O_UID(84) },
+ { "vec_re", 1, 1, O_vec_re, O_UID(85) },
+ { "vec_rl", 6, 2, O_vec_rl, O_UID(86) },
+ { "vec_round", 1, 1, O_vec_round, O_UID(87) },
+ { "vec_rsqrte", 1, 1, O_vec_rsqrte, O_UID(88) },
+ { "vec_sel", 20, 3, O_vec_sel, O_UID(89) },
+ { "vec_sl", 6, 2, O_vec_sl, O_UID(90) },
+ { "vec_sld", 11, 3, O_vec_sld, O_UID(91) },
+ { "vec_sll", 30, 2, O_vec_sll, O_UID(92) },
+ { "vec_slo", 16, 2, O_vec_slo, O_UID(93) },
+ { "vec_splat", 11, 2, O_vec_splat, O_UID(94) },
+ { "vec_splat_s16", 1, 1, O_vec_splat_s16, O_UID(95) },
+ { "vec_splat_s32", 1, 1, O_vec_splat_s32, O_UID(96) },
+ { "vec_splat_s8", 1, 1, O_vec_splat_s8, O_UID(97) },
+ { "vec_splat_u16", 1, 1, O_vec_splat_u16, O_UID(98) },
+ { "vec_splat_u32", 1, 1, O_vec_splat_u32, O_UID(99) },
+ { "vec_splat_u8", 1, 1, O_vec_splat_u8, O_UID(100) },
+ { "vec_sr", 6, 2, O_vec_sr, O_UID(101) },
+ { "vec_sra", 6, 2, O_vec_sra, O_UID(102) },
+ { "vec_srl", 30, 2, O_vec_srl, O_UID(103) },
+ { "vec_sro", 16, 2, O_vec_sro, O_UID(104) },
+ { "vec_st", 30, 3, O_vec_st, O_UID(105) },
+ { "vec_ste", 19, 3, O_vec_ste, O_UID(106) },
+ { "vec_stl", 30, 3, O_vec_stl, O_UID(107) },
+ { "vec_stvebx", 6, 3, O_vec_stvebx, O_UID(108) },
+ { "vec_stvehx", 4, 3, O_vec_stvehx, O_UID(109) },
+ { "vec_stvewx", 9, 3, O_vec_stvewx, O_UID(110) },
+ { "vec_stvx", 30, 3, O_vec_stvx, O_UID(111) },
+ { "vec_stvxl", 30, 3, O_vec_stvxl, O_UID(112) },
+ { "vec_sub", 19, 2, O_vec_sub, O_UID(113) },
+ { "vec_subc", 1, 2, O_vec_subc, O_UID(114) },
+ { "vec_subs", 18, 2, O_vec_subs, O_UID(115) },
+ { "vec_sum2s", 1, 2, O_vec_sum2s, O_UID(116) },
+ { "vec_sum4s", 3, 2, O_vec_sum4s, O_UID(117) },
+ { "vec_sums", 1, 2, O_vec_sums, O_UID(118) },
+ { "vec_trunc", 1, 1, O_vec_trunc, O_UID(119) },
+ { "vec_unpack2sh", 2, 2, O_vec_unpack2sh, O_UID(120) },
+ { "vec_unpack2sl", 2, 2, O_vec_unpack2sl, O_UID(121) },
+ { "vec_unpack2uh", 2, 2, O_vec_unpack2uh, O_UID(122) },
+ { "vec_unpack2ul", 2, 2, O_vec_unpack2ul, O_UID(123) },
+ { "vec_unpackh", 5, 1, O_vec_unpackh, O_UID(124) },
+ { "vec_unpackl", 5, 1, O_vec_unpackl, O_UID(125) },
+ { "vec_vaddcuw", 1, 2, O_vec_vaddcuw, O_UID(126) },
+ { "vec_vaddfp", 1, 2, O_vec_vaddfp, O_UID(127) },
+ { "vec_vaddsbs", 3, 2, O_vec_vaddsbs, O_UID(128) },
+ { "vec_vaddshs", 3, 2, O_vec_vaddshs, O_UID(129) },
+ { "vec_vaddsws", 3, 2, O_vec_vaddsws, O_UID(130) },
+ { "vec_vaddubm", 6, 2, O_vec_vaddubm, O_UID(131) },
+ { "vec_vaddubs", 3, 2, O_vec_vaddubs, O_UID(132) },
+ { "vec_vadduhm", 6, 2, O_vec_vadduhm, O_UID(133) },
+ { "vec_vadduhs", 3, 2, O_vec_vadduhs, O_UID(134) },
+ { "vec_vadduwm", 6, 2, O_vec_vadduwm, O_UID(135) },
+ { "vec_vadduws", 3, 2, O_vec_vadduws, O_UID(136) },
+ { "vec_vand", 24, 2, O_vec_vand, O_UID(137) },
+ { "vec_vandc", 24, 2, O_vec_vandc, O_UID(138) },
+ { "vec_vavgsb", 1, 2, O_vec_vavgsb, O_UID(139) },
+ { "vec_vavgsh", 1, 2, O_vec_vavgsh, O_UID(140) },
+ { "vec_vavgsw", 1, 2, O_vec_vavgsw, O_UID(141) },
+ { "vec_vavgub", 1, 2, O_vec_vavgub, O_UID(142) },
+ { "vec_vavguh", 1, 2, O_vec_vavguh, O_UID(143) },
+ { "vec_vavguw", 1, 2, O_vec_vavguw, O_UID(144) },
+ { "vec_vcfsx", 1, 2, O_vec_vcfsx, O_UID(145) },
+ { "vec_vcfux", 1, 2, O_vec_vcfux, O_UID(146) },
+ { "vec_vcmpbfp", 1, 2, O_vec_vcmpbfp, O_UID(147) },
+ { "vec_vcmpeqfp", 1, 2, O_vec_vcmpeqfp, O_UID(148) },
+ { "vec_vcmpequb", 2, 2, O_vec_vcmpequb, O_UID(149) },
+ { "vec_vcmpequh", 2, 2, O_vec_vcmpequh, O_UID(150) },
+ { "vec_vcmpequw", 2, 2, O_vec_vcmpequw, O_UID(151) },
+ { "vec_vcmpgefp", 1, 2, O_vec_vcmpgefp, O_UID(152) },
+ { "vec_vcmpgtfp", 1, 2, O_vec_vcmpgtfp, O_UID(153) },
+ { "vec_vcmpgtsb", 1, 2, O_vec_vcmpgtsb, O_UID(154) },
+ { "vec_vcmpgtsh", 1, 2, O_vec_vcmpgtsh, O_UID(155) },
+ { "vec_vcmpgtsw", 1, 2, O_vec_vcmpgtsw, O_UID(156) },
+ { "vec_vcmpgtub", 1, 2, O_vec_vcmpgtub, O_UID(157) },
+ { "vec_vcmpgtuh", 1, 2, O_vec_vcmpgtuh, O_UID(158) },
+ { "vec_vcmpgtuw", 1, 2, O_vec_vcmpgtuw, O_UID(159) },
+ { "vec_vctsxs", 1, 2, O_vec_vctsxs, O_UID(160) },
+ { "vec_vctuxs", 1, 2, O_vec_vctuxs, O_UID(161) },
+ { "vec_vexptefp", 1, 1, O_vec_vexptefp, O_UID(162) },
+ { "vec_vlogefp", 1, 1, O_vec_vlogefp, O_UID(163) },
+ { "vec_vmaddfp", 1, 3, O_vec_vmaddfp, O_UID(164) },
+ { "vec_vmaxfp", 1, 2, O_vec_vmaxfp, O_UID(165) },
+ { "vec_vmaxsb", 3, 2, O_vec_vmaxsb, O_UID(166) },
+ { "vec_vmaxsh", 3, 2, O_vec_vmaxsh, O_UID(167) },
+ { "vec_vmaxsw", 3, 2, O_vec_vmaxsw, O_UID(168) },
+ { "vec_vmaxub", 3, 2, O_vec_vmaxub, O_UID(169) },
+ { "vec_vmaxuh", 3, 2, O_vec_vmaxuh, O_UID(170) },
+ { "vec_vmaxuw", 3, 2, O_vec_vmaxuw, O_UID(171) },
+ { "vec_vmhaddshs", 1, 3, O_vec_vmhaddshs, O_UID(172) },
+ { "vec_vmhraddshs", 1, 3, O_vec_vmhraddshs, O_UID(173) },
+ { "vec_vminfp", 1, 2, O_vec_vminfp, O_UID(174) },
+ { "vec_vminsb", 3, 2, O_vec_vminsb, O_UID(175) },
+ { "vec_vminsh", 3, 2, O_vec_vminsh, O_UID(176) },
+ { "vec_vminsw", 3, 2, O_vec_vminsw, O_UID(177) },
+ { "vec_vminub", 3, 2, O_vec_vminub, O_UID(178) },
+ { "vec_vminuh", 3, 2, O_vec_vminuh, O_UID(179) },
+ { "vec_vminuw", 3, 2, O_vec_vminuw, O_UID(180) },
+ { "vec_vmladduhm", 4, 3, O_vec_vmladduhm, O_UID(181) },
+ { "vec_vmrghb", 3, 2, O_vec_vmrghb, O_UID(182) },
+ { "vec_vmrghh", 4, 2, O_vec_vmrghh, O_UID(183) },
+ { "vec_vmrghw", 4, 2, O_vec_vmrghw, O_UID(184) },
+ { "vec_vmrglb", 3, 2, O_vec_vmrglb, O_UID(185) },
+ { "vec_vmrglh", 4, 2, O_vec_vmrglh, O_UID(186) },
+ { "vec_vmrglw", 4, 2, O_vec_vmrglw, O_UID(187) },
+ { "vec_vmsummbm", 1, 3, O_vec_vmsummbm, O_UID(188) },
+ { "vec_vmsumshm", 1, 3, O_vec_vmsumshm, O_UID(189) },
+ { "vec_vmsumshs", 1, 3, O_vec_vmsumshs, O_UID(190) },
+ { "vec_vmsumubm", 1, 3, O_vec_vmsumubm, O_UID(191) },
+ { "vec_vmsumuhm", 1, 3, O_vec_vmsumuhm, O_UID(192) },
+ { "vec_vmsumuhs", 1, 3, O_vec_vmsumuhs, O_UID(193) },
+ { "vec_vmulesb", 1, 2, O_vec_vmulesb, O_UID(194) },
+ { "vec_vmulesh", 1, 2, O_vec_vmulesh, O_UID(195) },
+ { "vec_vmuleub", 1, 2, O_vec_vmuleub, O_UID(196) },
+ { "vec_vmuleuh", 1, 2, O_vec_vmuleuh, O_UID(197) },
+ { "vec_vmulosb", 1, 2, O_vec_vmulosb, O_UID(198) },
+ { "vec_vmulosh", 1, 2, O_vec_vmulosh, O_UID(199) },
+ { "vec_vmuloub", 1, 2, O_vec_vmuloub, O_UID(200) },
+ { "vec_vmulouh", 1, 2, O_vec_vmulouh, O_UID(201) },
+ { "vec_vnmsubfp", 1, 3, O_vec_vnmsubfp, O_UID(202) },
+ { "vec_vnor", 10, 2, O_vec_vnor, O_UID(203) },
+ { "vec_vor", 24, 2, O_vec_vor, O_UID(204) },
+ { "vec_vperm", 11, 3, O_vec_vperm, O_UID(205) },
+ { "vec_vpkpx", 1, 2, O_vec_vpkpx, O_UID(206) },
+ { "vec_vpkshss", 1, 2, O_vec_vpkshss, O_UID(207) },
+ { "vec_vpkshus", 1, 2, O_vec_vpkshus, O_UID(208) },
+ { "vec_vpkswss", 1, 2, O_vec_vpkswss, O_UID(209) },
+ { "vec_vpkswus", 1, 2, O_vec_vpkswus, O_UID(210) },
+ { "vec_vpkuhum", 3, 2, O_vec_vpkuhum, O_UID(211) },
+ { "vec_vpkuhus", 1, 2, O_vec_vpkuhus, O_UID(212) },
+ { "vec_vpkuwum", 3, 2, O_vec_vpkuwum, O_UID(213) },
+ { "vec_vpkuwus", 1, 2, O_vec_vpkuwus, O_UID(214) },
+ { "vec_vrefp", 1, 1, O_vec_vrefp, O_UID(215) },
+ { "vec_vrfim", 1, 1, O_vec_vrfim, O_UID(216) },
+ { "vec_vrfin", 1, 1, O_vec_vrfin, O_UID(217) },
+ { "vec_vrfip", 1, 1, O_vec_vrfip, O_UID(218) },
+ { "vec_vrfiz", 1, 1, O_vec_vrfiz, O_UID(219) },
+ { "vec_vrlb", 2, 2, O_vec_vrlb, O_UID(220) },
+ { "vec_vrlh", 2, 2, O_vec_vrlh, O_UID(221) },
+ { "vec_vrlw", 2, 2, O_vec_vrlw, O_UID(222) },
+ { "vec_vrsqrtefp", 1, 1, O_vec_vrsqrtefp, O_UID(223) },
+ { "vec_vsel", 20, 3, O_vec_vsel, O_UID(224) },
+ { "vec_vsl", 30, 2, O_vec_vsl, O_UID(225) },
+ { "vec_vslb", 2, 2, O_vec_vslb, O_UID(226) },
+ { "vec_vsldoi", 11, 3, O_vec_vsldoi, O_UID(227) },
+ { "vec_vslh", 2, 2, O_vec_vslh, O_UID(228) },
+ { "vec_vslo", 16, 2, O_vec_vslo, O_UID(229) },
+ { "vec_vslw", 2, 2, O_vec_vslw, O_UID(230) },
+ { "vec_vspltb", 3, 2, O_vec_vspltb, O_UID(231) },
+ { "vec_vsplth", 4, 2, O_vec_vsplth, O_UID(232) },
+ { "vec_vspltisb", 1, 1, O_vec_vspltisb, O_UID(233) },
+ { "vec_vspltish", 1, 1, O_vec_vspltish, O_UID(234) },
+ { "vec_vspltisw", 1, 1, O_vec_vspltisw, O_UID(235) },
+ { "vec_vspltw", 4, 2, O_vec_vspltw, O_UID(236) },
+ { "vec_vsr", 30, 2, O_vec_vsr, O_UID(237) },
+ { "vec_vsrab", 2, 2, O_vec_vsrab, O_UID(238) },
+ { "vec_vsrah", 2, 2, O_vec_vsrah, O_UID(239) },
+ { "vec_vsraw", 2, 2, O_vec_vsraw, O_UID(240) },
+ { "vec_vsrb", 2, 2, O_vec_vsrb, O_UID(241) },
+ { "vec_vsrh", 2, 2, O_vec_vsrh, O_UID(242) },
+ { "vec_vsro", 16, 2, O_vec_vsro, O_UID(243) },
+ { "vec_vsrw", 2, 2, O_vec_vsrw, O_UID(244) },
+ { "vec_vsubcuw", 1, 2, O_vec_vsubcuw, O_UID(245) },
+ { "vec_vsubfp", 1, 2, O_vec_vsubfp, O_UID(246) },
+ { "vec_vsubsbs", 3, 2, O_vec_vsubsbs, O_UID(247) },
+ { "vec_vsubshs", 3, 2, O_vec_vsubshs, O_UID(248) },
+ { "vec_vsubsws", 3, 2, O_vec_vsubsws, O_UID(249) },
+ { "vec_vsububm", 6, 2, O_vec_vsububm, O_UID(250) },
+ { "vec_vsububs", 3, 2, O_vec_vsububs, O_UID(251) },
+ { "vec_vsubuhm", 6, 2, O_vec_vsubuhm, O_UID(252) },
+ { "vec_vsubuhs", 3, 2, O_vec_vsubuhs, O_UID(253) },
+ { "vec_vsubuwm", 6, 2, O_vec_vsubuwm, O_UID(254) },
+ { "vec_vsubuws", 3, 2, O_vec_vsubuws, O_UID(255) },
+ { "vec_vsum2sws", 1, 2, O_vec_vsum2sws, O_UID(256) },
+ { "vec_vsum4sbs", 1, 2, O_vec_vsum4sbs, O_UID(257) },
+ { "vec_vsum4shs", 1, 2, O_vec_vsum4shs, O_UID(258) },
+ { "vec_vsum4ubs", 1, 2, O_vec_vsum4ubs, O_UID(259) },
+ { "vec_vsumsws", 1, 2, O_vec_vsumsws, O_UID(260) },
+ { "vec_vupkhpx", 1, 1, O_vec_vupkhpx, O_UID(261) },
+ { "vec_vupkhsb", 2, 1, O_vec_vupkhsb, O_UID(262) },
+ { "vec_vupkhsh", 2, 1, O_vec_vupkhsh, O_UID(263) },
+ { "vec_vupklpx", 1, 1, O_vec_vupklpx, O_UID(264) },
+ { "vec_vupklsb", 2, 1, O_vec_vupklsb, O_UID(265) },
+ { "vec_vupklsh", 2, 1, O_vec_vupklsh, O_UID(266) },
+ { "vec_vxor", 24, 2, O_vec_vxor, O_UID(267) },
+ { "vec_xor", 24, 2, O_vec_xor, O_UID(268) },
+ { NULL, 0, 0, NULL, 0 }
+};
+#define LAST_O_UID O_UID(269)
diff --git a/gcc/config/rs6000/vec.ops b/gcc/config/rs6000/vec.ops
new file mode 100644
index 00000000000..5ef80a2d6b8
--- /dev/null
+++ b/gcc/config/rs6000/vec.ops
@@ -0,0 +1,1025 @@
+# APPLE LOCAL file AltiVec
+# ops-to-gp -gcc vec.ops builtin.ops
+vec_abs vec_s8 = vec_s8 vec_abs BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE 1 FALSE FALSE transform_vec_abs
+vec_abs vec_s16 = vec_s16 vec_abs BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE 2 FALSE FALSE transform_vec_abs
+vec_abs vec_s32 = vec_s32 vec_abs BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE 3 FALSE FALSE transform_vec_abs
+vec_abs vec_f32 = vec_f32 vec_abs BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE 4 FALSE FALSE transform_vec_abs
+vec_abss vec_s8 = vec_s8 vec_abss BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE 5 FALSE FALSE transform_vec_abs
+vec_abss vec_s16 = vec_s16 vec_abss BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE 6 FALSE FALSE transform_vec_abs
+vec_abss vec_s32 = vec_s32 vec_abss BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE 7 FALSE FALSE transform_vec_abs
+vec_cmplt vec_u8 vec_u8 = vec_b8 vec_cmplt BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_vcmpgtub FALSE FALSE transform_vec_cmp_reverse
+vec_cmplt vec_u16 vec_u16 = vec_b16 vec_cmplt BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_vcmpgtuh FALSE FALSE transform_vec_cmp_reverse
+vec_cmplt vec_u32 vec_u32 = vec_b32 vec_cmplt BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_vcmpgtuw FALSE FALSE transform_vec_cmp_reverse
+vec_cmplt vec_s8 vec_s8 = vec_b8 vec_cmplt BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_vcmpgtsb FALSE FALSE transform_vec_cmp_reverse
+vec_cmplt vec_s16 vec_s16 = vec_b16 vec_cmplt BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_vcmpgtsh FALSE FALSE transform_vec_cmp_reverse
+vec_cmplt vec_s32 vec_s32 = vec_b32 vec_cmplt BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_vcmpgtsw FALSE FALSE transform_vec_cmp_reverse
+vec_cmplt vec_f32 vec_f32 = vec_b32 vec_cmplt BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_vcmpgtfp FALSE FALSE transform_vec_cmp_reverse
+vec_cmple vec_f32 vec_f32 = vec_b32 vec_cmple BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_vcmpgefp FALSE FALSE transform_vec_cmp_reverse
+vec_add vec_s8 vec_s8 = vec_s8 vec_vaddubm BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_add vec_s8 vec_b8 = vec_s8 vec_vaddubm BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_add vec_b8 vec_s8 = vec_s8 vec_vaddubm BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_add vec_s16 vec_s16 = vec_s16 vec_vadduhm BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_add vec_s16 vec_b16 = vec_s16 vec_vadduhm BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_add vec_b16 vec_s16 = vec_s16 vec_vadduhm BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_add vec_s32 vec_s32 = vec_s32 vec_vadduwm BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_add vec_s32 vec_b32 = vec_s32 vec_vadduwm BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_add vec_b32 vec_s32 = vec_s32 vec_vadduwm BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_add vec_u8 vec_u8 = vec_u8 vec_vaddubm BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_add vec_u8 vec_b8 = vec_u8 vec_vaddubm BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_add vec_b8 vec_u8 = vec_u8 vec_vaddubm BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_add vec_u16 vec_u16 = vec_u16 vec_vadduhm BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_add vec_u16 vec_b16 = vec_u16 vec_vadduhm BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_add vec_b16 vec_u16 = vec_u16 vec_vadduhm BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_add vec_u32 vec_u32 = vec_u32 vec_vadduwm BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_add vec_u32 vec_b32 = vec_u32 vec_vadduwm BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_add vec_b32 vec_u32 = vec_u32 vec_vadduwm BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_adds vec_s8 vec_s8 = vec_s8 vec_vaddsbs BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_adds vec_s8 vec_b8 = vec_s8 vec_vaddsbs BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_adds vec_b8 vec_s8 = vec_s8 vec_vaddsbs BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_adds vec_s16 vec_s16 = vec_s16 vec_vaddshs BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_adds vec_s16 vec_b16 = vec_s16 vec_vaddshs BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_adds vec_b16 vec_s16 = vec_s16 vec_vaddshs BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_adds vec_s32 vec_s32 = vec_s32 vec_vaddsws BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_adds vec_s32 vec_b32 = vec_s32 vec_vaddsws BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_adds vec_b32 vec_s32 = vec_s32 vec_vaddsws BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_adds vec_u8 vec_u8 = vec_u8 vec_vaddubs BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_adds vec_u8 vec_b8 = vec_u8 vec_vaddubs BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_adds vec_b8 vec_u8 = vec_u8 vec_vaddubs BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_adds vec_u16 vec_u16 = vec_u16 vec_vadduhs BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_adds vec_u16 vec_b16 = vec_u16 vec_vadduhs BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_adds vec_b16 vec_u16 = vec_u16 vec_vadduhs BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_adds vec_u32 vec_u32 = vec_u32 vec_vadduws BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_adds vec_u32 vec_b32 = vec_u32 vec_vadduws BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_adds vec_b32 vec_u32 = vec_u32 vec_vadduws BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_sub vec_s8 vec_s8 = vec_s8 vec_vsububm BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_sub vec_s8 vec_b8 = vec_s8 vec_vsububm BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_sub vec_b8 vec_s8 = vec_s8 vec_vsububm BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_sub vec_s16 vec_s16 = vec_s16 vec_vsubuhm BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_sub vec_s16 vec_b16 = vec_s16 vec_vsubuhm BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_sub vec_b16 vec_s16 = vec_s16 vec_vsubuhm BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_sub vec_s32 vec_s32 = vec_s32 vec_vsubuwm BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_sub vec_s32 vec_b32 = vec_s32 vec_vsubuwm BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_sub vec_b32 vec_s32 = vec_s32 vec_vsubuwm BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_sub vec_u8 vec_u8 = vec_u8 vec_vsububm BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_sub vec_u8 vec_b8 = vec_u8 vec_vsububm BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_sub vec_b8 vec_u8 = vec_u8 vec_vsububm BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_sub vec_u16 vec_u16 = vec_u16 vec_vsubuhm BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_sub vec_u16 vec_b16 = vec_u16 vec_vsubuhm BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_sub vec_b16 vec_u16 = vec_u16 vec_vsubuhm BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_sub vec_u32 vec_u32 = vec_u32 vec_vsubuwm BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_sub vec_u32 vec_b32 = vec_u32 vec_vsubuwm BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_sub vec_b32 vec_u32 = vec_u32 vec_vsubuwm BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_subs vec_s8 vec_s8 = vec_s8 vec_vsubsbs BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_subs vec_s8 vec_b8 = vec_s8 vec_vsubsbs BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_subs vec_b8 vec_s8 = vec_s8 vec_vsubsbs BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_subs vec_s16 vec_s16 = vec_s16 vec_vsubshs BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_subs vec_s16 vec_b16 = vec_s16 vec_vsubshs BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_subs vec_b16 vec_s16 = vec_s16 vec_vsubshs BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_subs vec_s32 vec_s32 = vec_s32 vec_vsubsws BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_subs vec_s32 vec_b32 = vec_s32 vec_vsubsws BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_subs vec_b32 vec_s32 = vec_s32 vec_vsubsws BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_subs vec_u8 vec_u8 = vec_u8 vec_vsububs BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_subs vec_u8 vec_b8 = vec_u8 vec_vsububs BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_subs vec_b8 vec_u8 = vec_u8 vec_vsububs BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_subs vec_u16 vec_u16 = vec_u16 vec_vsubuhs BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_subs vec_u16 vec_b16 = vec_u16 vec_vsubuhs BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_subs vec_b16 vec_u16 = vec_u16 vec_vsubuhs BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_subs vec_u32 vec_u32 = vec_u32 vec_vsubuws BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_subs vec_u32 vec_b32 = vec_u32 vec_vsubuws BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_subs vec_b32 vec_u32 = vec_u32 vec_vsubuws BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_addc vec_u32 vec_u32 = vec_u32 vec_vaddcuw BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_subc vec_u32 vec_u32 = vec_u32 vec_vsubcuw BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_mulo vec_u8 vec_u8 = vec_u16 vec_vmuloub BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_mulo vec_u16 vec_u16 = vec_u32 vec_vmulouh BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_mulo vec_s8 vec_s8 = vec_s16 vec_vmulosb BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_mulo vec_s16 vec_s16 = vec_s32 vec_vmulosh BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_mule vec_u8 vec_u8 = vec_u16 vec_vmuleub BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_mule vec_u16 vec_u16 = vec_u32 vec_vmuleuh BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_mule vec_s8 vec_s8 = vec_s16 vec_vmulesb BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_mule vec_s16 vec_s16 = vec_s32 vec_vmulesh BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_mladd vec_s16 vec_s16 vec_s16 = vec_s16 vec_vmladduhm BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_mladd vec_u16 vec_u16 vec_u16 = vec_u16 vec_vmladduhm BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_mladd vec_s16 vec_u16 vec_u16 = vec_s16 vec_vmladduhm BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_mladd vec_u16 vec_s16 vec_s16 = vec_s16 vec_vmladduhm BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_madds vec_s16 vec_s16 vec_s16 = vec_s16 vec_vmhaddshs BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_mradds vec_s16 vec_s16 vec_s16 = vec_s16 vec_vmhraddshs BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_msum vec_s8 vec_u8 vec_s32 = vec_s32 vec_vmsummbm BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_msum vec_u8 vec_u8 vec_u32 = vec_u32 vec_vmsumubm BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_msum vec_s16 vec_s16 vec_s32 = vec_s32 vec_vmsumshm BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_msum vec_u16 vec_u16 vec_u32 = vec_u32 vec_vmsumuhm BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_msums vec_s16 vec_s16 vec_s32 = vec_s32 vec_vmsumshs BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_msums vec_u16 vec_u16 vec_u32 = vec_u32 vec_vmsumuhs BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_sums vec_s32 vec_s32 = vec_s32 vec_vsumsws BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_sum2s vec_s32 vec_s32 = vec_s32 vec_vsum2sws BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_sum4s vec_s8 vec_s32 = vec_s32 vec_vsum4sbs BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_sum4s vec_u8 vec_u32 = vec_u32 vec_vsum4ubs BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_sum4s vec_s16 vec_s32 = vec_s32 vec_vsum4shs BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_avg vec_s8 vec_s8 = vec_s8 vec_vavgsb BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_avg vec_s16 vec_s16 = vec_s16 vec_vavgsh BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_avg vec_u8 vec_u8 = vec_u8 vec_vavgub BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_avg vec_u16 vec_u16 = vec_u16 vec_vavguh BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_avg vec_s32 vec_s32 = vec_s32 vec_vavgsw BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_avg vec_u32 vec_u32 = vec_u32 vec_vavguw BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_and vec_s8 vec_s8 = vec_s8 vec_vand BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_and vec_s8 vec_b8 = vec_s8 vec_vand BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_and vec_b8 vec_s8 = vec_s8 vec_vand BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_and vec_u8 vec_u8 = vec_u8 vec_vand BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_and vec_b8 vec_u8 = vec_u8 vec_vand BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_and vec_u8 vec_b8 = vec_u8 vec_vand BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_and vec_b8 vec_b8 = vec_b8 vec_vand BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_and vec_s16 vec_s16 = vec_s16 vec_vand BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_and vec_s16 vec_b16 = vec_s16 vec_vand BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_and vec_b16 vec_s16 = vec_s16 vec_vand BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_and vec_u16 vec_u16 = vec_u16 vec_vand BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_and vec_b16 vec_u16 = vec_u16 vec_vand BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_and vec_u16 vec_b16 = vec_u16 vec_vand BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_and vec_b16 vec_b16 = vec_b16 vec_vand BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_and vec_s32 vec_s32 = vec_s32 vec_vand BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_and vec_s32 vec_b32 = vec_s32 vec_vand BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_and vec_b32 vec_s32 = vec_s32 vec_vand BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_and vec_u32 vec_u32 = vec_u32 vec_vand BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_and vec_b32 vec_u32 = vec_u32 vec_vand BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_and vec_u32 vec_b32 = vec_u32 vec_vand BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_and vec_b32 vec_b32 = vec_b32 vec_vand BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_and vec_f32 vec_f32 = vec_f32 vec_vand BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_and vec_f32 vec_b32 = vec_f32 vec_vand BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_and vec_b32 vec_f32 = vec_f32 vec_vand BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_or vec_s8 vec_s8 = vec_s8 vec_vor BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_or vec_s8 vec_b8 = vec_s8 vec_vor BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_or vec_b8 vec_s8 = vec_s8 vec_vor BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_or vec_u8 vec_u8 = vec_u8 vec_vor BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_or vec_b8 vec_u8 = vec_u8 vec_vor BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_or vec_u8 vec_b8 = vec_u8 vec_vor BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_or vec_b8 vec_b8 = vec_b8 vec_vor BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_or vec_s16 vec_s16 = vec_s16 vec_vor BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_or vec_s16 vec_b16 = vec_s16 vec_vor BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_or vec_b16 vec_s16 = vec_s16 vec_vor BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_or vec_u16 vec_u16 = vec_u16 vec_vor BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_or vec_b16 vec_u16 = vec_u16 vec_vor BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_or vec_u16 vec_b16 = vec_u16 vec_vor BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_or vec_b16 vec_b16 = vec_b16 vec_vor BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_or vec_s32 vec_s32 = vec_s32 vec_vor BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_or vec_s32 vec_b32 = vec_s32 vec_vor BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_or vec_b32 vec_s32 = vec_s32 vec_vor BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_or vec_u32 vec_u32 = vec_u32 vec_vor BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_or vec_b32 vec_u32 = vec_u32 vec_vor BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_or vec_u32 vec_b32 = vec_u32 vec_vor BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_or vec_b32 vec_b32 = vec_b32 vec_vor BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_or vec_f32 vec_f32 = vec_f32 vec_vor BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_or vec_f32 vec_b32 = vec_f32 vec_vor BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_or vec_b32 vec_f32 = vec_f32 vec_vor BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_xor vec_s8 vec_s8 = vec_s8 vec_vxor BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_xor vec_s8 vec_b8 = vec_s8 vec_vxor BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_xor vec_b8 vec_s8 = vec_s8 vec_vxor BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_xor vec_u8 vec_u8 = vec_u8 vec_vxor BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_xor vec_b8 vec_u8 = vec_u8 vec_vxor BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_xor vec_u8 vec_b8 = vec_u8 vec_vxor BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_xor vec_b8 vec_b8 = vec_b8 vec_vxor BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_xor vec_s16 vec_s16 = vec_s16 vec_vxor BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_xor vec_s16 vec_b16 = vec_s16 vec_vxor BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_xor vec_b16 vec_s16 = vec_s16 vec_vxor BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_xor vec_u16 vec_u16 = vec_u16 vec_vxor BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_xor vec_b16 vec_u16 = vec_u16 vec_vxor BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_xor vec_u16 vec_b16 = vec_u16 vec_vxor BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_xor vec_b16 vec_b16 = vec_b16 vec_vxor BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_xor vec_s32 vec_s32 = vec_s32 vec_vxor BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_xor vec_s32 vec_b32 = vec_s32 vec_vxor BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_xor vec_b32 vec_s32 = vec_s32 vec_vxor BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_xor vec_u32 vec_u32 = vec_u32 vec_vxor BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_xor vec_b32 vec_u32 = vec_u32 vec_vxor BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_xor vec_u32 vec_b32 = vec_u32 vec_vxor BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_xor vec_b32 vec_b32 = vec_b32 vec_vxor BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_xor vec_f32 vec_f32 = vec_f32 vec_vxor BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_xor vec_f32 vec_b32 = vec_f32 vec_vxor BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_xor vec_b32 vec_f32 = vec_f32 vec_vxor BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_andc vec_s8 vec_s8 = vec_s8 vec_vandc BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_andc vec_s8 vec_b8 = vec_s8 vec_vandc BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_andc vec_b8 vec_s8 = vec_s8 vec_vandc BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_andc vec_u8 vec_u8 = vec_u8 vec_vandc BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_andc vec_b8 vec_u8 = vec_u8 vec_vandc BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_andc vec_u8 vec_b8 = vec_u8 vec_vandc BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_andc vec_b8 vec_b8 = vec_b8 vec_vandc BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_andc vec_s16 vec_s16 = vec_s16 vec_vandc BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_andc vec_s16 vec_b16 = vec_s16 vec_vandc BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_andc vec_b16 vec_s16 = vec_s16 vec_vandc BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_andc vec_u16 vec_u16 = vec_u16 vec_vandc BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_andc vec_b16 vec_u16 = vec_u16 vec_vandc BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_andc vec_u16 vec_b16 = vec_u16 vec_vandc BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_andc vec_b16 vec_b16 = vec_b16 vec_vandc BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_andc vec_s32 vec_s32 = vec_s32 vec_vandc BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_andc vec_s32 vec_b32 = vec_s32 vec_vandc BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_andc vec_b32 vec_s32 = vec_s32 vec_vandc BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_andc vec_u32 vec_u32 = vec_u32 vec_vandc BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_andc vec_b32 vec_u32 = vec_u32 vec_vandc BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_andc vec_u32 vec_b32 = vec_u32 vec_vandc BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_andc vec_b32 vec_b32 = vec_b32 vec_vandc BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_andc vec_f32 vec_f32 = vec_f32 vec_vandc BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_andc vec_f32 vec_b32 = vec_f32 vec_vandc BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_andc vec_b32 vec_f32 = vec_f32 vec_vandc BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_nor vec_u8 vec_u8 = vec_u8 vec_vnor BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_nor vec_s8 vec_s8 = vec_s8 vec_vnor BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_nor vec_b8 vec_b8 = vec_b8 vec_vnor BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_nor vec_u16 vec_u16 = vec_u16 vec_vnor BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_nor vec_s16 vec_s16 = vec_s16 vec_vnor BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_nor vec_b16 vec_b16 = vec_b16 vec_vnor BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_nor vec_u32 vec_u32 = vec_u32 vec_vnor BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_nor vec_s32 vec_s32 = vec_s32 vec_vnor BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_nor vec_b32 vec_b32 = vec_b32 vec_vnor BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_nor vec_f32 vec_f32 = vec_f32 vec_vnor BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_rl vec_u8 vec_u8 = vec_u8 vec_vrlb BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_rl vec_u16 vec_u16 = vec_u16 vec_vrlh BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_rl vec_u32 vec_u32 = vec_u32 vec_vrlw BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_rl vec_s8 vec_u8 = vec_s8 vec_vrlb BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_rl vec_s16 vec_u16 = vec_s16 vec_vrlh BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_rl vec_s32 vec_u32 = vec_s32 vec_vrlw BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_sl vec_u8 vec_u8 = vec_u8 vec_vslb BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_sl vec_u16 vec_u16 = vec_u16 vec_vslh BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_sl vec_u32 vec_u32 = vec_u32 vec_vslw BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_sl vec_s8 vec_u8 = vec_s8 vec_vslb BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_sl vec_s16 vec_u16 = vec_s16 vec_vslh BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_sl vec_s32 vec_u32 = vec_s32 vec_vslw BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_sll vec_u8 vec_u8 = vec_u8 vec_vsl BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_sll vec_u16 vec_u8 = vec_u16 vec_vsl BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_sll vec_u32 vec_u8 = vec_u32 vec_vsl BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_sll vec_s8 vec_u8 = vec_s8 vec_vsl BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_sll vec_s16 vec_u8 = vec_s16 vec_vsl BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_sll vec_s32 vec_u8 = vec_s32 vec_vsl BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_sll vec_b8 vec_u8 = vec_b8 vec_vsl BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_sll vec_b16 vec_u8 = vec_b16 vec_vsl BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_sll vec_b32 vec_u8 = vec_b32 vec_vsl BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_sll vec_p16 vec_u8 = vec_p16 vec_vsl BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_sll vec_u8 vec_u16 = vec_u8 vec_vsl BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_sll vec_u16 vec_u16 = vec_u16 vec_vsl BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_sll vec_u32 vec_u16 = vec_u32 vec_vsl BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_sll vec_s8 vec_u16 = vec_s8 vec_vsl BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_sll vec_s16 vec_u16 = vec_s16 vec_vsl BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_sll vec_s32 vec_u16 = vec_s32 vec_vsl BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_sll vec_b8 vec_u16 = vec_b8 vec_vsl BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_sll vec_b16 vec_u16 = vec_b16 vec_vsl BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_sll vec_b32 vec_u16 = vec_b32 vec_vsl BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_sll vec_p16 vec_u16 = vec_p16 vec_vsl BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_sll vec_u8 vec_u32 = vec_u8 vec_vsl BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_sll vec_u16 vec_u32 = vec_u16 vec_vsl BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_sll vec_u32 vec_u32 = vec_u32 vec_vsl BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_sll vec_s8 vec_u32 = vec_s8 vec_vsl BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_sll vec_s16 vec_u32 = vec_s16 vec_vsl BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_sll vec_s32 vec_u32 = vec_s32 vec_vsl BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_sll vec_b8 vec_u32 = vec_b8 vec_vsl BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_sll vec_b16 vec_u32 = vec_b16 vec_vsl BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_sll vec_b32 vec_u32 = vec_b32 vec_vsl BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_sll vec_p16 vec_u32 = vec_p16 vec_vsl BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_sr vec_u8 vec_u8 = vec_u8 vec_vsrb BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_sr vec_u16 vec_u16 = vec_u16 vec_vsrh BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_sr vec_u32 vec_u32 = vec_u32 vec_vsrw BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_sr vec_s8 vec_u8 = vec_s8 vec_vsrb BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_sr vec_s16 vec_u16 = vec_s16 vec_vsrh BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_sr vec_s32 vec_u32 = vec_s32 vec_vsrw BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_sra vec_u8 vec_u8 = vec_u8 vec_vsrab BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_sra vec_u16 vec_u16 = vec_u16 vec_vsrah BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_sra vec_u32 vec_u32 = vec_u32 vec_vsraw BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_sra vec_s8 vec_u8 = vec_s8 vec_vsrab BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_sra vec_s16 vec_u16 = vec_s16 vec_vsrah BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_sra vec_s32 vec_u32 = vec_s32 vec_vsraw BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_srl vec_u8 vec_u8 = vec_u8 vec_vsr BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_srl vec_u16 vec_u8 = vec_u16 vec_vsr BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_srl vec_u32 vec_u8 = vec_u32 vec_vsr BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_srl vec_s8 vec_u8 = vec_s8 vec_vsr BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_srl vec_s16 vec_u8 = vec_s16 vec_vsr BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_srl vec_s32 vec_u8 = vec_s32 vec_vsr BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_srl vec_b8 vec_u8 = vec_b8 vec_vsr BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_srl vec_b16 vec_u8 = vec_b16 vec_vsr BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_srl vec_b32 vec_u8 = vec_b32 vec_vsr BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_srl vec_p16 vec_u8 = vec_p16 vec_vsr BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_srl vec_u8 vec_u16 = vec_u8 vec_vsr BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_srl vec_u16 vec_u16 = vec_u16 vec_vsr BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_srl vec_u32 vec_u16 = vec_u32 vec_vsr BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_srl vec_s8 vec_u16 = vec_s8 vec_vsr BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_srl vec_s16 vec_u16 = vec_s16 vec_vsr BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_srl vec_s32 vec_u16 = vec_s32 vec_vsr BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_srl vec_b8 vec_u16 = vec_b8 vec_vsr BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_srl vec_b16 vec_u16 = vec_b16 vec_vsr BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_srl vec_b32 vec_u16 = vec_b32 vec_vsr BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_srl vec_p16 vec_u16 = vec_p16 vec_vsr BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_srl vec_u8 vec_u32 = vec_u8 vec_vsr BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_srl vec_u16 vec_u32 = vec_u16 vec_vsr BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_srl vec_u32 vec_u32 = vec_u32 vec_vsr BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_srl vec_s8 vec_u32 = vec_s8 vec_vsr BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_srl vec_s16 vec_u32 = vec_s16 vec_vsr BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_srl vec_s32 vec_u32 = vec_s32 vec_vsr BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_srl vec_b8 vec_u32 = vec_b8 vec_vsr BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_srl vec_b16 vec_u32 = vec_b16 vec_vsr BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_srl vec_b32 vec_u32 = vec_b32 vec_vsr BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_srl vec_p16 vec_u32 = vec_p16 vec_vsr BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_cmpgt vec_u8 vec_u8 = vec_b8 vec_vcmpgtub BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_cmpgt vec_u16 vec_u16 = vec_b16 vec_vcmpgtuh BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_cmpgt vec_u32 vec_u32 = vec_b32 vec_vcmpgtuw BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_cmpgt vec_s8 vec_s8 = vec_b8 vec_vcmpgtsb BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_cmpgt vec_s16 vec_s16 = vec_b16 vec_vcmpgtsh BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_cmpgt vec_s32 vec_s32 = vec_b32 vec_vcmpgtsw BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_cmpeq vec_u8 vec_u8 = vec_b8 vec_vcmpequb BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_cmpeq vec_u16 vec_u16 = vec_b16 vec_vcmpequh BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_cmpeq vec_u32 vec_u32 = vec_b32 vec_vcmpequw BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_cmpeq vec_s8 vec_s8 = vec_b8 vec_vcmpequb BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_cmpeq vec_s16 vec_s16 = vec_b16 vec_vcmpequh BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_cmpeq vec_s32 vec_s32 = vec_b32 vec_vcmpequw BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_sel vec_b8 vec_b8 vec_b8 = vec_b8 vec_vsel BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_sel vec_b8 vec_b8 vec_u8 = vec_b8 vec_vsel BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_sel vec_u8 vec_u8 vec_u8 = vec_u8 vec_vsel BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_sel vec_u8 vec_u8 vec_b8 = vec_u8 vec_vsel BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_sel vec_s8 vec_s8 vec_u8 = vec_s8 vec_vsel BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_sel vec_s8 vec_s8 vec_b8 = vec_s8 vec_vsel BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_sel vec_b16 vec_b16 vec_b16 = vec_b16 vec_vsel BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_sel vec_b16 vec_b16 vec_u16 = vec_b16 vec_vsel BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_sel vec_u16 vec_u16 vec_u16 = vec_u16 vec_vsel BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_sel vec_u16 vec_u16 vec_b16 = vec_u16 vec_vsel BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_sel vec_s16 vec_s16 vec_u16 = vec_s16 vec_vsel BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_sel vec_s16 vec_s16 vec_b16 = vec_s16 vec_vsel BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_sel vec_b32 vec_b32 vec_b32 = vec_b32 vec_vsel BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_sel vec_b32 vec_b32 vec_u32 = vec_b32 vec_vsel BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_sel vec_u32 vec_u32 vec_u32 = vec_u32 vec_vsel BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_sel vec_u32 vec_u32 vec_b32 = vec_u32 vec_vsel BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_sel vec_s32 vec_s32 vec_u32 = vec_s32 vec_vsel BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_sel vec_s32 vec_s32 vec_b32 = vec_s32 vec_vsel BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_sel vec_f32 vec_f32 vec_b32 = vec_f32 vec_vsel BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_sel vec_f32 vec_f32 vec_u32 = vec_f32 vec_vsel BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_pack vec_u16 vec_u16 = vec_u8 vec_vpkuhum BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_pack vec_u32 vec_u32 = vec_u16 vec_vpkuwum BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_pack vec_s16 vec_s16 = vec_s8 vec_vpkuhum BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_pack vec_s32 vec_s32 = vec_s16 vec_vpkuwum BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_pack vec_b16 vec_b16 = vec_b8 vec_vpkuhum BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_pack vec_b32 vec_b32 = vec_b16 vec_vpkuwum BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_packs vec_u16 vec_u16 = vec_u8 vec_vpkuhus BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_packs vec_u32 vec_u32 = vec_u16 vec_vpkuwus BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_packsu vec_u16 vec_u16 = vec_u8 vec_vpkuhus BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_packsu vec_u32 vec_u32 = vec_u16 vec_vpkuwus BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_packs vec_s16 vec_s16 = vec_s8 vec_vpkshss BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_packs vec_s32 vec_s32 = vec_s16 vec_vpkswss BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_packsu vec_s16 vec_s16 = vec_u8 vec_vpkshus BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_packsu vec_s32 vec_s32 = vec_u16 vec_vpkswus BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_packpx vec_u32 vec_u32 = vec_p16 vec_vpkpx BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_unpackh vec_s8 = vec_s16 vec_vupkhsb BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_unpackh vec_s16 = vec_s32 vec_vupkhsh BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_unpackh vec_b8 = vec_b16 vec_vupkhsb BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_unpackh vec_b16 = vec_b32 vec_vupkhsh BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_unpackh vec_p16 = vec_u32 vec_vupkhpx BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_unpackl vec_s8 = vec_s16 vec_vupklsb BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_unpackl vec_s16 = vec_s32 vec_vupklsh BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_unpackl vec_b8 = vec_b16 vec_vupklsb BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_unpackl vec_b16 = vec_b32 vec_vupklsh BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_unpackl vec_p16 = vec_u32 vec_vupklpx BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_mergeh vec_u8 vec_u8 = vec_u8 vec_vmrghb BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_mergeh vec_u16 vec_u16 = vec_u16 vec_vmrghh BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_mergeh vec_u32 vec_u32 = vec_u32 vec_vmrghw BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_mergeh vec_s8 vec_s8 = vec_s8 vec_vmrghb BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_mergeh vec_s16 vec_s16 = vec_s16 vec_vmrghh BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_mergeh vec_s32 vec_s32 = vec_s32 vec_vmrghw BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_mergeh vec_f32 vec_f32 = vec_f32 vec_vmrghw BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_mergeh vec_p16 vec_p16 = vec_p16 vec_vmrghh BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_mergeh vec_b8 vec_b8 = vec_b8 vec_vmrghb BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_mergeh vec_b16 vec_b16 = vec_b16 vec_vmrghh BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_mergeh vec_b32 vec_b32 = vec_b32 vec_vmrghw BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_unpack2uh vec_u8 vec_u8 = vec_u16 vec_unpack2uh BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_vmrghb
+vec_unpack2uh vec_u16 vec_u16 = vec_u32 vec_unpack2uh BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_vmrghh
+vec_unpack2sh vec_u8 vec_u8 = vec_s16 vec_unpack2sh BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_vmrghb
+vec_unpack2sh vec_u16 vec_u16 = vec_s32 vec_unpack2sh BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_vmrghh
+vec_mergel vec_u8 vec_u8 = vec_u8 vec_vmrglb BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_mergel vec_u16 vec_u16 = vec_u16 vec_vmrglh BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_mergel vec_u32 vec_u32 = vec_u32 vec_vmrglw BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_mergel vec_s8 vec_s8 = vec_s8 vec_vmrglb BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_mergel vec_s16 vec_s16 = vec_s16 vec_vmrglh BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_mergel vec_s32 vec_s32 = vec_s32 vec_vmrglw BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_mergel vec_f32 vec_f32 = vec_f32 vec_vmrglw BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_mergel vec_p16 vec_p16 = vec_p16 vec_vmrglh BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_mergel vec_b8 vec_b8 = vec_b8 vec_vmrglb BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_mergel vec_b16 vec_b16 = vec_b16 vec_vmrglh BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_mergel vec_b32 vec_b32 = vec_b32 vec_vmrglw BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_unpack2ul vec_u8 vec_u8 = vec_u16 vec_unpack2ul BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_vmrglb
+vec_unpack2ul vec_u16 vec_u16 = vec_u32 vec_unpack2ul BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_vmrglh
+vec_unpack2sl vec_u8 vec_u8 = vec_s16 vec_unpack2sl BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_vmrglb
+vec_unpack2sl vec_u16 vec_u16 = vec_s32 vec_unpack2sl BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_vmrglh
+vec_splat vec_u8 immed_u5 = vec_u8 vec_vspltb BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_splat vec_u16 immed_u5 = vec_u16 vec_vsplth BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_splat vec_u32 immed_u5 = vec_u32 vec_vspltw BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_splat vec_s8 immed_u5 = vec_s8 vec_vspltb BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_splat vec_s16 immed_u5 = vec_s16 vec_vsplth BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_splat vec_s32 immed_u5 = vec_s32 vec_vspltw BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_splat vec_b8 immed_u5 = vec_b8 vec_vspltb BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_splat vec_b16 immed_u5 = vec_b16 vec_vsplth BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_splat vec_b32 immed_u5 = vec_b32 vec_vspltw BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_splat vec_p16 immed_u5 = vec_p16 vec_vsplth BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_splat vec_f32 immed_u5 = vec_f32 vec_vspltw BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_splat_s8 immed_s5 = vec_s8 vec_vspltisb BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_splat_s16 immed_s5 = vec_s16 vec_vspltish BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_splat_s32 immed_s5 = vec_s32 vec_vspltisw BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_splat_u8 immed_s5 = vec_u8 vec_splat_u8 BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_vspltisb
+vec_splat_u16 immed_s5 = vec_u16 vec_splat_u16 BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_vspltish
+vec_splat_u32 immed_s5 = vec_u32 vec_splat_u32 BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_vspltisw
+vec_perm vec_u8 vec_u8 vec_u8 = vec_u8 vec_vperm BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_perm vec_u16 vec_u16 vec_u8 = vec_u16 vec_vperm BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_perm vec_u32 vec_u32 vec_u8 = vec_u32 vec_vperm BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_perm vec_s8 vec_s8 vec_u8 = vec_s8 vec_vperm BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_perm vec_s16 vec_s16 vec_u8 = vec_s16 vec_vperm BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_perm vec_s32 vec_s32 vec_u8 = vec_s32 vec_vperm BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_perm vec_b8 vec_b8 vec_u8 = vec_b8 vec_vperm BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_perm vec_b16 vec_b16 vec_u8 = vec_b16 vec_vperm BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_perm vec_b32 vec_b32 vec_u8 = vec_b32 vec_vperm BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_perm vec_p16 vec_p16 vec_u8 = vec_p16 vec_vperm BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_perm vec_f32 vec_f32 vec_u8 = vec_f32 vec_vperm BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_sld vec_u8 vec_u8 immed_u4 = vec_u8 vec_vsldoi BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_sld vec_u16 vec_u16 immed_u4 = vec_u16 vec_vsldoi BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_sld vec_u32 vec_u32 immed_u4 = vec_u32 vec_vsldoi BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_sld vec_s8 vec_s8 immed_u4 = vec_s8 vec_vsldoi BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_sld vec_s16 vec_s16 immed_u4 = vec_s16 vec_vsldoi BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_sld vec_s32 vec_s32 immed_u4 = vec_s32 vec_vsldoi BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_sld vec_p16 vec_p16 immed_u4 = vec_p16 vec_vsldoi BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_sld vec_f32 vec_f32 immed_u4 = vec_f32 vec_vsldoi BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_sld vec_b8 vec_b8 immed_u4 = vec_b8 vec_vsldoi BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_sld vec_b16 vec_b16 immed_u4 = vec_b16 vec_vsldoi BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_sld vec_b32 vec_b32 immed_u4 = vec_b32 vec_vsldoi BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_slo vec_u8 vec_u8 = vec_u8 vec_vslo BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_slo vec_u16 vec_u8 = vec_u16 vec_vslo BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_slo vec_u32 vec_u8 = vec_u32 vec_vslo BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_slo vec_s8 vec_u8 = vec_s8 vec_vslo BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_slo vec_s16 vec_u8 = vec_s16 vec_vslo BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_slo vec_s32 vec_u8 = vec_s32 vec_vslo BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_slo vec_p16 vec_u8 = vec_p16 vec_vslo BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_slo vec_u8 vec_s8 = vec_u8 vec_vslo BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_slo vec_u16 vec_s8 = vec_u16 vec_vslo BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_slo vec_u32 vec_s8 = vec_u32 vec_vslo BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_slo vec_s8 vec_s8 = vec_s8 vec_vslo BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_slo vec_s16 vec_s8 = vec_s16 vec_vslo BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_slo vec_s32 vec_s8 = vec_s32 vec_vslo BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_slo vec_p16 vec_s8 = vec_p16 vec_vslo BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_slo vec_f32 vec_u8 = vec_f32 vec_vslo BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_slo vec_f32 vec_s8 = vec_f32 vec_vslo BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_sro vec_u8 vec_u8 = vec_u8 vec_vsro BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_sro vec_u16 vec_u8 = vec_u16 vec_vsro BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_sro vec_u32 vec_u8 = vec_u32 vec_vsro BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_sro vec_s8 vec_u8 = vec_s8 vec_vsro BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_sro vec_s16 vec_u8 = vec_s16 vec_vsro BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_sro vec_s32 vec_u8 = vec_s32 vec_vsro BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_sro vec_p16 vec_u8 = vec_p16 vec_vsro BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_sro vec_u8 vec_s8 = vec_u8 vec_vsro BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_sro vec_u16 vec_s8 = vec_u16 vec_vsro BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_sro vec_u32 vec_s8 = vec_u32 vec_vsro BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_sro vec_s8 vec_s8 = vec_s8 vec_vsro BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_sro vec_s16 vec_s8 = vec_s16 vec_vsro BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_sro vec_s32 vec_s8 = vec_s32 vec_vsro BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_sro vec_p16 vec_s8 = vec_p16 vec_vsro BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_sro vec_f32 vec_u8 = vec_f32 vec_vsro BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_sro vec_f32 vec_s8 = vec_f32 vec_vsro BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_max vec_u8 vec_u8 = vec_u8 vec_vmaxub BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_max vec_u8 vec_b8 = vec_u8 vec_vmaxub BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_max vec_b8 vec_u8 = vec_u8 vec_vmaxub BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_max vec_s8 vec_s8 = vec_s8 vec_vmaxsb BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_max vec_s8 vec_b8 = vec_s8 vec_vmaxsb BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_max vec_b8 vec_s8 = vec_s8 vec_vmaxsb BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_max vec_u16 vec_u16 = vec_u16 vec_vmaxuh BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_max vec_u16 vec_b16 = vec_u16 vec_vmaxuh BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_max vec_b16 vec_u16 = vec_u16 vec_vmaxuh BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_max vec_s16 vec_s16 = vec_s16 vec_vmaxsh BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_max vec_s16 vec_b16 = vec_s16 vec_vmaxsh BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_max vec_b16 vec_s16 = vec_s16 vec_vmaxsh BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_max vec_u32 vec_u32 = vec_u32 vec_vmaxuw BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_max vec_u32 vec_b32 = vec_u32 vec_vmaxuw BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_max vec_b32 vec_u32 = vec_u32 vec_vmaxuw BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_max vec_s32 vec_s32 = vec_s32 vec_vmaxsw BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_max vec_s32 vec_b32 = vec_s32 vec_vmaxsw BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_max vec_b32 vec_s32 = vec_s32 vec_vmaxsw BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_min vec_u8 vec_u8 = vec_u8 vec_vminub BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_min vec_u8 vec_b8 = vec_u8 vec_vminub BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_min vec_b8 vec_u8 = vec_u8 vec_vminub BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_min vec_s8 vec_s8 = vec_s8 vec_vminsb BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_min vec_s8 vec_b8 = vec_s8 vec_vminsb BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_min vec_b8 vec_s8 = vec_s8 vec_vminsb BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_min vec_u16 vec_u16 = vec_u16 vec_vminuh BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_min vec_u16 vec_b16 = vec_u16 vec_vminuh BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_min vec_b16 vec_u16 = vec_u16 vec_vminuh BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_min vec_s16 vec_s16 = vec_s16 vec_vminsh BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_min vec_s16 vec_b16 = vec_s16 vec_vminsh BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_min vec_b16 vec_s16 = vec_s16 vec_vminsh BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_min vec_u32 vec_u32 = vec_u32 vec_vminuw BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_min vec_u32 vec_b32 = vec_u32 vec_vminuw BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_min vec_b32 vec_u32 = vec_u32 vec_vminuw BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_min vec_s32 vec_s32 = vec_s32 vec_vminsw BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_min vec_s32 vec_b32 = vec_s32 vec_vminsw BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_min vec_b32 vec_s32 = vec_s32 vec_vminsw BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_lde int const_unsigned_char_ptr = vec_u8_load_op vec_lvebx BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_lvebx TRUE FALSE
+vec_lde int const_unsigned_short_ptr = vec_u16_load_op vec_lvehx BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_lvehx TRUE FALSE
+vec_lde int const_unsigned_int_ptr = vec_u32_load_op vec_lvewx BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_lvewx TRUE FALSE
+vec_lde int const_unsigned_long_ptr = vec_u32_load_op vec_lvewx BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_lvewx TRUE FALSE
+vec_lde int const_signed_char_ptr = vec_s8_load_op vec_lvebx BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_lvebx TRUE FALSE
+vec_lde int const_short_ptr = vec_s16_load_op vec_lvehx BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_lvehx TRUE FALSE
+vec_lde int const_int_ptr = vec_s32_load_op vec_lvewx BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_lvewx TRUE FALSE
+vec_lde int const_long_ptr = vec_s32_load_op vec_lvewx BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_lvewx TRUE FALSE
+vec_lde int const_float_ptr = vec_f32_load_op vec_lvewx BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_lvewx TRUE FALSE
+vec_ld int const_unsigned_char_ptr = vec_u8_load_op vec_lvx BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_lvx TRUE FALSE transform_lvx
+vec_ld int const_unsigned_short_ptr = vec_u16_load_op vec_lvx BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_lvx TRUE FALSE transform_lvx
+vec_ld int const_unsigned_int_ptr = vec_u32_load_op vec_lvx BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_lvx TRUE FALSE transform_lvx
+vec_ld int const_unsigned_long_ptr = vec_u32_load_op vec_lvx BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_lvx TRUE FALSE transform_lvx
+vec_ld int const_signed_char_ptr = vec_s8_load_op vec_lvx BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_lvx TRUE FALSE transform_lvx
+vec_ld int const_short_ptr = vec_s16_load_op vec_lvx BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_lvx TRUE FALSE transform_lvx
+vec_ld int const_int_ptr = vec_s32_load_op vec_lvx BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_lvx TRUE FALSE transform_lvx
+vec_ld int const_long_ptr = vec_s32_load_op vec_lvx BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_lvx TRUE FALSE transform_lvx
+vec_ld int const_float_ptr = vec_f32_load_op vec_lvx BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_lvx TRUE FALSE transform_lvx
+vec_ldl int const_unsigned_char_ptr = vec_u8_load_op vec_lvxl BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_lvxl TRUE FALSE transform_lvx
+vec_ldl int const_unsigned_short_ptr = vec_u16_load_op vec_lvxl BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_lvxl TRUE FALSE transform_lvx
+vec_ldl int const_unsigned_int_ptr = vec_u32_load_op vec_lvxl BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_lvxl TRUE FALSE transform_lvx
+vec_ldl int const_unsigned_long_ptr = vec_u32_load_op vec_lvxl BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_lvxl TRUE FALSE transform_lvx
+vec_ldl int const_signed_char_ptr = vec_s8_load_op vec_lvxl BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_lvxl TRUE FALSE transform_lvx
+vec_ldl int const_short_ptr = vec_s16_load_op vec_lvxl BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_lvxl TRUE FALSE transform_lvx
+vec_ldl int const_int_ptr = vec_s32_load_op vec_lvxl BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_lvxl TRUE FALSE transform_lvx
+vec_ldl int const_long_ptr = vec_s32_load_op vec_lvxl BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_lvxl TRUE FALSE transform_lvx
+vec_ldl int const_float_ptr = vec_f32_load_op vec_lvxl BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_lvxl TRUE FALSE transform_lvx
+vec_ld int const_vec_u8_ptr = vec_u8_load_op vec_lvx BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_lvx TRUE FALSE transform_lvx
+vec_ld int const_vec_u16_ptr = vec_u16_load_op vec_lvx BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_lvx TRUE FALSE transform_lvx
+vec_ld int const_vec_u32_ptr = vec_u32_load_op vec_lvx BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_lvx TRUE FALSE transform_lvx
+vec_ld int const_vec_s8_ptr = vec_s8_load_op vec_lvx BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_lvx TRUE FALSE transform_lvx
+vec_ld int const_vec_s16_ptr = vec_s16_load_op vec_lvx BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_lvx TRUE FALSE transform_lvx
+vec_ld int const_vec_s32_ptr = vec_s32_load_op vec_lvx BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_lvx TRUE FALSE transform_lvx
+vec_ld int const_vec_p16_ptr = vec_p16_load_op vec_lvx BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_lvx TRUE FALSE transform_lvx
+vec_ld int const_vec_b8_ptr = vec_b8_load_op vec_lvx BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_lvx TRUE FALSE transform_lvx
+vec_ld int const_vec_b16_ptr = vec_b16_load_op vec_lvx BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_lvx TRUE FALSE transform_lvx
+vec_ld int const_vec_b32_ptr = vec_b32_load_op vec_lvx BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_lvx TRUE FALSE transform_lvx
+vec_ld int const_vec_f32_ptr = vec_f32_load_op vec_lvx BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_lvx TRUE FALSE transform_lvx
+vec_ldl int const_vec_u8_ptr = vec_u8_load_op vec_lvxl BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_lvxl TRUE FALSE transform_lvx
+vec_ldl int const_vec_u16_ptr = vec_u16_load_op vec_lvxl BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_lvxl TRUE FALSE transform_lvx
+vec_ldl int const_vec_u32_ptr = vec_u32_load_op vec_lvxl BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_lvxl TRUE FALSE transform_lvx
+vec_ldl int const_vec_s8_ptr = vec_s8_load_op vec_lvxl BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_lvxl TRUE FALSE transform_lvx
+vec_ldl int const_vec_s16_ptr = vec_s16_load_op vec_lvxl BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_lvxl TRUE FALSE transform_lvx
+vec_ldl int const_vec_s32_ptr = vec_s32_load_op vec_lvxl BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_lvxl TRUE FALSE transform_lvx
+vec_ldl int const_vec_p16_ptr = vec_p16_load_op vec_lvxl BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_lvxl TRUE FALSE transform_lvx
+vec_ldl int const_vec_b8_ptr = vec_b8_load_op vec_lvxl BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_lvxl TRUE FALSE transform_lvx
+vec_ldl int const_vec_b16_ptr = vec_b16_load_op vec_lvxl BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_lvxl TRUE FALSE transform_lvx
+vec_ldl int const_vec_b32_ptr = vec_b32_load_op vec_lvxl BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_lvxl TRUE FALSE transform_lvx
+vec_ldl int const_vec_f32_ptr = vec_f32_load_op vec_lvxl BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_lvxl TRUE FALSE transform_lvx
+vec_ste vec_u8 int unsigned_char_ptr = void_store_op vec_stvebx BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_ste vec_u16 int unsigned_short_ptr = void_store_op vec_stvehx BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_ste vec_u32 int unsigned_int_ptr = void_store_op vec_stvewx BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_ste vec_u32 int unsigned_long_ptr = void_store_op vec_stvewx BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_ste vec_s8 int signed_char_ptr = void_store_op vec_stvebx BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_ste vec_s16 int short_ptr = void_store_op vec_stvehx BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_ste vec_s32 int int_ptr = void_store_op vec_stvewx BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_ste vec_s32 int long_ptr = void_store_op vec_stvewx BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_ste vec_f32 int float_ptr = void_store_op vec_stvewx BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_ste vec_p16 int short_ptr = void_store_op vec_stvehx BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_ste vec_p16 int unsigned_short_ptr = void_store_op vec_stvehx BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_ste vec_b8 int unsigned_char_ptr = void_store_op vec_stvebx BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_ste vec_b8 int signed_char_ptr = void_store_op vec_stvebx BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_ste vec_b16 int unsigned_short_ptr = void_store_op vec_stvebx BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_ste vec_b16 int short_ptr = void_store_op vec_stvebx BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_ste vec_b32 int unsigned_int_ptr = void_store_op vec_stvewx BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_ste vec_b32 int unsigned_long_ptr = void_store_op vec_stvewx BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_ste vec_b32 int int_ptr = void_store_op vec_stvewx BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_ste vec_b32 int long_ptr = void_store_op vec_stvewx BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_st vec_u8 int unsigned_char_ptr = void_store_op vec_stvx BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_stvx FALSE FALSE transform_stvx
+vec_st vec_u16 int unsigned_short_ptr = void_store_op vec_stvx BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_stvx FALSE FALSE transform_stvx
+vec_st vec_u32 int unsigned_int_ptr = void_store_op vec_stvx BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_stvx FALSE FALSE transform_stvx
+vec_st vec_u32 int unsigned_long_ptr = void_store_op vec_stvx BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_stvx FALSE FALSE transform_stvx
+vec_st vec_s8 int signed_char_ptr = void_store_op vec_stvx BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_stvx FALSE FALSE transform_stvx
+vec_st vec_s16 int short_ptr = void_store_op vec_stvx BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_stvx FALSE FALSE transform_stvx
+vec_st vec_s32 int int_ptr = void_store_op vec_stvx BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_stvx FALSE FALSE transform_stvx
+vec_st vec_s32 int long_ptr = void_store_op vec_stvx BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_stvx FALSE FALSE transform_stvx
+vec_st vec_f32 int float_ptr = void_store_op vec_stvx BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_stvx FALSE FALSE transform_stvx
+vec_st vec_p16 int short_ptr = void_store_op vec_stvx BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_stvx FALSE FALSE transform_stvx
+vec_st vec_p16 int unsigned_short_ptr = void_store_op vec_stvx BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_stvx FALSE FALSE transform_stvx
+vec_st vec_b8 int unsigned_char_ptr = void_store_op vec_stvx BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_stvx FALSE FALSE transform_stvx
+vec_st vec_b8 int signed_char_ptr = void_store_op vec_stvx BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_stvx FALSE FALSE transform_stvx
+vec_st vec_b16 int unsigned_short_ptr = void_store_op vec_stvx BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_stvx FALSE FALSE transform_stvx
+vec_st vec_b16 int short_ptr = void_store_op vec_stvx BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_stvx FALSE FALSE transform_stvx
+vec_st vec_b32 int unsigned_int_ptr = void_store_op vec_stvx BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_stvx FALSE FALSE transform_stvx
+vec_st vec_b32 int unsigned_long_ptr = void_store_op vec_stvx BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_stvx FALSE FALSE transform_stvx
+vec_st vec_b32 int int_ptr = void_store_op vec_stvx BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_stvx FALSE FALSE transform_stvx
+vec_st vec_b32 int long_ptr = void_store_op vec_stvx BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_stvx FALSE FALSE transform_stvx
+vec_stl vec_u8 int unsigned_char_ptr = void_store_op vec_stvxl BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_stvxl FALSE FALSE transform_stvx
+vec_stl vec_u16 int unsigned_short_ptr = void_store_op vec_stvxl BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_stvxl FALSE FALSE transform_stvx
+vec_stl vec_u32 int unsigned_int_ptr = void_store_op vec_stvxl BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_stvxl FALSE FALSE transform_stvx
+vec_stl vec_u32 int unsigned_long_ptr = void_store_op vec_stvxl BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_stvxl FALSE FALSE transform_stvx
+vec_stl vec_s8 int signed_char_ptr = void_store_op vec_stvxl BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_stvxl FALSE FALSE transform_stvx
+vec_stl vec_s16 int short_ptr = void_store_op vec_stvxl BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_stvxl FALSE FALSE transform_stvx
+vec_stl vec_s32 int int_ptr = void_store_op vec_stvxl BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_stvxl FALSE FALSE transform_stvx
+vec_stl vec_s32 int long_ptr = void_store_op vec_stvxl BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_stvxl FALSE FALSE transform_stvx
+vec_stl vec_f32 int float_ptr = void_store_op vec_stvxl BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_stvxl FALSE FALSE transform_stvx
+vec_stl vec_p16 int short_ptr = void_store_op vec_stvxl BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_stvxl FALSE FALSE transform_stvx
+vec_stl vec_p16 int unsigned_short_ptr = void_store_op vec_stvxl BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_stvxl FALSE FALSE transform_stvx
+vec_stl vec_b8 int unsigned_char_ptr = void_store_op vec_stvxl BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_stvxl FALSE FALSE transform_stvx
+vec_stl vec_b8 int signed_char_ptr = void_store_op vec_stvxl BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_stvxl FALSE FALSE transform_stvx
+vec_stl vec_b16 int unsigned_short_ptr = void_store_op vec_stvxl BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_stvxl FALSE FALSE transform_stvx
+vec_stl vec_b16 int short_ptr = void_store_op vec_stvxl BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_stvxl FALSE FALSE transform_stvx
+vec_stl vec_b32 int unsigned_int_ptr = void_store_op vec_stvxl BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_stvxl FALSE FALSE transform_stvx
+vec_stl vec_b32 int unsigned_long_ptr = void_store_op vec_stvxl BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_stvxl FALSE FALSE transform_stvx
+vec_stl vec_b32 int int_ptr = void_store_op vec_stvxl BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_stvxl FALSE FALSE transform_stvx
+vec_stl vec_b32 int long_ptr = void_store_op vec_stvxl BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_stvxl FALSE FALSE transform_stvx
+vec_st vec_u8 int vec_u8_ptr = void_store_op vec_stvx BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_stvx FALSE FALSE transform_stvx
+vec_st vec_u16 int vec_u16_ptr = void_store_op vec_stvx BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_stvx FALSE FALSE transform_stvx
+vec_st vec_u32 int vec_u32_ptr = void_store_op vec_stvx BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_stvx FALSE FALSE transform_stvx
+vec_st vec_s8 int vec_s8_ptr = void_store_op vec_stvx BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_stvx FALSE FALSE transform_stvx
+vec_st vec_s16 int vec_s16_ptr = void_store_op vec_stvx BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_stvx FALSE FALSE transform_stvx
+vec_st vec_s32 int vec_s32_ptr = void_store_op vec_stvx BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_stvx FALSE FALSE transform_stvx
+vec_st vec_b8 int vec_b8_ptr = void_store_op vec_stvx BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_stvx FALSE FALSE transform_stvx
+vec_st vec_b16 int vec_b16_ptr = void_store_op vec_stvx BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_stvx FALSE FALSE transform_stvx
+vec_st vec_b32 int vec_b32_ptr = void_store_op vec_stvx BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_stvx FALSE FALSE transform_stvx
+vec_st vec_p16 int vec_p16_ptr = void_store_op vec_stvx BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_stvx FALSE FALSE transform_stvx
+vec_st vec_f32 int vec_f32_ptr = void_store_op vec_stvx BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_stvx FALSE FALSE transform_stvx
+vec_stl vec_u8 int vec_u8_ptr = void_store_op vec_stvxl BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_stvxl FALSE FALSE transform_stvx
+vec_stl vec_u16 int vec_u16_ptr = void_store_op vec_stvxl BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_stvxl FALSE FALSE transform_stvx
+vec_stl vec_u32 int vec_u32_ptr = void_store_op vec_stvxl BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_stvxl FALSE FALSE transform_stvx
+vec_stl vec_s8 int vec_s8_ptr = void_store_op vec_stvxl BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_stvxl FALSE FALSE transform_stvx
+vec_stl vec_s16 int vec_s16_ptr = void_store_op vec_stvxl BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_stvxl FALSE FALSE transform_stvx
+vec_stl vec_s32 int vec_s32_ptr = void_store_op vec_stvxl BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_stvxl FALSE FALSE transform_stvx
+vec_stl vec_b8 int vec_b8_ptr = void_store_op vec_stvxl BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_stvxl FALSE FALSE transform_stvx
+vec_stl vec_b16 int vec_b16_ptr = void_store_op vec_stvxl BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_stvxl FALSE FALSE transform_stvx
+vec_stl vec_b32 int vec_b32_ptr = void_store_op vec_stvxl BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_stvxl FALSE FALSE transform_stvx
+vec_stl vec_p16 int vec_p16_ptr = void_store_op vec_stvxl BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_stvxl FALSE FALSE transform_stvx
+vec_stl vec_f32 int vec_f32_ptr = void_store_op vec_stvxl BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_stvxl FALSE FALSE transform_stvx
+vec_lvsl int const_volatile_unsigned_char_ptr = vec_u8 vec_lvsl BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_lvsl TRUE TRUE
+vec_lvsl int const_volatile_unsigned_short_ptr = vec_u8 vec_lvsl BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_lvsl TRUE TRUE
+vec_lvsl int const_volatile_unsigned_int_ptr = vec_u8 vec_lvsl BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_lvsl TRUE TRUE
+vec_lvsl int const_volatile_unsigned_long_ptr = vec_u8 vec_lvsl BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_lvsl TRUE TRUE
+vec_lvsl int const_volatile_signed_char_ptr = vec_u8 vec_lvsl BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_lvsl TRUE TRUE
+vec_lvsl int const_volatile_short_ptr = vec_u8 vec_lvsl BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_lvsl TRUE TRUE
+vec_lvsl int const_volatile_int_ptr = vec_u8 vec_lvsl BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_lvsl TRUE TRUE
+vec_lvsl int const_volatile_long_ptr = vec_u8 vec_lvsl BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_lvsl TRUE TRUE
+vec_lvsl int const_volatile_float_ptr = vec_u8 vec_lvsl BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_lvsl TRUE TRUE
+vec_lvsr int const_volatile_unsigned_char_ptr = vec_u8 vec_lvsr BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_lvsr TRUE TRUE
+vec_lvsr int const_volatile_unsigned_short_ptr = vec_u8 vec_lvsr BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_lvsr TRUE TRUE
+vec_lvsr int const_volatile_unsigned_int_ptr = vec_u8 vec_lvsr BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_lvsr TRUE TRUE
+vec_lvsr int const_volatile_unsigned_long_ptr = vec_u8 vec_lvsr BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_lvsr TRUE TRUE
+vec_lvsr int const_volatile_signed_char_ptr = vec_u8 vec_lvsr BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_lvsr TRUE TRUE
+vec_lvsr int const_volatile_short_ptr = vec_u8 vec_lvsr BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_lvsr TRUE TRUE
+vec_lvsr int const_volatile_int_ptr = vec_u8 vec_lvsr BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_lvsr TRUE TRUE
+vec_lvsr int const_volatile_long_ptr = vec_u8 vec_lvsr BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_lvsr TRUE TRUE
+vec_lvsr int const_volatile_float_ptr = vec_u8 vec_lvsr BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_lvsr TRUE TRUE
+vec_mfvscr = volatile_vec_u16 vec_mfvscr BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_mtvscr vec_u8 = volatile_void vec_mtvscr BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_mtvscr vec_u16 = volatile_void vec_mtvscr BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_mtvscr vec_u32 = volatile_void vec_mtvscr BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_mtvscr vec_s8 = volatile_void vec_mtvscr BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_mtvscr vec_s16 = volatile_void vec_mtvscr BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_mtvscr vec_s32 = volatile_void vec_mtvscr BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_mtvscr vec_b8 = volatile_void vec_mtvscr BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_mtvscr vec_b16 = volatile_void vec_mtvscr BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_mtvscr vec_b32 = volatile_void vec_mtvscr BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_mtvscr vec_p16 = volatile_void vec_mtvscr BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_dst const_unsigned_char_ptr int immed_u2 = volatile_void_load_op vec_dst BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_dst TRUE FALSE
+vec_dst const_unsigned_short_ptr int immed_u2 = volatile_void_load_op vec_dst BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_dst TRUE FALSE
+vec_dst const_unsigned_int_ptr int immed_u2 = volatile_void_load_op vec_dst BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_dst TRUE FALSE
+vec_dst const_unsigned_long_ptr int immed_u2 = volatile_void_load_op vec_dst BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_dst TRUE FALSE
+vec_dst const_signed_char_ptr int immed_u2 = volatile_void_load_op vec_dst BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_dst TRUE FALSE
+vec_dst const_short_ptr int immed_u2 = volatile_void_load_op vec_dst BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_dst TRUE FALSE
+vec_dst const_int_ptr int immed_u2 = volatile_void_load_op vec_dst BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_dst TRUE FALSE
+vec_dst const_long_ptr int immed_u2 = volatile_void_load_op vec_dst BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_dst TRUE FALSE
+vec_dst const_float_ptr int immed_u2 = volatile_void_load_op vec_dst BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_dst TRUE FALSE
+vec_dstt const_unsigned_char_ptr int immed_u2 = volatile_void_load_op vec_dstt BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_dstt TRUE FALSE
+vec_dstt const_unsigned_short_ptr int immed_u2 = volatile_void_load_op vec_dstt BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_dstt TRUE FALSE
+vec_dstt const_unsigned_int_ptr int immed_u2 = volatile_void_load_op vec_dstt BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_dstt TRUE FALSE
+vec_dstt const_unsigned_long_ptr int immed_u2 = volatile_void_load_op vec_dstt BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_dstt TRUE FALSE
+vec_dstt const_signed_char_ptr int immed_u2 = volatile_void_load_op vec_dstt BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_dstt TRUE FALSE
+vec_dstt const_short_ptr int immed_u2 = volatile_void_load_op vec_dstt BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_dstt TRUE FALSE
+vec_dstt const_int_ptr int immed_u2 = volatile_void_load_op vec_dstt BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_dstt TRUE FALSE
+vec_dstt const_long_ptr int immed_u2 = volatile_void_load_op vec_dstt BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_dstt TRUE FALSE
+vec_dstt const_float_ptr int immed_u2 = volatile_void_load_op vec_dstt BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_dstt TRUE FALSE
+vec_dstst const_unsigned_char_ptr int immed_u2 = volatile_void_load_op vec_dstst BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_dstst TRUE FALSE
+vec_dstst const_unsigned_short_ptr int immed_u2 = volatile_void_load_op vec_dstst BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_dstst TRUE FALSE
+vec_dstst const_unsigned_int_ptr int immed_u2 = volatile_void_load_op vec_dstst BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_dstst TRUE FALSE
+vec_dstst const_unsigned_long_ptr int immed_u2 = volatile_void_load_op vec_dstst BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_dstst TRUE FALSE
+vec_dstst const_signed_char_ptr int immed_u2 = volatile_void_load_op vec_dstst BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_dstst TRUE FALSE
+vec_dstst const_short_ptr int immed_u2 = volatile_void_load_op vec_dstst BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_dstst TRUE FALSE
+vec_dstst const_int_ptr int immed_u2 = volatile_void_load_op vec_dstst BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_dstst TRUE FALSE
+vec_dstst const_long_ptr int immed_u2 = volatile_void_load_op vec_dstst BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_dstst TRUE FALSE
+vec_dstst const_float_ptr int immed_u2 = volatile_void_load_op vec_dstst BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_dstst TRUE FALSE
+vec_dststt const_unsigned_char_ptr int immed_u2 = volatile_void_load_op vec_dststt BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_dststt TRUE FALSE
+vec_dststt const_unsigned_short_ptr int immed_u2 = volatile_void_load_op vec_dststt BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_dststt TRUE FALSE
+vec_dststt const_unsigned_int_ptr int immed_u2 = volatile_void_load_op vec_dststt BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_dststt TRUE FALSE
+vec_dststt const_unsigned_long_ptr int immed_u2 = volatile_void_load_op vec_dststt BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_dststt TRUE FALSE
+vec_dststt const_signed_char_ptr int immed_u2 = volatile_void_load_op vec_dststt BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_dststt TRUE FALSE
+vec_dststt const_short_ptr int immed_u2 = volatile_void_load_op vec_dststt BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_dststt TRUE FALSE
+vec_dststt const_int_ptr int immed_u2 = volatile_void_load_op vec_dststt BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_dststt TRUE FALSE
+vec_dststt const_long_ptr int immed_u2 = volatile_void_load_op vec_dststt BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_dststt TRUE FALSE
+vec_dststt const_float_ptr int immed_u2 = volatile_void_load_op vec_dststt BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_dststt TRUE FALSE
+vec_dst const_vec_u8_ptr int immed_u2 = volatile_void_load_op vec_dst BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_dst TRUE FALSE
+vec_dst const_vec_u16_ptr int immed_u2 = volatile_void_load_op vec_dst BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_dst TRUE FALSE
+vec_dst const_vec_u32_ptr int immed_u2 = volatile_void_load_op vec_dst BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_dst TRUE FALSE
+vec_dst const_vec_s8_ptr int immed_u2 = volatile_void_load_op vec_dst BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_dst TRUE FALSE
+vec_dst const_vec_s16_ptr int immed_u2 = volatile_void_load_op vec_dst BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_dst TRUE FALSE
+vec_dst const_vec_s32_ptr int immed_u2 = volatile_void_load_op vec_dst BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_dst TRUE FALSE
+vec_dst const_vec_b8_ptr int immed_u2 = volatile_void_load_op vec_dst BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_dst TRUE FALSE
+vec_dst const_vec_b16_ptr int immed_u2 = volatile_void_load_op vec_dst BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_dst TRUE FALSE
+vec_dst const_vec_b32_ptr int immed_u2 = volatile_void_load_op vec_dst BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_dst TRUE FALSE
+vec_dst const_vec_p16_ptr int immed_u2 = volatile_void_load_op vec_dst BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_dst TRUE FALSE
+vec_dst const_vec_f32_ptr int immed_u2 = volatile_void_load_op vec_dst BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_dst TRUE FALSE
+vec_dstt const_vec_u8_ptr int immed_u2 = volatile_void_load_op vec_dstt BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_dstt TRUE FALSE
+vec_dstt const_vec_u16_ptr int immed_u2 = volatile_void_load_op vec_dstt BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_dstt TRUE FALSE
+vec_dstt const_vec_u32_ptr int immed_u2 = volatile_void_load_op vec_dstt BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_dstt TRUE FALSE
+vec_dstt const_vec_s8_ptr int immed_u2 = volatile_void_load_op vec_dstt BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_dstt TRUE FALSE
+vec_dstt const_vec_s16_ptr int immed_u2 = volatile_void_load_op vec_dstt BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_dstt TRUE FALSE
+vec_dstt const_vec_s32_ptr int immed_u2 = volatile_void_load_op vec_dstt BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_dstt TRUE FALSE
+vec_dstt const_vec_b8_ptr int immed_u2 = volatile_void_load_op vec_dstt BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_dstt TRUE FALSE
+vec_dstt const_vec_b16_ptr int immed_u2 = volatile_void_load_op vec_dstt BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_dstt TRUE FALSE
+vec_dstt const_vec_b32_ptr int immed_u2 = volatile_void_load_op vec_dstt BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_dstt TRUE FALSE
+vec_dstt const_vec_p16_ptr int immed_u2 = volatile_void_load_op vec_dstt BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_dstt TRUE FALSE
+vec_dstt const_vec_f32_ptr int immed_u2 = volatile_void_load_op vec_dstt BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_dstt TRUE FALSE
+vec_dstst const_vec_u8_ptr int immed_u2 = volatile_void_load_op vec_dstst BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_dstst TRUE FALSE
+vec_dstst const_vec_u16_ptr int immed_u2 = volatile_void_load_op vec_dstst BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_dstst TRUE FALSE
+vec_dstst const_vec_u32_ptr int immed_u2 = volatile_void_load_op vec_dstst BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_dstst TRUE FALSE
+vec_dstst const_vec_s8_ptr int immed_u2 = volatile_void_load_op vec_dstst BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_dstst TRUE FALSE
+vec_dstst const_vec_s16_ptr int immed_u2 = volatile_void_load_op vec_dstst BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_dstst TRUE FALSE
+vec_dstst const_vec_s32_ptr int immed_u2 = volatile_void_load_op vec_dstst BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_dstst TRUE FALSE
+vec_dstst const_vec_b8_ptr int immed_u2 = volatile_void_load_op vec_dstst BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_dstst TRUE FALSE
+vec_dstst const_vec_b16_ptr int immed_u2 = volatile_void_load_op vec_dstst BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_dstst TRUE FALSE
+vec_dstst const_vec_b32_ptr int immed_u2 = volatile_void_load_op vec_dstst BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_dstst TRUE FALSE
+vec_dstst const_vec_p16_ptr int immed_u2 = volatile_void_load_op vec_dstst BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_dstst TRUE FALSE
+vec_dstst const_vec_f32_ptr int immed_u2 = volatile_void_load_op vec_dstst BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_dstst TRUE FALSE
+vec_dststt const_vec_u8_ptr int immed_u2 = volatile_void_load_op vec_dststt BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_dststt TRUE FALSE
+vec_dststt const_vec_u16_ptr int immed_u2 = volatile_void_load_op vec_dststt BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_dststt TRUE FALSE
+vec_dststt const_vec_u32_ptr int immed_u2 = volatile_void_load_op vec_dststt BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_dststt TRUE FALSE
+vec_dststt const_vec_s8_ptr int immed_u2 = volatile_void_load_op vec_dststt BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_dststt TRUE FALSE
+vec_dststt const_vec_s16_ptr int immed_u2 = volatile_void_load_op vec_dststt BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_dststt TRUE FALSE
+vec_dststt const_vec_s32_ptr int immed_u2 = volatile_void_load_op vec_dststt BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_dststt TRUE FALSE
+vec_dststt const_vec_b8_ptr int immed_u2 = volatile_void_load_op vec_dststt BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_dststt TRUE FALSE
+vec_dststt const_vec_b16_ptr int immed_u2 = volatile_void_load_op vec_dststt BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_dststt TRUE FALSE
+vec_dststt const_vec_b32_ptr int immed_u2 = volatile_void_load_op vec_dststt BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_dststt TRUE FALSE
+vec_dststt const_vec_p16_ptr int immed_u2 = volatile_void_load_op vec_dststt BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_dststt TRUE FALSE
+vec_dststt const_vec_f32_ptr int immed_u2 = volatile_void_load_op vec_dststt BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_dststt TRUE FALSE
+vec_dss immed_u2 = volatile_void_load_op vec_dss BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_dssall = volatile_void_load_op vec_dssall BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_add vec_f32 vec_f32 = vec_f32 vec_vaddfp BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_sub vec_f32 vec_f32 = vec_f32 vec_vsubfp BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_madd vec_f32 vec_f32 vec_f32 = vec_f32 vec_vmaddfp BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_nmsub vec_f32 vec_f32 vec_f32 = vec_f32 vec_vnmsubfp BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_cmpgt vec_f32 vec_f32 = vec_b32 vec_vcmpgtfp BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_cmpge vec_f32 vec_f32 = vec_b32 vec_vcmpgefp BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_cmpeq vec_f32 vec_f32 = vec_b32 vec_vcmpeqfp BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_cmpb vec_f32 vec_f32 = vec_s32 vec_vcmpbfp BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_max vec_f32 vec_f32 = vec_f32 vec_vmaxfp BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_min vec_f32 vec_f32 = vec_f32 vec_vminfp BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_re vec_f32 = vec_f32 vec_vrefp BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_rsqrte vec_f32 = vec_f32 vec_vrsqrtefp BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_loge vec_f32 = vec_f32 vec_vlogefp BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_expte vec_f32 = vec_f32 vec_vexptefp BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_trunc vec_f32 = vec_f32 vec_vrfiz BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_round vec_f32 = vec_f32 vec_vrfin BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_ceil vec_f32 = vec_f32 vec_vrfip BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_floor vec_f32 = vec_f32 vec_vrfim BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_ctf vec_u32 immed_u5 = vec_f32 vec_vcfux BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_ctf vec_s32 immed_u5 = vec_f32 vec_vcfsx BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_ctu vec_f32 immed_u5 = vec_u32 vec_vctuxs BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_cts vec_f32 immed_u5 = vec_s32 vec_vctsxs BUILTIN_AFTER_TRAVERSE CFG_VEC
+vec_all_gt vec_u8 vec_u8 = cc24t vec_all_gt BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_vcmpgtubD
+vec_all_gt vec_u8 vec_b8 = cc24t vec_all_gt BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_vcmpgtubD
+vec_all_gt vec_b8 vec_u8 = cc24t vec_all_gt BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_vcmpgtubD
+vec_all_le vec_u8 vec_u8 = cc26t vec_all_le BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_vcmpgtubD
+vec_all_le vec_u8 vec_b8 = cc26t vec_all_le BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_vcmpgtubD
+vec_all_le vec_b8 vec_u8 = cc26t vec_all_le BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_vcmpgtubD
+vec_any_gt vec_u8 vec_u8 = cc26f vec_any_gt BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_vcmpgtubD
+vec_any_gt vec_u8 vec_b8 = cc26f vec_any_gt BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_vcmpgtubD
+vec_any_gt vec_b8 vec_u8 = cc26f vec_any_gt BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_vcmpgtubD
+vec_any_le vec_u8 vec_u8 = cc24f vec_any_le BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_vcmpgtubD
+vec_any_le vec_u8 vec_b8 = cc24f vec_any_le BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_vcmpgtubD
+vec_any_le vec_b8 vec_u8 = cc24f vec_any_le BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_vcmpgtubD
+vec_all_gt vec_s8 vec_s8 = cc24t vec_all_gt BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_vcmpgtsbD
+vec_all_gt vec_s8 vec_b8 = cc24t vec_all_gt BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_vcmpgtsbD
+vec_all_gt vec_b8 vec_s8 = cc24t vec_all_gt BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_vcmpgtsbD
+vec_all_le vec_s8 vec_s8 = cc26t vec_all_le BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_vcmpgtsbD
+vec_all_le vec_s8 vec_b8 = cc26t vec_all_le BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_vcmpgtsbD
+vec_all_le vec_b8 vec_s8 = cc26t vec_all_le BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_vcmpgtsbD
+vec_any_gt vec_s8 vec_s8 = cc26f vec_any_gt BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_vcmpgtsbD
+vec_any_gt vec_s8 vec_b8 = cc26f vec_any_gt BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_vcmpgtsbD
+vec_any_gt vec_b8 vec_s8 = cc26f vec_any_gt BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_vcmpgtsbD
+vec_any_le vec_s8 vec_s8 = cc24f vec_any_le BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_vcmpgtsbD
+vec_any_le vec_s8 vec_b8 = cc24f vec_any_le BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_vcmpgtsbD
+vec_any_le vec_b8 vec_s8 = cc24f vec_any_le BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_vcmpgtsbD
+vec_all_lt vec_u8 vec_u8 = cc24tr vec_all_lt BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_vcmpgtubD
+vec_all_lt vec_u8 vec_b8 = cc24tr vec_all_lt BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_vcmpgtubD
+vec_all_lt vec_b8 vec_u8 = cc24tr vec_all_lt BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_vcmpgtubD
+vec_all_ge vec_u8 vec_u8 = cc26tr vec_all_ge BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_vcmpgtubD
+vec_all_ge vec_u8 vec_b8 = cc26tr vec_all_ge BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_vcmpgtubD
+vec_all_ge vec_b8 vec_u8 = cc26tr vec_all_ge BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_vcmpgtubD
+vec_any_lt vec_u8 vec_u8 = cc26fr vec_any_lt BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_vcmpgtubD
+vec_any_lt vec_u8 vec_b8 = cc26fr vec_any_lt BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_vcmpgtubD
+vec_any_lt vec_b8 vec_u8 = cc26fr vec_any_lt BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_vcmpgtubD
+vec_any_ge vec_u8 vec_u8 = cc24fr vec_any_ge BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_vcmpgtubD
+vec_any_ge vec_u8 vec_b8 = cc24fr vec_any_ge BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_vcmpgtubD
+vec_any_ge vec_b8 vec_u8 = cc24fr vec_any_ge BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_vcmpgtubD
+vec_all_lt vec_s8 vec_s8 = cc24tr vec_all_lt BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_vcmpgtsbD
+vec_all_lt vec_s8 vec_b8 = cc24tr vec_all_lt BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_vcmpgtsbD
+vec_all_lt vec_b8 vec_s8 = cc24tr vec_all_lt BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_vcmpgtsbD
+vec_all_ge vec_s8 vec_s8 = cc26tr vec_all_ge BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_vcmpgtsbD
+vec_all_ge vec_s8 vec_b8 = cc26tr vec_all_ge BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_vcmpgtsbD
+vec_all_ge vec_b8 vec_s8 = cc26tr vec_all_ge BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_vcmpgtsbD
+vec_any_lt vec_s8 vec_s8 = cc26fr vec_any_lt BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_vcmpgtsbD
+vec_any_lt vec_s8 vec_b8 = cc26fr vec_any_lt BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_vcmpgtsbD
+vec_any_lt vec_b8 vec_s8 = cc26fr vec_any_lt BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_vcmpgtsbD
+vec_any_ge vec_s8 vec_s8 = cc24fr vec_any_ge BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_vcmpgtsbD
+vec_any_ge vec_s8 vec_b8 = cc24fr vec_any_ge BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_vcmpgtsbD
+vec_any_ge vec_b8 vec_s8 = cc24fr vec_any_ge BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_vcmpgtsbD
+vec_all_gt vec_u16 vec_u16 = cc24t vec_all_gt BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_vcmpgtuhD
+vec_all_gt vec_u16 vec_b16 = cc24t vec_all_gt BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_vcmpgtuhD
+vec_all_gt vec_b16 vec_u16 = cc24t vec_all_gt BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_vcmpgtuhD
+vec_all_le vec_u16 vec_u16 = cc26t vec_all_le BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_vcmpgtuhD
+vec_all_le vec_u16 vec_b16 = cc26t vec_all_le BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_vcmpgtuhD
+vec_all_le vec_b16 vec_u16 = cc26t vec_all_le BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_vcmpgtuhD
+vec_any_gt vec_u16 vec_u16 = cc26f vec_any_gt BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_vcmpgtuhD
+vec_any_gt vec_u16 vec_b16 = cc26f vec_any_gt BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_vcmpgtuhD
+vec_any_gt vec_b16 vec_u16 = cc26f vec_any_gt BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_vcmpgtuhD
+vec_any_le vec_u16 vec_u16 = cc24f vec_any_le BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_vcmpgtuhD
+vec_any_le vec_u16 vec_b16 = cc24f vec_any_le BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_vcmpgtuhD
+vec_any_le vec_b16 vec_u16 = cc24f vec_any_le BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_vcmpgtuhD
+vec_all_gt vec_s16 vec_s16 = cc24t vec_all_gt BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_vcmpgtshD
+vec_all_gt vec_s16 vec_b16 = cc24t vec_all_gt BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_vcmpgtshD
+vec_all_gt vec_b16 vec_s16 = cc24t vec_all_gt BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_vcmpgtshD
+vec_all_le vec_s16 vec_s16 = cc26t vec_all_le BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_vcmpgtshD
+vec_all_le vec_s16 vec_b16 = cc26t vec_all_le BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_vcmpgtshD
+vec_all_le vec_b16 vec_s16 = cc26t vec_all_le BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_vcmpgtshD
+vec_any_gt vec_s16 vec_s16 = cc26f vec_any_gt BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_vcmpgtshD
+vec_any_gt vec_s16 vec_b16 = cc26f vec_any_gt BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_vcmpgtshD
+vec_any_gt vec_b16 vec_s16 = cc26f vec_any_gt BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_vcmpgtshD
+vec_any_le vec_s16 vec_s16 = cc24f vec_any_le BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_vcmpgtshD
+vec_any_le vec_s16 vec_b16 = cc24f vec_any_le BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_vcmpgtshD
+vec_any_le vec_b16 vec_s16 = cc24f vec_any_le BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_vcmpgtshD
+vec_all_lt vec_u16 vec_u16 = cc24tr vec_all_lt BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_vcmpgtuhD
+vec_all_lt vec_u16 vec_b16 = cc24tr vec_all_lt BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_vcmpgtuhD
+vec_all_lt vec_b16 vec_u16 = cc24tr vec_all_lt BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_vcmpgtuhD
+vec_all_ge vec_u16 vec_u16 = cc26tr vec_all_ge BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_vcmpgtuhD
+vec_all_ge vec_u16 vec_b16 = cc26tr vec_all_ge BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_vcmpgtuhD
+vec_all_ge vec_b16 vec_u16 = cc26tr vec_all_ge BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_vcmpgtuhD
+vec_any_lt vec_u16 vec_u16 = cc26fr vec_any_lt BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_vcmpgtuhD
+vec_any_lt vec_u16 vec_b16 = cc26fr vec_any_lt BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_vcmpgtuhD
+vec_any_lt vec_b16 vec_u16 = cc26fr vec_any_lt BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_vcmpgtuhD
+vec_any_ge vec_u16 vec_u16 = cc24fr vec_any_ge BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_vcmpgtuhD
+vec_any_ge vec_u16 vec_b16 = cc24fr vec_any_ge BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_vcmpgtuhD
+vec_any_ge vec_b16 vec_u16 = cc24fr vec_any_ge BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_vcmpgtuhD
+vec_all_lt vec_s16 vec_s16 = cc24tr vec_all_lt BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_vcmpgtshD
+vec_all_lt vec_s16 vec_b16 = cc24tr vec_all_lt BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_vcmpgtshD
+vec_all_lt vec_b16 vec_s16 = cc24tr vec_all_lt BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_vcmpgtshD
+vec_all_ge vec_s16 vec_s16 = cc26tr vec_all_ge BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_vcmpgtshD
+vec_all_ge vec_s16 vec_b16 = cc26tr vec_all_ge BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_vcmpgtshD
+vec_all_ge vec_b16 vec_s16 = cc26tr vec_all_ge BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_vcmpgtshD
+vec_any_lt vec_s16 vec_s16 = cc26fr vec_any_lt BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_vcmpgtshD
+vec_any_lt vec_s16 vec_b16 = cc26fr vec_any_lt BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_vcmpgtshD
+vec_any_lt vec_b16 vec_s16 = cc26fr vec_any_lt BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_vcmpgtshD
+vec_any_ge vec_s16 vec_s16 = cc24fr vec_any_ge BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_vcmpgtshD
+vec_any_ge vec_s16 vec_b16 = cc24fr vec_any_ge BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_vcmpgtshD
+vec_any_ge vec_b16 vec_s16 = cc24fr vec_any_ge BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_vcmpgtshD
+vec_all_gt vec_u32 vec_u32 = cc24t vec_all_gt BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_vcmpgtuwD
+vec_all_gt vec_u32 vec_b32 = cc24t vec_all_gt BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_vcmpgtuwD
+vec_all_gt vec_b32 vec_u32 = cc24t vec_all_gt BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_vcmpgtuwD
+vec_all_le vec_u32 vec_u32 = cc26t vec_all_le BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_vcmpgtuwD
+vec_all_le vec_u32 vec_b32 = cc26t vec_all_le BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_vcmpgtuwD
+vec_all_le vec_b32 vec_u32 = cc26t vec_all_le BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_vcmpgtuwD
+vec_any_gt vec_u32 vec_u32 = cc26f vec_any_gt BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_vcmpgtuwD
+vec_any_gt vec_u32 vec_b32 = cc26f vec_any_gt BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_vcmpgtuwD
+vec_any_gt vec_b32 vec_u32 = cc26f vec_any_gt BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_vcmpgtuwD
+vec_any_le vec_u32 vec_u32 = cc24f vec_any_le BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_vcmpgtuwD
+vec_any_le vec_u32 vec_b32 = cc24f vec_any_le BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_vcmpgtuwD
+vec_any_le vec_b32 vec_u32 = cc24f vec_any_le BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_vcmpgtuwD
+vec_all_gt vec_s32 vec_s32 = cc24t vec_all_gt BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_vcmpgtswD
+vec_all_gt vec_s32 vec_b32 = cc24t vec_all_gt BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_vcmpgtswD
+vec_all_gt vec_b32 vec_s32 = cc24t vec_all_gt BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_vcmpgtswD
+vec_all_le vec_s32 vec_s32 = cc26t vec_all_le BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_vcmpgtswD
+vec_all_le vec_s32 vec_b32 = cc26t vec_all_le BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_vcmpgtswD
+vec_all_le vec_b32 vec_s32 = cc26t vec_all_le BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_vcmpgtswD
+vec_any_gt vec_s32 vec_s32 = cc26f vec_any_gt BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_vcmpgtswD
+vec_any_gt vec_s32 vec_b32 = cc26f vec_any_gt BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_vcmpgtswD
+vec_any_gt vec_b32 vec_s32 = cc26f vec_any_gt BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_vcmpgtswD
+vec_any_le vec_s32 vec_s32 = cc24f vec_any_le BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_vcmpgtswD
+vec_any_le vec_s32 vec_b32 = cc24f vec_any_le BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_vcmpgtswD
+vec_any_le vec_b32 vec_s32 = cc24f vec_any_le BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_vcmpgtswD
+vec_all_lt vec_u32 vec_u32 = cc24tr vec_all_lt BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_vcmpgtuwD
+vec_all_lt vec_u32 vec_b32 = cc24tr vec_all_lt BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_vcmpgtuwD
+vec_all_lt vec_b32 vec_u32 = cc24tr vec_all_lt BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_vcmpgtuwD
+vec_all_ge vec_u32 vec_u32 = cc26tr vec_all_ge BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_vcmpgtuwD
+vec_all_ge vec_u32 vec_b32 = cc26tr vec_all_ge BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_vcmpgtuwD
+vec_all_ge vec_b32 vec_u32 = cc26tr vec_all_ge BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_vcmpgtuwD
+vec_any_lt vec_u32 vec_u32 = cc26fr vec_any_lt BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_vcmpgtuwD
+vec_any_lt vec_u32 vec_b32 = cc26fr vec_any_lt BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_vcmpgtuwD
+vec_any_lt vec_b32 vec_u32 = cc26fr vec_any_lt BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_vcmpgtuwD
+vec_any_ge vec_u32 vec_u32 = cc24fr vec_any_ge BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_vcmpgtuwD
+vec_any_ge vec_u32 vec_b32 = cc24fr vec_any_ge BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_vcmpgtuwD
+vec_any_ge vec_b32 vec_u32 = cc24fr vec_any_ge BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_vcmpgtuwD
+vec_all_lt vec_s32 vec_s32 = cc24tr vec_all_lt BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_vcmpgtswD
+vec_all_lt vec_s32 vec_b32 = cc24tr vec_all_lt BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_vcmpgtswD
+vec_all_lt vec_b32 vec_s32 = cc24tr vec_all_lt BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_vcmpgtswD
+vec_all_ge vec_s32 vec_s32 = cc26tr vec_all_ge BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_vcmpgtswD
+vec_all_ge vec_s32 vec_b32 = cc26tr vec_all_ge BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_vcmpgtswD
+vec_all_ge vec_b32 vec_s32 = cc26tr vec_all_ge BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_vcmpgtswD
+vec_any_lt vec_s32 vec_s32 = cc26fr vec_any_lt BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_vcmpgtswD
+vec_any_lt vec_s32 vec_b32 = cc26fr vec_any_lt BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_vcmpgtswD
+vec_any_lt vec_b32 vec_s32 = cc26fr vec_any_lt BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_vcmpgtswD
+vec_any_ge vec_s32 vec_s32 = cc24fr vec_any_ge BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_vcmpgtswD
+vec_any_ge vec_s32 vec_b32 = cc24fr vec_any_ge BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_vcmpgtswD
+vec_any_ge vec_b32 vec_s32 = cc24fr vec_any_ge BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_vcmpgtswD
+vec_all_eq vec_u8 vec_u8 = cc24t vec_all_eq BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_vcmpequbD
+vec_all_eq vec_u8 vec_b8 = cc24t vec_all_eq BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_vcmpequbD
+vec_all_eq vec_b8 vec_u8 = cc24t vec_all_eq BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_vcmpequbD
+vec_all_eq vec_b8 vec_b8 = cc24t vec_all_eq BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_vcmpequbD
+vec_all_ne vec_u8 vec_u8 = cc26t vec_all_ne BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_vcmpequbD
+vec_all_ne vec_u8 vec_b8 = cc26t vec_all_ne BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_vcmpequbD
+vec_all_ne vec_b8 vec_u8 = cc26t vec_all_ne BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_vcmpequbD
+vec_all_ne vec_b8 vec_b8 = cc26t vec_all_ne BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_vcmpequbD
+vec_any_eq vec_u8 vec_u8 = cc26f vec_any_eq BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_vcmpequbD
+vec_any_eq vec_u8 vec_b8 = cc26f vec_any_eq BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_vcmpequbD
+vec_any_eq vec_b8 vec_u8 = cc26f vec_any_eq BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_vcmpequbD
+vec_any_eq vec_b8 vec_b8 = cc26f vec_any_eq BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_vcmpequbD
+vec_any_ne vec_u8 vec_u8 = cc24f vec_any_ne BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_vcmpequbD
+vec_any_ne vec_u8 vec_b8 = cc24f vec_any_ne BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_vcmpequbD
+vec_any_ne vec_b8 vec_u8 = cc24f vec_any_ne BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_vcmpequbD
+vec_any_ne vec_b8 vec_b8 = cc24f vec_any_ne BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_vcmpequbD
+vec_all_eq vec_s8 vec_s8 = cc24t vec_all_eq BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_vcmpequbD
+vec_all_eq vec_s8 vec_b8 = cc24t vec_all_eq BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_vcmpequbD
+vec_all_eq vec_b8 vec_s8 = cc24t vec_all_eq BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_vcmpequbD
+vec_all_ne vec_s8 vec_s8 = cc26t vec_all_ne BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_vcmpequbD
+vec_all_ne vec_s8 vec_b8 = cc26t vec_all_ne BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_vcmpequbD
+vec_all_ne vec_b8 vec_s8 = cc26t vec_all_ne BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_vcmpequbD
+vec_any_eq vec_s8 vec_s8 = cc26f vec_any_eq BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_vcmpequbD
+vec_any_eq vec_s8 vec_b8 = cc26f vec_any_eq BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_vcmpequbD
+vec_any_eq vec_b8 vec_s8 = cc26f vec_any_eq BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_vcmpequbD
+vec_any_ne vec_s8 vec_s8 = cc24f vec_any_ne BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_vcmpequbD
+vec_any_ne vec_s8 vec_b8 = cc24f vec_any_ne BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_vcmpequbD
+vec_any_ne vec_b8 vec_s8 = cc24f vec_any_ne BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_vcmpequbD
+vec_all_eq vec_u16 vec_u16 = cc24t vec_all_eq BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_vcmpequhD
+vec_all_eq vec_u16 vec_b16 = cc24t vec_all_eq BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_vcmpequhD
+vec_all_eq vec_b16 vec_u16 = cc24t vec_all_eq BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_vcmpequhD
+vec_all_eq vec_b16 vec_b16 = cc24t vec_all_eq BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_vcmpequhD
+vec_all_eq vec_p16 vec_p16 = cc24t vec_all_eq BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_vcmpequhD
+vec_all_ne vec_u16 vec_u16 = cc26t vec_all_ne BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_vcmpequhD
+vec_all_ne vec_u16 vec_b16 = cc26t vec_all_ne BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_vcmpequhD
+vec_all_ne vec_b16 vec_u16 = cc26t vec_all_ne BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_vcmpequhD
+vec_all_ne vec_b16 vec_b16 = cc26t vec_all_ne BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_vcmpequhD
+vec_all_ne vec_p16 vec_p16 = cc26t vec_all_ne BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_vcmpequhD
+vec_any_eq vec_u16 vec_u16 = cc26f vec_any_eq BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_vcmpequhD
+vec_any_eq vec_u16 vec_b16 = cc26f vec_any_eq BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_vcmpequhD
+vec_any_eq vec_b16 vec_u16 = cc26f vec_any_eq BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_vcmpequhD
+vec_any_eq vec_b16 vec_b16 = cc26f vec_any_eq BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_vcmpequhD
+vec_any_eq vec_p16 vec_p16 = cc26f vec_any_eq BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_vcmpequhD
+vec_any_ne vec_u16 vec_u16 = cc24f vec_any_ne BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_vcmpequhD
+vec_any_ne vec_u16 vec_b16 = cc24f vec_any_ne BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_vcmpequhD
+vec_any_ne vec_b16 vec_u16 = cc24f vec_any_ne BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_vcmpequhD
+vec_any_ne vec_b16 vec_b16 = cc24f vec_any_ne BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_vcmpequhD
+vec_any_ne vec_p16 vec_p16 = cc24f vec_any_ne BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_vcmpequhD
+vec_all_eq vec_s16 vec_s16 = cc24t vec_all_eq BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_vcmpequhD
+vec_all_eq vec_s16 vec_b16 = cc24t vec_all_eq BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_vcmpequhD
+vec_all_eq vec_b16 vec_s16 = cc24t vec_all_eq BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_vcmpequhD
+vec_all_ne vec_s16 vec_s16 = cc26t vec_all_ne BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_vcmpequhD
+vec_all_ne vec_s16 vec_b16 = cc26t vec_all_ne BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_vcmpequhD
+vec_all_ne vec_b16 vec_s16 = cc26t vec_all_ne BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_vcmpequhD
+vec_any_eq vec_s16 vec_s16 = cc26f vec_any_eq BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_vcmpequhD
+vec_any_eq vec_s16 vec_b16 = cc26f vec_any_eq BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_vcmpequhD
+vec_any_eq vec_b16 vec_s16 = cc26f vec_any_eq BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_vcmpequhD
+vec_any_ne vec_s16 vec_s16 = cc24f vec_any_ne BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_vcmpequhD
+vec_any_ne vec_s16 vec_b16 = cc24f vec_any_ne BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_vcmpequhD
+vec_any_ne vec_b16 vec_s16 = cc24f vec_any_ne BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_vcmpequhD
+vec_all_eq vec_u32 vec_u32 = cc24t vec_all_eq BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_vcmpequwD
+vec_all_eq vec_u32 vec_b32 = cc24t vec_all_eq BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_vcmpequwD
+vec_all_eq vec_b32 vec_u32 = cc24t vec_all_eq BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_vcmpequwD
+vec_all_eq vec_b32 vec_b32 = cc24t vec_all_eq BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_vcmpequwD
+vec_all_ne vec_u32 vec_u32 = cc26t vec_all_ne BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_vcmpequwD
+vec_all_ne vec_u32 vec_b32 = cc26t vec_all_ne BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_vcmpequwD
+vec_all_ne vec_b32 vec_u32 = cc26t vec_all_ne BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_vcmpequwD
+vec_all_ne vec_b32 vec_b32 = cc26t vec_all_ne BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_vcmpequwD
+vec_any_eq vec_u32 vec_u32 = cc26f vec_any_eq BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_vcmpequwD
+vec_any_eq vec_u32 vec_b32 = cc26f vec_any_eq BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_vcmpequwD
+vec_any_eq vec_b32 vec_u32 = cc26f vec_any_eq BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_vcmpequwD
+vec_any_eq vec_b32 vec_b32 = cc26f vec_any_eq BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_vcmpequwD
+vec_any_ne vec_u32 vec_u32 = cc24f vec_any_ne BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_vcmpequwD
+vec_any_ne vec_u32 vec_b32 = cc24f vec_any_ne BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_vcmpequwD
+vec_any_ne vec_b32 vec_u32 = cc24f vec_any_ne BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_vcmpequwD
+vec_any_ne vec_b32 vec_b32 = cc24f vec_any_ne BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_vcmpequwD
+vec_all_eq vec_s32 vec_s32 = cc24t vec_all_eq BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_vcmpequwD
+vec_all_eq vec_s32 vec_b32 = cc24t vec_all_eq BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_vcmpequwD
+vec_all_eq vec_b32 vec_s32 = cc24t vec_all_eq BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_vcmpequwD
+vec_all_ne vec_s32 vec_s32 = cc26t vec_all_ne BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_vcmpequwD
+vec_all_ne vec_s32 vec_b32 = cc26t vec_all_ne BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_vcmpequwD
+vec_all_ne vec_b32 vec_s32 = cc26t vec_all_ne BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_vcmpequwD
+vec_any_eq vec_s32 vec_s32 = cc26f vec_any_eq BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_vcmpequwD
+vec_any_eq vec_s32 vec_b32 = cc26f vec_any_eq BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_vcmpequwD
+vec_any_eq vec_b32 vec_s32 = cc26f vec_any_eq BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_vcmpequwD
+vec_any_ne vec_s32 vec_s32 = cc24f vec_any_ne BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_vcmpequwD
+vec_any_ne vec_s32 vec_b32 = cc24f vec_any_ne BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_vcmpequwD
+vec_any_ne vec_b32 vec_s32 = cc24f vec_any_ne BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_vcmpequwD
+vec_all_gt vec_f32 vec_f32 = cc24t vec_all_gt BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_vcmpgtfpD
+vec_all_ngt vec_f32 vec_f32 = cc26t vec_all_ngt BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_vcmpgtfpD
+vec_any_ngt vec_f32 vec_f32 = cc24f vec_any_ngt BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_vcmpgtfpD
+vec_any_gt vec_f32 vec_f32 = cc26f vec_any_gt BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_vcmpgtfpD
+vec_all_lt vec_f32 vec_f32 = cc24tr vec_all_lt BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_vcmpgtfpD
+vec_all_nlt vec_f32 vec_f32 = cc26tr vec_all_nlt BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_vcmpgtfpD
+vec_any_nlt vec_f32 vec_f32 = cc24fr vec_any_nlt BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_vcmpgtfpD
+vec_any_lt vec_f32 vec_f32 = cc26fr vec_any_lt BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_vcmpgtfpD
+vec_all_ge vec_f32 vec_f32 = cc24t vec_all_ge BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_vcmpgefpD
+vec_all_nge vec_f32 vec_f32 = cc26t vec_all_nge BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_vcmpgefpD
+vec_any_nge vec_f32 vec_f32 = cc24f vec_any_nge BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_vcmpgefpD
+vec_any_ge vec_f32 vec_f32 = cc26f vec_any_ge BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_vcmpgefpD
+vec_all_le vec_f32 vec_f32 = cc24tr vec_all_le BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_vcmpgefpD
+vec_all_nle vec_f32 vec_f32 = cc26tr vec_all_nle BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_vcmpgefpD
+vec_any_nle vec_f32 vec_f32 = cc24fr vec_any_nle BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_vcmpgefpD
+vec_any_le vec_f32 vec_f32 = cc26fr vec_any_le BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_vcmpgefpD
+vec_all_eq vec_f32 vec_f32 = cc24t vec_all_eq BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_vcmpeqfpD
+vec_all_ne vec_f32 vec_f32 = cc26t vec_all_ne BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_vcmpeqfpD
+vec_any_ne vec_f32 vec_f32 = cc24f vec_any_ne BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_vcmpeqfpD
+vec_any_eq vec_f32 vec_f32 = cc26f vec_any_eq BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_vcmpeqfpD
+vec_all_numeric vec_f32 = cc24td vec_all_numeric BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_vcmpeqfpD
+vec_all_nan vec_f32 = cc26td vec_all_nan BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_vcmpeqfpD
+vec_any_nan vec_f32 = cc24fd vec_any_nan BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_vcmpeqfpD
+vec_any_numeric vec_f32 = cc26fd vec_any_numeric BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_vcmpeqfpD
+vec_all_in vec_f32 vec_f32 = cc26t vec_all_in BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_vcmpbfpD
+vec_any_out vec_f32 vec_f32 = cc26f vec_any_out BUILTIN_AFTER_TRAVERSE CFG_VEC FALSE MOP_vcmpbfpD
diff --git a/gcc/config/t-darwin b/gcc/config/t-darwin
index f5af52eb2e4..cbdb11d9325 100644
--- a/gcc/config/t-darwin
+++ b/gcc/config/t-darwin
@@ -14,7 +14,7 @@ gt-darwin.h : s-gtype ; @true
# Explain how to build crt2.o
$(T)crt2$(objext): $(srcdir)/config/darwin-crt2.c $(GCC_PASSES) \
$(TCONFIG_H) stmp-int-hdrs tsystem.h
- $(GCC_FOR_TARGET) $(GCC_CFLAGS) $(INCLUDES) $(MULTILIB_CFLAGS) \
+ $(GCC_FOR_TARGET) $(GCC_CFLAGS) $(INCLUDES) $(MULTILIB_CFLAGS) -mlongcall \
-c $(srcdir)/config/darwin-crt2.c -o $(T)crt2$(objext)
# Use unwind-dw2-fde-darwin
diff --git a/gcc/config/t-slibgcc-darwin b/gcc/config/t-slibgcc-darwin
index 34cb0d4160f..0120cf53cb9 100644
--- a/gcc/config/t-slibgcc-darwin
+++ b/gcc/config/t-slibgcc-darwin
@@ -28,3 +28,6 @@ SHLIB_INSTALL = \
$$(DESTDIR)$$(slibdir)$(SHLIB_SLIBDIR_QUAL)/$(SHLIB_SOLINK)
SHLIB_MKMAP = $(srcdir)/mkmap-symver.awk
SHLIB_MAPFILES = $(srcdir)/libgcc-darwin.ver
+
+# APPLE LOCAL libcc_kext
+SHLIB_MULTILIB=.
diff --git a/gcc/config/x-linux b/gcc/config/x-linux
deleted file mode 100644
index d14586b0b36..00000000000
--- a/gcc/config/x-linux
+++ /dev/null
@@ -1,4 +0,0 @@
-host-linux.o : $(srcdir)/config/host-linux.c $(CONFIG_H) $(SYSTEM_H) \
- coretypes.h hosthooks.h hosthooks-def.h
- $(CC) -c $(ALL_CFLAGS) $(ALL_CPPFLAGS) $(INCLUDES) \
- $(srcdir)/config/host-linux.c
diff --git a/gcc/config/x-solaris b/gcc/config/x-solaris
deleted file mode 100644
index 782f4a36802..00000000000
--- a/gcc/config/x-solaris
+++ /dev/null
@@ -1,4 +0,0 @@
-host-solaris.o : $(srcdir)/config/host-solaris.c $(CONFIG_H) $(SYSTEM_H) \
- coretypes.h hosthooks.h hosthooks-def.h
- $(CC) -c $(ALL_CFLAGS) $(ALL_CPPFLAGS) $(INCLUDES) \
- $(srcdir)/config/host-solaris.c
diff --git a/gcc/configure b/gcc/configure
index 392dddf83e3..74797cae044 100755
--- a/gcc/configure
+++ b/gcc/configure
@@ -4884,6 +4884,150 @@ test -z "$INSTALL_PROGRAM" && INSTALL_PROGRAM='${INSTALL}'
test -z "$INSTALL_DATA" && INSTALL_DATA='${INSTALL} -m 644'
+# APPLE LOCAL Mach time
+
+for ac_header in mach/mach_time.h
+do
+as_ac_Header=`echo "ac_cv_header_$ac_header" | $as_tr_sh`
+if eval "test \"\${$as_ac_Header+set}\" = set"; then
+ echo "$as_me:$LINENO: checking for $ac_header" >&5
+echo $ECHO_N "checking for $ac_header... $ECHO_C" >&6
+if eval "test \"\${$as_ac_Header+set}\" = set"; then
+ echo $ECHO_N "(cached) $ECHO_C" >&6
+fi
+echo "$as_me:$LINENO: result: `eval echo '${'$as_ac_Header'}'`" >&5
+echo "${ECHO_T}`eval echo '${'$as_ac_Header'}'`" >&6
+else
+ # Is the header compilable?
+echo "$as_me:$LINENO: checking $ac_header usability" >&5
+echo $ECHO_N "checking $ac_header usability... $ECHO_C" >&6
+cat >conftest.$ac_ext <<_ACEOF
+#line $LINENO "configure"
+/* confdefs.h. */
+_ACEOF
+cat confdefs.h >>conftest.$ac_ext
+cat >>conftest.$ac_ext <<_ACEOF
+/* end confdefs.h. */
+$ac_includes_default
+#include <$ac_header>
+_ACEOF
+rm -f conftest.$ac_objext
+if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5
+ (eval $ac_compile) 2>&5
+ ac_status=$?
+ echo "$as_me:$LINENO: \$? = $ac_status" >&5
+ (exit $ac_status); } &&
+ { ac_try='test -s conftest.$ac_objext'
+ { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
+ (eval $ac_try) 2>&5
+ ac_status=$?
+ echo "$as_me:$LINENO: \$? = $ac_status" >&5
+ (exit $ac_status); }; }; then
+ ac_header_compiler=yes
+else
+ echo "$as_me: failed program was:" >&5
+sed 's/^/| /' conftest.$ac_ext >&5
+
+ac_header_compiler=no
+fi
+rm -f conftest.$ac_objext conftest.$ac_ext
+echo "$as_me:$LINENO: result: $ac_header_compiler" >&5
+echo "${ECHO_T}$ac_header_compiler" >&6
+
+# Is the header present?
+echo "$as_me:$LINENO: checking $ac_header presence" >&5
+echo $ECHO_N "checking $ac_header presence... $ECHO_C" >&6
+cat >conftest.$ac_ext <<_ACEOF
+#line $LINENO "configure"
+/* confdefs.h. */
+_ACEOF
+cat confdefs.h >>conftest.$ac_ext
+cat >>conftest.$ac_ext <<_ACEOF
+/* end confdefs.h. */
+#include <$ac_header>
+_ACEOF
+if { (eval echo "$as_me:$LINENO: \"$ac_cpp conftest.$ac_ext\"") >&5
+ (eval $ac_cpp conftest.$ac_ext) 2>conftest.er1
+ ac_status=$?
+ grep -v '^ *+' conftest.er1 >conftest.err
+ rm -f conftest.er1
+ cat conftest.err >&5
+ echo "$as_me:$LINENO: \$? = $ac_status" >&5
+ (exit $ac_status); } >/dev/null; then
+ if test -s conftest.err; then
+ ac_cpp_err=$ac_c_preproc_warn_flag
+ else
+ ac_cpp_err=
+ fi
+else
+ ac_cpp_err=yes
+fi
+if test -z "$ac_cpp_err"; then
+ ac_header_preproc=yes
+else
+ echo "$as_me: failed program was:" >&5
+sed 's/^/| /' conftest.$ac_ext >&5
+
+ ac_header_preproc=no
+fi
+rm -f conftest.err conftest.$ac_ext
+echo "$as_me:$LINENO: result: $ac_header_preproc" >&5
+echo "${ECHO_T}$ac_header_preproc" >&6
+
+# So? What about this header?
+case $ac_header_compiler:$ac_header_preproc in
+ yes:no )
+ { echo "$as_me:$LINENO: WARNING: $ac_header: accepted by the compiler, rejected by the preprocessor!" >&5
+echo "$as_me: WARNING: $ac_header: accepted by the compiler, rejected by the preprocessor!" >&2;}
+ { echo "$as_me:$LINENO: WARNING: $ac_header: proceeding with the preprocessor's result" >&5
+echo "$as_me: WARNING: $ac_header: proceeding with the preprocessor's result" >&2;}
+ (
+ cat <<\_ASBOX
+## ------------------------------------ ##
+## Report this to bug-autoconf@gnu.org. ##
+## ------------------------------------ ##
+_ASBOX
+ ) |
+ sed "s/^/$as_me: WARNING: /" >&2
+ ;;
+ no:yes )
+ { echo "$as_me:$LINENO: WARNING: $ac_header: present but cannot be compiled" >&5
+echo "$as_me: WARNING: $ac_header: present but cannot be compiled" >&2;}
+ { echo "$as_me:$LINENO: WARNING: $ac_header: check for missing prerequisite headers?" >&5
+echo "$as_me: WARNING: $ac_header: check for missing prerequisite headers?" >&2;}
+ { echo "$as_me:$LINENO: WARNING: $ac_header: proceeding with the preprocessor's result" >&5
+echo "$as_me: WARNING: $ac_header: proceeding with the preprocessor's result" >&2;}
+ (
+ cat <<\_ASBOX
+## ------------------------------------ ##
+## Report this to bug-autoconf@gnu.org. ##
+## ------------------------------------ ##
+_ASBOX
+ ) |
+ sed "s/^/$as_me: WARNING: /" >&2
+ ;;
+esac
+echo "$as_me:$LINENO: checking for $ac_header" >&5
+echo $ECHO_N "checking for $ac_header... $ECHO_C" >&6
+if eval "test \"\${$as_ac_Header+set}\" = set"; then
+ echo $ECHO_N "(cached) $ECHO_C" >&6
+else
+ eval "$as_ac_Header=$ac_header_preproc"
+fi
+echo "$as_me:$LINENO: result: `eval echo '${'$as_ac_Header'}'`" >&5
+echo "${ECHO_T}`eval echo '${'$as_ac_Header'}'`" >&6
+
+fi
+if test `eval echo '${'$as_ac_Header'}'` = yes; then
+ cat >>confdefs.h <<_ACEOF
+#define `echo "HAVE_$ac_header" | $as_tr_cpp` 1
+_ACEOF
+
+fi
+
+done
+
+
# See if cmp has --ignore-initial.
echo "$as_me:$LINENO: checking for cmp's capabilities" >&5
echo $ECHO_N "checking for cmp's capabilities... $ECHO_C" >&6
@@ -5009,7 +5153,7 @@ if test "${gcc_cv_prog_makeinfo_modern+set}" = set; then
else
ac_prog_version=`$MAKEINFO --version 2>&1 |
sed -n 's/^.*GNU texinfo.* \([0-9][0-9.]*\).*$/\1/p'`
- echo "configure:5012: version of makeinfo is $ac_prog_version" >&5
+ echo "configure:5147: version of makeinfo is $ac_prog_version" >&5
case $ac_prog_version in
'') gcc_cv_prog_makeinfo_modern=no;;
4.[2-9]*)
diff --git a/gcc/configure.ac b/gcc/configure.ac
index 39d6b8e3674..9de04d65bfb 100644
--- a/gcc/configure.ac
+++ b/gcc/configure.ac
@@ -632,6 +632,9 @@ gcc_AC_PROG_LN_S
AC_PROG_RANLIB
gcc_AC_PROG_INSTALL
+# APPLE LOCAL Mach time
+AC_CHECK_HEADERS(mach/mach_time.h)
+
# See if cmp has --ignore-initial.
gcc_AC_PROG_CMP_IGNORE_INITIAL
diff --git a/gcc/coretypes.h b/gcc/coretypes.h
index e800d004252..bf6c20a0710 100644
--- a/gcc/coretypes.h
+++ b/gcc/coretypes.h
@@ -49,6 +49,8 @@ typedef union tree_node *tree;
Note that the cpp_reader typedef remains part of cpplib.h. */
struct cpp_reader;
+/* APPLE LOCAL AltiVec */
+struct cpp_token;
#else
diff --git a/gcc/cp/ChangeLog.apple-ppc b/gcc/cp/ChangeLog.apple-ppc
new file mode 100644
index 00000000000..775d813b0ae
--- /dev/null
+++ b/gcc/cp/ChangeLog.apple-ppc
@@ -0,0 +1,5 @@
+2004-04-02 Ziemowit Laski <zlaski@apple.com>
+
+ Remove APPLE LOCAL AltiVec code whenever possible; merge in
+ AltiVec/VECTOR_TYPE-handling code from mainline.
+
diff --git a/gcc/cp/Make-lang.in b/gcc/cp/Make-lang.in
index eb87c256dd5..f67b2500993 100644
--- a/gcc/cp/Make-lang.in
+++ b/gcc/cp/Make-lang.in
@@ -69,6 +69,15 @@ g++-cross$(exeext): g++$(exeext)
-rm -f g++-cross$(exeext)
cp g++$(exeext) g++-cross$(exeext)
+# APPLE LOCAL begin order files ilr
+ifeq ($(ORDER_FILES),yes)
+CC1PLUS_ORDER_FLAGS = `if [ -f $(srcdir)/../order-files/cc1plus.order ]; then \
+ echo -sectorder __TEXT __text $(srcdir)/../order-files/cc1plus.order -e start ; fi`
+else
+CC1PLUS_ORDER_FLAGS =
+endif
+# APPLE LOCAL end order files ilr
+
# The compiler itself.
# Shared with C front end:
CXX_C_OBJS = attribs.o c-common.o c-format.o c-pragma.o c-semantics.o c-lex.o \
@@ -77,20 +86,29 @@ CXX_C_OBJS = attribs.o c-common.o c-format.o c-pragma.o c-semantics.o c-lex.o \
c-simplify.o tree-inline.o
# Language-specific object files.
-CXX_OBJS = cp/call.o cp/decl.o cp/expr.o cp/pt.o cp/typeck2.o \
+# APPLE LOCAL Objective-C++
+CXX_AND_OBJCP_OBJS = cp/call.o cp/decl.o cp/expr.o cp/pt.o cp/typeck2.o \
cp/class.o cp/decl2.o cp/error.o cp/lex.o cp/parser.o cp/ptree.o cp/rtti.o \
cp/typeck.o cp/cvt.o cp/except.o cp/friend.o cp/init.o cp/method.o \
cp/search.o cp/semantics.o cp/tree.o cp/repo.o cp/dump.o cp/optimize.o \
- cp/mangle.o cp/cp-lang.o cp/name-lookup.o cp/cxx-pretty-print.o \
+ cp/mangle.o cp/name-lookup.o cp/cxx-pretty-print.o \
cp/cp-simplify.o tree-mudflap.o cp/cp-mudflap.o
+# APPLE LOCAL begin Objective-C++
+# APPLE LOCAL debugging
+CXX_OBJS = $(CXX_AND_OBJCP_OBJS) cp/cp-lang.o cp/cp-idebug.o \
+ stub-objc.o # cp/cp-dmp-tree.o
+# APPLE LOCAL end Objective-C++
+
# Use strict warnings for this front end.
cp-warn = $(STRICT_WARN) $(WERROR)
+# APPLE LOCAL order files ilr
cc1plus$(exeext): $(CXX_OBJS) $(CXX_C_OBJS) $(BACKEND) \
libcpp.a $(LIBDEPS)
$(CC) $(ALL_CFLAGS) $(LDFLAGS) -o $@ \
- $(CXX_OBJS) $(CXX_C_OBJS) $(BACKEND) libcpp.a $(LIBS)
+ $(CXX_OBJS) $(CXX_C_OBJS) $(BACKEND) libcpp.a $(LIBS) \
+ $(CC1PLUS_ORDER_FLAGS)
# Special build rules.
$(srcdir)/cp/cfns.h: $(srcdir)/cp/cfns.gperf
@@ -260,7 +278,19 @@ cp/semantics.o: cp/semantics.c $(CXX_TREE_H) $(TM_H) cp/lex.h except.h toplev.h
cp/dump.o: cp/dump.c $(CXX_TREE_H) $(TM_H) tree-dump.h
cp/optimize.o: cp/optimize.c $(CXX_TREE_H) $(TM_H) rtl.h integrate.h insn-config.h \
input.h $(PARAMS_H) debug.h tree-inline.h tree-simple.h
-cp/mangle.o: cp/mangle.c $(CXX_TREE_H) $(TM_H) toplev.h real.h gt-cp-mangle.h $(TM_P_H)
+cp/mangle.o: cp/mangle.c $(CXX_TREE_H) $(TM_H) toplev.h real.h gt-cp-mangle.h \
+ $(TARGET_H) $(TM_P_H)
+
+# APPLE LOCAL debugging
+# Suppress all warnings explicitly for the idebug builds since there can be
+# many when, and if, -traditional-cpp is used.
+cp/cp-idebug.o: cp/cp-idebug.c $(CXX_TREE_H) $(TM_H) $(RTL_H) flags.h idebug.c
+ $(CC) -c $(ALL_CFLAGS) $(ALL_CPPFLAGS) $(INCLUDES) $(BIG_SWITCHFLAG) \
+ -w -Wno-traditional $(srcdir)/cp/cp-idebug.c -o cp/cp-idebug.o
+
+# APPLE LOCAL new tree dump
+cp/cp-dmp-tree.o: cp/cp-dmp-tree.c $(CXX_TREE_H) $(SYSTEM_H) $(TM_H) coretypes.h \
+ dmp-tree.h c-dmp-tree.c
cp/parser.o: cp/parser.c $(CXX_TREE_H) $(TM_H) diagnostic.h gt-cp-parser.h \
output.h
diff --git a/gcc/cp/call.c b/gcc/cp/call.c
index b8d72f4f348..3020b9c6543 100644
--- a/gcc/cp/call.c
+++ b/gcc/cp/call.c
@@ -660,8 +660,7 @@ standard_conversion (tree to, tree from, tree expr)
else if (tcode == POINTER_TYPE && fcode == POINTER_TYPE
&& TREE_CODE (TREE_TYPE (to)) == VECTOR_TYPE
&& TREE_CODE (TREE_TYPE (from)) == VECTOR_TYPE
- && ((*targetm.vector_opaque_p) (TREE_TYPE (to))
- || (*targetm.vector_opaque_p) (TREE_TYPE (from))))
+ && vector_types_compatible_p (TREE_TYPE (to), TREE_TYPE (from)))
conv = build_conv (ck_std, to, conv);
else if ((tcode == INTEGER_TYPE && fcode == POINTER_TYPE)
|| (tcode == POINTER_TYPE && fcode == INTEGER_TYPE))
@@ -820,8 +819,7 @@ standard_conversion (tree to, tree from, tree expr)
conv->rank = cr_promotion;
}
else if (fcode == VECTOR_TYPE && tcode == VECTOR_TYPE
- && ((*targetm.vector_opaque_p) (from)
- || (*targetm.vector_opaque_p) (to)))
+ && vector_types_compatible_p (from, to))
return build_conv (ck_std, to, conv);
else if (IS_AGGR_TYPE (to) && IS_AGGR_TYPE (from)
&& is_properly_derived_from (from, to))
@@ -3363,7 +3361,7 @@ build_conditional_expr (tree arg1, tree arg2, tree arg3)
We need to force the lvalue-to-rvalue conversion here for class types,
so we get TARGET_EXPRs; trying to deal with a COND_EXPR of class rvalues
that isn't wrapped with a TARGET_EXPR plays havoc with exception
- regions. */
+ regions. */
arg2 = force_rvalue (arg2);
if (!CLASS_TYPE_P (arg2_type))
@@ -4061,6 +4059,36 @@ enforce_access (tree basetype_path, tree decl)
return true;
}
+/* APPLE LOCAL begin direct-binding-refs turly 20020224 */
+
+/* Should we *really* call a constructor for the object whose reference type
+ we want? If we have a user conversion function which returns the ref
+ type directly, there's no need to call the object's constructor as we
+ can bind directly (dcl.init.ref.)
+
+ These must be exactly the same types. */
+
+static int really_call_constructor_p (tree, tree, tree);
+static int
+really_call_constructor_p (tree expr, tree convfn, tree totype)
+{
+ /* TEMPORARILY DISABLING THIS "FIX" NOW WE HAVE A SOURCE WORKAROUND. */
+ /* However, we'll leave the code here pending input from the FSF
+ on this issue. */
+
+ if (0 /* && ! NEED_TEMPORARY_P (convfn) Watch out! this macro is undefined */
+ && TREE_CODE (expr) == INDIRECT_REF
+ && TREE_CODE (TREE_TYPE (convfn)) == METHOD_TYPE
+ && TREE_CODE (TREE_TYPE (TREE_TYPE (convfn))) == REFERENCE_TYPE
+ && TREE_CODE (TREE_TYPE (TREE_TYPE (TREE_TYPE (convfn)))) == RECORD_TYPE
+ && TREE_TYPE (TREE_TYPE (TREE_TYPE (convfn))) == totype
+ && TREE_TYPE (expr) == totype)
+ return 0;
+
+ return 1;
+}
+/* APPLE LOCAL end direct-binding-refs turly 20020224 */
+
/* Initialize a temporary of type TYPE with EXPR. The FLAGS are a
bitwise or of LOOKUP_* values. If any errors are warnings are
generated, set *DIAGNOSTIC_FN to "error" or "warning",
@@ -4172,6 +4200,8 @@ convert_like_real (conversion *convs, tree expr, tree fn, int argnum,
If the target is a class, that means call a ctor. */
if (IS_AGGR_TYPE (totype)
+ /* APPLE LOCAL direct-binding-refs turly 20020224 */
+ && really_call_constructor_p (expr, convfn, totype)
&& (inner >= 0 || !lvalue_p (expr)))
{
expr = (build_temp
@@ -4812,7 +4842,11 @@ build_over_call (struct z_candidate *cand, int flags)
mark_used (fn);
- if (DECL_VINDEX (fn) && (flags & LOOKUP_NONVIRTUAL) == 0)
+ /* APPLE LOCAL begin -findirect-virtual-calls 2001-10-30 sts */
+ if (DECL_VINDEX (fn)
+ && (flag_indirect_virtual_calls
+ || (flags & LOOKUP_NONVIRTUAL) == 0))
+ /* APPLE LOCAL end -findirect-virtual-calls 2001-10-30 sts */
{
tree t, *p = &TREE_VALUE (converted_args);
tree binfo = lookup_base (TREE_TYPE (TREE_TYPE (*p)),
@@ -4826,6 +4860,33 @@ build_over_call (struct z_candidate *cand, int flags)
t = build_pointer_type (TREE_TYPE (fn));
if (DECL_CONTEXT (fn) && TYPE_JAVA_INTERFACE (DECL_CONTEXT (fn)))
fn = build_java_interface_fn_ref (fn, *p);
+ /* APPLE LOCAL begin -findirect-virtual-calls 2001-10-30 sts */
+ /* If this is not really supposed to be a virtual call, find the
+ vtable corresponding to the correct type, and use it. */
+ else if (flags & LOOKUP_NONVIRTUAL) {
+ tree call_site_type = TREE_TYPE (cand->access_path);
+ tree fn_class_type = DECL_CLASS_CONTEXT (fn);
+
+ my_friendly_assert (call_site_type != NULL &&
+ fn_class_type != NULL &&
+ AGGREGATE_TYPE_P (call_site_type) &&
+ AGGREGATE_TYPE_P (fn_class_type),
+ 20020717);
+ my_friendly_assert(lookup_base(TYPE_MAIN_VARIANT (call_site_type),
+ TYPE_MAIN_VARIANT (fn_class_type),
+ ba_any | ba_quiet,
+ NULL) != NULL,
+ 20020719);
+
+ if (TYPE_USES_MULTIPLE_INHERITANCE (call_site_type)
+ || TYPE_USES_VIRTUAL_BASECLASSES (call_site_type))
+ error ("indirect virtual calls are invalid for a type that uses multiple or virtual inheritance");
+
+ fn = (build_vfn_ref_using_vtable
+ (BINFO_VTABLE (TYPE_BINFO (call_site_type)),
+ DECL_VINDEX (fn)));
+ }
+ /* APPLE LOCAL end -findirect-virtual-calls 2001-10-30 sts */
else
fn = build_vfn_ref (build_indirect_ref (*p, 0), DECL_VINDEX (fn));
TREE_TYPE (fn) = t;
diff --git a/gcc/cp/class.c b/gcc/cp/class.c
index dca5fe90363..a53548dab62 100644
--- a/gcc/cp/class.c
+++ b/gcc/cp/class.c
@@ -228,6 +228,9 @@ int n_compute_conversion_costs = 0;
int n_inner_fields_searched = 0;
#endif
+/* APPLE LOCAL Macintosh alignment 2002-5-24 ff */
+extern int darwin_align_is_first_member_of_class;
+
/* Convert to or from a base subobject. EXPR is an expression of type
`A' or `A*', an expression of type `B' or `B*' is returned. To
convert A to a base B, CODE is PLUS_EXPR and BINFO is the binfo for
@@ -452,6 +455,11 @@ build_vtbl_ref_1 (tree instance, tree idx)
assemble_external (vtbl);
+ /* APPLE LOCAL double destructor turly 20020301 */
+#ifdef ADJUST_VTABLE_INDEX
+ ADJUST_VTABLE_INDEX (idx, vtbl);
+#endif
+
aref = build_array_ref (vtbl, idx);
TREE_CONSTANT (aref) |= TREE_CONSTANT (vtbl) && TREE_CONSTANT (idx);
TREE_INVARIANT (aref) = TREE_CONSTANT (aref);
@@ -484,6 +492,30 @@ build_vfn_ref (tree instance, tree idx)
return aref;
}
+/* APPLE LOCAL begin -findirect-virtual-calls 2001-10-30 sts */
+/* Given a VTBL and an IDX, return an expression for the function
+ pointer located at the indicated index. BASETYPE is the static
+ type of the object containing the vtable. */
+
+tree
+build_vfn_ref_using_vtable (tree vtbl, tree idx)
+{
+ tree aref;
+
+ assemble_external (vtbl);
+
+ /* APPLE LOCAL double destructor turly 20020301 */
+#ifdef ADJUST_VTABLE_INDEX
+ ADJUST_VTABLE_INDEX (idx, vtbl);
+#endif
+
+ aref = build_array_ref (vtbl, idx);
+ TREE_CONSTANT (aref) = 1;
+
+ return aref;
+}
+/* APPLE LOCAL end -findirect-virtual-calls 2001-10-30 sts */
+
/* Return the name of the virtual function table (as an IDENTIFIER_NODE)
for the given TYPE. */
@@ -1778,9 +1810,27 @@ layout_vtable_decl (tree binfo, int n)
{
tree atype;
tree vtable;
+ /* APPLE LOCAL begin terminated-vtables */
+ int n_entries;
+
+ n_entries = n;
+
+ /* Enlarge suggested vtable size by one entry; it will be filled
+ with a zero word. Darwin kernel dynamic-driver loader looks
+ for this value to find vtable ends for patching.
+
+ Kludge: IOKit project all use -findirect_virtual_calls, and all
+ will need the newly-created -fterminated_vtables flag when built
+ with GCC3, so as a short-term hack to avoid updating
+ eighty-odd IOKit projects, enable both when we see the one currently
+ used by all IOKit projects. */
+ if (flag_terminated_vtables || flag_indirect_virtual_calls)
+ n_entries += 1;
+ /* APPLE LOCAL end terminated-vtables */
atype = build_cplus_array_type (vtable_entry_type,
- build_index_type (size_int (n - 1)));
+ /* APPLE LOCAL terminated-vtables */
+ build_index_type (size_int (n_entries - 1)));
layout_type (atype);
/* We may have to grow the vtable. */
@@ -3830,6 +3880,104 @@ build_clone (tree fn, tree name)
return clone;
}
+/* APPLE LOCAL begin double destructor turly 20020212 */
+
+/* Return whether CLASS or any of its ancestors have the
+ "apple_kext_compatibility" attribute, in which case the non-deleting
+ destructor is not emitted.
+
+ Note that this only works for single inheritance. */
+int
+has_apple_kext_compatibility_attr_p (tree class)
+{
+ while (class != NULL)
+ {
+ if (TYPE_USES_MULTIPLE_INHERITANCE (class))
+ return 0;
+
+ if (lookup_attribute ("apple_kext_compatibility",
+ TYPE_ATTRIBUTES (class)))
+ return 1;
+
+ /* Multiple inheritance here? Just say no. */
+ if (CLASSTYPE_N_BASECLASSES (class) == 1)
+ class = TYPE_BINFO_BASETYPE (class, 0);
+ else
+ break;
+ }
+
+ return 0;
+}
+
+/* TRUE if we have an operator delete which is empty (i.e., NO CODE!) */
+int
+has_empty_operator_delete_p (tree class)
+{
+ if (class != NULL)
+ {
+ if (TYPE_USES_MULTIPLE_INHERITANCE (class))
+ return 0;
+
+ if (TYPE_GETS_DELETE (class))
+ {
+ tree f = lookup_fnfields (TYPE_BINFO (class),
+ ansi_opname (DELETE_EXPR), 0);
+
+ if (f == error_mark_node)
+ return 0;
+
+ if (BASELINK_P (f))
+ f = TREE_VALUE (f);
+
+ if (OVL_CURRENT (f))
+ {
+ f = OVL_CURRENT (f);
+
+ /* We've overridden TREE_SIDE_EFFECTS for C++ operator deletes
+ to mean that the function is empty. */
+ if (TREE_SIDE_EFFECTS (f))
+ return 1;
+
+ /* Otherwise, it could be an inline but empty function. */
+ if (DECL_SAVED_TREE (f)
+ && TREE_CODE (DECL_SAVED_TREE (f)) == COMPOUND_STMT
+ && COMPOUND_BODY (DECL_SAVED_TREE (f)))
+ return compound_body_is_empty_p (COMPOUND_BODY
+ (DECL_SAVED_TREE (f)));
+ }
+ }
+ }
+
+ return 0;
+}
+
+/* Walk through a COMPOUND_STMT and return true if nothing in there would
+ cause us to generate code. */
+int
+compound_body_is_empty_p (tree t)
+{
+ while (t && t != error_mark_node)
+ {
+ enum tree_code tc = TREE_CODE (t);
+ if (tc == COMPOUND_STMT)
+ {
+ if (compound_body_is_empty_p (COMPOUND_BODY (t)))
+ t = TREE_CHAIN (t);
+ else
+ return 0;
+ }
+ else
+ if (tc == SCOPE_STMT)
+ t = TREE_CHAIN (t);
+ else
+ return 0;
+ }
+ /* We hit the end of the body function without seeing anything. */
+ return 1;
+}
+
+/* APPLE LOCAL end double destructor turly 20020212 */
+
/* Produce declarations for all appropriate clones of FN. If
UPDATE_METHOD_VEC_P is nonzero, the clones are added to the
CLASTYPE_METHOD_VEC as well. */
@@ -3874,9 +4022,17 @@ clone_function_decl (tree fn, int update_method_vec_p)
if (update_method_vec_p)
add_method (DECL_CONTEXT (clone), clone, /*error_p=*/0);
}
- clone = build_clone (fn, complete_dtor_identifier);
- if (update_method_vec_p)
- add_method (DECL_CONTEXT (clone), clone, /*error_p=*/0);
+
+ /* APPLE LOCAL double destructor turly 20020212 */
+ /* Don't use the complete dtor. */
+ if (! flag_apple_kext
+ || ! has_apple_kext_compatibility_attr_p (DECL_CONTEXT (fn)))
+ {
+ clone = build_clone (fn, complete_dtor_identifier);
+ if (update_method_vec_p)
+ add_method (DECL_CONTEXT (clone), clone, /*error_p=*/0);
+ }
+
clone = build_clone (fn, base_dtor_identifier);
if (update_method_vec_p)
add_method (DECL_CONTEXT (clone), clone, /*error_p=*/0);
@@ -4593,6 +4749,13 @@ layout_class_type (tree t, tree *virtuals_p)
NULL, NULL);
build_base_fields (rli, empty_base_offsets, next_field);
+ /* APPLE LOCAL begin Macintosh alignment 2002-5-24 ff */
+ /* Turn on this flag until the first real member of the class is
+ laid out. (Enums and such things declared in the class do not
+ count.) */
+ darwin_align_is_first_member_of_class = 1;
+ /* APPLE LOCAL end Macintosh alignment 2002-5-24 ff */
+
/* Layout the non-static data members. */
for (field = non_static_data_members; field; field = TREE_CHAIN (field))
{
@@ -4705,6 +4868,12 @@ layout_class_type (tree t, tree *virtuals_p)
layout_nonempty_base_or_field (rli, field, NULL_TREE,
empty_base_offsets);
+ /* APPLE LOCAL begin Macintosh alignment 2002-5-24 ff */
+ /* When we reach here we have laid out the first real member of
+ the class. */
+ darwin_align_is_first_member_of_class = 0;
+ /* APPLE LOCAL end Macintosh alignment 2002-5-24 ff */
+
/* Remember the location of any empty classes in FIELD. */
if (abi_version_at_least (2))
record_subobject_offsets (TREE_TYPE (field),
@@ -4756,6 +4925,12 @@ layout_class_type (tree t, tree *virtuals_p)
last_field_was_bitfield = DECL_C_BIT_FIELD (field);
}
+ /* APPLE LOCAL begin Macintosh alignment 2002-5-24 ff */
+ /* Make sure the flag is turned off in cases where there were no
+ real members in the class. */
+ darwin_align_is_first_member_of_class = 0;
+
+ /* APPLE LOCAL end Macintosh alignment 2002-5-24 ff */
if (abi_version_at_least (2) && !integer_zerop (rli->bitpos))
{
/* Make sure that we are on a byte boundary so that the size of
@@ -5609,6 +5784,15 @@ push_lang_context (tree name)
{
current_lang_name = name;
}
+ /* APPLE LOCAL begin Objective-C++ */
+ else if (name == lang_name_objc)
+ {
+ /* Suppress the warning for now, make it informative. */
+ inform ("`extern \"Objective-C\"' is deprecated; "
+ "use `extern \"C\"' instead");
+ current_lang_name = lang_name_c;
+ }
+ /* APPLE LOCAL end Objective-C++ */
else
error ("language string `\"%s\"' not recognized", IDENTIFIER_POINTER (name));
}
@@ -7203,6 +7387,19 @@ dfs_accumulate_vtbl_inits (tree binfo,
index = size_binop (MULT_EXPR,
TYPE_SIZE_UNIT (vtable_entry_type),
index);
+ /* APPLE LOCAL begin double destructor turly 20020301 */
+#ifdef VPTR_INITIALIZER_ADJUSTMENT
+ /* Subtract VPTR_INITIALIZER_ADJUSTMENT from INDEX. */
+ if (flag_apple_kext && !ctor_vtbl_p && ! BINFO_PRIMARY_P (binfo)
+ && TREE_CODE (index) == INTEGER_CST
+ && TREE_INT_CST_LOW (index) >= VPTR_INITIALIZER_ADJUSTMENT
+ && TREE_INT_CST_HIGH (index) == 0)
+ index = fold (build (MINUS_EXPR,
+ TREE_TYPE (index), index,
+ size_int (VPTR_INITIALIZER_ADJUSTMENT)));
+#endif
+ /* APPLE LOCAL end double destructor turly 20020301 */
+
vtbl = build (PLUS_EXPR, TREE_TYPE (vtbl), vtbl, index);
}
diff --git a/gcc/cp/cp-dmp-tree.c b/gcc/cp/cp-dmp-tree.c
new file mode 100644
index 00000000000..3827e3d7fbd
--- /dev/null
+++ b/gcc/cp/cp-dmp-tree.c
@@ -0,0 +1,1326 @@
+/* APPLE LOCAL file new tree dump */
+/* Common condensed c++ tree display routines. Based on dmp-tree.c
+ Copyright (C) 2001 Free Software Foundation, Inc.
+ Contributed by Devang Patel (dpatel@apple.com)
+ and Ira L. Ruben (ira@apple.com)
+
+This file is part of GNU CC.
+
+GNU CC is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2, or (at your option)
+any later version.
+
+GNU CC is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+GNU General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with GNU CC; see the file COPYING. If not, write to
+the Free Software Foundation, 59 Temple Place - Suite 330,
+Boston, MA 02111-1307, USA. */
+
+/* Both C and C++ node handling is required for C++. The C handling is
+ done in c-dmp-tree.c. But that is a C language specific file, i.e.,
+ only built for C. Thus we need to #include it here to get the stuff
+ we need defined. But we need to tell c-dmp-tree.c that we are doing
+ this so it doesn't define stuff we don't want defined. That's the
+ purpose of the CP_DMP_TREE switch.
+
+ Note that c-dmp-tree.c does all the main #includes so we don't need
+ them here. */
+
+#define CP_DMP_TREE
+#include "c-dmp-tree.c"
+
+#include "cp-tree.h"
+
+int cp_dump_tree_p (FILE *, const char *, tree, int);
+lang_dump_tree_p_t cp_prev_lang_dump_tree_p = NULL;
+
+#define DEFTREECODE(SYM, NAME, TYPE, LENGTH) \
+static void print_ ## SYM (FILE *file, const char *annotation, tree node, int indent);
+#include "cp-tree.def"
+#undef DEFTREECODE
+
+static void print_RECORD_TYPE (FILE *, const char *, tree, int);
+static void print_NAMESPACE_DECL (FILE *, const char *, tree, int);
+static void print_ADDR_EXPR (FILE *, const char *, tree, int);
+
+/*-------------------------------------------------------------------*/
+
+/* Called twice for dmp-tree() for an IDENTIFIER_NODE. The first call
+ is after the common info for the node is generated but before
+ displaying the identifer (before_id==0) which is always assumed
+ to be the last thing on the line.
+
+ The second call is done after the id is displayed (before_id!=0).
+ This is for displaying any language-specific node information that
+ should be preceded by an newline_and_indent() call or a recursive
+ call to dump_tree() for nodes which are language specific operands
+ to a IDENTIFIER_NODE. */
+
+void
+cxx_dump_identifier (FILE *file,
+ tree node,
+ int indent ATTRIBUTE_UNUSED,
+ int after_id)
+{
+ if (!after_id)
+ {
+ if (C_IS_RESERVED_WORD (node))
+ fputs (" reserved", file);
+ if (IDENTIFIER_CTOR_OR_DTOR_P (node))
+ fputs (" ctor/dtor", file);
+ if (IDENTIFIER_NAMESPACE_BINDINGS (node))
+ {
+ fprintf (file, " ns-bindings=");
+ fprintf (file, HOST_PTR_PRINTF, IDENTIFIER_NAMESPACE_BINDINGS (node));
+ }
+ if (IDENTIFIER_CLASS_VALUE (node))
+ {
+ fprintf (file, " binding=");
+ fprintf (file, HOST_PTR_PRINTF, IDENTIFIER_CLASS_VALUE (node));
+ }
+ if (IDENTIFIER_BINDING (node))
+ {
+ fprintf (file, " lcl-bindings=");
+ fprintf (file, HOST_PTR_PRINTF, IDENTIFIER_BINDING (node));
+ }
+ if (IDENTIFIER_LABEL_VALUE (node))
+ {
+ fprintf (file, " gbl=");
+ fprintf (file, HOST_PTR_PRINTF, IDENTIFIER_LABEL_VALUE (node));
+ }
+ if (IDENTIFIER_TEMPLATE (node))
+ {
+ fprintf (file, " tmpl=");
+ fprintf (file, HOST_PTR_PRINTF, IDENTIFIER_TEMPLATE (node));
+ }
+ if (IDENTIFIER_IMPLICIT_DECL (node))
+ {
+ fprintf (file, " impl=");
+ fprintf (file, HOST_PTR_PRINTF, IDENTIFIER_IMPLICIT_DECL (node));
+ }
+ if (IDENTIFIER_ERROR_LOCUS (node))
+ {
+ fprintf (file, " err-locus=");
+ fprintf (file, HOST_PTR_PRINTF, IDENTIFIER_ERROR_LOCUS (node));
+ }
+ }
+ else
+ {
+#if 0
+ dump_binding (file, "(bindings)", IDENTIFIER_NAMESPACE_BINDINGS (node), indent + INDENT);
+#endif
+ dump_tree (file, "(class)", IDENTIFIER_CLASS_VALUE (node), indent + INDENT);
+#if 0
+ dump_binding (file, "(lcl-bindings)", IDENTIFIER_BINDING (node), indent + INDENT);
+#endif
+ dump_tree (file, "(lbl)", IDENTIFIER_LABEL_VALUE (node), indent + INDENT);
+ dump_tree (file, "(tmpl)", IDENTIFIER_TEMPLATE (node), indent + INDENT);
+ dump_tree (file, "(impl)", IDENTIFIER_IMPLICIT_DECL (node), indent + INDENT);
+ dump_tree (file, "(err-locus)", IDENTIFIER_ERROR_LOCUS (node), indent + INDENT);
+ }
+}
+
+/* Called twice for dmp_tree() for a ..._DECL node. The first call
+ after the common info for the node is generated but before
+ displaying the identifier (before_id==0) which is always assumed
+ to be the last thing on the line.
+
+ The second call is done after the id is displayed (before_id!=0).
+ This is for displaying any language-specific node information that
+ should be preceded by an newline_and_indent() call or a recursive
+ call to dump_tree() for nodes which are language specific operands
+ to a ..._DECL node. */
+
+void
+cxx_dump_decl (FILE *file, tree node, int indent ATTRIBUTE_UNUSED, int after_id)
+{
+ switch (TREE_CODE (node))
+ {
+ case FUNCTION_DECL:
+ if (!after_id)
+ {
+ if (DECL_STATIC_FUNCTION_P (node))
+ fputs (" static", file);
+ if (DECL_FRIEND_P (node))
+ fputs (" frnd", file);
+ if (DECL_CONSTRUCTOR_P (node))
+ fprintf (file, " %sctor",
+ DECL_COPY_CONSTRUCTOR_P (node) ? "cpy-" : "");
+ if (DECL_DESTRUCTOR_P (node))
+ fputs (" dtor", file);
+ if (DECL_PURE_VIRTUAL_P (node))
+ fputs (" pure-virt", file);
+ if (DECL_CONST_MEMFUNC_P (node))
+ fputs (" const", file);
+ if (DECL_VOLATILE_MEMFUNC_P (node))
+ fputs (" volatile", file);
+ if (DECL_MUTABLE_P (node))
+ fputs (" mutable", file);
+ if (DECL_THUNK_P (node))
+ fputs (" thnk", file);
+ if (DECL_LANG_SPECIFIC (node))
+ {
+ if (DECL_PENDING_INLINE_INFO (node))
+ {
+ fprintf (file, " pending-inline-info=");
+ fprintf (file, HOST_PTR_PRINTF,
+ HOST_PTR_PRINTF_VALUE (DECL_PENDING_INLINE_INFO (node)));
+ }
+ if (DECL_TEMPLATE_INFO (node))
+ {
+ fprintf (file, " tmpl-info=");
+ fprintf (file, HOST_PTR_PRINTF,
+ HOST_PTR_PRINTF_VALUE (DECL_TEMPLATE_INFO (node)));
+ }
+ }
+ }
+ break;
+
+ case FIELD_DECL:
+ if (!after_id)
+ {
+ if (DECL_MUTABLE_P (node))
+ fputs (" mutable", file);
+ }
+ break;
+
+ case TYPE_DECL:
+ if (!after_id)
+ {
+ if (DECL_LANG_SPECIFIC (node))
+ {
+ if (DECL_TEMPLATE_INFO (node))
+ {
+ fprintf (file, " tmpl-info=");
+ fprintf (file, HOST_PTR_PRINTF,
+ HOST_PTR_PRINTF_VALUE (DECL_TEMPLATE_INFO (node)));
+ }
+ if (DECL_SORTED_FIELDS (node))
+ {
+ fprintf (file, " sorted-fields=");
+ fprintf (file, HOST_PTR_PRINTF,
+ HOST_PTR_PRINTF_VALUE (DECL_SORTED_FIELDS (node)));
+ }
+ }
+ }
+ break;
+
+ case VAR_DECL:
+ if (!after_id)
+ {
+ if (DECL_LANG_SPECIFIC (node))
+ {
+ if (DECL_TEMPLATE_INFO (node))
+ {
+ fprintf (file, " tmpl-info=");
+ fprintf (file, HOST_PTR_PRINTF,
+ HOST_PTR_PRINTF_VALUE (DECL_TEMPLATE_INFO (node)));
+ }
+ }
+ if (DECL_SHADOWED_FOR_VAR (node))
+ fputs (" shadowed", file);
+ }
+ break;
+
+ default:
+ break;
+ }
+}
+
+/* Called twice for dmp_tree() for a ..._TYPE node. The first call
+ after the common info for the node is generated but before
+ displaying the identifier (before_id==0) which is always assumed
+ to be the last thing on the line.
+
+ The second call is done after the id is displayed (before_id!=0).
+ This is for displaying any language-specific node information that
+ should be preceded by an newline_and_indent() call or a recursive
+ call to dump_tree() for nodes which are language specific operands
+ to a ..._TYPE node. */
+
+void
+cxx_dump_type (FILE *file, tree node, int indent, int after_id)
+{
+ if (!after_id)
+ {
+ if (CLASS_TYPE_P (node)) /* RECORD_TYPE, UNION_TYPE only */
+ {
+ if (TYPE_NEEDS_CONSTRUCTING (node))
+ fputs (" needs-ctor", file);
+ if (TYPE_HAS_NONTRIVIAL_DESTRUCTOR (node))
+ fputs (" needs-dtor", file);
+ if (TYPE_HAS_DESTRUCTOR (node))
+ fputs (" ~X()", file);
+ if (TYPE_HAS_DEFAULT_CONSTRUCTOR (node))
+ fputs (" X()", file);
+ if (TYPE_HAS_CONVERSION (node))
+ fputs (" has-conv", file);
+ if (TYPE_HAS_INIT_REF (node))
+ {
+ if (TYPE_HAS_CONST_INIT_REF (node))
+ fputs (" X(constX&)", file);
+ else
+ fputs (" X(X&)", file);
+ }
+ if (TYPE_HAS_NEW_OPERATOR (node))
+ fputs (" new", file);
+ if (TYPE_HAS_ARRAY_NEW_OPERATOR (node))
+ fputs (" new[]", file);
+ if (TYPE_GETS_DELETE (node) & 1)
+ fputs (" delete", file);
+ if (TYPE_GETS_DELETE (node) & 2)
+ fputs (" delete[]", file);
+ if (TYPE_HAS_ASSIGN_REF (node))
+ fputs (" this=(X&)", file);
+ if (TYPE_USES_MULTIPLE_INHERITANCE (node))
+ fputs (" uses-mult-inh", file);
+ }
+ }
+
+ switch (TREE_CODE (node))
+ {
+ case FUNCTION_TYPE:
+ case METHOD_TYPE:
+ if (!after_id)
+ {
+ if (TYPE_RAISES_EXCEPTIONS (node))
+ {
+ fprintf (file, " throws=");
+ fprintf (file, HOST_PTR_PRINTF,
+ HOST_PTR_PRINTF_VALUE (TYPE_RAISES_EXCEPTIONS (node)));
+ }
+ }
+ else
+ {
+ if (TYPE_RAISES_EXCEPTIONS (node))
+ dump_tree (file, "(throws)", TYPE_RAISES_EXCEPTIONS (node),
+ indent + INDENT);
+ }
+ break;
+
+ default:
+ break;
+ }
+}
+
+/* Normally a blank line is inserted before each statement node (a
+ statement node is determined by calling statement_code_p()). This
+ makes the display easier to read by keeping each statement grouped
+ like a paragraph. There may, however, be some kinds of statements
+ where a blank line isn't desired (e.g., a begin SCOPE_STMT in C).
+ Thus dump_lang_blank_line() is called to ask if a particular
+ statement should be preceded by a blank line dependent upon the
+ node that preceded it.
+
+ dump_lang_blank_line_p() is called for each statement passing the
+ previous node (not necessarily a statement) and current node (a
+ statement node by definition). It should return 1 if a blank
+ line is to be inserted and 0 otherwise. */
+
+int
+cxx_dump_blank_line_p (tree previous_node ATTRIBUTE_UNUSED,
+ tree current_node ATTRIBUTE_UNUSED)
+{
+ return 1;
+}
+
+/* This is called for each node to display file and/or line number
+ information for those nodes that have such information. If it
+ is displayed the function should return 1. If not, 0.
+
+ The function generally does not have to handle ..._DECL nodes
+ unless there some special handling is reequired. They are
+ handled by print_lineno() (dump_lang_lineno_p()'s caller).
+ It is defined to not repeat the filename if it does not
+ change from what's in dump_tree_state.curr_file and then
+ it only displays the basename (using lbasename()). The
+ format of the display is " line=nbr(basename)" where the
+ leading space is included as usual in these displays and
+ the parenthesized basename omitted if not needed or is
+ the same as before. */
+
+int
+cxx_dump_lineno_p (FILE *file ATTRIBUTE_UNUSED, tree node ATTRIBUTE_UNUSED)
+{
+ return 0;
+}
+
+/* Called only by tree-dump.c when doing a full compilation tree dump
+ under one of the -fdmp-xxxx options. This makes tree_dump.c, which
+ is common to all languages, independent of dmp_tree, which currently
+ only supports the c languages. */
+int
+cxx_dmp_tree3 (file, node, flags)
+ FILE *file;
+ tree node;
+ int flags;
+{
+ dmp_tree3 (file, node, flags);
+ return 1;
+}
+
+/*-------------------------------------------------------------------*/
+
+static void
+print_OFFSET_REF (FILE *file, const char *annotation, tree node, int indent)
+{
+ if (PTRMEM_OK_P (node))
+ fputs (" ptr-to-mbr-ok", file);
+ print_ref (file, annotation, node, indent);
+
+ print_operands (file, node, indent, TRUE, "(obj)", "(offset)", NULL);
+}
+
+static void
+print_NON_DEPENDENT_EXPR (FILE *file, const char *annotation, tree node,
+ int indent)
+{
+}
+
+static void
+print_PTRMEM_CST (FILE *file,
+ const char *annotation ATTRIBUTE_UNUSED,
+ tree node,
+ int indent ATTRIBUTE_UNUSED)
+{
+ fprintf (file, " rec-type::mbr-decl=");
+ fprintf (file, HOST_PTR_PRINTF, HOST_PTR_PRINTF_VALUE (PTRMEM_CST_CLASS (node)));
+ fprintf (file, "::");
+ fprintf (file, HOST_PTR_PRINTF, HOST_PTR_PRINTF_VALUE (PTRMEM_CST_MEMBER (node)));
+ /* not sure I want to follow these nodes here */
+}
+
+static void
+print_NEW_EXPR (FILE *file,
+ const char *annotation ATTRIBUTE_UNUSED,
+ tree node,
+ int indent)
+{
+ if (NEW_EXPR_USE_GLOBAL (node))
+ fputs ("use-glbl", file);
+
+ print_operands (file, node, indent, TRUE, "(placement)", "(new)", "(init)", NULL);
+}
+
+static void
+print_VEC_NEW_EXPR (FILE *file,
+ const char *annotation ATTRIBUTE_UNUSED,
+ tree node,
+ int indent)
+{
+ print_operands (file, node, indent, TRUE, "(placement)", "(new)", "(init)", NULL);
+}
+
+static void
+print_DELETE_EXPR (FILE *file,
+ const char *annotation ATTRIBUTE_UNUSED,
+ tree node,
+ int indent)
+{
+ if (DELETE_EXPR_USE_GLOBAL (node))
+ fputs ("use-glbl", file);
+ if (DELETE_EXPR_USE_VEC (node))
+ fputs ("use-vec", file);
+
+ print_operands (file, node, indent, TRUE, "(store)", "(how)", NULL);
+}
+
+static void
+print_VEC_DELETE_EXPR (FILE *file,
+ const char *annotation ATTRIBUTE_UNUSED,
+ tree node,
+ int indent)
+{
+ print_operands (file, node, indent, TRUE, "(store)", "(how)", NULL);
+}
+
+static void
+print_SCOPE_REF (FILE *file,
+ const char *annotation ATTRIBUTE_UNUSED,
+ tree node,
+ int indent)
+{
+ print_ref (file, annotation, node, indent);
+ fprintf (file, " complexity=%d", TREE_COMPLEXITY (node));
+
+ print_operands (file, node, indent, TRUE, "(class)", "(field)", NULL);
+}
+
+static void
+print_MEMBER_REF (FILE *file,
+ const char *annotation ATTRIBUTE_UNUSED,
+ tree node,
+ int indent)
+{
+ print_ref (file, annotation, node, indent);
+
+ print_operands (file, node, indent, FALSE, "(obj)", "(mbr)", NULL);
+ /* not sure I want to follow these nodes here */
+}
+
+static void
+print_TYPE_EXPR (FILE *file,
+ const char *annotation ATTRIBUTE_UNUSED,
+ tree node,
+ int indent)
+{
+ fprintf (file, " type=");
+ fprintf (file, HOST_PTR_PRINTF,
+ HOST_PTR_PRINTF_VALUE (TREE_TYPE (node)));
+
+ print_operands (file, node, indent, TRUE, NULL);
+}
+
+static void
+print_AGGR_INIT_EXPR (FILE *file,
+ const char *annotation ATTRIBUTE_UNUSED,
+ tree node,
+ int indent)
+{
+ if (AGGR_INIT_VIA_CTOR_P(node))
+ fputs (" ctor", file);
+
+ print_operands (file, node, indent, TRUE, "(init-funct)", "(args)", "(slot)", NULL);
+}
+
+static void
+print_THROW_EXPR (FILE *file,
+ const char *annotation ATTRIBUTE_UNUSED,
+ tree node,
+ int indent)
+{
+ print_operands (file, node, indent, TRUE, NULL);
+}
+
+static void
+print_EMPTY_CLASS_EXPR (FILE *file,
+ const char *annotation ATTRIBUTE_UNUSED,
+ tree node,
+ int indent ATTRIBUTE_UNUSED)
+{
+ if (TREE_TYPE (node))
+ {
+ fprintf (file, "class=");
+ fprintf (file, HOST_PTR_PRINTF,
+ HOST_PTR_PRINTF_VALUE (TREE_TYPE (node)));
+ }
+}
+
+static void
+print_BASELINK (FILE *file,
+ const char *annotation ATTRIBUTE_UNUSED,
+ tree node,
+ int indent)
+{
+ print_operands (file, node, indent, TRUE, NULL);
+}
+
+static void
+print_TEMPLATE_DECL (FILE *file,
+ const char *annotation ATTRIBUTE_UNUSED,
+ tree node,
+ int indent)
+{
+ dump_tree_state.line_cnt = 0;
+
+ fprintf (file, " args=");
+ fprintf (file, HOST_PTR_PRINTF,
+ HOST_PTR_PRINTF_VALUE (DECL_ARGUMENTS (node)));
+ if (DECL_LANG_SPECIFIC (node) && DECL_TEMPLATE_INFO (node))
+ {
+ fprintf (file, " tmpl-info=");
+ fprintf (file, HOST_PTR_PRINTF,
+ HOST_PTR_PRINTF_VALUE (DECL_TEMPLATE_INFO (node)));
+ }
+ if (DECL_VINDEX (node))
+ {
+ fprintf (file, " inst=");
+ fprintf (file, HOST_PTR_PRINTF,
+ HOST_PTR_PRINTF_VALUE (DECL_VINDEX (node)));
+ }
+ if (TREE_TYPE (node))
+ {
+ fprintf (file, " obj-type=");
+ fprintf (file, HOST_PTR_PRINTF,
+ HOST_PTR_PRINTF_VALUE (TREE_TYPE (node)));
+ }
+ if (DECL_TEMPLATE_RESULT (node))
+ {
+ fprintf (file, " obj-decl=");
+ fprintf (file, HOST_PTR_PRINTF,
+ HOST_PTR_PRINTF_VALUE (DECL_TEMPLATE_RESULT (node)));
+ }
+ if (DECL_INITIAL (node))
+ {
+ fprintf (file, " assoc-tmpls=");
+ fprintf (file, HOST_PTR_PRINTF,
+ HOST_PTR_PRINTF_VALUE (DECL_INITIAL (node)));
+ }
+ print_decl (file, annotation, node, indent);
+ (void)node_seen (node, TRUE);
+
+ if (DECL_ARGUMENTS (node))
+ {
+ if (dump_tree_state.line_cnt > 1)
+ newline_and_indent (file, 0);
+ dump_tree (file, "(args)", DECL_ARGUMENTS (node), indent + INDENT);
+ }
+
+ if (DECL_VINDEX (node))
+ {
+ if (dump_tree_state.line_cnt > 1)
+ newline_and_indent (file, 0);
+ dump_tree (file, "(inst)", DECL_VINDEX (node), indent + INDENT);
+ }
+
+ /* tsubst_decl() in cp/pt.c looks interesting */
+ if (TREE_TYPE (node))
+ {
+ if (dump_tree_state.line_cnt > 1)
+ newline_and_indent (file, 0);
+ dump_tree (file, "(obj-type)", TREE_TYPE (node), indent + INDENT);
+ }
+
+ if (DECL_TEMPLATE_RESULT (node))
+ {
+ if (dump_tree_state.line_cnt > 1)
+ newline_and_indent (file, 0);
+ dump_tree (file, "(obj-decl)", DECL_TEMPLATE_RESULT (node), indent + INDENT);
+ }
+
+ if (DECL_INITIAL (node))
+ {
+ if (dump_tree_state.line_cnt > 1)
+ newline_and_indent (file, 0);
+ dump_tree (file, "(assoc-tmpl)", DECL_INITIAL (node), indent + INDENT);
+ }
+}
+
+static void
+print_TEMPLATE_PARM_INDEX (FILE *file,
+ const char *annotation ATTRIBUTE_UNUSED,
+ tree node,
+ int indent)
+{
+ fprintf (file, " idx/lvl=("HOST_WIDE_INT_PRINT_DEC","HOST_WIDE_INT_PRINT_DEC")"
+ " orig-lvl="HOST_WIDE_INT_PRINT_DEC
+ " dcndnts=",
+ TEMPLATE_PARM_IDX (node), TEMPLATE_PARM_LEVEL(node),
+ TEMPLATE_PARM_ORIG_LEVEL (node));
+ fprintf (file, HOST_PTR_PRINTF, HOST_PTR_PRINTF_VALUE (TEMPLATE_PARM_DESCENDANTS (node)));
+
+
+ print_decl (file, annotation, TEMPLATE_PARM_DECL(node), indent + INDENT);
+ dump_tree (file, "(dcndnt)", TEMPLATE_PARM_DESCENDANTS (node), indent + INDENT);
+}
+
+static void
+print_TEMPLATE_TYPE_PARM (FILE *file,
+ const char *annotation,
+ tree node,
+ int indent)
+{
+ fprintf (file, " parms=");
+ fprintf (file, HOST_PTR_PRINTF, HOST_PTR_PRINTF_VALUE (TEMPLATE_TYPE_IDX (node)));
+ fprintf (file, " idx/lvl=("HOST_WIDE_INT_PRINT_DEC","HOST_WIDE_INT_PRINT_DEC")"
+ " orig-lvl="HOST_WIDE_INT_PRINT_DEC,
+ TEMPLATE_TYPE_IDX (node), TEMPLATE_TYPE_LEVEL (node),
+ TEMPLATE_TYPE_ORIG_LEVEL (node));
+ print_type (file, annotation, node, indent);
+
+ dump_tree (file, "(parm)", TEMPLATE_TYPE_PARM_INDEX (node), indent + INDENT);
+}
+
+static void
+print_TEMPLATE_TEMPLATE_PARM (FILE *file,
+ const char *annotation,
+ tree node,
+ int indent)
+{
+ fprintf (file, " tmpl-decl=");
+ fprintf (file, HOST_PTR_PRINTF,
+ HOST_PTR_PRINTF_VALUE (TYPE_NAME (node)));
+
+ print_TEMPLATE_TYPE_PARM (file, annotation, node, indent);
+
+ dump_tree (file, "(tmpl-decl)", TYPE_NAME (node), indent + INDENT);
+}
+
+static void
+print_BOUND_TEMPLATE_TEMPLATE_PARM (FILE *file,
+ const char *annotation,
+ tree node,
+ int indent)
+{
+ fprintf (file, " name=");
+ fprintf (file, HOST_PTR_PRINTF,
+ HOST_PTR_PRINTF_VALUE (TEMPLATE_TEMPLATE_PARM_TEMPLATE_INFO (node)));
+ fprintf (file, " type-decl=");
+ fprintf (file, HOST_PTR_PRINTF,
+ HOST_PTR_PRINTF_VALUE (TYPE_NAME (node)));
+ fprintf (file, " tmpl-decl=");
+ fprintf (file, HOST_PTR_PRINTF,
+ HOST_PTR_PRINTF_VALUE (TYPE_TI_TEMPLATE (node)));
+
+ print_TEMPLATE_TYPE_PARM (file, annotation, node, indent);
+
+ dump_tree (file, "(name)", TEMPLATE_TEMPLATE_PARM_TEMPLATE_INFO (node), indent + INDENT);
+ dump_tree (file, "(type-decl)", TYPE_NAME (node), indent + INDENT);
+ dump_tree (file, "(tmpl-decl)", TYPE_TI_TEMPLATE (node), indent + INDENT);
+}
+
+static void
+print_TYPENAME_TYPE (FILE *file,
+ const char *annotation,
+ tree node,
+ int indent)
+{
+ fprintf (file, " cntxt::id=");
+ fprintf (file, HOST_PTR_PRINTF,
+ HOST_PTR_PRINTF_VALUE (TYPE_CONTEXT (node)));
+ fprintf (file, "::");
+ fprintf (file, HOST_PTR_PRINTF,
+ HOST_PTR_PRINTF_VALUE (TYPE_NAME (node)));
+
+ if (TYPENAME_TYPE_FULLNAME (node))
+ {
+ fprintf (file, " fullname=");
+ fprintf (file, HOST_PTR_PRINTF,
+ HOST_PTR_PRINTF_VALUE (TYPENAME_TYPE_FULLNAME (node)));
+ }
+ if (TREE_TYPE (node))
+ {
+ fprintf (file, " impl-type=");
+ fprintf (file, HOST_PTR_PRINTF,
+ HOST_PTR_PRINTF_VALUE (TREE_TYPE (node)));
+ }
+ print_type (file, annotation, node, indent);
+
+ dump_tree (file, "(cntxt)", TYPE_CONTEXT (node), indent + INDENT);
+ dump_tree (file, "(id)", TYPE_NAME (node), indent + INDENT);
+ dump_tree (file, "(fullname)", TYPENAME_TYPE_FULLNAME (node), indent + INDENT);
+ dump_tree (file, "(impl-type)", TREE_TYPE (node), indent + INDENT);
+}
+
+static void
+print_UNBOUND_CLASS_TEMPLATE (FILE *file,
+ const char *annotation,
+ tree node,
+ int indent)
+{
+ fprintf (file, " cntxt::id=");
+ fprintf (file, HOST_PTR_PRINTF,
+ HOST_PTR_PRINTF_VALUE (TYPE_CONTEXT (node)));
+ fprintf (file, "::");
+ fprintf (file, HOST_PTR_PRINTF,
+ HOST_PTR_PRINTF_VALUE (TYPE_NAME (node)));
+ print_type (file, annotation, node, indent);
+
+ dump_tree (file, "(cntxt)", TYPE_CONTEXT (node), indent + INDENT);
+ dump_tree (file, "(id)", TYPE_NAME (node), indent + INDENT);
+}
+
+static void
+print_TYPEOF_TYPE (FILE *file,
+ const char *annotation,
+ tree node,
+ int indent)
+{
+ fprintf (file, " ");
+ fprintf (file, HOST_PTR_PRINTF,
+ HOST_PTR_PRINTF_VALUE (TYPE_FIELDS (node)));
+ print_type (file, annotation, node, indent);
+
+ dump_tree (file, NULL, TYPE_FIELDS (node), indent + INDENT);
+}
+
+static void
+print_USING_DECL (FILE *file,
+ const char *annotation,
+ tree node,
+ int indent)
+{
+ fprintf (file, " scope=");
+ fprintf (file, HOST_PTR_PRINTF,
+ HOST_PTR_PRINTF_VALUE (DECL_INITIAL (node)));
+ print_decl (file, annotation, node, indent);
+
+ dump_tree (file, "(scope)", DECL_INITIAL (node), indent + INDENT);
+}
+
+static void
+print_USING_STMT (FILE *file,
+ const char *annotation ATTRIBUTE_UNUSED,
+ tree node,
+ int indent)
+{
+ print_operands (file, node, indent, TRUE, "(using)", NULL);
+}
+
+static void
+print_DEFAULT_ARG (FILE *file,
+ const char *annotation ATTRIBUTE_UNUSED,
+ tree node,
+ int indent ATTRIBUTE_UNUSED)
+{
+#if 0
+ /* TO DO */
+ fprintf (file, " def-arg=");
+ fprintf (file, HOST_PTR_PRINTF,
+ HOST_PTR_PRINTF_VALUE (DEFARG_POINTER (node)));
+#endif
+ fprintf (file, " (struct unparsed_text * in cp/spew.c)");
+
+ if (TREE_PURPOSE (node))
+ {
+ fprintf (file, " purpose=");
+ fprintf (file, HOST_PTR_PRINTF,
+ HOST_PTR_PRINTF_VALUE (TREE_PURPOSE (node)));
+ dump_tree (file, "(purpose)", TREE_PURPOSE (node), indent + INDENT);
+ }
+}
+
+static void
+print_TEMPLATE_ID_EXPR (FILE *file,
+ const char *annotation ATTRIBUTE_UNUSED,
+ tree node,
+ int indent)
+{
+ print_operands (file, node, indent, TRUE, "(tmpl)", "(args)", NULL);
+}
+
+#if 0
+
+static void
+print_CPLUS_BINDING (FILE *file,
+ const char *annotation ATTRIBUTE_UNUSED,
+ tree node,
+ int indent)
+{
+ tree n;
+
+ #define BINDING_LEVEL(NODE) \
+ (((struct tree_binding*)NODE)->scope.level)
+
+ if (LOCAL_BINDING_P (node))
+ fputs (" local", file);
+ if (INHERITED_VALUE_BINDING_P (node))
+ fputs (" inherited", file);
+
+ fprintf (file, " value=");
+ fprintf (file, HOST_PTR_PRINTF,
+ HOST_PTR_PRINTF_VALUE (BINDING_VALUE (node)));
+
+ if (BINDING_HAS_LEVEL_P (node))
+ {
+ fprintf (file, " level=");
+ fprintf (file, HOST_PTR_PRINTF,
+ HOST_PTR_PRINTF_VALUE ( (node)));
+ fprintf (file, " (struct binding_level * in cp/decl.c)");
+ }
+ else
+ {
+ fprintf (file, " scope=");
+ fprintf (file, HOST_PTR_PRINTF,
+ HOST_PTR_PRINTF_VALUE (BINDING_LEVEL (node)));
+ }
+
+ if (TREE_CHAIN (node))
+ {
+ fprintf (file, " chain=");
+ fprintf (file, HOST_PTR_PRINTF,
+ HOST_PTR_PRINTF_VALUE (TREE_CHAIN (node)));
+ }
+
+ dump_tree (file, "(value)", BINDING_VALUE (node), indent + INDENT);
+ if (!BINDING_HAS_LEVEL_P (node))
+ dump_tree (file, "(scope)", BINDING_SCOPE (node), indent + INDENT);
+
+ for (n = TREE_CHAIN (node); n; n = TREE_CHAIN (n))
+ dump_tree (file, "(chain)", n, indent + INDENT);
+}
+
+#endif
+
+static void
+print_OVERLOAD (FILE *file,
+ const char *annotation ATTRIBUTE_UNUSED,
+ tree node,
+ int indent)
+{
+ tree n;
+
+ if (OVL_FUNCTION (node))
+ {
+ fprintf (file, " ovld=");
+ fprintf (file, HOST_PTR_PRINTF,
+ HOST_PTR_PRINTF_VALUE (OVL_FUNCTION (node)));
+ }
+ if (OVL_CHAIN (node))
+ {
+ fprintf (file, " next-ovld=");
+ fprintf (file, HOST_PTR_PRINTF,
+ HOST_PTR_PRINTF_VALUE (OVL_CHAIN (node)));
+ }
+
+ if ((TREE_CODE (OVL_FUNCTION (node)) == FUNCTION_DECL
+ || TREE_CODE (OVL_FUNCTION (node)) == TEMPLATE_DECL)
+ && DECL_NAME (OVL_FUNCTION (node)))
+ fprintf (file, " %s",
+ IDENTIFIER_POINTER (DECL_NAME (OVL_FUNCTION (node))));
+
+ if (DECL_CONSTRUCTOR_P (OVL_FUNCTION (node)))
+ dump_tree (file, NULL, OVL_FUNCTION (node), indent + INDENT);
+ else
+ dump_tree (file, "(ovld)", OVL_FUNCTION (node), indent + INDENT);
+
+ for (n = OVL_CHAIN (node); n; n = OVL_CHAIN (n))
+ dump_tree (file, NULL, n, indent + INDENT);
+}
+
+static void
+print_WRAPPER (FILE *file,
+ const char *annotation ATTRIBUTE_UNUSED,
+ tree node,
+ int indent ATTRIBUTE_UNUSED)
+{
+ /* TODO: Print out tree_common. */
+ fprintf (file, " ptr=");
+ fprintf (file, HOST_PTR_PRINTF, HOST_PTR_PRINTF_VALUE (WRAPPER_ZC (node)));
+}
+
+static void
+print_MODOP_EXPR (FILE *file,
+ const char *annotation ATTRIBUTE_UNUSED,
+ tree node,
+ int indent)
+{
+ print_operands (file, node, indent, TRUE, "(lhs)", "(modifycode)", "(rhs)", NULL);
+}
+
+static void
+print_CAST_EXPR (FILE *file,
+ const char *annotation ATTRIBUTE_UNUSED,
+ tree node,
+ int indent)
+{
+ print_operands (file, node, indent, TRUE, NULL);
+}
+
+static void
+print_REINTERPRET_CAST_EXPR (FILE *file,
+ const char *annotation ATTRIBUTE_UNUSED,
+ tree node,
+ int indent)
+{
+ print_operands (file, node, indent, TRUE, NULL);
+}
+
+static void
+print_CONST_CAST_EXPR (FILE *file,
+ const char *annotation ATTRIBUTE_UNUSED,
+ tree node,
+ int indent)
+{
+ print_operands (file, node, indent, TRUE, NULL);
+}
+
+static void
+print_STATIC_CAST_EXPR (FILE *file,
+ const char *annotation ATTRIBUTE_UNUSED,
+ tree node,
+ int indent)
+{
+ print_operands (file, node, indent, TRUE, NULL);
+}
+
+static void
+print_DYNAMIC_CAST_EXPR (FILE *file,
+ const char *annotation ATTRIBUTE_UNUSED,
+ tree node ATTRIBUTE_UNUSED,
+ int indent ATTRIBUTE_UNUSED)
+{
+ print_operands (file, node, indent, TRUE, NULL);
+}
+
+static void
+print_DOTSTAR_EXPR (FILE *file,
+ const char *annotation ATTRIBUTE_UNUSED,
+ tree node,
+ int indent)
+{
+ print_operands (file, node, indent, TRUE, "(datum)", "(cmpnt)", NULL);
+}
+
+static void
+print_TYPEID_EXPR (FILE *file,
+ const char *annotation ATTRIBUTE_UNUSED,
+ tree node,
+ int indent)
+{
+ print_operands (file, node, indent, TRUE, NULL);
+}
+
+static void
+print_PSEUDO_DTOR_EXPR (FILE *file,
+ const char *annotation ATTRIBUTE_UNUSED,
+ tree node,
+ int indent)
+{
+ print_operands (file, node, indent, TRUE, "(obj)", "(scope)", "(dtor)", NULL);
+}
+
+static void
+print_CTOR_INITIALIZER (FILE *file,
+ const char *annotation ATTRIBUTE_UNUSED,
+ tree node,
+ int indent)
+{
+ print_operands (file, node, indent, TRUE, "(mbr-init)", "(base-init)", NULL);
+}
+
+#if 0
+static void
+print_RETURN_INIT (FILE *file,
+ const char *annotation ATTRIBUTE_UNUSED,
+ tree node,
+ int indent)
+{
+ print_operands (file, node, indent, TRUE, "(id)", "(init)", NULL);
+}
+#endif
+
+static void
+print_TRY_BLOCK (FILE *file,
+ const char *annotation ATTRIBUTE_UNUSED,
+ tree node,
+ int indent)
+{
+ if (FN_TRY_BLOCK_P (node))
+ fputs (" func-try-blk", file);
+ if (CLEANUP_P (node))
+ fputs (" clnup", file);
+
+ print_operands (file, node, indent, TRUE, "(body)", "(hndlrs)", NULL);
+}
+
+static void
+print_EH_SPEC_BLOCK (FILE *file,
+ const char *annotation ATTRIBUTE_UNUSED,
+ tree node,
+ int indent)
+{
+ print_operands (file, node, indent, TRUE, "(body)", "(raises)", NULL);
+}
+
+static void
+print_HANDLER (FILE *file,
+ const char *annotation ATTRIBUTE_UNUSED,
+ tree node,
+ int indent)
+{
+ fprintf (file, " hdnlr-type=");
+ fprintf (file, HOST_PTR_PRINTF,
+ HOST_PTR_PRINTF_VALUE (HANDLER_TYPE (node)));
+
+ print_operands (file, node, indent, TRUE, "(parms)", "(body)", NULL);
+}
+
+static void
+print_MUST_NOT_THROW_EXPR (FILE *file,
+ const char *annotation ATTRIBUTE_UNUSED,
+ tree node,
+ int indent)
+{
+ print_operands (file, node, indent, TRUE, NULL);
+}
+
+static void
+print_TAG_DEFN (FILE *file ATTRIBUTE_UNUSED,
+ const char *annotation ATTRIBUTE_UNUSED,
+ tree node ATTRIBUTE_UNUSED,
+ int indent ATTRIBUTE_UNUSED)
+{
+}
+
+static void
+print_IDENTITY_CONV (FILE *file,
+ const char *annotation ATTRIBUTE_UNUSED,
+ tree node,
+ int indent)
+{
+ print_operands (file, node, indent, TRUE, NULL);
+}
+
+static void
+print_LVALUE_CONV (FILE *file,
+ const char *annotation ATTRIBUTE_UNUSED,
+ tree node,
+ int indent)
+{
+ print_operands (file, node, indent, TRUE, NULL);
+}
+
+static void
+print_QUAL_CONV (FILE *file,
+ const char *annotation ATTRIBUTE_UNUSED,
+ tree node,
+ int indent)
+{
+ print_operands (file, node, indent, TRUE, NULL);
+}
+
+static void
+print_STD_CONV (FILE *file,
+ const char *annotation ATTRIBUTE_UNUSED,
+ tree node,
+ int indent)
+{
+ print_operands (file, node, indent, TRUE, NULL);
+}
+
+static void
+print_PTR_CONV (FILE *file,
+ const char *annotation ATTRIBUTE_UNUSED,
+ tree node,
+ int indent)
+{
+ print_operands (file, node, indent, TRUE, NULL);
+}
+
+static void
+print_PMEM_CONV (FILE *file,
+ const char *annotation ATTRIBUTE_UNUSED,
+ tree node,
+ int indent)
+{
+ print_operands (file, node, indent, TRUE, NULL);
+}
+
+static void
+print_BASE_CONV (FILE *file,
+ const char *annotation ATTRIBUTE_UNUSED,
+ tree node,
+ int indent)
+{
+ print_operands (file, node, indent, TRUE, NULL);
+}
+
+static void
+print_REF_BIND (FILE *file,
+ const char *annotation ATTRIBUTE_UNUSED,
+ tree node,
+ int indent)
+{
+ print_operands (file, node, indent, TRUE, NULL);
+}
+
+static void
+print_USER_CONV (FILE *file,
+ const char *annotation ATTRIBUTE_UNUSED,
+ tree node,
+ int indent)
+{
+ fprintf (file, " from=");
+ fprintf (file, HOST_PTR_PRINTF,
+ HOST_PTR_PRINTF_VALUE (TREE_OPERAND (node, 0)));
+ fprintf (file, " cand=");
+ fprintf (file, HOST_PTR_PRINTF,
+ HOST_PTR_PRINTF_VALUE (TREE_OPERAND (node, 1)));
+
+ print_operands (file, node, indent, TRUE, "(from)", "(cand)", NULL);
+}
+
+static void
+print_AMBIG_CONV (FILE *file,
+ const char *annotation ATTRIBUTE_UNUSED,
+ tree node,
+ int indent)
+{
+ print_operands (file, node, indent, TRUE, NULL);
+}
+
+static void
+print_RVALUE_CONV (FILE *file,
+ const char *annotation ATTRIBUTE_UNUSED,
+ tree node,
+ int indent)
+{
+ print_operands (file, node, indent, TRUE, NULL);
+}
+
+/*-------------------------------------------------------------------*/
+
+/* Override to routine in dmp-tree.c print Method vector Record Type. */
+static void
+print_RECORD_TYPE (FILE *file,
+ const char *annotation,
+ tree node,
+ int indent)
+{
+ tree n;
+
+ fprintf (file, " fields=");
+ fprintf (file, HOST_PTR_PRINTF,
+ HOST_PTR_PRINTF_VALUE (TYPE_FIELDS (node)));
+ fprintf (file, " mbrs=");
+ fprintf (file, HOST_PTR_PRINTF,
+ HOST_PTR_PRINTF_VALUE (CLASSTYPE_METHOD_VEC (node)));
+ if (TYPE_NO_FORCE_BLK (node))
+ fputs (" no-force-blk", file);
+ fprintf (file, " #parents=%d", CLASSTYPE_N_BASECLASSES (node));
+ if (CLASSTYPE_USE_TEMPLATE (node))
+ fprintf (file, " use-tmpl=%d", CLASSTYPE_USE_TEMPLATE (node));
+ if (TYPE_PTRMEMFUNC_P (node))
+ {
+ fprintf (file, " ptrmemfunc-fn-type=");
+ fprintf (file, HOST_PTR_PRINTF,
+ HOST_PTR_PRINTF_VALUE (TYPE_PTRMEMFUNC_FN_TYPE (node)));
+ }
+ print_type (file, annotation, node, indent);
+ (void)node_seen (node, TRUE);
+
+ for (n = TYPE_FIELDS (node); n; n = TREE_CHAIN (n))
+ {
+ if (TREE_CODE (n) == TYPE_DECL
+ && TREE_TYPE (n) == DECL_CONTEXT (n)
+ && TREE_TYPE (n) == node)
+ dump_tree (file, "(self-reference)", n, indent + INDENT);
+ else
+ dump_tree (file, NULL, n, indent + INDENT);
+ }
+
+ dump_tree (file, "(mbrs)", CLASSTYPE_METHOD_VEC (node), indent + INDENT);
+
+ if (TYPE_PTRMEMFUNC_P (node))
+ {
+ newline_and_indent (file, 0);
+ dump_tree (file, "(ptrmemfunc-fn-type)",
+ TYPE_PTRMEMFUNC_FN_TYPE (node), indent + INDENT);
+ }
+}
+
+/* Override to routine in dmp-tree.c to print namespace. */
+static void
+print_NAMESPACE_DECL (FILE *file,
+ const char *annotation,
+ tree node,
+ int indent)
+{
+ if (NAMESPACE_LEVEL (node))
+ {
+ fprintf (file, " binding_lvl=");
+ fprintf (file, HOST_PTR_PRINTF,
+ HOST_PTR_PRINTF_VALUE (NAMESPACE_LEVEL (node)));
+ }
+ if (DECL_NAMESPACE_ALIAS (node))
+ {
+ fprintf (file, " alias=");
+ fprintf (file, HOST_PTR_PRINTF,
+ HOST_PTR_PRINTF_VALUE (DECL_NAMESPACE_ALIAS (node)));
+ }
+ if (DECL_NAMESPACE_USING (node))
+ {
+ fprintf (file, " using=");
+ fprintf (file, HOST_PTR_PRINTF,
+ HOST_PTR_PRINTF_VALUE (DECL_NAMESPACE_USING (node)));
+ }
+ if (DECL_NAMESPACE_USERS (node))
+ {
+ fprintf (file, " usrs=");
+ fprintf (file, HOST_PTR_PRINTF,
+ HOST_PTR_PRINTF_VALUE (DECL_NAMESPACE_USERS (node)));
+ }
+
+ print_decl (file, annotation, node, indent);
+
+ dump_tree (file, "(alias)", DECL_NAMESPACE_ALIAS (node), indent + INDENT);
+ dump_tree (file, "(using)", DECL_NAMESPACE_USING (node), indent + INDENT);
+ dump_tree (file, "(usrs)", DECL_NAMESPACE_USERS (node), indent + INDENT);
+
+ if (dump_tree_state.visit_only_once == DMP_TREE_VISIT_ONCE2)
+ {
+ for (node = cp_namespace_decls (node); node; node = TREE_CHAIN (node))
+ dump_tree (file, NULL, node, indent + INDENT);
+ }
+}
+
+static void
+print_ADDR_EXPR (FILE *file,
+ const char *annotation ATTRIBUTE_UNUSED,
+ tree node,
+ int indent)
+{
+ if (PTRMEM_OK_P (node))
+ fputs (" ptr-to-mbr-ok", file);
+
+ print_operands (file, node, indent, TRUE, NULL);
+}
+
+static void
+print_ALIAS_DECL (FILE *file ATTRIBUTE_UNUSED,
+ const char *annotation ATTRIBUTE_UNUSED,
+ tree node ATTRIBUTE_UNUSED,
+ int indent ATTRIBUTE_UNUSED)
+{
+ /* TO DO */
+}
+
+/*-------------------------------------------------------------------*/
+
+/* Return 1 if tree node is a C++ specific tree node from cp-tree.def
+ or a tree node specific to whatever cp_prev_lang_dump_tree_p
+ calls. Otherwise return 0.
+*/
+
+int
+cp_dump_tree_p (FILE *file, const char *annotation, tree node, int indent)
+{
+ switch (TREE_CODE (node))
+ {
+ #define DEFTREECODE(SYM, NAME, TYPE, LENGTH) \
+ case SYM: print_ ## SYM (file, annotation, node, indent); break;
+ #include "cp-tree.def"
+ #undef DEFTREECODE
+
+ case RECORD_TYPE:
+ print_RECORD_TYPE (file, annotation, node, indent);
+ break;
+
+ case NAMESPACE_DECL:
+ print_NAMESPACE_DECL (file, annotation, node, indent);
+ break;
+
+ case ADDR_EXPR:
+ print_ADDR_EXPR (file, annotation, node, indent);
+ break;
+
+ default:
+ return cp_prev_lang_dump_tree_p (file, annotation, node, indent);
+ break;
+ }
+
+ return 1;
+}
+
+/*-------------------------------------------------------------------*/
+
+#if 0
+
+cd $gcc3/gcc; \
+cc -no-cpp-precomp -c -DIN_GCC -g \
+ -W -Wall -Wwrite-strings -Wstrict-prototypes -Wmissing-prototypes \
+ -DHAVE_CONFIG_H \
+ -I$gcc3obj \
+ -Icp \
+ -I. \
+ -Iconfig \
+ -I../include \
+ cp/cp-dmp-tree.c -o ~/tmp.o -w
+
+#endif
diff --git a/gcc/cp/cp-idebug.c b/gcc/cp/cp-idebug.c
new file mode 100644
index 00000000000..1ed38930881
--- /dev/null
+++ b/gcc/cp/cp-idebug.c
@@ -0,0 +1,463 @@
+/* APPLE LOCAL file debugging */
+/* C++ tree & rtl accessors defined as functions for use in a debugger.
+ Copyright (C) 2001 Free Software Foundation, Inc.
+ Contributed by Ira L. Ruben (ira@apple.com)
+
+This file is part of GNU CC.
+
+GNU CC is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2, or (at your option)
+any later version.
+
+GNU CC is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+GNU General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with GNU CC; see the file COPYING. If not, write to
+the Free Software Foundation, 59 Temple Place - Suite 330,
+Boston, MA 02111-1307, USA. */
+
+/* What we do here is to instantiate each macro as a function *BY
+ THE SAME NAME*. Depends on the macro not being expanded when
+ it is surrounded by parens.
+
+ Note that this file includes idebug.c so that only debugging
+ macros for cp-tree.h are actually defined here. For C++ only
+ this file is included in the link while for C only c-idebug.c
+ is built and included in the link. */
+
+#include "idebug.c"
+
+#ifdef ENABLE_IDEBUG
+
+#include "cp/cp-tree.h"
+
+/* C++ tree debugging macro functions. From cp-tree.h.
+ I made special-case meta-macros for the most common
+ one-parameter ones, that take a node and return either
+ a node or an int. */
+
+#define fn_noden( m ) fn_1(m, tree, tree)
+#define fn_nodei( m ) fn_1(m, int, tree)
+
+/* Macros from cp-tree.h */
+
+fn_nodei( C_IS_RESERVED_WORD )
+fn_1( C_RID_CODE, enum rid, struct lang_identifier * )
+fn_1( LANG_IDENTIFIER_CAST, struct lang_identifier *, tree )
+fn_noden( BINDING_SCOPE )
+fn_nodei( BINDING_HAS_LEVEL_P )
+fn_noden( BINDING_VALUE )
+fn_noden( BINDING_TYPE )
+fn_noden( IDENTIFIER_GLOBAL_VALUE )
+fn_noden( IDENTIFIER_NAMESPACE_VALUE )
+fn_nodei( CLEANUP_P )
+fn_noden( CLEANUP_DECL )
+fn_noden( CLEANUP_EXPR )
+fn_2( same_type_p, int, tree, tree )
+fn_2( same_type_ignoring_top_level_qualifiers_p, int, tree, tree )
+fn_nodei( DECL_MAIN_P )
+fn_noden( OVL_FUNCTION )
+fn_noden( OVL_CHAIN )
+fn_noden( OVL_CURRENT )
+fn_noden( OVL_NEXT )
+fn_nodei( OVL_USED )
+fn_nodei( BASELINK_P )
+fn_nodei( SET_BASELINK_P )
+fn_1( SRCLOC_FILE, const char *, tree )
+fn_nodei( SRCLOC_LINE )
+fn_noden( IDENTIFIER_NAMESPACE_BINDINGS )
+fn_noden( IDENTIFIER_TEMPLATE )
+fn_noden( IDENTIFIER_BINDING )
+fn_noden( IDENTIFIER_VALUE )
+fn_noden( IDENTIFIER_CLASS_VALUE )
+fn_noden( IDENTIFIER_TYPE_VALUE )
+fn_noden( REAL_IDENTIFIER_TYPE_VALUE )
+fn_nodei( IDENTIFIER_HAS_TYPE_VALUE )
+fn_noden( IDENTIFIER_LABEL_VALUE )
+fn_noden( IDENTIFIER_IMPLICIT_DECL )
+fn_noden( IDENTIFIER_ERROR_LOCUS )
+fn_nodei( IDENTIFIER_VIRTUAL_P )
+fn_nodei( IDENTIFIER_OPNAME_P )
+fn_nodei( IDENTIFIER_TYPENAME_P )
+fn_nodei( IDENTIFIER_CTOR_OR_DTOR_P )
+fn_nodei( C_TYPE_FIELDS_READONLY )
+/*fn_nodei( C_EXP_ORIGINAL_CODE ) already declared in c-common.h */
+fn_2( C_SET_EXP_ORIGINAL_CODE, int, tree, tree )
+fn_1( ansi_opname, tree, int )
+fn_1( ansi_assopname, tree, int )
+fn_noden( TYPE_IDENTIFIER )
+fn_1( TYPE_NAME_STRING, char*, tree )
+fn_nodei( TYPE_NAME_LENGTH )
+fn_1( TYPE_ASSEMBLER_NAME_STRING, char*, tree )
+fn_nodei( TYPE_ASSEMBLER_NAME_LENGTH )
+fn_noden( TYPE_MAIN_DECL )
+fn_nodei( IS_AGGR_TYPE )
+fn_nodei( CLASS_TYPE_P )
+fn_1( IS_AGGR_TYPE_CODE, int, int )
+fn_2( IS_AGGR_TYPE_2, int, tree, tree )
+fn_nodei( IS_OVERLOAD_TYPE )
+fn_nodei( TYPE_BUILT_IN )
+fn_nodei( TYPE_FOR_JAVA )
+fn_nodei( CP_TYPE_QUALS )
+fn_nodei( CP_TYPE_CONST_P )
+fn_nodei( CP_TYPE_VOLATILE_P )
+fn_nodei( CP_TYPE_RESTRICT_P )
+fn_nodei( CP_TYPE_CONST_NON_VOLATILE_P )
+fn_noden( FNADDR_FROM_VTABLE_ENTRY )
+fn_noden( FUNCTION_ARG_CHAIN )
+fn_noden( FUNCTION_FIRST_USER_PARMTYPE )
+fn_noden( FUNCTION_FIRST_USER_PARM )
+fn_2( PROMOTES_TO_AGGR_TYPE, int, tree, unsigned )
+fn_2( UNIQUELY_DERIVED_FROM_P, int, tree, tree )
+fn_2( ACCESSIBLY_DERIVED_FROM_P, int, tree, tree )
+fn_2( ACCESSIBLY_UNIQUELY_DERIVED_P, int, tree, tree )
+fn_2( PUBLICLY_UNIQUELY_DERIVED_P, int, tree, tree )
+fn_2( DERIVED_FROM_P, int, tree, tree )
+fn_nodei( CLASSTYPE_USE_TEMPLATE )
+fn_noden( CLASSTYPE_INLINE_FRIENDS )
+fn_nodei( TYPE_GETS_DELETE )
+fn_nodei( TYPE_GETS_REG_DELETE )
+fn_nodei( TYPE_VEC_DELETE_TAKES_SIZE )
+fn_nodei( TYPE_VEC_NEW_USES_COOKIE )
+fn_nodei( TYPE_HAS_CONVERSION )
+fn_nodei( TYPE_HAS_ASSIGN_REF )
+fn_nodei( TYPE_HAS_CONST_ASSIGN_REF )
+fn_nodei( TYPE_HAS_INIT_REF )
+fn_nodei( TYPE_HAS_CONST_INIT_REF )
+fn_nodei( TYPE_HAS_NEW_OPERATOR )
+fn_nodei( TYPE_HAS_ARRAY_NEW_OPERATOR )
+fn_nodei( TYPE_BEING_DEFINED )
+fn_nodei( TYPE_REDEFINED )
+fn_noden( CLASSTYPE_RTTI )
+fn_nodei( TYPE_OVERLOADS_CALL_EXPR )
+fn_nodei( TYPE_OVERLOADS_ARRAY_REF )
+fn_nodei( TYPE_OVERLOADS_ARROW )
+fn_nodei( TYPE_USES_MULTIPLE_INHERITANCE )
+fn_nodei( TYPE_USES_VIRTUAL_BASECLASSES )
+fn_noden( CLASSTYPE_METHOD_VEC )
+fn_noden( CLASSTYPE_CONSTRUCTORS )
+fn_noden( CLASSTYPE_DESTRUCTORS )
+fn_2( CLASSTYPE_MARKED_N, int, tree, int )
+fn_nodei( CLASSTYPE_MARKED )
+fn_nodei( CLASSTYPE_MARKED2 )
+fn_nodei( CLASSTYPE_MARKED3 )
+fn_nodei( CLASSTYPE_MARKED4 )
+fn_nodei( CLASSTYPE_MARKED5 )
+fn_nodei( CLASSTYPE_MARKED6 )
+fn_noden( CLASSTYPE_TAGS )
+fn_nodei( CLASSTYPE_HAS_PRIMARY_BASE_P )
+fn_noden( CLASSTYPE_PRIMARY_BINFO )
+fn_nodei( CLASSTYPE_VSIZE )
+fn_noden( CLASSTYPE_VBASECLASSES )
+fn_2( CANONICAL_BINFO, tree, tree, tree )
+fn_nodei( CLASSTYPE_N_BASECLASSES )
+fn_noden( CLASSTYPE_SIZE )
+fn_noden( CLASSTYPE_SIZE_UNIT )
+fn_nodei( CLASSTYPE_ALIGN )
+fn_nodei( CLASSTYPE_USER_ALIGN )
+fn_nodei( CLASSTYPE_ALIGN_UNIT )
+fn_nodei( TYPE_JAVA_INTERFACE )
+fn_noden( CLASSTYPE_PURE_VIRTUALS )
+fn_nodei( CLASSTYPE_GOT_SEMICOLON )
+fn_nodei( CLASSTYPE_NEEDS_VIRTUAL_REINIT )
+fn_nodei( TYPE_HAS_DEFAULT_CONSTRUCTOR )
+fn_nodei( CLASSTYPE_HAS_MUTABLE )
+fn_nodei( TYPE_HAS_MUTABLE_P )
+fn_nodei( CLASSTYPE_NON_POD_P )
+fn_nodei( CLASSTYPE_NEARLY_EMPTY_P )
+fn_nodei( CLASSTYPE_COM_INTERFACE )
+fn_noden( CLASSTYPE_FRIEND_CLASSES )
+fn_noden( CLASSTYPE_BEFRIENDING_CLASSES )
+fn_nodei( CLASSTYPE_DECLARED_CLASS )
+fn_nodei( CLASSTYPE_READONLY_FIELDS_NEED_INIT )
+fn_nodei( CLASSTYPE_REF_FIELDS_NEED_INIT )
+fn_nodei( CLASSTYPE_INTERFACE_ONLY )
+fn_nodei( CLASSTYPE_INTERFACE_KNOWN )
+fn_nodei( CLASSTYPE_INTERFACE_UNKNOWN )
+fn_2( SET_CLASSTYPE_INTERFACE_UNKNOWN_X, int, tree, int )
+fn_nodei( SET_CLASSTYPE_INTERFACE_UNKNOWN )
+fn_nodei( SET_CLASSTYPE_INTERFACE_KNOWN )
+fn_nodei( CLASSTYPE_DEBUG_REQUESTED )
+fn_nodei( BINFO_MARKED )
+fn_nodei( BINFO_VTABLE_PATH_MARKED )
+fn_nodei( BINFO_NEW_VTABLE_MARKED )
+fn_nodei( BINFO_PUSHDECLS_MARKED )
+fn_nodei( BINFO_PRIMARY_P )
+fn_noden( BINFO_SUBVTT_INDEX )
+fn_noden( BINFO_VPTR_INDEX )
+fn_noden( BINFO_PRIMARY_BASE_OF )
+fn_nodei( BINFO_LOST_PRIMARY_P )
+fn_nodei( BINFO_INDIRECT_PRIMARY_P )
+fn_nodei( IDENTIFIER_MARKED )
+fn_noden( CLASSTYPE_VFIELDS )
+fn_noden( VF_BINFO_VALUE )
+fn_noden( VF_BASETYPE_VALUE )
+fn_noden( VF_DERIVED_VALUE )
+fn_noden( BV_DELTA )
+fn_noden( BV_VCALL_INDEX )
+fn_noden( BV_FN )
+fn_nodei( BV_USE_VCALL_INDEX_P )
+fn_nodei( BV_GENERATE_THUNK_WITH_VTABLE_P )
+fn_nodei( TREE_PARMLIST )
+fn_nodei( PARMLIST_ELLIPSIS_P )
+fn_noden( TYPE_RAISES_EXCEPTIONS )
+fn_nodei( TYPE_NOTHROW_P )
+fn_1( NAMESPACE_LEVEL, struct binding_level*, tree )
+fn_nodei( CAN_HAVE_FULL_LANG_DECL_P )
+fn_1( DEFARG_POINTER, const unsigned char *, tree )
+fn_nodei( DECL_NEEDED_P )
+fn_nodei( DECL_IN_MEMORY_P )
+fn_nodei( DECL_LANGUAGE )
+fn_nodei( DECL_CONSTRUCTOR_P )
+fn_nodei( DECL_COMPLETE_CONSTRUCTOR_P )
+fn_nodei( DECL_BASE_CONSTRUCTOR_P )
+fn_nodei( DECL_MAYBE_IN_CHARGE_CONSTRUCTOR_P )
+fn_nodei( DECL_COPY_CONSTRUCTOR_P )
+fn_nodei( DECL_DESTRUCTOR_P )
+fn_nodei( DECL_MAYBE_IN_CHARGE_DESTRUCTOR_P )
+fn_nodei( DECL_COMPLETE_DESTRUCTOR_P )
+fn_nodei( DECL_BASE_DESTRUCTOR_P )
+fn_nodei( DECL_DELETING_DESTRUCTOR_P )
+fn_nodei( DECL_CLONED_FUNCTION_P )
+fn_noden( DECL_CLONED_FUNCTION )
+fn_nodei( DECL_DISCRIMINATOR_P )
+fn_nodei( DECL_DISCRIMINATOR )
+fn_nodei( DECL_HAS_VTT_PARM_P )
+fn_nodei( DECL_NEEDS_VTT_PARM_P )
+fn_nodei( DECL_CONV_FN_P )
+fn_2( SET_OVERLOADED_OPERATOR_CODE, enum tree_code, tree, enum tree_code )
+fn_nodei( DECL_OVERLOADED_OPERATOR_P )
+fn_nodei( DECL_ASSIGNMENT_OPERATOR_P )
+fn_nodei( DECL_HAS_IN_CHARGE_PARM_P )
+fn_nodei( DECL_ARRAY_DELETE_OPERATOR_P )
+fn_nodei( DECL_IN_AGGR_P )
+fn_nodei( DECL_INITIALIZED_IN_CLASS_P )
+fn_nodei( DECL_FRIEND_P )
+fn_noden( DECL_BEFRIENDING_CLASSES )
+fn_nodei( DECL_STATIC_FUNCTION_P )
+fn_nodei( DECL_NONSTATIC_MEMBER_FUNCTION_P )
+fn_nodei( DECL_FUNCTION_MEMBER_P )
+fn_nodei( DECL_CONST_MEMFUNC_P )
+fn_nodei( DECL_VOLATILE_MEMFUNC_P )
+fn_nodei( DECL_NONSTATIC_MEMBER_P )
+fn_nodei( DECL_MUTABLE_P )
+fn_nodei( DECL_NONCONVERTING_P )
+fn_nodei( DECL_PURE_VIRTUAL_P )
+fn_nodei( DECL_NEEDS_FINAL_OVERRIDER_P )
+fn_nodei( DECL_THUNK_P )
+fn_nodei( DECL_NON_THUNK_FUNCTION_P )
+fn_nodei( DECL_EXTERN_C_P )
+fn_nodei( DECL_EXTERN_C_FUNCTION_P )
+fn_2 ( SET_DECL_THUNK_P, tree, tree, tree )
+fn_nodei( DECL_PRETTY_FUNCTION_P )
+fn_noden( DECL_CLASS_CONTEXT )
+fn_noden( DECL_FRIEND_CONTEXT )
+fn_2( SET_DECL_FRIEND_CONTEXT, tree, tree, tree )
+fn_noden( CP_DECL_CONTEXT )
+fn_noden( FROB_CONTEXT )
+fn_noden( DECL_VIRTUAL_CONTEXT )
+fn_nodei( DECL_NAMESPACE_SCOPE_P )
+fn_nodei( DECL_CLASS_SCOPE_P )
+fn_nodei( DECL_FUNCTION_SCOPE_P )
+fn_nodei( LOCAL_CLASS_P )
+fn_noden( DECL_NAMESPACE_USING )
+fn_noden( DECL_NAMESPACE_USERS )
+fn_noden( DECL_NAMESPACE_ALIAS )
+fn_noden( ORIGINAL_NAMESPACE )
+fn_nodei( DECL_NAMESPACE_STD_P )
+fn_nodei( DECL_INIT_PRIORITY )
+fn_nodei( TREE_INDIRECT_USING )
+fn_noden( DECL_SHADOWED_FOR_VAR )
+fn_nodei( DECL_PENDING_INLINE_P )
+fn_1( DECL_PENDING_INLINE_INFO, struct unparsed_text *, tree )
+fn_noden( DECL_SORTED_FIELDS )
+fn_nodei( DECL_DEFERRED_FN )
+fn_noden( DECL_TEMPLATE_INFO )
+fn_noden( CLASSTYPE_TEMPLATE_INFO )
+fn_noden( ENUM_TEMPLATE_INFO )
+fn_noden( TEMPLATE_TEMPLATE_PARM_TEMPLATE_INFO )
+fn_noden( TYPE_TEMPLATE_INFO )
+fn_2( SET_TYPE_TEMPLATE_INFO, tree, tree, tree )
+fn_noden( TI_TEMPLATE )
+fn_noden( TI_ARGS )
+fn_nodei( TI_PENDING_TEMPLATE_FLAG )
+fn_nodei( TMPL_ARGS_HAVE_MULTIPLE_LEVELS )
+fn_nodei( TMPL_ARGS_DEPTH )
+fn_2( TMPL_ARGS_LEVEL, tree, tree, int )
+fn_3( SET_TMPL_ARGS_LEVEL, tree, tree, int, tree )
+fn_3( TMPL_ARG, tree, tree, int, int )
+fn_4( SET_TMPL_ARG, tree, tree, int, int, tree )
+fn_nodei( NUM_TMPL_ARGS )
+fn_noden( INNERMOST_TEMPLATE_ARGS )
+fn_1( TMPL_PARMS_DEPTH, unsigned HOST_WIDE_INT, tree )
+fn_noden( DECL_TI_TEMPLATE )
+fn_noden( DECL_TI_ARGS )
+fn_noden( CLASSTYPE_TI_TEMPLATE )
+fn_noden( CLASSTYPE_TI_ARGS )
+fn_noden( ENUM_TI_TEMPLATE )
+fn_noden( ENUM_TI_ARGS )
+fn_noden( TYPE_TI_TEMPLATE )
+fn_noden( TYPE_TI_ARGS)
+fn_noden( INNERMOST_TEMPLATE_PARMS )
+fn_nodei( TEMPLATE_PARMS_FOR_INLINE )
+fn_1( DECL_SAVED_FUNCTION_DATA, struct cp_language_function *, tree )
+fn_nodei( NEW_EXPR_USE_GLOBAL )
+fn_nodei( DELETE_EXPR_USE_GLOBAL )
+fn_nodei( DELETE_EXPR_USE_VEC )
+fn_nodei( LOOKUP_EXPR_GLOBAL )
+fn_nodei( AGGR_INIT_VIA_CTOR_P )
+fn_nodei( CLASSTYPE_IS_TEMPLATE )
+fn_noden( TYPENAME_TYPE_FULLNAME )
+fn_nodei( IMPLICIT_TYPENAME_P )
+fn_nodei( IMPLICIT_TYPENAME_TYPE_DECL_P )
+fn_nodei( TREE_NEGATED_INT )
+fn_nodei( TYPE_BASE_CONVS_MAY_REQUIRE_CODE_P )
+fn_nodei( TYPE_POLYMORPHIC_P )
+fn_nodei( TYPE_CONTAINS_VPTR_P )
+fn_nodei( DECL_DEAD_FOR_LOCAL )
+fn_nodei( DECL_ERROR_REPORTED )
+fn_nodei( DECL_LOCAL_FUNCTION_P )
+fn_nodei( DECL_ANTICIPATED )
+fn_nodei( C_TYPEDEF_EXPLICITLY_SIGNED )
+fn_nodei( DECL_EXTERNAL_LINKAGE_P )
+fn_1( INTEGRAL_CODE_P, int, int )
+fn_nodei( CP_INTEGRAL_TYPE_P )
+fn_nodei( ARITHMETIC_TYPE_P )
+fn_nodei( TYPE_HAS_CONSTRUCTOR )
+fn_nodei( TREE_HAS_CONSTRUCTOR )
+fn_nodei( EMPTY_CONSTRUCTOR_P )
+fn_nodei( TYPE_HAS_DESTRUCTOR )
+fn_nodei( CLASSTYPE_NON_AGGREGATE )
+fn_nodei( TYPE_NON_AGGREGATE_CLASS )
+fn_nodei( TYPE_HAS_REAL_ASSIGN_REF )
+fn_nodei( TYPE_HAS_COMPLEX_ASSIGN_REF )
+fn_nodei( TYPE_HAS_ABSTRACT_ASSIGN_REF )
+fn_nodei( TYPE_HAS_COMPLEX_INIT_REF )
+fn_nodei( TYPE_HAS_TRIVIAL_DESTRUCTOR1 )
+fn_nodei( TYPE_HAS_NONTRIVIAL_DESTRUCTOR )
+fn_nodei( TYPE_HAS_TRIVIAL_INIT_REF )
+fn_nodei( TYPE_HAS_TRIVIAL_ASSIGN_REF )
+fn_nodei( TYPE_PTRMEM_P )
+fn_nodei( TYPE_PTR_P )
+fn_nodei( TYPE_PTROB_P )
+fn_nodei( TYPE_PTROBV_P )
+fn_nodei( TYPE_PTRFN_P )
+fn_nodei( TYPE_PTRMEMFUNC_P )
+fn_nodei( TYPE_PTRMEMFUNC_FLAG )
+fn_nodei( PTRMEM_OK_P )
+fn_noden( TYPE_PTRMEMFUNC_FN_TYPE )
+fn_noden( TYPE_PTRMEMFUNC_OBJECT_TYPE )
+fn_noden( TYPE_GET_PTRMEMFUNC_TYPE )
+#if 0 /* this one doesn't have a return value */
+fn_2( TYPE_SET_PTRMEMFUNC_TYPE, struct lang_type *, tree, struct lang_type*)
+#endif
+fn_noden( DELTA2_FROM_PTRMEMFUNC )
+fn_noden( PFN_FROM_PTRMEMFUNC )
+fn_noden( TYPE_PTRMEM_CLASS_TYPE )
+fn_noden( TYPE_PTRMEM_POINTED_TO_TYPE )
+fn_noden( PTRMEM_CST_CLASS )
+fn_noden( PTRMEM_CST_MEMBER )
+fn_nodei( DECL_THIS_EXTERN )
+fn_nodei( DECL_THIS_STATIC )
+fn_nodei( ANON_AGGR_TYPE_P )
+fn_nodei( SET_ANON_AGGR_TYPE_P )
+fn_nodei( ANON_UNION_TYPE_P )
+fn_nodei( TYPE_WAS_ANONYMOUS )
+fn_noden( DECL_FRIENDLIST )
+fn_noden( FRIEND_NAME )
+fn_noden( FRIEND_DECLS )
+fn_noden( DECL_ACCESS )
+fn_nodei( DECL_GLOBAL_CTOR_P )
+fn_nodei( DECL_GLOBAL_DTOR_P )
+fn_nodei( GLOBAL_INIT_PRIORITY )
+fn_noden( DECL_TEMPLATE_PARMS )
+fn_noden( DECL_INNERMOST_TEMPLATE_PARMS )
+fn_nodei( DECL_NTPARMS )
+fn_noden( DECL_TEMPLATE_RESULT )
+fn_noden( DECL_TEMPLATE_INSTANTIATIONS )
+fn_noden( DECL_TEMPLATE_SPECIALIZATIONS )
+fn_nodei( DECL_TEMPLATE_PARM_P )
+fn_nodei( SET_DECL_TEMPLATE_PARM_P )
+fn_nodei( DECL_TEMPLATE_TEMPLATE_PARM_P )
+fn_nodei( DECL_FUNCTION_TEMPLATE_P )
+fn_nodei( DECL_CLASS_TEMPLATE_P )
+fn_nodei( DECL_DECLARES_TYPE_P )
+fn_nodei( DECL_IMPLICIT_TYPEDEF_P )
+fn_nodei( SET_DECL_IMPLICIT_TYPEDEF_P )
+fn_noden( DECL_PRIMARY_TEMPLATE )
+fn_nodei( PRIMARY_TEMPLATE_P )
+fn_nodei( CLASSTYPE_TEMPLATE_LEVEL )
+fn_nodei( DECL_USE_TEMPLATE )
+fn_nodei( DECL_TEMPLATE_INSTANTIATION )
+fn_nodei( CLASSTYPE_TEMPLATE_INSTANTIATION )
+fn_nodei( DECL_TEMPLATE_SPECIALIZATION )
+fn_nodei( SET_DECL_TEMPLATE_SPECIALIZATION )
+fn_nodei( CLASSTYPE_TEMPLATE_SPECIALIZATION )
+fn_nodei( SET_CLASSTYPE_TEMPLATE_SPECIALIZATION )
+fn_nodei( DECL_IMPLICIT_INSTANTIATION )
+fn_nodei( SET_DECL_IMPLICIT_INSTANTIATIO )
+fn_nodei( CLASSTYPE_IMPLICIT_INSTANTIATION )
+fn_nodei( SET_CLASSTYPE_IMPLICIT_INSTANTIATION )
+fn_nodei( DECL_EXPLICIT_INSTANTIATION )
+fn_nodei( SET_DECL_EXPLICIT_INSTANTIATION )
+fn_nodei( CLASSTYPE_EXPLICIT_INSTANTIATION )
+fn_nodei( SET_CLASSTYPE_EXPLICIT_INSTANTIATION )
+fn_nodei( DECL_FRIEND_PSEUDO_TEMPLATE_INSTANTIATION )
+fn_nodei( PARTIAL_INSTANTIATION_P )
+fn_0( PROCESSING_REAL_TEMPLATE_DECL_P, int )
+fn_nodei( DECL_MAYBE_TEMPLATE )
+fn_nodei( DECL_TEMPLATE_INSTANTIATED )
+fn_nodei( DECL_INTERFACE_KNOWN )
+fn_nodei( DECL_DECLARED_INLINE_P )
+fn_nodei( DECL_NOT_REALLY_EXTERN )
+fn_nodei( DECL_REALLY_EXTERN )
+fn_nodei( THUNK_DELTA )
+fn_noden( THUNK_VCALL_OFFSET )
+fn_nodei( THUNK_GENERATE_WITH_VTABLE_P )
+fn_noden( TRY_STMTS )
+fn_noden( TRY_HANDLERS )
+fn_noden( EH_SPEC_STMTS )
+fn_noden( EH_SPEC_RAISES )
+fn_nodei( FN_TRY_BLOCK_P )
+fn_noden( HANDLER_PARMS )
+fn_noden( HANDLER_BODY )
+fn_noden( SUBOBJECT_CLEANUP )
+fn_noden( START_CATCH_TYPE )
+fn_nodei( CTOR_BEGIN_P )
+fn_nodei( CTOR_END_P )
+fn_noden( CALL_DECLARATOR_PARMS )
+fn_noden( CALL_DECLARATOR_QUALS )
+fn_noden( CALL_DECLARATOR_EXCEPTION_SPEC )
+fn_noden( TINST_DECL )
+fn_nodei( TINST_LINE )
+fn_1( TINST_FILE, char*, tree )
+fn_nodei( THIS_NAME_P )
+fn_nodei( VPTR_NAME_P )
+fn_nodei( DESTRUCTOR_NAME_P )
+fn_nodei( VTABLE_NAME_P )
+fn_nodei( VBASE_NAME_P )
+fn_nodei( TEMP_NAME_P )
+fn_nodei( VFIELD_NAME_P )
+fn_nodei( ANON_AGGRNAME_P )
+fn_nodei( ANON_PARMNAME_P )
+fn_2( same_or_base_type_p, int, tree, tree )
+fn_1( TEMPLATE_PARM_INDEX_CAST, template_parm_index*, tree )
+fn_nodei( TEMPLATE_PARM_IDX )
+fn_nodei( TEMPLATE_PARM_LEVEL )
+fn_noden( TEMPLATE_PARM_DESCENDANTS )
+fn_nodei( TEMPLATE_PARM_ORIG_LEVEL )
+fn_noden( TEMPLATE_PARM_DECL )
+fn_noden( TEMPLATE_TYPE_PARM_INDEX )
+fn_nodei( TEMPLATE_TYPE_IDX )
+fn_nodei( TEMPLATE_TYPE_LEVEL )
+fn_nodei( TEMPLATE_TYPE_ORIG_LEVEL )
+fn_noden( TEMPLATE_TYPE_DECL )
+fn_noden( TEMPLATE_TEMPLATE_PARM_TEMPLATE_DECL )
+fn_2( cp_build_qualified_type, tree, tree, int )
+fn_3( cp_build_binary_op, tree, enum tree_code, tree, tree )
+
+#endif /* ENABLE_IDEBUG */
diff --git a/gcc/cp/cp-lang.c b/gcc/cp/cp-lang.c
index fb5b2389131..8af09e9c3f4 100644
--- a/gcc/cp/cp-lang.c
+++ b/gcc/cp/cp-lang.c
@@ -53,6 +53,8 @@ static void cxx_initialize_diagnostics (diagnostic_context *);
#define LANG_HOOKS_FINISH cxx_finish
#undef LANG_HOOKS_CLEAR_BINDING_STACK
#define LANG_HOOKS_CLEAR_BINDING_STACK pop_everything
+#undef LANG_HOOKS_FINISH_FILE
+#define LANG_HOOKS_FINISH_FILE finish_file
#undef LANG_HOOKS_INIT_OPTIONS
#define LANG_HOOKS_INIT_OPTIONS c_common_init_options
#undef LANG_HOOKS_INITIALIZE_DIAGNOSTICS
@@ -189,6 +191,22 @@ static void cxx_initialize_diagnostics (diagnostic_context *);
#undef LANG_HOOKS_GIMPLIFY_EXPR
#define LANG_HOOKS_GIMPLIFY_EXPR cp_gimplify_expr
+/* APPLE LOCAL begin Objective-C++ */
+/* Redefine the hooks that need to be different for ObjC++. */
+#ifdef OBJCPLUS
+static void objcplus_init_options PARAMS ((void));
+#include "objc/objc-act.h"
+#undef LANG_HOOKS_NAME
+#define LANG_HOOKS_NAME "GNU Objective-C++"
+#undef LANG_HOOKS_INIT
+#define LANG_HOOKS_INIT objc_init
+#undef LANG_HOOKS_FINISH_FILE
+#define LANG_HOOKS_FINISH_FILE objc_finish_file
+#undef LANG_HOOKS_INIT_OPTIONS
+#define LANG_HOOKS_INIT_OPTIONS objcplus_init_options
+#endif /* OBJCPLUS */
+/* APPLE LOCAL end Objective-C++ */
+
/* Each front end provides its own hooks, for toplev.c. */
const struct lang_hooks lang_hooks = LANG_HOOKS_INITIALIZER;
@@ -202,6 +220,12 @@ const char tree_code_type[] = {
#include "c-common.def"
'x',
#include "cp-tree.def"
+/* APPLE LOCAL begin Objective-C++ */
+#ifdef OBJCPLUS
+ 'x',
+#include "objc-tree.def"
+#endif
+/* APPLE LOCAL end Objective-C++ */
};
#undef DEFTREECODE
@@ -217,6 +241,12 @@ const unsigned char tree_code_length[] = {
#include "c-common.def"
0,
#include "cp-tree.def"
+/* APPLE LOCAL begin Objective-C++ */
+#ifdef OBJCPLUS
+ 0,
+#include "objc-tree.def"
+#endif
+/* APPLE LOCAL end Objective-C++ */
};
#undef DEFTREECODE
@@ -230,6 +260,12 @@ const char *const tree_code_name[] = {
#include "c-common.def"
"@@dummy",
#include "cp-tree.def"
+/* APPLE LOCAL begin Objective-C++ */
+#ifdef OBJCPLUS
+ "@@dummy",
+#include "objc-tree.def"
+#endif
+/* APPLE LOCAL end Objective-C++ */
};
#undef DEFTREECODE
@@ -269,6 +305,16 @@ cxx_warn_unused_global_decl (tree decl)
return true;
}
+/* APPLE LOCAL begin Objective-C++ */
+#ifdef OBJCPLUS
+static void
+objcplus_init_options (void)
+{
+ flag_objc = 1;
+ cxx_init_options ();
+}
+#endif
+
/* Langhook for expr_size: Tell the backend that the value of an expression
of non-POD class type does not include any tail padding; a derived class
might have allocated something there. */
@@ -386,3 +432,20 @@ cxx_initialize_diagnostics (diagnostic_context *context)
/* It is safe to free this object because it was previously malloc()'d. */
free (base);
}
+
+/* APPLE LOCAL Objective-C++ */
+/* Include the GC roots here instead of in cp/decl.c, so we can
+ conditionalize on OBJCPLUS. */
+#include "decl.h"
+#include "debug.h"
+#include "lex.h"
+#include "gt-cp-cp-tree-h.h"
+#include "gt-cp-decl-h.h"
+#ifdef OBJCPLUS
+tree objcp_dummy = 0;
+#include "gtype-objcp.h"
+#else
+tree cp_dummy = 0;
+#include "gtype-cp.h"
+#endif
+/* APPLE LOCAL end Objective-C++ */
diff --git a/gcc/cp/cp-root.h b/gcc/cp/cp-root.h
new file mode 100644
index 00000000000..3bb87980f0d
--- /dev/null
+++ b/gcc/cp/cp-root.h
@@ -0,0 +1,4 @@
+/* APPLE LOCAL file Objective-C++ */
+/* Empty file to be the base for gtype-cp.h. */
+
+extern GTY(()) tree cp_dummy;
diff --git a/gcc/cp/cp-tree.h b/gcc/cp/cp-tree.h
index f6282105daf..69596bc635c 100644
--- a/gcc/cp/cp-tree.h
+++ b/gcc/cp/cp-tree.h
@@ -223,6 +223,9 @@ struct lang_identifier GTY(())
cxx_binding *bindings;
tree class_value;
tree class_template_info;
+ /* APPLE begin LOCAL objc speedup dpatel */
+ tree interface_value;
+ /* APPLE end LOCAL objc speedup dpatel */
tree label_value;
tree implicit_decl;
tree error_locus;
@@ -536,6 +539,8 @@ enum cp_tree_index
CPTI_LANG_NAME_C,
CPTI_LANG_NAME_CPLUSPLUS,
CPTI_LANG_NAME_JAVA,
+ /* APPLE LOCAL Objective-C++ */
+ CPTI_LANG_NAME_OBJC,
CPTI_EMPTY_EXCEPT_SPEC,
CPTI_NULL,
@@ -548,6 +553,12 @@ enum cp_tree_index
CPTI_KEYED_CLASSES,
+ /* APPLE LOCAL begin 2.95-ptmf-compatibility turly 20020313 */
+ CPTI_DELTA2_IDENTIFIER,
+ CPTI_INDEX_IDENTIFIER,
+ CPTI_PFN_OR_DELTA2_IDENTIFIER,
+ /* APPLE LOCAL end 2.95-ptmf-compatibility turly 20020313 */
+
CPTI_MAX
};
@@ -619,6 +630,12 @@ extern GTY(()) tree cp_global_trees[CPTI_MAX];
#define deleting_dtor_identifier cp_global_trees[CPTI_DELETING_DTOR_IDENTIFIER]
#define delta_identifier cp_global_trees[CPTI_DELTA_IDENTIFIER]
#define in_charge_identifier cp_global_trees[CPTI_IN_CHARGE_IDENTIFIER]
+ /* APPLE LOCAL begin 2.95-ptmf-compatibility turly 20020313 */
+#define delta2_identifier cp_global_trees[CPTI_DELTA2_IDENTIFIER]
+#define index_identifier cp_global_trees[CPTI_INDEX_IDENTIFIER]
+#define pfn_or_delta2_identifier cp_global_trees[CPTI_PFN_OR_DELTA2_IDENTIFIER]
+ /* APPLE LOCAL end 2.95-ptmf-compatibility turly 20020313 */
+
/* The name of the parameter that contains a pointer to the VTT to use
for this subobject constructor or destructor. */
#define vtt_parm_identifier cp_global_trees[CPTI_VTT_PARM_IDENTIFIER]
@@ -631,6 +648,8 @@ extern GTY(()) tree cp_global_trees[CPTI_MAX];
#define lang_name_c cp_global_trees[CPTI_LANG_NAME_C]
#define lang_name_cplusplus cp_global_trees[CPTI_LANG_NAME_CPLUSPLUS]
#define lang_name_java cp_global_trees[CPTI_LANG_NAME_JAVA]
+/* APPLE LOCAL Objective-C++ */
+#define lang_name_objc cp_global_trees[CPTI_LANG_NAME_OBJC]
/* Exception specifier used for throw(). */
#define empty_except_spec cp_global_trees[CPTI_EMPTY_EXCEPT_SPEC]
@@ -879,7 +898,8 @@ enum cplus_tree_code {
CTOR_INITIALIZER, TRY_BLOCK, HANDLER, \
EH_SPEC_BLOCK, USING_STMT, TAG_DEFN
-enum languages { lang_c, lang_cplusplus, lang_java };
+/* APPLE LOCAL Objective-C++ */
+enum languages { lang_c, lang_cplusplus, lang_java, lang_objc };
/* Macros to make error reporting functions' lives easier. */
#define TYPE_IDENTIFIER(NODE) (DECL_NAME (TYPE_NAME (NODE)))
@@ -2504,8 +2524,13 @@ struct lang_decl GTY(())
/* Get the POINTER_TYPE to the METHOD_TYPE associated with this
pointer to member function. TYPE_PTRMEMFUNC_P _must_ be true,
before using this macro. */
-#define TYPE_PTRMEMFUNC_FN_TYPE(NODE) \
- (TREE_TYPE (TYPE_FIELDS (NODE)))
+ /* APPLE LOCAL begin 2.95-ptmf-compatibility turly 20020313 */ \
+#define TYPE_PTRMEMFUNC_FN_TYPE(NODE) \
+ *((flag_apple_kext) ? \
+ &(TREE_TYPE (TYPE_FIELDS (TREE_TYPE (TREE_CHAIN ( \
+ TREE_CHAIN (TYPE_FIELDS (NODE))))))) : \
+ &(TREE_TYPE (TYPE_FIELDS (NODE)))) \
+ /* APPLE LOCAL end 2.95-ptmf-compatibility turly 20020313 */
/* Returns `A' for a type like `int (A::*)(double)' */
#define TYPE_PTRMEMFUNC_OBJECT_TYPE(NODE) \
@@ -3567,6 +3592,8 @@ extern void note_name_declared_in_class (tree, tree);
extern tree get_vtbl_decl_for_binfo (tree);
extern tree get_vtt_name (tree);
extern tree get_primary_binfo (tree);
+/* APPLE LOCAL -findirect-virtual-calls 2001-10-30 sts */
+extern tree build_vfn_ref_using_vtable (tree, tree);
extern void debug_class (tree);
extern void debug_thunks (tree);
@@ -3587,6 +3614,12 @@ extern void clone_function_decl (tree, int);
extern void adjust_clone_args (tree);
/* decl.c */
+/* APPLE LOCAL msg send super */
+extern struct cp_binding_level *get_current_binding_level (void);
+/* APPLE LOCAL begin Objective-C++ */
+extern tree grokparms (tree);
+extern void store_parm_decls (tree);
+/* APPLE LOCAL end Objective-C++ */
extern void insert_block (tree);
extern void set_block (tree);
extern tree pushdecl (tree);
@@ -4265,6 +4298,22 @@ extern tree mangle_ref_init_variable (tree);
/* in dump.c */
extern bool cp_dump_tree (void *, tree);
+/* APPLE LOCAL begin ddtor double destructor turly 20020215 */
+extern int has_apple_kext_compatibility_attr_p PARAMS ((tree));
+extern int has_empty_operator_delete_p PARAMS ((tree));
+extern int compound_body_is_empty_p PARAMS ((tree));
+/* APPLE LOCAL end ddtor double destructor turly 20020215 */
+
+/* APPLE LOCAL begin new tree dump */
+/* in cp-dmp-tree.c */
+extern void cxx_dump_identifier PARAMS ((FILE *, tree, int, int));
+extern void cxx_dump_decl PARAMS ((FILE *, tree, int, int));
+extern void cxx_dump_type PARAMS ((FILE *, tree, int, int));
+extern int cxx_dump_blank_line_p PARAMS ((tree, tree));
+extern int cxx_dump_lineno_p PARAMS ((FILE *, tree));
+extern int cxx_dmp_tree3 PARAMS ((FILE *, tree, int));
+/* APPLE LOCAL end new tree dump */
+
/* in cp-simplify.c */
extern int cp_gimplify_expr (tree *, tree *, tree *);
extern int cp_gimplify_stmt (tree *, tree *);
diff --git a/gcc/cp/decl.c b/gcc/cp/decl.c
index 8e7eded6047..bffca7900f8 100644
--- a/gcc/cp/decl.c
+++ b/gcc/cp/decl.c
@@ -53,7 +53,9 @@ Boston, MA 02111-1307, USA. */
#include "timevar.h"
#include "tree-flow.h"
-static tree grokparms (tree);
+/* APPLE LOCAL Objective-C++ */
+/* 'grokparms' is now extern, prototype moved to cp-tree.h. */
+
static const char *redeclaration_error_message (tree, tree);
static int decl_jump_unsafe (tree);
@@ -114,7 +116,8 @@ static tree check_special_function_return_type
(special_function_kind, tree, tree);
static tree push_cp_library_fn (enum tree_code, tree);
static tree build_cp_library_fn (tree, enum tree_code, tree);
-static void store_parm_decls (tree);
+/* APPLE LOCAL Objective-C++ */
+/* 'store_parm_decls' is now extern, prototype moved to cp-tree.h. */
static void initialize_local_var (tree, tree);
static void expand_static_init (tree, tree);
static tree next_initializable_field (tree);
@@ -237,10 +240,17 @@ int function_depth;
with __attribute__((deprecated)). An object declared as
__attribute__((deprecated)) suppresses warnings of uses of other
deprecated items. */
+/* APPLE LOCAL begin unavailable */
+/* An object declared as __attribute__((unavailable)) suppresses
+ any reports of being declared with unavailable or deprecated
+ items. */
+/* APPLE LOCAL end unavailable */
enum deprecated_states {
DEPRECATED_NORMAL,
DEPRECATED_SUPPRESS
+ /* APPLE LOCAL unavailable */
+ , DEPRECATED_UNAVAILABLE_SUPPRESS
};
static enum deprecated_states deprecated_state = DEPRECATED_NORMAL;
@@ -1297,6 +1307,9 @@ duplicate_decls (tree newdecl, tree olddecl)
olddecl = TREE_VALUE (olddecl);
cp_error_at ("previous declaration of `%#D'", olddecl);
+ /* New decl is completely inconsistent with the old one =>
+ tell caller to replace the old one. */
+
return error_mark_node;
}
else if (!types_match)
@@ -1828,6 +1841,8 @@ duplicate_decls (tree newdecl, tree olddecl)
regardless of declaration matches. */
SET_DECL_RTL (newdecl, DECL_RTL (olddecl));
}
+ else
+ DECL_ESTIMATED_INSNS (newdecl) = DECL_ESTIMATED_INSNS (olddecl);
DECL_RESULT (newdecl) = DECL_RESULT (olddecl);
/* Don't clear out the arguments if we're redefining a function. */
@@ -2859,6 +2874,8 @@ initialize_predefined_identifiers (void)
static const predefined_identifier predefined_identifiers[] = {
{ "C++", &lang_name_cplusplus, 0 },
{ "C", &lang_name_c, 0 },
+ /* APPLE LOCAL Objective-C++ */
+ { "Objective-C", &lang_name_objc, 0 }, /* this is DEPRECATED */
{ "Java", &lang_name_java, 0 },
{ CTOR_NAME, &ctor_identifier, 1 },
{ "__base_ctor", &base_ctor_identifier, 1 },
@@ -2885,6 +2902,45 @@ initialize_predefined_identifiers (void)
if (pid->ctor_or_dtor_p)
IDENTIFIER_CTOR_OR_DTOR_P (*pid->node) = 1;
}
+ /* APPLE LOCAL begin 2.95-ptmf-compatibility turly 20020313 */
+ if (flag_apple_kext)
+ {
+ /* This is snarfed from the 2.95 cp-tree.h. The mechanism is
+ completely different from gcc3 (see cp-tree.h, and read the
+ comment just above 'enum ptrmemfunc_vbit_where_t'. Sigh.
+
+ A 2.95 pointer-to-function member type looks like:
+
+ struct {
+ short __delta;
+ short __index;
+ union {
+ P __pfn;
+ short __delta2;
+ } __pfn_or_delta2;
+ };
+
+ where P is a POINTER_TYPE to a METHOD_TYPE appropriate for the
+ pointer to member. The fields are used as follows:
+
+ If __INDEX is -1, then the function to call is non-virtual, and
+ is located at the address given by __PFN.
+
+ If __INDEX is zero, then this a NULL pointer-to-member.
+
+ Otherwise, the function to call is virtual. Then, __DELTA2 gives
+ the offset from an instance of the object to the virtual function
+ table, and __INDEX - 1 is the index into the vtable to use to
+ find the function.
+
+ The value to use for the THIS parameter is the address of the
+ object plus __DELTA. */
+
+ delta2_identifier = get_identifier ("__delta2");
+ index_identifier = get_identifier ("__index");
+ pfn_or_delta2_identifier = get_identifier ("__pfn_or_delta2");
+ }
+ /* APPLE LOCAL end 2.95-ptmf-compatibility turly 20020313 */
}
/* Create the predefined scalar types of C,
@@ -2974,6 +3030,11 @@ cxx_init_decl_processing (void)
record_builtin_type (RID_MAX, NULL, string_type_node);
#endif
+ /* APPLE LOCAL begin 2.95-ptmf-compatibility turly 20020313 */
+ if (flag_apple_kext)
+ delta_type_node = short_integer_type_node;
+ else
+ /* APPLE LOCAL end 2.95-ptmf-compatibility turly 20020313 */
delta_type_node = ptrdiff_type_node;
vtable_index_type = ptrdiff_type_node;
@@ -3231,7 +3292,10 @@ builtin_function (const char* name,
{
/* All builtins that don't begin with an '_' should additionally
go in the 'std' namespace. */
- if (name[0] != '_')
+ /* APPLE LOCAL begin alloca not in std */
+ /* Don't use `std' namespace for alloca. */
+ if (name[0] != '_' && strcmp (name, "alloca"))
+ /* APPLE LOCAL end alloca not in std */
{
push_namespace (std_identifier);
builtin_function_1 (name, type, std_node, code, class, libname, attrs);
@@ -3344,6 +3408,7 @@ push_throw_library_fn (tree name, tree type)
TREE_NOTHROW (fn) = 0;
return fn;
}
+
/* When we call finish_struct for an anonymous union, we create
default copy constructors and such. But, an anonymous union
@@ -3623,6 +3688,8 @@ start_decl (tree declarator,
tree decl;
tree type, tem;
tree context;
+ /* APPLE LOCAL unavailable */
+ tree a;
/* This should only be done once on the top most decl. */
if (have_extern_spec)
@@ -3632,10 +3699,34 @@ start_decl (tree declarator,
have_extern_spec = false;
}
- /* An object declared as __attribute__((deprecated)) suppresses
- warnings of uses of other deprecated items. */
+ /* APPLE LOCAL begin unavailable */
+ /* An object declared as __attribute__((unavailable)) suppresses
+ any reports of being declared with unavailable or deprecated
+ items. An object declared as __attribute__((deprecated))
+ suppresses warnings of uses of other deprecated items. */
+#ifdef A_LESS_INEFFICENT_WAY /* which I really don't want to do! */
if (lookup_attribute ("deprecated", attributes))
deprecated_state = DEPRECATED_SUPPRESS;
+ else if (lookup_attribute ("unavailable", attributes))
+ deprecated_state = DEPRECATED_UNAVAILABLE_SUPPRESS;
+#else /* a more efficient way doing what lookup_attribute would do */
+ for (a = attributes; a; a = TREE_CHAIN (a))
+ {
+ tree name = TREE_PURPOSE (a);
+ if (TREE_CODE (name) == IDENTIFIER_NODE)
+ if (is_attribute_p ("deprecated", name))
+ {
+ deprecated_state = DEPRECATED_SUPPRESS;
+ break;
+ }
+ if (is_attribute_p ("unavailable", name))
+ {
+ deprecated_state = DEPRECATED_UNAVAILABLE_SUPPRESS;
+ break;
+ }
+ }
+#endif
+ /* APPLE LOCAL end unavailable */
attributes = chainon (attributes, prefix_attributes);
@@ -4070,6 +4161,14 @@ maybe_commonize_var (tree decl)
}
else
{
+ /* APPLE LOCAL begin coalescing */
+#ifdef MAKE_DECL_COALESCED
+ if (DECL_INTERFACE_KNOWN (current_function_decl))
+ DECL_EXTERNAL (decl) = DECL_EXTERNAL (current_function_decl);
+ TREE_PUBLIC (decl) = 1;
+ MAKE_DECL_COALESCED (decl);
+#else
+ /* APPLE LOCAL end coalescing */
if (DECL_INITIAL (decl) == NULL_TREE
|| DECL_INITIAL (decl) == error_mark_node)
{
@@ -4089,6 +4188,8 @@ maybe_commonize_var (tree decl)
warning ("%J you can work around this by removing the initializer",
decl);
}
+/* APPLE LOCAL coalescing */
+#endif
}
}
else if (DECL_LANG_SPECIFIC (decl) && DECL_COMDAT (decl))
@@ -4587,6 +4688,17 @@ make_rtl_for_nonlocal_decl (tree decl, tree init, const char* asmspec)
isn't stored in the tree, yet) */
if (defer_p && asmspec)
make_decl_rtl (decl, asmspec);
+ /* APPLE LOCAL begin static const members turly 20020110 */
+ /* Static const members which require runtime initialisation should
+ not be placed in readonly memory. Avoid this by temporarily
+ whacking the TREE_READONLY bit. */
+ else if (!defer_p && init != NULL_TREE && TREE_READONLY (decl) && toplev)
+ {
+ TREE_READONLY (decl) = 0;
+ rest_of_decl_compilation (decl, asmspec, toplev, at_eof);
+ TREE_READONLY (decl) = 1;
+ }
+ /* APPLE LOCAL end static const members turly 20020110 */
/* If we're not deferring, go ahead and assemble the variable. */
else if (!defer_p)
rest_of_decl_compilation (decl, asmspec, toplev, at_eof);
@@ -5905,12 +6017,48 @@ build_ptrmemfunc_type (tree type)
unqualified_variant
= build_ptrmemfunc_type (TYPE_MAIN_VARIANT (type));
+ /* APPLE LOCAL begin 2.95-ptmf-compatibility turly 20020313 */
+ if (flag_apple_kext)
+ {
+ abort ();
+#if 0
+ /* MERGE FIXME */
+ tree u = make_aggr_type (UNION_TYPE);
+ SET_IS_AGGR_TYPE (u, 0);
+ fields = build_decl (FIELD_DECL, pfn_identifier, type);
+ TREE_CHAIN (fields)
+ = build_decl (FIELD_DECL, delta2_identifier, delta_type_node);
+ finish_builtin_type (u, "__ptrmemfunc_type", fields, 1, ptr_type_node);
+ TYPE_NAME (u) = NULL_TREE;
+
+ t = make_aggr_type (RECORD_TYPE);
+
+ /* Let the front-end know this is a pointer to member function... */
+ TYPE_PTRMEMFUNC_FLAG (t) = 1;
+ /* ... and not really an aggregate. */
+ SET_IS_AGGR_TYPE (t, 0);
+
+ fields = build_decl (FIELD_DECL, delta_identifier, delta_type_node);
+ TREE_CHAIN (fields) =
+ build_decl (FIELD_DECL, index_identifier, delta_type_node);
+ TREE_CHAIN (TREE_CHAIN (fields)) =
+ build_decl (FIELD_DECL, pfn_or_delta2_identifier, u);
+ finish_builtin_type (t, "__ptrmemfunc_type", fields, 2, ptr_type_node);
+#endif
+ }
+ else
+ {
+ /* APPLE LOCAL end 2.95-ptmf-compatibility turly 20020313 */
+
t = make_aggr_type (RECORD_TYPE);
/* Let the front-end know this is a pointer to member function... */
TYPE_PTRMEMFUNC_FLAG (t) = 1;
/* ... and not really an aggregate. */
SET_IS_AGGR_TYPE (t, 0);
+ /* APPLE LOCAL 2.95-ptmf-compatibility turly 20020313 */
+ }
+
field = build_decl (FIELD_DECL, pfn_identifier, type);
fields = field;
@@ -6707,11 +6855,38 @@ grokdeclarator (tree declarator,
/* If the entire declaration is itself tagged as deprecated then
suppress reports of deprecated items. */
+ /* APPLE LOCAL begin unavailable */
+ /* If the entire declaration is itself tagged as unavailable then
+ suppress reports of unavailable/deprecated items. If the
+ entire declaration is tagged as only deprecated we still
+ report unavailable uses. */
if (!adding_implicit_members && id && TREE_DEPRECATED (id))
{
- if (deprecated_state != DEPRECATED_SUPPRESS)
- warn_deprecated_use (id);
+ if (TREE_UNAVAILABLE (id))
+ {
+ if (deprecated_state != DEPRECATED_UNAVAILABLE_SUPPRESS)
+ warn_deprecated_use (id);
+ #if 0
+ returned_attrs
+ = chainon (returned_attrs,
+ build_tree_list (get_identifier ("unavailable"),
+ NULL_TREE));
+ #endif
+ }
+ else
+ {
+ if (deprecated_state != DEPRECATED_SUPPRESS
+ && deprecated_state != DEPRECATED_UNAVAILABLE_SUPPRESS)
+ warn_deprecated_use (id);
+ #if 0
+ returned_attrs
+ = chainon (returned_attrs,
+ build_tree_list (get_identifier ("deprecated"),
+ NULL_TREE));
+ #endif
+ }
}
+ /* APPLE LOCAL end unavailable */
if (TREE_CODE (id) == IDENTIFIER_NODE)
{
@@ -6880,6 +7055,8 @@ grokdeclarator (tree declarator,
RIDBIT_RESET (RID_LONG, specbits);
type = build_qualified_type (long_double_type_node,
cp_type_quals (type));
+ /* APPLE LOCAL -Wlong-double dpatel */
+ warn_about_long_double ();
}
/* Check all other uses of type modifiers. */
@@ -8580,7 +8757,8 @@ check_default_argument (tree decl, tree arg)
Also set last_function_parms to the chain of PARM_DECLs. */
-static tree
+/* APPLE LOCAL Objective-C++ */
+tree
grokparms (tree first_parm)
{
tree result = NULL_TREE;
@@ -9684,8 +9862,9 @@ start_enum (tree name)
/* If this is the real definition for a previous forward reference,
fill in the contents in the same object that used to be the
forward reference. */
-
- if (name != NULL_TREE)
+ /* APPLE LOCAL do not forward reference anonymous enum */
+ /* Note that an anonymous enum cannot be forward-referenced. */
+ if (name != NULL_TREE && !ANON_AGGRNAME_P (name))
enumtype = lookup_tag (ENUMERAL_TYPE, name, b, 1);
if (enumtype != NULL_TREE && TREE_CODE (enumtype) == ENUMERAL_TYPE)
@@ -10242,6 +10421,9 @@ start_function (tree declspecs, tree declarator, tree attrs, int flags)
/* Start the statement-tree, start the tree now. */
begin_stmt_tree (&DECL_SAVED_TREE (decl1));
+ /* Don't double-count statements in templates. */
+ DECL_ESTIMATED_INSNS (decl1) = 0;
+
/* Let the user know we're compiling this function. */
announce_function (decl1);
@@ -10388,6 +10570,9 @@ start_function (tree declspecs, tree declarator, tree attrs, int flags)
begin_scope (sk_function_parms, decl1);
+ /* APPLE LOCAL weak_import (Radar 2809704) ilr */
+ cplus_decl_attributes (&decl1, attrs, (int)ATTR_FLAG_FUNCTION_DEF);
+
++function_depth;
if (DECL_DESTRUCTOR_P (decl1))
@@ -10409,7 +10594,8 @@ start_function (tree declspecs, tree declarator, tree attrs, int flags)
Also install to binding contour return value identifier, if any. */
-static void
+/* APPLE LOCAL Objective-C++ */
+/* static */ void /* 'store_parm_decls' is extern for Obj-C++ */
store_parm_decls (tree current_function_parms)
{
tree fndecl = current_function_decl;
@@ -11099,6 +11285,26 @@ cxx_maybe_build_cleanup (tree decl)
{
int flags = LOOKUP_NORMAL|LOOKUP_DESTRUCTOR;
tree rval;
+ /* APPLE LOCAL begin double destructor turly 20020214 */
+ special_function_kind dtor = sfk_complete_destructor;
+ if (flag_apple_kext
+ && has_apple_kext_compatibility_attr_p (type))
+ {
+ /* If we have a trivial operator delete (), we can go ahead and
+ just use the deleting destructor, sfk_deleting_destructor. */
+
+ if (! has_empty_operator_delete_p (type) || pedantic)
+ {
+ cp_warning_at ("'%D' is an instance of a class which does "
+ "not allow global or stack-based objects; it "
+ "does not have an empty `operator delete', and "
+ "so it will ** NOT ** be destructed.", decl);
+ return 0;
+ }
+ dtor = sfk_deleting_destructor;
+ }
+ /* APPLE LOCAL end double destructor turly 20020214 */
+
if (TREE_CODE (type) == ARRAY_TYPE)
rval = decl;
@@ -11114,7 +11320,8 @@ cxx_maybe_build_cleanup (tree decl)
flags |= LOOKUP_NONVIRTUAL;
rval = build_delete (TREE_TYPE (rval), rval,
- sfk_complete_destructor, flags, 0);
+ /* APPLE LOCAL double destructor */
+ dtor, flags, 0);
if (TYPE_USES_VIRTUAL_BASECLASSES (type)
&& ! TYPE_HAS_DESTRUCTOR (type))
@@ -11244,4 +11451,5 @@ cp_missing_noreturn_ok_p (tree decl)
}
#include "gt-cp-decl.h"
-#include "gtype-cp.h"
+/* APPLE LOCAL Objective-C++ */
+/* Move gtype-cp.h to cp-lang.c. */
diff --git a/gcc/cp/decl2.c b/gcc/cp/decl2.c
index a802fd4bab1..b783ea990c6 100644
--- a/gcc/cp/decl2.c
+++ b/gcc/cp/decl2.c
@@ -968,6 +968,8 @@ grokfield (tree declarator, tree declspecs, tree init, tree asmspec_tree,
cp_finish_decl (value, init, NULL_TREE, flags);
DECL_INITIAL (value) = init;
DECL_IN_AGGR_P (value) = 1;
+ /* APPLE LOCAL Objective-C++ */
+ objc_check_decl (value);
return value;
}
if (TREE_CODE (value) == FUNCTION_DECL)
@@ -1049,6 +1051,10 @@ grokbitfield (tree declarator, tree declspecs, tree width)
}
DECL_IN_AGGR_P (value) = 1;
+
+ /* APPLE LOCAL Objective-C++ */
+ objc_check_decl (value);
+
return value;
}
@@ -1555,6 +1561,9 @@ maybe_emit_vtables (tree ctype)
{
tree vtbl;
tree primary_vtbl;
+ /* APPLE LOCAL begin coalescing radar 2997605 */
+ int coalesce_vtables;
+ /* APPLE LOCAL end coalescing radar 2997605 */
bool needed = false;
/* If the vtables for this class have already been emitted there is
@@ -1586,6 +1595,22 @@ maybe_emit_vtables (tree ctype)
else if (TREE_PUBLIC (vtbl) && !DECL_COMDAT (vtbl))
needed = true;
+ /* APPLE LOCAL begin coalescing radar 2997605 */
+ /* Check if we're going to coalesce these vtables. On other systems
+ vtables are always weak. We can't do that on OS X because
+ coalescing implies private extern, and making all vtables private
+ extern would break code that defines classes in dylibs. So
+ instead we'll only coalesce vtables that would get emitted in
+ multiple translation units: implicit class template
+ instantiations, classes with no key methods, and classes whose
+ key methods weren't inline in the class definition but turned out
+ to be inline later. */
+ if (CLASSTYPE_USE_TEMPLATE (ctype))
+ coalesce_vtables = CLASSTYPE_IMPLICIT_INSTANTIATION (ctype);
+ else
+ coalesce_vtables = !CLASSTYPE_KEY_METHOD (ctype)
+ || DECL_DECLARED_INLINE_P (CLASSTYPE_KEY_METHOD (ctype));
+ /* APPLE LOCAL end coalescing radar 2997605 */
/* The ABI requires that we emit all of the vtables if we emit any
of them. */
@@ -1636,6 +1661,13 @@ maybe_emit_vtables (tree ctype)
if (flag_weak)
comdat_linkage (vtbl);
+ /* APPLE LOCAL begin coalescing radar 2997605 */
+#ifdef MAKE_DECL_COALESCED
+ if (coalesce_vtables)
+ MAKE_DECL_COALESCED (vtbl);
+#endif /* MAKE_DECL_COALESCED */
+ /* APPLE LOCAL end coalescing radar 2997605 */
+
rest_of_decl_compilation (vtbl, NULL, 1, 1);
/* Because we're only doing syntax-checking, we'll never end up
@@ -1710,9 +1742,25 @@ import_export_decl (tree decl)
}
else
comdat_linkage (decl);
+ /* APPLE LOCAL begin coalescing */
+ /* coalesce inline member functions */
+#ifdef MAKE_DECL_COALESCED
+ if (DECL_DECLARED_INLINE_P (decl))
+ {
+ MAKE_DECL_COALESCED (decl);
+ }
+#endif /* MAKE_DECL_COALESCED */
+ /* APPLE LOCAL end coalescing */
}
+ /* APPLE LOCAL begin coalesce inline functions */
else
- comdat_linkage (decl);
+ {
+ comdat_linkage (decl);
+#ifdef MAKE_DECL_COALESCED
+ MAKE_DECL_COALESCED(decl);
+#endif /* MAKE_DECL_COALESCED */
+ }
+ /* APPLE LOCAL end coalesce inline functions */
DECL_INTERFACE_KNOWN (decl) = 1;
}
@@ -1735,7 +1783,9 @@ import_export_tinfo (tree decl, tree type, bool is_in_library)
/* If -fno-rtti, we're not necessarily emitting this stuff with
the class, so go ahead and emit it now. This can happen when
a class is used in exception handling. */
- && flag_rtti)
+ && flag_rtti
+ /* APPLE LOCAL Jaguar C++ abi compat mrs */
+ && abi_version_at_least (1))
{
DECL_NOT_REALLY_EXTERN (decl) = !CLASSTYPE_INTERFACE_ONLY (type);
DECL_COMDAT (decl) = 0;
@@ -1744,6 +1794,12 @@ import_export_tinfo (tree decl, tree type, bool is_in_library)
{
DECL_NOT_REALLY_EXTERN (decl) = 1;
DECL_COMDAT (decl) = 1;
+ /* APPLE LOCAL coalescing */
+#ifdef MAKE_DECL_COALESCED
+ TREE_PUBLIC (decl) = 1;
+ if (! is_in_library)
+ MAKE_DECL_COALESCED (decl);
+#endif /* MAKE_DECL_COALESCED */
}
/* Now override some cases. */
@@ -1814,6 +1870,11 @@ get_guard (tree decl)
if (TREE_PUBLIC (decl))
DECL_WEAK (guard) = DECL_WEAK (decl);
+ /* APPLE LOCAL coalescing */
+#ifdef MAKE_DECL_COALESCED
+ if (TREE_PUBLIC (decl) || DECL_COALESCED (decl))
+ MAKE_DECL_COALESCED (guard);
+#endif
DECL_ARTIFICIAL (guard) = 1;
TREE_USED (guard) = 1;
pushdecl_top_level_and_finish (guard, NULL_TREE);
@@ -1920,6 +1981,14 @@ start_objects (int method_type, int initp)
DECL_GLOBAL_DTOR_P (current_function_decl) = 1;
DECL_LANG_SPECIFIC (current_function_decl)->decl_flags.u2sel = 1;
+ /* APPLE LOCAL begin static structors in __StaticInit section */
+#ifdef STATIC_INIT_SECTION
+ if ( ! flag_apple_kext)
+ DECL_SECTION_NAME (current_function_decl) =
+ build_string (strlen (STATIC_INIT_SECTION), STATIC_INIT_SECTION);
+#endif
+ /* APPLE LOCAL end static structors in __StaticInit section */
+
body = begin_compound_stmt (/*has_no_scope=*/false);
/* We cannot allow these functions to be elided, even if they do not
@@ -2026,6 +2095,14 @@ start_static_storage_duration_function (unsigned count)
TREE_PUBLIC (ssdf_decl) = 0;
DECL_ARTIFICIAL (ssdf_decl) = 1;
+ /* APPLE LOCAL begin static structors in __StaticInit section */
+#ifdef STATIC_INIT_SECTION
+ if ( ! flag_apple_kext)
+ DECL_SECTION_NAME (ssdf_decl) = build_string (strlen (STATIC_INIT_SECTION),
+ STATIC_INIT_SECTION);
+#endif
+ /* APPLE LOCAL end static structors in __StaticInit section */
+
/* Put this function in the list of functions to be called from the
static constructors and destructors. */
if (!ssdf_decls)
@@ -2538,6 +2615,11 @@ finish_file (void)
if (pch_file)
c_common_write_pch ();
+ /* APPLE LOCAL Symbol Separation */
+ /* Write context information. */
+ if (dbg_dir)
+ c_common_write_context ();
+
/* Otherwise, GDB can get confused, because in only knows
about source for LINENO-1 lines. */
input_line -= 1;
@@ -2783,6 +2865,22 @@ finish_file (void)
import_export_decl (decl);
if (DECL_NOT_REALLY_EXTERN (decl) && ! DECL_IN_AGGR_P (decl))
DECL_EXTERNAL (decl) = 0;
+ /* APPLE LOCAL begin write used class statics turly 20020226 */
+#ifdef MACHOPIC_VAR_REFERRED_TO_P
+ else
+ if (TREE_USED (decl) && DECL_INITIAL (decl) != 0
+ && DECL_INITIAL (decl) != error_mark_node
+ && TREE_CODE (DECL_INITIAL (decl)) != CONSTRUCTOR
+ && DECL_EXTERNAL (decl)
+ && MACHOPIC_VAR_REFERRED_TO_P (IDENTIFIER_POINTER (
+ DECL_ASSEMBLER_NAME (decl))))
+ {
+ /* Force a local copy of this decl to be written. */
+ DECL_EXTERNAL (decl) = 0;
+ TREE_PUBLIC (decl) = 0;
+ }
+#endif
+ /* APPLE LOCAL end write used class statics turly 20020226 */
}
if (pending_statics
&& wrapup_global_declarations (&VARRAY_TREE (pending_statics, 0),
diff --git a/gcc/cp/g++spec.c b/gcc/cp/g++spec.c
index e6c9ee6892a..a73db2a4352 100644
--- a/gcc/cp/g++spec.c
+++ b/gcc/cp/g++spec.c
@@ -46,6 +46,10 @@ Boston, MA 02111-1307, USA. */
#define LIBSTDCXX_PROFILE "-lstdc++"
#endif
+/* APPLE LOCAL begin radar 3554191 */
+extern unsigned int macosx_version_min_required; /* defined in gcc.c */
+/* APPLE LOCAL end radar 3554191 */
+
void
lang_specific_driver (int *in_argc, const char *const **in_argv,
int *in_added_libraries)
@@ -241,6 +245,13 @@ lang_specific_driver (int *in_argc, const char *const **in_argv,
shared_libgcc = 0;
#endif
+ /* APPLE LOCAL begin radar 3554191 */
+ {
+ if (macosx_version_min_required && macosx_version_min_required < 1040)
+ shared_libgcc = 0;
+ }
+ /* APPLE LOCAL end radar 3554191 */
+
/* Make sure to have room for the trailing NULL argument. */
num_args = argc + added + need_math + shared_libgcc + (library > 0) + 1;
arglist = xmalloc (num_args * sizeof (char *));
diff --git a/gcc/cp/init.c b/gcc/cp/init.c
index 04e70bcc89d..f246a613eac 100644
--- a/gcc/cp/init.c
+++ b/gcc/cp/init.c
@@ -2978,6 +2978,16 @@ build_delete (tree type, tree addr, special_function_kind auto_delete,
build_op_delete_call (DELETE_EXPR, addr, cxx_sizeof_nowarn (type),
/*global_p=*/false, NULL_TREE);
}
+ /* APPLE LOCAL begin double destructor matt 20020501 */
+ /* If we're compiling a class in kext compatibility mode we
+ don't have a non-deleting destructor, so we unconditionally
+ generate a reference to the deleting variety. */
+ if (flag_apple_kext && has_apple_kext_compatibility_attr_p (type))
+ {
+ my_friendly_assert (auto_delete != sfk_base_destructor, 20020501);
+ auto_delete = sfk_deleting_destructor;
+ }
+ /* APPLE LOCAL end double destructor matt 20020501 */
expr = build_dtor_call (build_indirect_ref (addr, NULL),
auto_delete, flags);
diff --git a/gcc/cp/lang-specs.h b/gcc/cp/lang-specs.h
index 5815ea57896..732ac2ed0c9 100644
--- a/gcc/cp/lang-specs.h
+++ b/gcc/cp/lang-specs.h
@@ -43,10 +43,13 @@ Boston, MA 02111-1307, USA. */
cc1plus %{save-temps|no-integrated-cpp:-fpreprocessed %{save-temps:%b.ii} %{!save-temps:%g.ii}}\
%{!save-temps:%{!no-integrated-cpp:%(cpp_unique_options)}}\
%(cc1_options) %2 %{+e1*}\
- -o %g.s %{!o*:--output-pch=%i.gch} %W{o*:--output-pch=%*}%V}}}",
+ "/* APPLE LOCAL symbol separation */" \
+ %(dbg_ss) %(pch)}}}",
CPLUSPLUS_CPP_SPEC},
{"@c++",
"%{E|M|MM:cc1plus -E %(cpp_options) %2 %(cpp_debug_options)}\
+ "/* APPLE LOCAL prohibit -arch with -E and -S */"\
+ %{E|S:%{@:%e-E and -S are not allowed with multiple -arch flags}}\
%{!E:%{!M:%{!MM:\
%{save-temps|no-integrated-cpp:cc1plus -E\
%(cpp_options) %2 -o %{save-temps:%b.ii} %{!save-temps:%g.ii} \n}\
diff --git a/gcc/cp/lex.c b/gcc/cp/lex.c
index 2239c76ca87..4fa16394ba5 100644
--- a/gcc/cp/lex.c
+++ b/gcc/cp/lex.c
@@ -239,6 +239,8 @@ struct resword
_true_. */
#define D_EXT 0x01 /* GCC extension */
#define D_ASM 0x02 /* in C99, but has a switch to turn it off */
+/* APPLE LOCAL Objective-C++ */
+#define D_OBJC 0x10 /* Objective C only */
CONSTRAINT(ridbits_fit, RID_LAST_MODIFIER < sizeof(unsigned long) * CHAR_BIT);
@@ -266,6 +268,8 @@ static const struct resword reswords[] =
{ "__inline__", RID_INLINE, 0 },
{ "__label__", RID_LABEL, 0 },
{ "__null", RID_NULL, 0 },
+ /* APPLE LOCAL private extern */
+ { "__private_extern__", RID_PRIVATE_EXTERN, 0 },
{ "__offsetof", RID_OFFSETOF, 0 },
{ "__offsetof__", RID_OFFSETOF, 0 },
{ "__real", RID_REALPART, 0 },
@@ -343,7 +347,33 @@ static const struct resword reswords[] =
{ "volatile", RID_VOLATILE, 0 },
{ "wchar_t", RID_WCHAR, 0 },
{ "while", RID_WHILE, 0 },
-
+ /* APPLE LOCAL begin Objective-C++ */
+ { "id", RID_ID, D_OBJC },
+
+ /* These objc keywords are recognized only immediately after
+ an '@'. Note that some of these overlap with existing C++ keywords. */
+/*{ "class", RID_AT_CLASS, D_OBJC }, OVERLAP */
+ { "compatibility_alias", RID_AT_ALIAS, D_OBJC },
+ { "defs", RID_AT_DEFS, D_OBJC },
+ { "encode", RID_AT_ENCODE, D_OBJC },
+ { "end", RID_AT_END, D_OBJC },
+ { "implementation", RID_AT_IMPLEMENTATION, D_OBJC },
+ { "interface", RID_AT_INTERFACE, D_OBJC },
+/*{ "private", RID_AT_PRIVATE, D_OBJC }, OVERLAP */
+/*{ "protected", RID_AT_PROTECTED, D_OBJC }, OVERLAP */
+ { "protocol", RID_AT_PROTOCOL, D_OBJC },
+/*{ "public", RID_AT_PUBLIC, D_OBJC }, OVERLAP */
+ { "selector", RID_AT_SELECTOR, D_OBJC },
+
+ /* These are recognized only in protocol-qualifier context
+ (see above) */
+ { "bycopy", RID_BYCOPY, D_OBJC },
+ { "byref", RID_BYREF, D_OBJC },
+ { "in", RID_IN, D_OBJC },
+ { "inout", RID_INOUT, D_OBJC },
+ { "oneway", RID_ONEWAY, D_OBJC },
+ { "out", RID_OUT, D_OBJC },
+ /* APPLE LOCAL end Objective-C++ */
};
void
@@ -354,6 +384,9 @@ init_reswords (void)
int mask = ((flag_no_asm ? D_ASM : 0)
| (flag_no_gnu_keywords ? D_EXT : 0));
+ /* APPLE LOCAL objc++ */
+ mask |= D_OBJC;
+
ridpointers = ggc_calloc ((int) RID_MAX, sizeof (tree));
for (i = 0; i < ARRAY_SIZE (reswords); i++)
{
@@ -363,6 +396,25 @@ init_reswords (void)
if (! (reswords[i].disable & mask))
C_IS_RESERVED_WORD (id) = 1;
}
+
+ /* APPLE LOCAL begin private extern Radar 2872481 ilr */
+ /* For C++ there is always a -D__private_extern__=extern on the
+ command line. However, if -fpreprocessed was specified then
+ macros are not expanded so the -D is meaningless. But this
+ replacement is required for C++. There for we have to "pretend"
+ that '__private_extern__' is 'extern' and we can do this simply by
+ making the rid code for '__private_extern__' be the same as for
+ extern. Note, we probably could always do this here since
+ '__private_extern__' is always to be treated like 'extern' for
+ c++. But we'll be conservative and only do it when -fpreprocessed
+ is specified and depend on the macro substitution in all other
+ cases. */
+ if (flag_preprocessed)
+ {
+ id = get_identifier ("__private_extern__");
+ C_RID_CODE (id) = RID_EXTERN;
+ }
+ /* APPLE LOCAL end private extern Radar 2872481 ilr */
}
static void
@@ -427,6 +479,14 @@ cxx_init (void)
init_repo (main_input_filename);
pop_srcloc();
+
+ /* APPLE LOCAL gdb only used symbols */
+#ifdef DBX_ONLY_USED_SYMBOLS
+ /* By default we want to use -gused for C++ and Objective-C++. */
+ if (flag_debug_only_used_symbols == -1)
+ flag_debug_only_used_symbols = 1;
+#endif
+
return true;
}
diff --git a/gcc/cp/lex.h b/gcc/cp/lex.h
index 35c3503ea41..0a9c88478d1 100644
--- a/gcc/cp/lex.h
+++ b/gcc/cp/lex.h
@@ -65,4 +65,19 @@ typedef unsigned long RID_BIT_TYPE; /* assumed at least 32 bits */
#define RIDBIT_RESET_ALL(V) do { (V) = 0; } while (0)
#endif
+/* APPLE LOCAL begin Objective-C++ */
+/* Parser/lexer state pertinent to ObjC++. */
+extern int objc_receiver_context;
+extern int objc_declarator_context;
+extern int objc_msg_context;
+extern int objc_public_flag;
+extern int objc_need_raw_identifier;
+extern int objc_pq_context;
+
+#define OBJC_NEED_RAW_IDENTIFIER(VAL) \
+ do { if (flag_objc) objc_need_raw_identifier = VAL; } \
+ while (0)
+
+/* APPLE LOCAL end Objective-C++ */
+
#endif /* ! GCC_CP_LEX_H */
diff --git a/gcc/cp/mangle.c b/gcc/cp/mangle.c
index 2580d39866f..577159c4753 100644
--- a/gcc/cp/mangle.c
+++ b/gcc/cp/mangle.c
@@ -59,6 +59,7 @@
#include "toplev.h"
#include "varray.h"
#include "flags.h"
+#include "target.h"
/* Debugging support. */
@@ -1306,10 +1307,8 @@ write_identifier (const char *identifier)
::= C3 # complete object allocating constructor
Currently, allocating constructors are never used.
-
- We also need to provide mangled names for the maybe-in-charge
- constructor, so we treat it here too. mangle_decl_string will
- append *INTERNAL* to that, to make sure we never emit it. */
+ APPLE LOCAL decloning
+*/
static void
write_special_name_constructor (const tree ctor)
@@ -1322,6 +1321,11 @@ write_special_name_constructor (const tree ctor)
write_string ("C1");
else if (DECL_BASE_CONSTRUCTOR_P (ctor))
write_string ("C2");
+ /* APPLE LOCAL begin decloning */
+ /* This is the old-style "[unified]" constructor. */
+ else if (DECL_MAYBE_IN_CHARGE_CONSTRUCTOR_P (ctor))
+ write_string ("C4");
+ /* APPLE LOCAL end decloning */
else
abort ();
}
@@ -1350,6 +1354,11 @@ write_special_name_destructor (const tree dtor)
write_string ("D1");
else if (DECL_BASE_DESTRUCTOR_P (dtor))
write_string ("D2");
+ /* APPLE LOCAL begin decloning */
+ else if (DECL_MAYBE_IN_CHARGE_DESTRUCTOR_P (dtor))
+ /* This is the old-style "[unified]" destructor. */
+ write_string ("D4");
+ /* APPLE LOCAL end decloning */
else
abort ();
}
@@ -1501,12 +1510,24 @@ write_type (tree type)
case BOOLEAN_TYPE:
case INTEGER_TYPE: /* Includes wchar_t. */
case REAL_TYPE:
+ {
+ /* Handle any target-specific fundamental types. */
+ const char *target_mangling
+ = targetm.mangle_fundamental_type (type);
+
+ if (target_mangling)
+ {
+ write_string (target_mangling);
+ return;
+ }
+
/* If this is a typedef, TYPE may not be one of
the standard builtin type nodes, but an alias of one. Use
TYPE_MAIN_VARIANT to get to the underlying builtin type. */
write_builtin_type (TYPE_MAIN_VARIANT (type));
++is_builtin_type;
break;
+ }
case COMPLEX_TYPE:
write_char ('C');
diff --git a/gcc/cp/method.c b/gcc/cp/method.c
index bb34d822157..1d61c165546 100644
--- a/gcc/cp/method.c
+++ b/gcc/cp/method.c
@@ -397,6 +397,14 @@ use_thunk (tree thunk_fndecl, bool emit_p)
return;
}
+ /* APPLE LOCAL begin coalescing */
+ /* coalesce thunks */
+#if defined(COALESCE_STATIC_THUNK)
+ if (DECL_VISIBILITY (function) == VISIBILITY_HIDDEN || !TREE_PUBLIC (function) || DECL_INLINE (function))
+ COALESCE_STATIC_THUNK (thunk_fndecl, /* public*/ 0);
+#endif /* COALESCE_STATIC_THUNK */
+ /* APPLE LOCAL end coalescing */
+
push_to_top_level ();
#ifdef ASM_OUTPUT_DEF
diff --git a/gcc/cp/optimize.c b/gcc/cp/optimize.c
index 1be4d8afdcc..f36b0ea519c 100644
--- a/gcc/cp/optimize.c
+++ b/gcc/cp/optimize.c
@@ -46,6 +46,10 @@ Software Foundation, 59 Temple Place - Suite 330, Boston, MA
static tree calls_setjmp_r (tree *, int *, void *);
static void update_cloned_parm (tree, tree);
+/* APPLE LOCAL begin structor thunks */
+static int maybe_alias_body (tree fn, tree clone);
+static int maybe_thunk_body (tree fn);
+/* APPLE LOCAL end structor thunks */
/* Called from calls_setjmp_p via walk_tree. */
@@ -96,6 +100,165 @@ update_cloned_parm (tree parm, tree cloned_parm)
DECL_SOURCE_LOCATION (cloned_parm) = DECL_SOURCE_LOCATION (parm);
}
+/* APPLE LOCAL begin structor thunks */
+/* FN is a constructor or destructor, and there are FUNCTION_DECLs cloned from it nearby.
+ If the clone and the original funciton have identical parameter lists,
+ it is a fully-degenerate (does absolutely nothing) thunk.
+ Make the clone an alias for the original function label. */
+static int
+maybe_alias_body (tree fn ATTRIBUTE_UNUSED, tree clone ATTRIBUTE_UNUSED)
+{
+ extern FILE *asm_out_file ATTRIBUTE_UNUSED;
+
+#ifdef ASM_MAYBE_ALIAS_BODY
+ ASM_MAYBE_ALIAS_BODY (asm_out_file, fn, clone);
+#endif
+ return 0;
+}
+
+/* FN is a constructor or destructor, and there are FUNCTION_DECLs
+ cloned from it nearby. Instead of cloning this body, leave it
+ alone and create tiny one-call bodies for the cloned
+ FUNCTION_DECLs. These clones are sibcall candidates, and their
+ resulting code will be very thunk-esque. */
+static int
+maybe_thunk_body (tree fn)
+{
+ tree call, clone, expr_stmt, fn_parm, fn_parm_typelist, last_arg, start;
+ int parmno, vtt_parmno;
+
+ if (flag_apple_kext || flag_clone_structors)
+ return 0;
+
+ /* If we've already seen this structor, avoid re-processing it. */
+ if (TREE_ASM_WRITTEN (fn))
+ return 1;
+
+ /* If function accepts variable arguments, give up. */
+ last_arg = tree_last (TYPE_ARG_TYPES (TREE_TYPE (fn)));
+ if ( ! VOID_TYPE_P (TREE_VALUE (last_arg)))
+ return 0;
+
+ /* If constructor expects vector (AltiVec) arguments, give up. */
+ for (fn_parm = DECL_ARGUMENTS( fn); fn_parm; fn_parm = TREE_CHAIN (fn_parm))
+ if (TREE_CODE (fn_parm) == VECTOR_TYPE)
+ return 0;
+
+ /* If we don't see a clone, nothing to do. */
+ clone = TREE_CHAIN (fn);
+ if (!clone || ! DECL_CLONED_FUNCTION_P (clone))
+ return 0;
+
+ /* This is only a win if there are two or more clones. */
+ if ( ! TREE_CHAIN (clone))
+ return 0;
+
+ /* Only thunk-ify non-trivial structors. */
+ if (DECL_ESTIMATED_INSNS (fn) < 5)
+ return 0;
+
+ /* If we got this far, we've decided to turn the clones into thunks. */
+
+ /* We're going to generate code for fn, so it is no longer "abstract." */
+ /* APPLE LOCAL begin 3271957 and 3262497 */
+ /* Leave 'abstract' bit set for unified constructs and destructors when
+ -gused is used. */
+ if (!(flag_debug_only_used_symbols
+ && DECL_DESTRUCTOR_P (fn)
+ && DECL_MAYBE_IN_CHARGE_DESTRUCTOR_P (fn))
+ && !(flag_debug_only_used_symbols
+ && DECL_CONSTRUCTOR_P (fn)
+ && DECL_MAYBE_IN_CHARGE_CONSTRUCTOR_P (fn))
+ )
+ DECL_ABSTRACT (fn) = 0;
+ /* APPLE LOCAL end 3271957 and 3262497 */
+
+ /* Find the vtt_parm, if present. */
+ for (vtt_parmno = -1, parmno = 0, fn_parm = DECL_ARGUMENTS (fn);
+ fn_parm;
+ ++parmno, fn_parm = TREE_CHAIN (fn_parm))
+ {
+ if (DECL_ARTIFICIAL (fn_parm) && DECL_NAME (fn_parm) == vtt_parm_identifier)
+ {
+ vtt_parmno = parmno; /* Compensate for removed in_charge parameter. */
+ break;
+ }
+ }
+
+ /* We know that any clones immediately follow FN in the TYPE_METHODS
+ list. */
+ for (clone = start = TREE_CHAIN (fn);
+ clone && DECL_CLONED_FUNCTION_P (clone);
+ clone = TREE_CHAIN (clone))
+ {
+ tree clone_parm, parmlist;
+
+ /* If the clone and original parmlists are identical, turn the clone into an alias. */
+ if (maybe_alias_body (fn, clone))
+ continue;
+
+ /* If we've already generated a body for this clone, avoid duplicating it.
+ (Is it possible for a clone-list to grow after we first see it?) */
+ if (DECL_SAVED_TREE (clone) || TREE_ASM_WRITTEN (clone))
+ continue;
+
+ /* Start processing the function. */
+ push_to_top_level ();
+ start_function (NULL_TREE, clone, NULL_TREE, SF_PRE_PARSED);
+
+ /* Walk parameter lists together, creating parameter list for call to original function. */
+ for (parmno = 0,
+ parmlist = NULL,
+ fn_parm = DECL_ARGUMENTS (fn),
+ fn_parm_typelist = TYPE_ARG_TYPES (TREE_TYPE (fn)),
+ clone_parm = DECL_ARGUMENTS (clone);
+ fn_parm;
+ ++parmno,
+ fn_parm = TREE_CHAIN (fn_parm))
+ {
+ if (parmno == vtt_parmno && ! DECL_HAS_VTT_PARM_P (clone))
+ {
+ tree typed_null_pointer_node = copy_node (null_pointer_node);
+ my_friendly_assert (fn_parm_typelist, 0);
+ /* Clobber actual parameter with formal parameter type. */
+ TREE_TYPE (typed_null_pointer_node) = TREE_VALUE (fn_parm_typelist);
+ parmlist = tree_cons (NULL, typed_null_pointer_node, parmlist);
+ }
+ else if (parmno == 1 && DECL_HAS_IN_CHARGE_PARM_P (fn))
+ {
+ tree in_charge = copy_node (in_charge_arg_for_name (DECL_NAME (clone)));
+ parmlist = tree_cons (NULL, in_charge, parmlist);
+ }
+ /* Map other parameters to their equivalents in the cloned
+ function. */
+ else
+ {
+ my_friendly_assert (clone_parm, 0);
+ DECL_ABSTRACT_ORIGIN (clone_parm) = NULL;
+ parmlist = tree_cons (NULL, clone_parm, parmlist);
+ clone_parm = TREE_CHAIN (clone_parm);
+ }
+ if (fn_parm_typelist)
+ fn_parm_typelist = TREE_CHAIN (fn_parm_typelist);
+ }
+
+ /* We built this list backwards; fix now. */
+ parmlist = nreverse (parmlist);
+ mark_used (fn);
+ call = build_function_call (fn, parmlist);
+ expr_stmt = build_stmt (EXPR_STMT, call);
+ add_stmt (expr_stmt);
+
+ /* Now, expand this function into RTL, if appropriate. */
+ finish_function (0);
+ DECL_ABSTRACT_ORIGIN (clone) = NULL;
+ expand_body (clone);
+ pop_from_top_level ();
+ }
+ return 1;
+}
+/* APPLE LOCAL end structor thunks */
+
/* FN is a function that has a complete body. Clone the body as
necessary. Returns nonzero if there's no longer any need to
process the main body. */
@@ -121,8 +284,7 @@ maybe_clone_body (tree fn)
{
tree parm;
tree clone_parm;
- int parmno;
- splay_tree decl_map;
+ /* APPLE LOCAL structor thunks */
/* Update CLONE's source position information to match FN's. */
DECL_SOURCE_LOCATION (clone) = DECL_SOURCE_LOCATION (fn);
@@ -138,6 +300,8 @@ maybe_clone_body (tree fn)
DECL_NOT_REALLY_EXTERN (clone) = DECL_NOT_REALLY_EXTERN (fn);
TREE_PUBLIC (clone) = TREE_PUBLIC (fn);
DECL_VISIBILITY (clone) = DECL_VISIBILITY (fn);
+ /* APPLE LOCAL coalescing */
+ DECL_COALESCED (clone) = DECL_COALESCED (fn);
/* Adjust the parameter names and locations. */
parm = DECL_ARGUMENTS (fn);
@@ -156,6 +320,28 @@ maybe_clone_body (tree fn)
parm = TREE_CHAIN (parm), clone_parm = TREE_CHAIN (clone_parm))
/* Update this parameter. */
update_cloned_parm (parm, clone_parm);
+ /* APPLE LOCAL structor thunks */
+ }
+
+ /* APPLE LOCAL begin structor thunks */
+ /* If we decide to turn clones into thunks, they will branch to fn.
+ Must have original function available to call. */
+ if (maybe_thunk_body (fn))
+ return 0;
+ /* APPLE LOCAL end structor thunks */
+
+ /* APPLE LOCAL begin structor thunks */
+ /* We know that any clones immediately follow FN in the TYPE_METHODS
+ list. */
+ for (clone = TREE_CHAIN (fn);
+ clone && DECL_CLONED_FUNCTION_P (clone);
+ clone = TREE_CHAIN (clone))
+ {
+ tree parm;
+ tree clone_parm;
+ int parmno;
+ splay_tree decl_map;
+ /* APPLE LOCAL end structor thunks */
/* Start processing the function. */
push_to_top_level ();
@@ -215,6 +401,10 @@ maybe_clone_body (tree fn)
/* Clone the body. */
clone_body (clone, fn, decl_map);
+ /* There are as many statements in the clone as in the
+ original. */
+ DECL_ESTIMATED_INSNS (clone) = DECL_ESTIMATED_INSNS (fn);
+
/* Clean up. */
splay_tree_delete (decl_map);
diff --git a/gcc/cp/pt.c b/gcc/cp/pt.c
index 8a51a247289..826edc3f4d6 100644
--- a/gcc/cp/pt.c
+++ b/gcc/cp/pt.c
@@ -11121,6 +11121,12 @@ instantiate_decl (tree d, int defer_ok)
/* Regenerate the declaration in case the template has been modified
by a subsequent redeclaration. */
regenerate_decl_from_template (d, td);
+
+ /* APPLE LOCAL begin coalescing */
+#ifdef MARK_TEMPLATE_COALESCED
+ MARK_TEMPLATE_COALESCED (d);
+#endif
+ /* APPLE LOCAL end coalescing */
/* We already set the file and line above. Reset them now in case
they changed as a result of calling regenerate_decl_from_template. */
diff --git a/gcc/cp/rtti.c b/gcc/cp/rtti.c
index a2750b220c2..133ebe4fd36 100644
--- a/gcc/cp/rtti.c
+++ b/gcc/cp/rtti.c
@@ -760,6 +760,15 @@ tinfo_base_init (tree desc, tree target)
TREE_STATIC (name_decl) = 1;
DECL_EXTERNAL (name_decl) = 0;
TREE_PUBLIC (name_decl) = 1;
+ comdat_linkage (name_decl);
+ /* APPLE LOCAL begin coalescing */
+ /* coalesce typeinfo */
+#ifdef MAKE_DECL_COALESCED
+ if (!typeinfo_in_lib_p (target))
+ MAKE_DECL_COALESCED (name_decl);
+#endif /* MAKE_DECL_COALESCED */
+ /* APPLE LOCAL end coalescing */
+
import_export_tinfo (name_decl, target, typeinfo_in_lib_p (target));
/* External name of the string containing the type's name has a
special name. */
diff --git a/gcc/cp/tree.c b/gcc/cp/tree.c
index 2c232f389cb..35287bd570a 100644
--- a/gcc/cp/tree.c
+++ b/gcc/cp/tree.c
@@ -35,6 +35,16 @@ Boston, MA 02111-1307, USA. */
#include "tree-inline.h"
#include "target.h"
+/* APPLE LOCAL begin new tree dump */
+#ifdef ENABLE_DMP_TREE
+#include "dmp-tree.h"
+extern int cp_dump_tree_p PARAMS ((FILE *, const char *, tree, int));
+extern lang_dump_tree_p_t cp_prev_lang_dump_tree_p;
+extern int c_dump_tree_p PARAMS ((FILE *, const char *, tree, int));
+extern lang_dump_tree_p_t c_prev_lang_dump_tree_p;
+#endif
+/* APPLE LOCAL end new tree dump */
+
static tree bot_manip (tree *, int *, void *);
static tree bot_replace (tree *, int *, void *);
static tree build_cplus_array_type_1 (tree, tree);
@@ -1767,10 +1777,8 @@ pod_type_p (tree t)
return 1; /* pointer to non-member */
if (TYPE_PTR_TO_MEMBER_P (t))
return 1; /* pointer to member */
-
if (TREE_CODE (t) == VECTOR_TYPE)
return 1; /* vectors are (small) arrays if scalars */
-
if (! CLASS_TYPE_P (t))
return 0; /* other non-class type (reference or function) */
if (CLASSTYPE_NON_POD_P (t))
diff --git a/gcc/cp/typeck.c b/gcc/cp/typeck.c
index 40988c7c807..77463544c90 100644
--- a/gcc/cp/typeck.c
+++ b/gcc/cp/typeck.c
@@ -1058,6 +1058,17 @@ comptypes (tree t1, tree t2, int strict)
case COMPLEX_TYPE:
return same_type_p (TREE_TYPE (t1), TREE_TYPE (t2));
+ case VECTOR_TYPE:
+ /* This is a comparison of types. If both of them are opaque,
+ the types are identical as long as their size is equal; else
+ check if the underlying types are identical as well. */
+ return TYPE_VECTOR_SUBPARTS (t1) == TYPE_VECTOR_SUBPARTS (t2)
+ && (targetm.vector_opaque_p (t1)
+ ? targetm.vector_opaque_p (t2)
+ : !targetm.vector_opaque_p (t2)
+ && same_type_p (TREE_TYPE (t1), TREE_TYPE (t2)));
+ break;
+
default:
break;
}
@@ -1996,6 +2007,8 @@ build_ptrmemfunc_access_expr (tree ptrmem, tree member_name)
routine directly because it expects the object to be of class
type. */
ptrmem_type = TREE_TYPE (ptrmem);
+ /* APPLE LOCAL 2.95-ptmf-compatibility */
+ if (!flag_apple_kext)
my_friendly_assert (TYPE_PTRMEMFUNC_P (ptrmem_type), 20020804);
member = lookup_member (ptrmem_type, member_name, /*protect=*/0,
/*want_type=*/false);
@@ -2278,7 +2291,10 @@ get_member_function_from_ptrfunc (tree *instance_ptrptr, tree function)
if (TYPE_PTRMEMFUNC_P (TREE_TYPE (function)))
{
- tree idx, delta, e1, e2, e3, vtbl, basetype;
+ /* APPLE LOCAL begin 2.95-ptmf-compatibility */
+ tree idx, delta, e1, e2, e3, vtbl = vtbl, basetype;
+ /* APPLE LOCAL 2.95-ptmf-compatibility turly 20020314 */
+ tree delta2 = delta2;
tree fntype = TYPE_PTRMEMFUNC_FN_TYPE (TREE_TYPE (function));
tree instance_ptr = *instance_ptrptr;
@@ -2310,6 +2326,17 @@ get_member_function_from_ptrfunc (tree *instance_ptrptr, tree function)
/* Start by extracting all the information from the PMF itself. */
e3 = PFN_FROM_PTRMEMFUNC (function);
delta = build_ptrmemfunc_access_expr (function, delta_identifier);
+
+ /* APPLE LOCAL begin 2.95-ptmf-compatibility turly 20020314 */
+ if (flag_apple_kext)
+ {
+ idx = build_ptrmemfunc_access_expr (function, index_identifier);
+ idx = save_expr (default_conversion (idx));
+ e1 = cp_build_binary_op (GE_EXPR, idx, integer_zero_node);
+ }
+ else
+ {
+ /* APPLE LOCAL end 2.95-ptmf-compatibility turly 20020314 */
idx = build1 (NOP_EXPR, vtable_index_type, e3);
switch (TARGET_PTRMEMFUNC_VBIT_LOCATION)
{
@@ -2327,6 +2354,19 @@ get_member_function_from_ptrfunc (tree *instance_ptrptr, tree function)
abort ();
}
+ /* APPLE LOCAL begin 2.95-ptmf-compatibility turly 20020314 */
+ }
+ /* DELTA2 is the amount by which to adjust the `this' pointer
+ to find the vtbl. */
+ if (flag_apple_kext)
+ {
+ delta2 = build_ptrmemfunc_access_expr (function,
+ pfn_or_delta2_identifier);
+ delta2 = build_ptrmemfunc_access_expr (delta2,
+ delta2_identifier);
+ }
+ /* APPLE LOCAL end 2.95-ptmf-compatibility turly 20020314 */
+
/* Convert down to the right base before using the instance. First
use the type... */
basetype = TYPE_METHOD_BASETYPE (TREE_TYPE (fntype));
@@ -2335,6 +2375,14 @@ get_member_function_from_ptrfunc (tree *instance_ptrptr, tree function)
instance_ptr = build_base_path (PLUS_EXPR, instance_ptr, basetype, 1);
if (instance_ptr == error_mark_node)
return error_mark_node;
+
+ /* APPLE LOCAL begin 2.95-ptmf-compatibility */
+ if (flag_apple_kext)
+ /* Next extract the vtable pointer from the object. */
+ vtbl = build (PLUS_EXPR,build_pointer_type (vtbl_ptr_type_node),
+ instance_ptr, cp_convert (ptrdiff_type_node, delta2));
+ /* APPLE LOCAL end 2.95-ptmf-compatibility */
+
/* ...and then the delta in the PMF. */
instance_ptr = build (PLUS_EXPR, TREE_TYPE (instance_ptr),
instance_ptr, delta);
@@ -2342,11 +2390,28 @@ get_member_function_from_ptrfunc (tree *instance_ptrptr, tree function)
/* Hand back the adjusted 'this' argument to our caller. */
*instance_ptrptr = instance_ptr;
+ /* APPLE LOCAL 2.95-ptmf-compatibility */
+ if (!flag_apple_kext)
/* Next extract the vtable pointer from the object. */
vtbl = build1 (NOP_EXPR, build_pointer_type (vtbl_ptr_type_node),
instance_ptr);
vtbl = build_indirect_ref (vtbl, NULL);
+ /* APPLE LOCAL double destructor turly 20020301 */
+#ifdef ADJUST_VTABLE_INDEX
+ /* vptr hack already compensated for! */
+ if (0) ADJUST_VTABLE_INDEX (idx, vtbl);
+#endif
+
+ /* APPLE LOCAL begin 2.95-ptmf-compatibility turly 20020314 */
+ /* 2.95-style indices are off by one. */
+ if (flag_apple_kext)
+ {
+ idx = cp_build_binary_op (MINUS_EXPR, idx, integer_one_node);
+ idx = cp_build_binary_op (LSHIFT_EXPR, idx, integer_two_node);
+ }
+ /* APPLE LOCAL end 2.95-ptmf-compatibility turly 20020314 */
+
/* Finally, extract the function pointer from the vtable. */
e2 = fold (build (PLUS_EXPR, TREE_TYPE (vtbl), vtbl, idx));
e2 = build_indirect_ref (e2, NULL);
@@ -3011,6 +3076,13 @@ build_binary_op (enum tree_code code, tree orig_op0, tree orig_op1,
}
else if (TYPE_PTRMEMFUNC_P (type0) && null_ptr_cst_p (op1))
{
+ /* APPLE LOCAL begin 2.95-ptmf-compatibility turly 20020314 */
+ /* Shouldn't we use INDEX here rather than PFN? This seems to
+ work fine, though... */
+ if (flag_apple_kext)
+ op0 = build_ptrmemfunc_access_expr (op0, index_identifier);
+ else
+ /* APPLE LOCAL end 2.95-ptmf-compatibility turly 20020314 */
op0 = build_ptrmemfunc_access_expr (op0, pfn_identifier);
op1 = cp_convert (TREE_TYPE (op0), integer_zero_node);
result_type = TREE_TYPE (op0);
@@ -4364,8 +4436,12 @@ tree
build_compound_expr (tree lhs, tree rhs)
{
lhs = decl_constant_value (lhs);
- lhs = convert_to_void (lhs, "left-hand operand of comma");
-
+ /* APPLE LOCAL begin AltiVec */
+ lhs = convert_to_void (lhs, targetm.cast_expr_as_vector_init
+ ? NULL
+ : "left-hand operand of comma");
+ /* APPLE LOCAL end AltiVec */
+
if (lhs == error_mark_node || rhs == error_mark_node)
return error_mark_node;
@@ -4409,6 +4485,13 @@ build_static_cast (tree type, tree expr)
if (type == error_mark_node || expr == error_mark_node)
return error_mark_node;
+ /* APPLE LOCAL begin AltiVec */
+ /* If we are casting to a vector type, treat the expression as a vector
+ initializer if this target supports it. */
+ if (TREE_CODE (type) == VECTOR_TYPE && targetm.cast_expr_as_vector_init)
+ return vector_constructor_from_expr (expr, type);
+ /* APPLE LOCAL end AltiVec */
+
if (processing_template_decl)
{
expr = build_min (STATIC_CAST_EXPR, type, expr);
@@ -4598,6 +4681,13 @@ build_reinterpret_cast (tree type, tree expr)
if (type == error_mark_node || expr == error_mark_node)
return error_mark_node;
+ /* APPLE LOCAL begin AltiVec */
+ /* If we are casting to a vector type, treat the expression as a vector
+ initializer if this target supports it. */
+ if (TREE_CODE (type) == VECTOR_TYPE && targetm.cast_expr_as_vector_init)
+ return vector_constructor_from_expr (expr, type);
+ /* APPLE LOCAL end AltiVec */
+
if (processing_template_decl)
{
tree t = build_min (REINTERPRET_CAST_EXPR, type, expr);
@@ -4675,6 +4765,14 @@ build_reinterpret_cast (tree type, tree expr)
intype, type);
return error_mark_node;
}
+
+ /* APPLE LOCAL begin don't sign-extend pointers cast to integers */
+ if (TREE_CODE (type) == INTEGER_TYPE
+ && TREE_CODE (intype) == POINTER_TYPE
+ && TYPE_PRECISION (type) > TYPE_PRECISION (intype)
+ && TREE_UNSIGNED (type))
+ expr = cp_convert (c_common_type_for_size (POINTER_SIZE, 1), expr);
+ /* APPLE LOCAL end don't sign-extend pointers cast to integers */
return cp_convert (type, expr);
}
@@ -4760,6 +4858,13 @@ build_c_cast (tree type, tree expr)
if (type == error_mark_node || expr == error_mark_node)
return error_mark_node;
+ /* APPLE LOCAL begin AltiVec */
+ /* If we are casting to a vector type, treat the expression as a vector
+ initializer if this target supports it. */
+ if (TREE_CODE (type) == VECTOR_TYPE && targetm.cast_expr_as_vector_init)
+ return vector_constructor_from_expr (expr, type);
+ /* APPLE LOCAL end AltiVec */
+
if (processing_template_decl)
{
tree t = build_min (CAST_EXPR, type,
@@ -4876,6 +4981,16 @@ build_c_cast (tree type, tree expr)
value = decl_constant_value (value);
+ /* APPLE LOCAL begin don't sign-extend pointers cast to integers */
+ if (TREE_CODE (type) == INTEGER_TYPE
+ && TREE_CODE (otype) == POINTER_TYPE
+ && TYPE_PRECISION (type) > TYPE_PRECISION (otype)
+ && TREE_UNSIGNED (type))
+ value = convert_force (c_common_type_for_size (POINTER_SIZE, 1),
+ value,
+ CONV_C_CAST);
+ /* APPLE LOCAL end don't sign-extend pointers cast to integers */
+
ovalue = value;
value = convert_force (type, value, CONV_C_CAST);
@@ -5076,6 +5191,49 @@ build_modify_expr (tree lhs, enum tree_code modifycode, tree rhs)
20011220);
}
+ /* Handle a cast used as an "lvalue".
+ We have already performed any binary operator using the value as cast.
+ Now convert the result to the cast type of the lhs,
+ and then true type of the lhs and store it there;
+ then convert result back to the cast type to be the value
+ of the assignment. */
+
+ switch (TREE_CODE (lhs))
+ {
+ case NOP_EXPR:
+ case CONVERT_EXPR:
+ case FLOAT_EXPR:
+ case FIX_TRUNC_EXPR:
+ case FIX_FLOOR_EXPR:
+ case FIX_ROUND_EXPR:
+ case FIX_CEIL_EXPR:
+ {
+ tree inner_lhs = TREE_OPERAND (lhs, 0);
+ tree result;
+
+ if (TREE_CODE (TREE_TYPE (newrhs)) == ARRAY_TYPE
+ || TREE_CODE (TREE_TYPE (newrhs)) == FUNCTION_TYPE
+ || TREE_CODE (TREE_TYPE (newrhs)) == METHOD_TYPE
+ || TREE_CODE (TREE_TYPE (newrhs)) == OFFSET_TYPE)
+ newrhs = decay_conversion (newrhs);
+
+ /* ISO C++ 5.4/1: The result is an lvalue if T is a reference
+ type, otherwise the result is an rvalue. */
+ if (! lvalue_p (lhs))
+ pedwarn ("ISO C++ forbids cast to non-reference type used as lvalue");
+
+ result = build_modify_expr (inner_lhs, NOP_EXPR,
+ cp_convert (TREE_TYPE (inner_lhs),
+ cp_convert (lhstype, newrhs)));
+ if (result == error_mark_node)
+ return result;
+ return cp_convert (TREE_TYPE (lhs), result);
+ }
+
+ default:
+ break;
+ }
+
/* The left-hand side must be an lvalue. */
if (!lvalue_or_else (lhs, "assignment"))
return error_mark_node;
@@ -5292,6 +5450,106 @@ build_ptrmemfunc1 (tree type, tree delta, tree pfn)
tree delta_field;
tree pfn_field;
+ /* APPLE LOCAL begin 2.95-ptmf-compatibility turly 20020313 */
+ if (flag_apple_kext)
+ {
+ /* Ooo-err, Missus. Cons up a 2.95-style ptmf struct given
+ gcc3-style inputs! Recall:
+
+ struct ptmf2 { struct ptmf3 {
+ short __delta; __P __pfn;
+ short __index; ptrdiff_t __delta;
+ union { }
+ __P __pfn;
+ short __delta2;
+ }
+ }
+
+ Won't this be fun. Much of this is snarfed from 2.95.
+ Note that the __delta2 val, if required, will always be __delta. */
+
+ tree subtype, pfn_or_delta2_field, idx, idx_field, delta2_field;
+ tree delta2 = integer_zero_node;
+ int ixval = 0;
+ int allconstant = 0, allsimple = 0;
+
+ delta_field = TYPE_FIELDS (type);
+ idx_field = TREE_CHAIN (delta_field);
+ pfn_or_delta2_field = TREE_CHAIN (idx_field);
+ subtype = TREE_TYPE (pfn_or_delta2_field);
+ pfn_field = TYPE_FIELDS (subtype);
+ delta2_field = TREE_CHAIN (pfn_field);
+
+ if (TARGET_PTRMEMFUNC_VBIT_LOCATION == ptrmemfunc_vbit_in_pfn)
+ {
+ /* If the low bit of PFN is set, the virtual index is PFN >> 1.
+ Else it's nonvirtual. */
+ allconstant = TREE_CONSTANT (pfn);
+ allsimple = !! initializer_constant_valid_p (pfn, TREE_TYPE (pfn));
+ if (TREE_CODE (pfn) == INTEGER_CST && (TREE_INT_CST_LOW (pfn) & 1))
+ {
+ /* It's a virtual function. PFN is the vt offset + 1. */
+
+ int vt_entry_sz = 4;
+ tree vt_entry_sz_tree = TYPE_SIZE_UNIT (vtable_entry_type);
+ if (TREE_CODE (vt_entry_sz_tree) == INTEGER_CST)
+ vt_entry_sz = TREE_INT_CST_LOW (vt_entry_sz_tree);
+
+ ixval = (TREE_INT_CST_LOW (pfn) - 1);
+ ixval /= vt_entry_sz;
+
+ /* Now add 2 for that spadgey VPTR index hack, plus one because
+ 2.95 indices are offset by 1. */
+ ixval += 2 + 1;
+
+ /* __delta2 is the same as __delta. */
+ u = tree_cons (delta2_field, delta, NULL_TREE);
+ }
+ else
+ if (TREE_CODE (pfn) == INTEGER_CST && TREE_INT_CST_LOW (pfn) == 0)
+ {
+ /* NULL pfn. Just zero out everything. */
+ ixval = 0;
+ pfn = integer_zero_node;
+ delta = integer_zero_node;
+ u = tree_cons (pfn_field, pfn, NULL_TREE);
+ }
+ else
+ {
+ ixval = -1; /* -1 ==> PFN is the pointer */
+ u = tree_cons (pfn_field, pfn, NULL_TREE);
+ }
+ }
+ else /* Low bit of DELTA is set if we're virtual. */
+ {
+ /* Don't know how to do this yet. Much like the above, probably. */
+ abort ();
+ allconstant = TREE_CONSTANT (delta);
+ allsimple = !! initializer_constant_valid_p (delta,
+ TREE_TYPE (delta));
+
+ u = tree_cons (delta2_field, delta2, NULL_TREE);
+ }
+
+ delta = convert_and_check (delta_type_node, delta);
+ idx = convert_and_check (delta_type_node, ssize_int (ixval));
+
+ allconstant = allconstant && TREE_CONSTANT (delta) && TREE_CONSTANT (idx);
+ allsimple = allsimple
+ && initializer_constant_valid_p (delta, TREE_TYPE (delta))
+ && initializer_constant_valid_p (idx, TREE_TYPE (idx));
+
+ u = build (CONSTRUCTOR, subtype, NULL_TREE, u);
+ u = tree_cons (delta_field, delta,
+ tree_cons (idx_field, idx,
+ tree_cons (pfn_or_delta2_field, u, NULL_TREE)));
+ u = build (CONSTRUCTOR, type, NULL_TREE, u);
+ TREE_CONSTANT (u) = allconstant;
+ TREE_STATIC (u) = allconstant && allsimple;
+ return u;
+ }
+ /* APPLE LOCAL end 2.95-ptmf-compatibility turly 20020313 */
+
/* Pull the FIELD_DECLs out of the type. */
pfn_field = TYPE_FIELDS (type);
delta_field = TREE_CHAIN (pfn_field);
@@ -5475,6 +5733,22 @@ expand_ptrmemfunc_cst (tree cst, tree *delta, tree *pfn)
tree
pfn_from_ptrmemfunc (tree t)
{
+ /* APPLE LOCAL begin 2.95-ptmf-compatibility turly 20020313 */
+ if (flag_apple_kext)
+ {
+ if (TREE_CODE (t) == PTRMEM_CST)
+ {
+ tree fn = PTRMEM_CST_MEMBER (t);
+ if (!DECL_VIRTUAL_P (fn))
+ return convert (TYPE_PTRMEMFUNC_FN_TYPE (TREE_TYPE (t)),
+ build_addr_func (fn));
+ }
+
+ t = build_ptrmemfunc_access_expr (t, pfn_or_delta2_identifier);
+ return build_ptrmemfunc_access_expr (t, pfn_identifier);
+ }
+ /* APPLE LOCAL end 2.95-ptmf-compatibility turly 20020313 */
+
if (TREE_CODE (t) == PTRMEM_CST)
{
tree delta;
@@ -5562,8 +5836,7 @@ convert_for_assignment (tree type, tree rhs,
coder = TREE_CODE (rhstype);
if (TREE_CODE (type) == VECTOR_TYPE && coder == VECTOR_TYPE
- && ((*targetm.vector_opaque_p) (type)
- || (*targetm.vector_opaque_p) (rhstype)))
+ && vector_types_compatible_p (type, rhstype))
return convert (type, rhs);
if (rhs == error_mark_node || rhstype == error_mark_node)
diff --git a/gcc/cp/typeck2.c b/gcc/cp/typeck2.c
index f0717f60884..3edf58313aa 100644
--- a/gcc/cp/typeck2.c
+++ b/gcc/cp/typeck2.c
@@ -555,13 +555,21 @@ digest_init (tree type, tree init, tree* tail)
if ((TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (string)))
!= char_type_node)
+ /* APPLE LOCAL begin Pascal strings 2001-07-05 zll */
+ && (TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (string)))
+ != unsigned_char_type_node)
+ /* APPLE LOCAL end Pascal strings 2001-07-05 zll */
&& TYPE_PRECISION (typ1) == BITS_PER_UNIT)
{
error ("char-array initialized from wide string");
return error_mark_node;
}
- if ((TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (string)))
+ /* APPLE LOCAL begin Pascal strings 2001-07-05 zll */
+ if (((TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (string)))
== char_type_node)
+ || (TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (string)))
+ == unsigned_char_type_node))
+ /* APPLE LOCAL end Pascal strings 2001-07-05 zll */
&& TYPE_PRECISION (typ1) != BITS_PER_UNIT)
{
error ("int-array initialized from non-wide string");
diff --git a/gcc/cppcharset.c b/gcc/cppcharset.c
index b46f47a1fe0..8f97a972d70 100644
--- a/gcc/cppcharset.c
+++ b/gcc/cppcharset.c
@@ -1243,7 +1243,10 @@ narrow_str_to_charconst (cpp_reader *pfile, cpp_string str,
cpp_error (pfile, CPP_DL_WARNING,
"character constant too long for its type");
}
- else if (i > 1 && CPP_OPTION (pfile, warn_multichar))
+ /* APPLE LOCAL begin -Wfour-char-constants */
+ else if ((i == 4 && CPP_OPTION (pfile, warn_four_char_constants))
+ || (i > 1 && i != 4 && CPP_OPTION (pfile, warn_multichar)))
+ /* APPLE LOCAL end -Wfour-char-constants */
cpp_error (pfile, CPP_DL_WARNING, "multi-character character constant");
/* Multichar constants are of type int and therefore signed. */
diff --git a/gcc/cpperror.c b/gcc/cpperror.c
index d57238069d6..1ceb3457c66 100644
--- a/gcc/cpperror.c
+++ b/gcc/cpperror.c
@@ -29,6 +29,8 @@ Foundation, 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
#include "cpphash.h"
#include "intl.h"
+/* APPLE LOCAL error-colon */
+static int gcc_error_colon = 0;
static void print_location (cpp_reader *, source_location, unsigned int);
/* Print the logical file location (LINE, COL) in preparation for a
@@ -38,6 +40,23 @@ static void print_location (cpp_reader *, source_location, unsigned int);
static void
print_location (cpp_reader *pfile, source_location line, unsigned int col)
{
+ /* APPLE LOCAL begin error-colon */
+ const char *estr;
+ {
+ static int done = 0;
+ if ( ! done)
+ {
+ done = 1; /* Do this only once. */
+ /* Pretend we saw "-w" on commandline. */
+ if (getenv ("GCC_DASH_W"))
+ CPP_OPTION (pfile, inhibit_warnings) = 1; /* referenced by diagnostic.h:diagnostic_report_warnings() */
+ if (getenv ("GCC_ERROR_COLON"))
+ gcc_error_colon = 1;
+ }
+ }
+ estr = (gcc_error_colon) ? "error:" : "" ;
+ /* APPLE LOCAL end error-colon */
+
if (line == 0)
fprintf (stderr, "%s: ", progname);
else
@@ -56,12 +75,14 @@ print_location (cpp_reader *pfile, source_location line, unsigned int col)
col = 1;
}
+ /* APPLE LOCAL begin error-colon */
if (lin == 0)
- fprintf (stderr, "%s:", map->to_file);
+ fprintf (stderr, "%s:%s", map->to_file, estr);
else if (CPP_OPTION (pfile, show_column) == 0)
- fprintf (stderr, "%s:%u:", map->to_file, lin);
+ fprintf (stderr, "%s:%u:%s", map->to_file, lin, estr);
else
- fprintf (stderr, "%s:%u:%u:", map->to_file, lin, col);
+ fprintf (stderr, "%s:%u:%u:%s", map->to_file, lin, col, estr);
+ /* APPLE LOCAL end error-colon */
fputc (' ', stderr);
}
diff --git a/gcc/cpphash.h b/gcc/cpphash.h
index 4e86bf37d5b..337263f8fcc 100644
--- a/gcc/cpphash.h
+++ b/gcc/cpphash.h
@@ -153,7 +153,8 @@ extern unsigned char *_cpp_unaligned_alloc (cpp_reader *, size_t);
#define BUFF_LIMIT(BUFF) ((BUFF)->limit)
/* #include types. */
-enum include_type {IT_INCLUDE, IT_INCLUDE_NEXT, IT_IMPORT, IT_CMDLINE};
+/* APPLE LOCAL pch distcc mrs */
+enum include_type {IT_INCLUDE, IT_INCLUDE_PCH, IT_INCLUDE_NEXT, IT_IMPORT, IT_CMDLINE};
union utoken
{
@@ -328,6 +329,21 @@ struct cpp_buffer
struct cset_converter input_cset_desc;
};
+/* APPLE LOCAL begin Symbol Separation */
+/* Indicate state of context info processing.
+ Context info processing shares code with PCH, but it does not need
+ everything PCH does. Use this context info states to exclude not
+ required stuff. */
+enum cpp_cinfo_state
+ {
+ CINFO_NONE,
+ CINFO_FOUND, /* Context information found */
+ CINFO_VALID, /* Context information is valid */
+ CINFO_READ, /* Reading context information */
+ CINFO_WRITE /* Writing context information */
+ };
+/* APPLE LOCAL end Symbol Separation */
+
/* A cpp_reader encapsulates the "state" of a pre-processor run.
Applying cpp_get_token repeatedly yields a stream of pre-processor
tokens. Usually, there is only one cpp_reader object active. */
@@ -469,6 +485,12 @@ struct cpp_reader
/* Used to save the original line number during traditional
preprocessing. */
unsigned int saved_line;
+ /* APPLE LOCAL begin Symbol Separation */
+ const char *cinfo_candidate_file;
+ const char *cinfo_src_file;
+ /* State of context information read/write operation. */
+ enum cpp_cinfo_state cinfo_state;
+ /* APPLE LOCAL end Symbol Separation */
/* A saved list of the defined macros, for dependency checking
of precompiled headers. */
@@ -504,6 +526,10 @@ extern unsigned char _cpp_trigraph_map[UCHAR_MAX + 1];
/* Macros. */
+/* APPLE LOCAL begin warning in system headers */
+#define CPP_IN_SYSTEM_HEADER(PFILE) ((PFILE)->line_table && (PFILE)->line_table->maps && (PFILE)->line_table->maps->sysp)
+/* APPLE LOCAL end warning in system headers */
+
static inline int cpp_in_system_header (cpp_reader *);
static inline int
cpp_in_system_header (cpp_reader *pfile)
@@ -533,6 +559,10 @@ extern void _cpp_init_hashtable (cpp_reader *, hash_table *);
extern void _cpp_destroy_hashtable (cpp_reader *);
/* In cppfiles.c */
+/* APPLE LOCAL begin Symbol Separation */
+extern void find_include_cinfo (cpp_reader *, const char *);
+/* APPLE LOCAL end Symbol Separation */
+
typedef struct _cpp_file _cpp_file;
extern _cpp_file *_cpp_find_file (cpp_reader *, const char *fname,
cpp_dir *start_dir, bool fake);
diff --git a/gcc/cppinit.c b/gcc/cppinit.c
index a6da0b69b6f..865bca775d6 100644
--- a/gcc/cppinit.c
+++ b/gcc/cppinit.c
@@ -135,6 +135,17 @@ cpp_create_reader (enum c_lang lang, hash_table *table,
pfile = xcalloc (1, sizeof (cpp_reader));
cpp_set_lang (pfile, lang);
+ /* APPLE LOCAL begin -Wextra-tokens 2001-08-01 sts */
+ /* Suppress warnings about extra tokens after #endif etc. */
+ CPP_OPTION (pfile, warn_extra_tokens) = 0;
+ /* APPLE LOCAL end -Wextra-tokens 2001-08-01 sts */
+ /* APPLE LOCAL begin -Wnewline-eof 2001-08-23 sts */
+ /* Suppress warnings about missing newlines at ends of files. */
+ CPP_OPTION (pfile, warn_newline_at_eof) = 0;
+ /* APPLE LOCAL end -Wnewline-eof 2001-08-23 sts */
+ /* APPLE LOCAL begin -Wfour-char-constants */
+ CPP_OPTION (pfile, warn_four_char_constants) = 1;
+ /* APPLE LOCAL end -Wfour-char-constants */
CPP_OPTION (pfile, warn_multichar) = 1;
CPP_OPTION (pfile, discard_comments) = 1;
CPP_OPTION (pfile, discard_comments_in_macro_exp) = 1;
@@ -142,8 +153,11 @@ cpp_create_reader (enum c_lang lang, hash_table *table,
CPP_OPTION (pfile, tabstop) = 8;
CPP_OPTION (pfile, operator_names) = 1;
CPP_OPTION (pfile, warn_trigraphs) = 2;
- CPP_OPTION (pfile, warn_endif_labels) = 1;
- CPP_OPTION (pfile, warn_deprecated) = 1;
+ /* APPLE LOCAL begin -Wextra-tokens */
+ /* Suppress warnings about extra tokens after #endif etc. */
+ CPP_OPTION (pfile, warn_endif_labels) = 0;
+ /* APPLE LOCAL suppress useful warnings */
+ CPP_OPTION (pfile, warn_deprecated) = 0;
CPP_OPTION (pfile, warn_long_long) = !CPP_OPTION (pfile, c99);
CPP_OPTION (pfile, dollars_in_ident) = 1;
CPP_OPTION (pfile, warn_dollars) = 1;
@@ -473,6 +487,13 @@ cpp_read_main_file (cpp_reader *pfile, const char *fname)
if (_cpp_find_failed (pfile->main_file))
return false;
+ /* APPLE LOCAL begin Symbol Separation */
+ /* If creating PCH file then main input file is a header and it is a candidate
+ for separate symbol repository. Find one if available. */
+ if (CPP_OPTION (pfile, making_pch) && CPP_OPTION (pfile, use_ss))
+ find_include_cinfo (pfile, fname);
+ /* APPLE LOCAL end Symbol Separation */
+
_cpp_stack_file (pfile, pfile->main_file, false);
/* For foo.i, read the original filename foo.c now, for the benefit
diff --git a/gcc/cpplib.c b/gcc/cpplib.c
index f2556b385a0..75d8707f0ed 100644
--- a/gcc/cpplib.c
+++ b/gcc/cpplib.c
@@ -71,12 +71,20 @@ struct pragma_entry
means this directive should be handled even if -fpreprocessed is in
effect (these are the directives with callback hooks).
+ APPLE LOCAL BEGIN pch distcc mrs
+ IN_I_PCH means that this directive should be handled even if
+ -fpreprocessed is in effect as long as pch_preprocess is also in
+ effect.
+ APPLE LOCAL BEGIN pch distcc mrs
+
EXPAND is set on directives that are always macro-expanded. */
#define COND (1 << 0)
#define IF_COND (1 << 1)
#define INCL (1 << 2)
#define IN_I (1 << 3)
#define EXPAND (1 << 4)
+/* APPLE LOCAL pch distcc mrs */
+#define IN_I_PCH (1 << 5)
/* Defines one #-directive, including how to handle it. */
typedef void (*directive_handler) (cpp_reader *);
@@ -143,6 +151,8 @@ static void handle_assertion (cpp_reader *, const char *, int);
#define DIRECTIVE_TABLE \
D(define, T_DEFINE = 0, KANDR, IN_I) /* 270554 */ \
D(include, T_INCLUDE, KANDR, INCL | EXPAND) /* 52262 */ \
+/* APPLE LOCAL pch distcc mrs */ \
+D(include_pch, T_INCLUDE_PCH, KANDR, INCL | IN_I_PCH) \
D(endif, T_ENDIF, KANDR, COND) /* 45855 */ \
D(ifdef, T_IFDEF, KANDR, COND | IF_COND) /* 22000 */ \
D(if, T_IF, KANDR, COND | IF_COND | EXPAND) /* 18162 */ \
@@ -214,7 +224,9 @@ skip_rest_of_line (cpp_reader *pfile)
static void
check_eol (cpp_reader *pfile)
{
- if (! SEEN_EOL () && _cpp_lex_token (pfile)->type != CPP_EOF)
+ /* APPLE LOCAL -Wextra-tokens 2001-08-02 sts */
+ if (! SEEN_EOL () && _cpp_lex_token (pfile)->type != CPP_EOF
+ && CPP_OPTION (pfile, warn_extra_tokens))
cpp_error (pfile, CPP_DL_PEDWARN, "extra tokens at end of #%s directive",
pfile->directive->name);
}
@@ -382,7 +394,11 @@ _cpp_handle_directive (cpp_reader *pfile, int indented)
-fpreprocessed mode only if the # is in column 1. cppmacro.c
puts a space in front of any '#' at the start of a macro. */
if (CPP_OPTION (pfile, preprocessed)
- && (indented || !(dir->flags & IN_I)))
+ /* APPLE LOCAL BEGIN pch distcc mrs */
+ && (indented || !(dir->flags & IN_I))
+ && ! (CPP_OPTION (pfile, pch_preprocess)
+ && (dir->flags & IN_I_PCH)))
+ /* APPLE LOCAL END pch distcc mrs */
{
skip = 0;
dir = 0;
@@ -704,6 +720,14 @@ do_include (cpp_reader *pfile)
do_include_common (pfile, IT_INCLUDE);
}
+/* APPLE LOCAL pch distcc mrs */
+static void
+do_include_pch (cpp_reader *pfile)
+{
+ do_include_common (pfile, IT_INCLUDE_PCH);
+}
+/* APPLE LOCAL pch distcc mrs */
+
static void
do_import (cpp_reader *pfile)
{
@@ -941,7 +965,14 @@ static void
do_warning (cpp_reader *pfile)
{
/* We want #warning diagnostics to be emitted in system headers too. */
- do_diagnostic (pfile, CPP_DL_WARNING_SYSHDR, 1);
+ /* APPLE LOCAL begin handle -Wno-system-headers (2910306) ilr */
+ /* Unless explicitly suppressed with -Wno-system-headers or
+ -Wno-#warning. */
+ if (!CPP_OPTION (pfile, no_pound_warnings)
+ && (!CPP_IN_SYSTEM_HEADER (pfile)
+ || CPP_OPTION (pfile, warn_system_headers)))
+ do_diagnostic (pfile, CPP_DL_WARNING_SYSHDR, 1);
+ /* APPLE LOCAL end handle -Wno-system-headers (2910306) ilr */
}
/* Report program identification. */
@@ -1473,7 +1504,9 @@ do_else (cpp_reader *pfile)
ifs->mi_cmacro = 0;
/* Only check EOL if was not originally skipping. */
- if (!ifs->was_skipping && CPP_OPTION (pfile, warn_endif_labels))
+ /* APPLE LOCAL -Wextra-tokens */
+ if (!ifs->was_skipping
+ && (CPP_OPTION (pfile, warn_endif_labels) || CPP_OPTION (pfile, warn_extra_tokens)))
check_eol (pfile);
}
}
@@ -1526,7 +1559,9 @@ do_endif (cpp_reader *pfile)
else
{
/* Only check EOL if was not originally skipping. */
- if (!ifs->was_skipping && CPP_OPTION (pfile, warn_endif_labels))
+ /* APPLE LOCAL -Wextra-tokens */
+ if (!ifs->was_skipping
+ && (CPP_OPTION (pfile, warn_endif_labels) || CPP_OPTION (pfile, warn_extra_tokens)))
check_eol (pfile);
/* If potential control macro, we go back outside again. */
@@ -1902,6 +1937,14 @@ cpp_get_options (cpp_reader *pfile)
return &pfile->opts;
}
+/* APPLE LOCAL begin read-from-stdin */
+void
+set_stdin_option (cpp_reader *pfile, const char *arg)
+{
+ CPP_OPTION (pfile, stdin_diag_filename) = arg;
+}
+/* APPLE LOCAL end read-from-stdin */
+
/* The callbacks structure. */
cpp_callbacks *
cpp_get_callbacks (cpp_reader *pfile)
@@ -1971,6 +2014,19 @@ _cpp_pop_buffer (cpp_reader *pfile)
_cpp_pop_file_buffer (pfile, inc);
_cpp_do_file_change (pfile, LC_LEAVE, 0, 0, 0);
+
+ /* APPLE LOCAL begin Symbol Separation */
+#if 0
+ /* MERGE FIXME inc is not what it used to be */
+ if (suppress_dbg_info (inc))
+ {
+ /* We are not using symbol repository anymore. */
+ pfile->cinfo_state = CINFO_NONE;
+ if (pfile->cb.restore_write_symbols)
+ pfile->cb.restore_write_symbols ();
+ }
+#endif
+ /* APPLE LOCAL end Symbol Separation */
}
}
@@ -1988,3 +2044,29 @@ _cpp_init_directives (cpp_reader *pfile)
node->directive_index = i;
}
}
+
+/* APPLE LOCAL begin Symbol Separation */
+/* MERGE FIXME: These are stub routines. */
+void find_include_cinfo (cpp_reader *pfile ATTRIBUTE_UNUSED,
+ const char *in_name ATTRIBUTE_UNUSED)
+{
+}
+
+const char *
+cpp_symbol_separation_init (struct cpp_reader *pfile ATTRIBUTE_UNUSED,
+ const char * dbg_dir ATTRIBUTE_UNUSED,
+ const char * main_input_filename ATTRIBUTE_UNUSED)
+{
+ return dbg_dir;
+}
+
+void cpp_write_symbol_deps (struct cpp_reader *pfile ATTRIBUTE_UNUSED)
+{
+}
+
+unsigned long
+cpp_get_stabs_checksum (void)
+{
+ return 0;
+}
+/* APPLE LOCAL end symbol separation */
diff --git a/gcc/cpplib.h b/gcc/cpplib.h
index c53375d4138..55618f6ee83 100644
--- a/gcc/cpplib.h
+++ b/gcc/cpplib.h
@@ -213,6 +213,18 @@ struct cpp_options
/* Characters between tab stops. */
unsigned int tabstop;
+ /* APPLE LOCAL begin -header-mapfile */
+ /* The central header translation mapfile, set by the '-header-mapfile'
+ option, or NULL if none. */
+ struct hmap_header_map *header_map;
+ struct search_path *hmap_path;
+ /* APPLE LOCAL end -header-mapfile */
+
+ /* APPLE LOCAL begin read-from-stdin */
+ /* function name that should be used in issung diagnostics when input is read from stdin */
+ const char *stdin_diag_filename;
+ /* APPLE LOCAL end read-from-stdin */
+
/* The language we're preprocessing. */
enum c_lang lang;
@@ -267,6 +279,19 @@ struct cpp_options
/* Nonzero means warn if there are any trigraphs. */
unsigned char warn_trigraphs;
+ /* APPLE LOCAL begin -Wextra-tokens 2001-08-02 sts */
+ /* Nonzero means warn if extra tokens at end of directives. */
+ unsigned char warn_extra_tokens;
+ /* APPLE LOCAL end -Wextra-tokens 2001-08-02 sts */
+ /* APPLE LOCAL begin -Wnewline-eof 2001-08-23 sts */
+ /* Nonzero means warn if no newline at end of file. */
+ unsigned char warn_newline_at_eof;
+ /* APPLE LOCAL end -Wnewline-eof 2001-08-23 sts */
+ /* APPLE LOCAL begin -Wfour-char-constants */
+ /* Warn about four-char literals (e.g., MacOS-style OSTypes: 'APPL'). */
+ unsigned char warn_four_char_constants;
+ /* APPLE LOCAL end -Wfour-char-constants */
+
/* Nonzero means warn about multicharacter charconsts. */
unsigned char warn_multichar;
@@ -327,6 +352,10 @@ struct cpp_options
/* Nonzero means handle C++ alternate operator names. */
unsigned char operator_names;
+ /* APPLE LOCAL -Wno-#warnings */
+ /* Nonzero means suppress all #warning messages. (Radar 2796309) */
+ int no_pound_warnings;
+
/* True for traditional preprocessing. */
unsigned char traditional;
@@ -345,6 +374,20 @@ struct cpp_options
/* True if dependencies should be restored from a precompiled header. */
bool restore_pch_deps;
+ /* APPLE LOCAL begin Symbol Separation */
+ unsigned char making_pch;
+ unsigned char making_ss;
+ /* True to warn about symbol repositories we couldn't use. */
+ bool warn_invalid_sr;
+ bool use_ss;
+ /* APPLE LOCAL end Symbol Separation */
+
+ /* APPLE LOCAL BEGIN pch distcc mrs */
+ /* True if PCH should omit from the -E output all lines from PCH files
+ found in PCH files. */
+ unsigned char pch_preprocess;
+ /* APPLE LOCAL END pch distcc mrs */
+
/* Dependency generation. */
struct
{
@@ -409,6 +452,16 @@ struct cpp_callbacks
int (*valid_pch) (cpp_reader *, const char *, int);
void (*read_pch) (cpp_reader *, const char *, int, const char *);
missing_header_cb missing_header;
+
+ /* APPLE LOCAL begin Symbol Separation */
+ void (*restore_write_symbols) (void);
+ void (*clear_write_symbols) (const char *, unsigned long);
+ void (*start_symbol_repository) (unsigned int, const char *, unsigned long);
+ void (*end_symbol_repository) (unsigned int);
+ int (*is_builtin_identifier) (cpp_hashnode *);
+ /* APPLE LOCAL end Symbol Separation */
+ /* APPLE LOCAL - PCH distcc debugging mrs */
+ void (*set_working_directory)(const char *);
};
/* Chain of directories to look for include files in. */
@@ -518,6 +571,20 @@ struct cpp_hashnode GTY(())
} GTY ((desc ("0"))) value;
};
+/* APPLE LOCAL begin Symbol Separation */
+struct cpp_stab_checksum GTY(())
+{
+ unsigned long checksum;
+};
+extern void cpp_write_symbol_deps PARAMS ((struct cpp_reader *));
+extern void cpp_read_stabs_checksum PARAMS ((struct cpp_reader *, int));
+extern unsigned long cpp_get_stabs_checksum PARAMS ((void));
+extern void cpp_calculate_stabs_checksum PARAMS ((const char *));
+extern const char * cpp_symbol_separation_init PARAMS ((struct cpp_reader *, const char *,
+ const char *));
+
+/* APPLE LOCAL end Symbol Separation */
+
/* Call this first to get a handle to pass to other functions.
If you want cpplib to manage its own hashtable, pass in a NULL
@@ -709,6 +776,43 @@ extern void cpp_errno (cpp_reader *, int, const char *msgid);
extern void cpp_error_with_line (cpp_reader *, int, source_location, unsigned,
const char *msgid, ...) ATTRIBUTE_PRINTF_5;
+/* APPLE LOCAL begin -header-mapfile */
+#define HMAP_SAME_ENDIANNESS_MAGIC (((((('h' << 8) | 'm') << 8) | 'a') << 8) | 'p')
+#define HMAP_OPPOSITE_ENDIANNESS_MAGIC (((((('p' << 8) | 'a') << 8) | 'm') << 8) | 'h')
+
+#define HMAP_NOT_A_KEY 0x00000000
+
+#if !defined(uint32)
+typedef unsigned short uint16;
+typedef unsigned long uint32;
+#endif
+
+struct hmap_bucket
+{
+ uint32 key; /* Offset (into strings) of key */
+ struct {
+ uint32 prefix; /* Offset (into strings) of value prefix */
+ uint32 suffix; /* Offset (into strings) of value suffix */
+ } value; /* Value (prefix- and suffix-strings) */
+};
+
+struct hmap_header_map
+{
+ uint32 magic; /* Magic word, also indicates byte order */
+ uint16 version; /* Version number -- currently 1 */
+ uint16 _reserved; /* Reserved for future use -- zero for now */
+ uint32 strings_offset; /* Offset to start of string pool */
+ uint32 count; /* Number of entries in the string table */
+ uint32 capacity; /* Number of buckets (always a power of 2) */
+ uint32 max_value_length; /* Length of longest result path (excl. '\0') */
+ struct hmap_bucket buckets[1]; /* Inline array of 'capacity' maptable buckets */
+ /* Strings follow the buckets, at strings_offset. */
+};
+
+extern struct search_path *hmap_lookup_path PARAMS ((cpp_reader *,
+ const char **));
+/* APPLE LOCAL end -header-mapfile */
+
/* In cpplex.c */
extern int cpp_ideq (const cpp_token *, const char *);
extern void cpp_output_line (cpp_reader *, FILE *);
@@ -748,6 +852,11 @@ extern cpp_buffer *cpp_get_buffer (cpp_reader *);
extern struct _cpp_file *cpp_get_file (cpp_buffer *);
extern cpp_buffer *cpp_get_prev (cpp_buffer *);
+/* APPLE LOCAL begin read-from-stdin */
+extern bool read_from_stdin PARAMS ((cpp_reader *));
+extern void set_stdin_option PARAMS ((cpp_reader *, const char*));
+/* APPLE LOCAL end read-from-stdin */
+
/* In cpppch.c */
struct save_macro_data;
extern int cpp_save_state (cpp_reader *, FILE *);
diff --git a/gcc/cpppch.c b/gcc/cpppch.c
index 8cb5bcff87a..a4886ae3457 100644
--- a/gcc/cpppch.c
+++ b/gcc/cpppch.c
@@ -224,6 +224,12 @@ count_defs (cpp_reader *pfile ATTRIBUTE_UNUSED, cpp_hashnode *hn, void *ss_p)
struct cpp_string news;
void **slot;
+ /* APPLE LOCAL begin Symbol Separation */
+ if (pfile->cinfo_state == CINFO_WRITE && pfile->cb.is_builtin_identifier)
+ if (pfile->cb.is_builtin_identifier (hn))
+ return 1;
+ /* APPLE LOCAL end Symbol Separation */
+
news.len = NODE_LEN (hn);
news.text = NODE_NAME (hn);
slot = htab_find (ss->definedhash, &news);
@@ -263,6 +269,12 @@ write_defs (cpp_reader *pfile ATTRIBUTE_UNUSED, cpp_hashnode *hn, void *ss_p)
struct cpp_string news;
void **slot;
+ /* APPLE LOCAL begin Symbol Separation */
+ if (pfile->cinfo_state == CINFO_WRITE && pfile->cb.is_builtin_identifier)
+ if (pfile->cb.is_builtin_identifier (hn))
+ return 1;
+ /* APPLE LOCAL end Symbol Separation */
+
news.len = NODE_LEN (hn);
news.text = NODE_NAME (hn);
slot = htab_find (ss->definedhash, &news);
@@ -420,8 +432,9 @@ collect_ht_nodes (cpp_reader *pfile ATTRIBUTE_UNUSED, cpp_hashnode *hn,
- anything that was not defined then, but is defined now, was not
used by the PCH.
- NAME is used to print warnings if `warn_invalid_pch' is set in the
- reader's flags.
+ APPLE LOCAL Symbol Separation
+ NAME is used to print warnings if `warn_invalid_pch' or `warn_invalid_sr'
+ is set in the reader's flags.
*/
int
@@ -434,7 +447,14 @@ cpp_valid_state (cpp_reader *r, const char *name, int fd)
struct ht_node_list nl = { 0, 0, 0 };
unsigned char *first, *last;
unsigned int i;
-
+ /* APPLE LOCAL begin pch distcc mrs */
+ int skip_validation;
+
+ /* Skip pch validation if we have just validated it. */
+ skip_validation = CPP_OPTION (r, pch_preprocess)
+ && CPP_OPTION (r, preprocessed);
+ /* APPLE LOCAL end pch distcc mrs */
+
/* Read in the list of identifiers that must be defined
Check that they are defined in the same way. */
for (;;)
@@ -459,12 +479,18 @@ cpp_valid_state (cpp_reader *r, const char *name, int fd)
!= m.definition_length)
goto error;
+ /* APPLE LOCAL begin pch distcc mrs */
+ if (skip_validation)
+ continue;
+ /* APPLE LOCAL end pch distcc mrs */
+
h = cpp_lookup (r, namebuf, m.name_length);
if (m.flags & NODE_POISONED
|| h->type != NT_MACRO
|| h->flags & NODE_POISONED)
{
- if (CPP_OPTION (r, warn_invalid_pch))
+ /* APPLE LOCAL Symbol Separtion */
+ if (CPP_OPTION (r, warn_invalid_pch) || CPP_OPTION (r, warn_invalid_sr))
cpp_error (r, CPP_DL_WARNING_SYSHDR,
"%s: not used because `%.*s' not defined",
name, m.name_length, namebuf);
@@ -476,7 +502,8 @@ cpp_valid_state (cpp_reader *r, const char *name, int fd)
if (m.definition_length != ustrlen (newdefn)
|| memcmp (namebuf, newdefn, m.definition_length) != 0)
{
- if (CPP_OPTION (r, warn_invalid_pch))
+ /* APPLE LOCAL Symbol Separtion */
+ if (CPP_OPTION (r, warn_invalid_pch) || CPP_OPTION (r, warn_invalid_sr))
cpp_error (r, CPP_DL_WARNING_SYSHDR,
"%s: not used because `%.*s' defined as `%s' not `%.*s'",
name, m.name_length, namebuf, newdefn + m.name_length,
@@ -494,6 +521,14 @@ cpp_valid_state (cpp_reader *r, const char *name, int fd)
if ((size_t) read (fd, undeftab, m.definition_length) != m.definition_length)
goto error;
+ /* APPLE LOCAL begin pch distcc mrs */
+ if (skip_validation)
+ {
+ free (undeftab);
+ return 0;
+ }
+ /* APPLE LOCAL end pch distcc mrs */
+
/* Collect identifiers from the current hash table. */
nl.n_defs = 0;
nl.asize = 10;
@@ -517,7 +552,8 @@ cpp_valid_state (cpp_reader *r, const char *name, int fd)
++i;
else
{
- if (CPP_OPTION (r, warn_invalid_pch))
+ /* APPLE LOCAL Symbol Separtion */
+ if (CPP_OPTION (r, warn_invalid_pch) || CPP_OPTION (r, warn_invalid_sr))
cpp_error (r, CPP_DL_WARNING_SYSHDR,
"%s: not used because `%s' is defined",
name, first);
@@ -619,6 +655,11 @@ cpp_read_state (cpp_reader *r, const char *name, FILE *f,
struct save_macro_item *d;
size_t i, mac_count;
int saved_line = r->line;
+ /* APPLE LOCAL pch distcc mrs */
+ void (*saved_line_change) PARAMS ((cpp_reader *, const cpp_token *, int));
+
+ /* APPLE LOCAL pch distcc mrs */
+ saved_line_change = r->cb.line_change;
/* Restore spec_nodes, which will be full of references to the old
hashtable entries and so will now be invalid. */
@@ -663,6 +704,9 @@ cpp_read_state (cpp_reader *r, const char *name, FILE *f,
r->state.prevent_expansion = 1;
r->state.angled_headers = 0;
+ /* APPLE LOCAL pch distcc mrs */
+ r->cb.line_change = 0;
+
/* Read in the identifiers that must be defined. */
for (;;)
{
@@ -708,6 +752,9 @@ cpp_read_state (cpp_reader *r, const char *name, FILE *f,
r->state = old_state;
r->line = saved_line;
+ /* APPLE LOCAL pch distcc mrs */
+ r->cb.line_change = saved_line_change;
+
free (defn);
defn = NULL;
diff --git a/gcc/cse.c b/gcc/cse.c
index 2c4ab8eb071..406ffe507f5 100644
--- a/gcc/cse.c
+++ b/gcc/cse.c
@@ -4811,6 +4811,9 @@ cse_insn (rtx insn, rtx libcall_insn)
rtx src_eqv_here;
rtx src_const = 0;
rtx src_related = 0;
+ /* APPLE LOCAL begin cse of ZERO/SIGN EXTEND */
+ rtx zero_sign_extended_src = NULL_RTX;
+ /* APPLE LOCAL end cse of ZERO/SIGN EXTEND */
struct table_elt *src_const_elt = 0;
int src_cost = MAX_COST;
int src_eqv_cost = MAX_COST;
@@ -4945,7 +4948,35 @@ cse_insn (rtx insn, rtx libcall_insn)
REG_NOTE. */
if (!sets[i].src_volatile)
+ /* APPLE LOCAL begin cse of ZERO/SIGN EXTEND */
+ {
elt = lookup (src, sets[i].src_hash, mode);
+ if (!elt
+ && (GET_CODE(src) == ZERO_EXTEND || GET_CODE(src) == SIGN_EXTEND)
+ && GET_CODE (XEXP (src, 0)) == MEM)
+ {
+ unsigned mem_hash;
+ rtx nsrc = XEXP (src, 0);
+ enum machine_mode nmode = GET_MODE(nsrc);
+ do_not_record = 0;
+ hash_arg_in_memory = 0;
+ mem_hash = HASH (nsrc, nmode);
+ elt = lookup (nsrc, mem_hash, nmode);
+ if (elt)
+ {
+ sets[i].src = nsrc;
+ sets[i].src_hash = mem_hash;
+ sets[i].src_volatile = do_not_record;
+ sets[i].src_in_memory = hash_arg_in_memory;
+ zero_sign_extended_src = src;
+ src = nsrc;
+ mode = GET_MODE (src) == VOIDmode ? GET_MODE (dest) : GET_MODE (src);
+ sets[i].mode = mode;
+ src_folded = fold_rtx (src, insn);
+ }
+ }
+ }
+ /* APPLE LOCAL end cse of ZERO/SIGN EXTEND */
sets[i].src_elt = elt;
@@ -4974,6 +5005,26 @@ cse_insn (rtx insn, rtx libcall_insn)
for (p = elt->first_same_value; p; p = p->next_same_value)
if (p->is_const)
{
+ /* APPLE LOCAL begin cse of ZERO/SIGN EXTEND */
+ /* If we're looking at a MEM under a SIGN/ZERO_EXTEND,
+ constants match only if the high bits match. */
+ if (zero_sign_extended_src)
+ {
+ rtx truncated_const, trial;
+ truncated_const = gen_rtx_TRUNCATE (
+ GET_MODE (XEXP (zero_sign_extended_src, 0)),
+ copy_rtx (p->exp));
+ if (GET_CODE (zero_sign_extended_src) == ZERO_EXTEND)
+ trial = gen_rtx_ZERO_EXTEND (
+ GET_MODE (zero_sign_extended_src), truncated_const);
+ else
+ trial = gen_rtx_SIGN_EXTEND (
+ GET_MODE (zero_sign_extended_src), truncated_const);
+ trial = fold_rtx (trial, NULL_RTX);
+ if (!rtx_equal_p (trial, p->exp))
+ continue;
+ }
+ /* APPLE LOCAL end cse of ZERO/SIGN EXTEND */
src_const = p->exp;
src_const_elt = elt;
break;
@@ -5346,6 +5397,18 @@ cse_insn (rtx insn, rtx libcall_insn)
&& preferable (src_related_cost, src_related_regcost,
src_elt_cost, src_elt_regcost) <= 0)
trial = copy_rtx (src_related), src_related_cost = MAX_COST;
+ /* APPLE LOCAL begin cse of ZERO/SIGN EXTEND */
+ else if (zero_sign_extended_src)
+ {
+ trial = GET_CODE(zero_sign_extended_src) == ZERO_EXTEND
+ ? gen_rtx_ZERO_EXTEND (GET_MODE(zero_sign_extended_src),
+ copy_rtx (elt->exp))
+ : gen_rtx_SIGN_EXTEND (GET_MODE(zero_sign_extended_src),
+ copy_rtx (elt->exp));
+ elt = elt->next_same_value;
+ src_elt_cost = MAX_COST;
+ }
+ /* APPLE LOCAL end cse of ZERO/SIGN EXTEND */
else
{
trial = copy_rtx (elt->exp);
@@ -5426,6 +5489,10 @@ cse_insn (rtx insn, rtx libcall_insn)
}
src = SET_SRC (sets[i].rtl);
+ /* APPLE LOCAL begin cse of ZERO/SIGN EXTEND */
+ if (zero_sign_extended_src)
+ src = XEXP (src, 0);
+ /* APPLE LOCAL end cse of ZERO/SIGN EXTEND */
/* In general, it is good to have a SET with SET_SRC == SET_DEST.
However, there is an important exception: If both are registers
@@ -5740,6 +5807,8 @@ cse_insn (rtx insn, rtx libcall_insn)
rtx dest = SET_DEST (sets[i].rtl);
enum machine_mode mode
= GET_MODE (src) == VOIDmode ? GET_MODE (dest) : GET_MODE (src);
+ if (!classp)
+ classp = sets[i].src_const_elt;
/* It's possible that we have a source value known to be
constant but don't have a REG_EQUAL note on the insn.
@@ -6600,10 +6669,6 @@ cse_set_around_loop (rtx x, rtx insn, rtx loop_start)
}
else
{
- if (CONSTANT_P (SET_SRC (set))
- && ! find_reg_equal_equiv_note (insn))
- set_unique_reg_note (insn, REG_EQUAL,
- SET_SRC (set));
if (control_flow_insn_p (p))
/* p can cause a control flow transfer so it
is the last insn of a basic block. We can't
diff --git a/gcc/dbxout.c b/gcc/dbxout.c
index 39f0d554501..6f34ac92a3d 100644
--- a/gcc/dbxout.c
+++ b/gcc/dbxout.c
@@ -88,6 +88,9 @@ Software Foundation, 59 Temple Place - Suite 330, Boston, MA
#include "function.h"
#include "target.h"
#include "langhooks.h"
+/* APPLE LOCAL begin Constructors return THIS turly 20020315 */
+/* FIXME: dbxout.c should not need language-specific headers. */
+#include "c-common.h"
#ifdef XCOFF_DEBUGGING_INFO
#include "xcoffout.h"
@@ -338,6 +341,13 @@ static void emit_pending_bincls (void);
#endif
static inline void emit_pending_bincls_if_required (void);
+/* APPLE LOCAL begin Symbol Separtion */
+static void dbxout_restore_write_symbols (void);
+static void dbxout_clear_write_symbols (const char *, unsigned long);
+static void dbxout_start_symbol_repository (unsigned int, const char *, unsigned long);
+static void dbxout_end_symbol_repository (unsigned int);
+/* APPLE LOCAL end Symbol Separation */
+
static void dbxout_init (const char *);
static void dbxout_finish (const char *);
static void dbxout_start_source_file (unsigned, const char *);
@@ -408,7 +418,13 @@ const struct gcc_debug_hooks dbx_debug_hooks =
debug_nothing_tree, /* deferred_inline_function */
debug_nothing_tree, /* outlining_inline_function */
debug_nothing_rtx, /* label */
- dbxout_handle_pch, /* handle_pch */
+ dbxout_handle_pch, /* handle_pch */
+ /* APPLE LOCAL begin Symbol Separation */
+ dbxout_restore_write_symbols,
+ dbxout_clear_write_symbols,
+ dbxout_start_symbol_repository,
+ dbxout_end_symbol_repository,
+ /* APPLE LOCAL end Symbol Separation */
debug_nothing_rtx /* var_location */
};
#endif /* DBX_DEBUGGING_INFO */
@@ -439,6 +455,12 @@ const struct gcc_debug_hooks xcoff_debug_hooks =
debug_nothing_tree, /* outlining_inline_function */
debug_nothing_rtx, /* label */
dbxout_handle_pch, /* handle_pch */
+ /* APPLE LOCAL begin Symbol Separtion */
+ debug_nothing_void, /* restore write_symbols */
+ debug_nothing_void, /* clear write_symbols */
+ debug_nothing_void, /* start repository */
+ debug_nothing_void, /* end repository */
+ /* APPLE LOCAL end Symbol Separation */
debug_nothing_rtx /* var_location */
};
#endif /* XCOFF_DEBUGGING_INFO */
@@ -448,6 +470,9 @@ static void
dbxout_function_end (void)
{
char lscope_label_name[100];
+ /* APPLE LOCAL begin hot/cold partitioning */
+ function_section (current_function_decl);
+ /* APPLE LOCAL end hot/cold partitioning */
/* Convert Ltext into the appropriate format for local labels in case
the system doesn't insert underscores in front of user generated
labels. */
@@ -501,9 +526,9 @@ dbxout_init (const char *input_file_name)
#else /* no DBX_OUTPUT_MAIN_SOURCE_DIRECTORY */
fprintf (asmfile, "%s", ASM_STABS_OP);
output_quoted_string (asmfile, cwd);
- fprintf (asmfile, ",%d,0,0,", N_SO);
- assemble_name (asmfile, ltext_label_name);
- fputc ('\n', asmfile);
+ /* APPLE LOCAL begin 3109828 fix */
+ fprintf (asmfile, ",%d,0,0,0\n", N_SO);
+ /* APPLE LOCAL end 3109828 fix */
#endif /* no DBX_OUTPUT_MAIN_SOURCE_DIRECTORY */
}
}
@@ -516,10 +541,10 @@ dbxout_init (const char *input_file_name)
/* Used to put `Ltext:' before the reference, but that loses on sun 4. */
fprintf (asmfile, "%s", ASM_STABS_OP);
output_quoted_string (asmfile, input_file_name);
- fprintf (asmfile, ",%d,0,0,", N_SO);
- assemble_name (asmfile, ltext_label_name);
- fputc ('\n', asmfile);
+ /* APPLE LOCAL begin 3109828 fix */
+ fprintf (asmfile, ",%d,0,0,0\n", N_SO);
text_section ();
+ /* APPLE LOCAL end 3109828 fix */
(*targetm.asm_out.internal_label) (asmfile, "Ltext", 0);
#endif /* no DBX_OUTPUT_MAIN_SOURCE_FILENAME */
@@ -546,6 +571,20 @@ dbxout_init (const char *input_file_name)
current_file->pending_bincl_name = NULL;
#endif
+ /* Make sure that types `int' and `char' have numbers 1 and 2.
+ Definitions of other integer types will refer to those numbers.
+ (Actually it should no longer matter what their numbers are.
+ Also, if any types with tags have been defined, dbxout_symbol
+ will output them first, so the numbers won't be 1 and 2. That
+ happens in C++. So it's a good thing it should no longer matter). */
+
+/* APPLE LOCAL gdb only used symbols */
+#ifndef DBX_ONLY_USED_SYMBOLS
+ dbxout_symbol (TYPE_NAME (integer_type_node), 0);
+ dbxout_symbol (TYPE_NAME (char_type_node), 0);
+/* APPLE LOCAL gdb only used symbols */
+#endif
+
/* Get all permanent types that have typedef names, and output them
all, except for those already output. Some language front ends
put these declarations in the top-level scope; some do not;
@@ -581,6 +620,59 @@ dbxout_typedefs (tree syms)
}
}
+/* APPLE LOCAL begin Symbol Separation */
+/* Restore write_symbols */
+static void
+dbxout_restore_write_symbols (void)
+{
+ if (flag_grepository)
+ write_symbols = orig_write_symbols;
+}
+
+/* Clear write_symbols and emit EXCL stab. */
+static void
+dbxout_clear_write_symbols (const char *filename, unsigned long checksum)
+{
+ if (flag_grepository)
+ {
+ write_symbols = NO_DEBUG;
+ fprintf (asmfile, "%s", ASM_STABS_OP);
+ output_quoted_string (asmfile, filename);
+ fprintf (asmfile, ",%d,0,0,%ld\n", N_EXCL, checksum);
+ }
+}
+
+/* Start symbol repository */
+/* Add checksum with BINCL. */
+static void
+dbxout_start_symbol_repository (unsigned int lineno ATTRIBUTE_UNUSED,
+ const char *filename ATTRIBUTE_UNUSED,
+ unsigned long checksum ATTRIBUTE_UNUSED)
+{
+#ifdef DBX_USE_BINCL
+ struct dbx_file *n = (struct dbx_file *) xmalloc (sizeof *n);
+
+ n->next = current_file;
+ n->file_number = next_file_number++;
+ n->next_type_number = 1;
+ current_file = n;
+ fprintf (asmfile, "%s", ASM_STABS_OP);
+ output_quoted_string (asmfile, filename);
+ fprintf (asmfile, ",%d,0,0,%ld\n", N_BINCL, checksum);
+#endif
+}
+
+/* End symbol repository */
+static void
+dbxout_end_symbol_repository (unsigned int lineno ATTRIBUTE_UNUSED)
+{
+#ifdef DBX_USE_BINCL
+ fprintf (asmfile, "%s%d,0,0,0\n", ASM_STABN_OP, N_EINCL);
+ current_file = current_file->next;
+#endif
+}
+/* APPLE LOCAL end Symbol Separation */
+
#ifdef DBX_USE_BINCL
/* Emit BINCL stab using given name. */
static void
@@ -648,6 +740,14 @@ dbxout_start_source_file (unsigned int line ATTRIBUTE_UNUSED,
#ifdef DBX_USE_BINCL
struct dbx_file *n = xmalloc (sizeof *n);
+ /* APPLE LOCAL begin Symbol Separation */
+ if (write_symbols == NO_DEBUG)
+ {
+ n = NULL;
+ return;
+ }
+ /* APPLE LOCAL end Symbol Separation */
+
n->next = current_file;
n->next_type_number = 1;
/* Do not assign file number now.
@@ -668,6 +768,11 @@ static void
dbxout_end_source_file (unsigned int line ATTRIBUTE_UNUSED)
{
#ifdef DBX_USE_BINCL
+ /* APPLE LOCAL begin Symbol Separation */
+ if (write_symbols == NO_DEBUG)
+ return;
+ /* APPLE LOCAL end Symbol Separation */
+
/* Emit EINCL stab only if BINCL is not pending. */
if (current_file->bincl_status == BINCL_PROCESSED)
fprintf (asmfile, "%s%d,0,0,0\n", ASM_STABN_OP, N_EINCL);
@@ -721,14 +826,16 @@ dbxout_source_file (FILE *file, const char *filename)
source_label_number);
fprintf (file, "%s", ASM_STABS_OP);
output_quoted_string (file, filename);
- fprintf (asmfile, ",%d,0,0,", N_SOL);
- assemble_name (asmfile, ltext_label_name);
- fputc ('\n', asmfile);
- if (current_function_decl != NULL_TREE
- && DECL_SECTION_NAME (current_function_decl) != NULL_TREE)
+ /* APPLE LOCAL 310928 fix */
+ fprintf (asmfile, ",%d,0,0,0\n", N_SOL);
+ /* APPLE LOCAL begin hot/cold partitioning */
+ if ((current_function_decl != NULL_TREE
+ && DECL_SECTION_NAME (current_function_decl) != NULL_TREE)
+ || flag_reorder_blocks_and_partition)
; /* Don't change section amid function. */
else
text_section ();
+ /* APPLE LOCAL end hot/cold partitioning */
(*targetm.asm_out.internal_label) (file, "Ltext", source_label_number);
source_label_number++;
lastfile = filename;
@@ -2218,7 +2325,14 @@ dbxout_symbol (tree decl, int local ATTRIBUTE_UNUSED)
int tag_needed = 1;
int did_output = 0;
- if (DECL_NAME (decl))
+ if (DECL_NAME (decl)
+ /* APPLE LOCAL begin gdb only used symbols */
+#ifdef DBX_ONLY_USED_SYMBOLS
+ /* Do not generate a tag for incomplete records */
+ && (COMPLETE_TYPE_P (type) || TREE_CODE (type) == VOID_TYPE)
+#endif
+ /* APPLE LOCAL end gdb only used symbols */
+ )
{
/* Nonzero means we must output a tag as well as a typedef. */
tag_needed = 0;
@@ -3195,6 +3309,15 @@ dbxout_begin_function (tree decl)
dbxout_parms (DECL_ARGUMENTS (decl));
if (DECL_NAME (DECL_RESULT (decl)) != 0)
+ /* APPLE LOCAL begin Constructors return THIS turly 20020315 */
+#ifdef POSSIBLY_COMPILING_APPLE_KEXT_P
+ /* We cheat with kext constructors: DECL_RESULT is "this", but "this"
+ is actually the first parameter, so don't confuse matters by
+ outputting the same parameter twice. */
+ if (!(POSSIBLY_COMPILING_APPLE_KEXT_P ()
+ && DECL_RESULT (decl) == DECL_ARGUMENTS (decl)))
+#endif
+ /* APPLE LOCAL end Constructors return THIS turly 20020315 */
dbxout_symbol (DECL_RESULT (decl), 1);
}
#endif /* DBX_DEBUGGING_INFO */
diff --git a/gcc/debug.c b/gcc/debug.c
index 812920604ba..69654c96184 100644
--- a/gcc/debug.c
+++ b/gcc/debug.c
@@ -47,6 +47,9 @@ const struct gcc_debug_hooks do_nothing_debug_hooks =
debug_nothing_tree, /* outlining_inline_function */
debug_nothing_rtx, /* label */
debug_nothing_int, /* handle_pch */
+ /* APPLE LOCAL begin Symbol Separation */
+ NULL, NULL, NULL, NULL,
+ /* APPLE LOCAL end Symbol Separation */
debug_nothing_rtx /* var_location */
};
diff --git a/gcc/debug.h b/gcc/debug.h
index 547b7f68eab..a38a3598c59 100644
--- a/gcc/debug.h
+++ b/gcc/debug.h
@@ -117,6 +117,13 @@ struct gcc_debug_hooks
The parameter is 0 if after the start, 1 if before the end. */
void (* handle_pch) (unsigned int);
+ /* APPLE LOCAL begin Symbol Separation */
+ void (* restore_write_symbols) (void);
+ void (* clear_write_symbols) (const char *, unsigned long);
+ void (* start_symbol_repository) (unsigned int, const char *, unsigned long);
+ void (* end_symbol_repository) (unsigned int);
+ /* APPLE LOCAL end Symbol Separation */
+
/* Called from final_scan_insn for any NOTE_INSN_VAR_LOCATION note. */
void (* var_location) (rtx);
};
diff --git a/gcc/defaults.h b/gcc/defaults.h
index 685a2802359..e5814279f29 100644
--- a/gcc/defaults.h
+++ b/gcc/defaults.h
@@ -587,6 +587,17 @@ You Lose! You must define PREFERRED_DEBUGGING_TYPE!
#define UNLIKELY_EXECUTED_TEXT_SECTION_NAME "text.unlikely"
#endif
+/* APPLE LOCAL begin hot/cold partitioning */
+
+#ifndef HAS_LONG_COND_BRANCH
+#define HAS_LONG_COND_BRANCH 0
+#endif
+
+#ifndef HAS_LONG_UNCOND_BRANCH
+#define HAS_LONG_UNCOND_BRANCH 0
+#endif
+/* APPLE LOCAL end hot/cold partitioning */
+
#ifndef VECTOR_MODE_SUPPORTED_P
#define VECTOR_MODE_SUPPORTED_P(MODE) 0
#endif
diff --git a/gcc/diagnostic.c b/gcc/diagnostic.c
index 5350d0c5531..e6ba94d55c7 100644
--- a/gcc/diagnostic.c
+++ b/gcc/diagnostic.c
@@ -61,12 +61,19 @@ static void real_abort (void) ATTRIBUTE_NORETURN;
static diagnostic_context global_diagnostic_context;
diagnostic_context *global_dc = &global_diagnostic_context;
+/* APPLE LOCAL error-colon */
+static int gcc_error_colon = 0;
+
/* Boilerplate text used in two locations. */
#define bug_report_request \
"Please submit a full bug report,\n\
with preprocessed source if appropriate.\n\
See %s for instructions.\n"
+/* APPLE LOCAL insert assembly ".abort" directive on fatal error */
+#ifdef EXIT_FROM_FATAL_DIAGNOSTIC
+#define exit(status) EXIT_FROM_FATAL_DIAGNOSTIC (status)
+#endif
/* Return a malloc'd string containing MSG formatted a la printf. The
caller is responsible for freeing the memory. */
@@ -87,6 +94,11 @@ build_message_string (const char *msg, ...)
char *
file_name_as_prefix (const char *f)
{
+ /* APPLE LOCAL begin error-colon */
+ if (gcc_error_colon)
+ return build_message_string ("%s: error: ", f);
+ else
+ /* APPLE LOCAL end error-colon */
return build_message_string ("%s: ", f);
}
@@ -190,6 +202,23 @@ diagnostic_count_diagnostic (diagnostic_context *context,
diagnostic_info *diagnostic)
{
diagnostic_t kind = diagnostic->kind;
+
+ /* APPLE LOCAL begin error-colon */
+ /* Here so it gets executed early on. */
+ {
+ static int done = 0;
+ if (!done)
+ {
+ done = 1; /* Do this only once. */
+ /* Pretend we saw "-w" on commandline. */
+ if (getenv ("GCC_DASH_W"))
+ inhibit_warnings = 1; /* referenced by diagnostic.h:diagnostic_report_warnings() */
+ if (getenv ("GCC_ERROR_COLON"))
+ gcc_error_colon = 1;
+ }
+ }
+ /* APPLE LOCAL end error-colon */
+
switch (kind)
{
default:
diff --git a/gcc/dmp-tree.c b/gcc/dmp-tree.c
new file mode 100644
index 00000000000..2d278da9bb7
--- /dev/null
+++ b/gcc/dmp-tree.c
@@ -0,0 +1,3695 @@
+/* APPLE LOCAL new tree dump */
+/* Common condensed tree display routines.
+ Copyright (C) 2001, 2002 Free Software Foundation, Inc.
+ Contributed by Ira L. Ruben (ira@apple.com)
+
+This file is part of GNU CC.
+
+GNU CC is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2, or (at your option)
+any later version.
+
+GNU CC is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+GNU General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with GNU CC; see the file COPYING. If not, write to
+the Free Software Foundation, 59 Temple Place - Suite 330,
+Boston, MA 02111-1307, USA. */
+
+/* This dumper is intended for used with the debugger. You call
+ dump_tree(x), where x is the node of interest. The tree display
+ produced here is much more condensed than what is produced by,
+ say, debug_tree(). Here each node is displayed as a single
+ (possibly line wrapped) line. The emphasis here is mainly on
+ the parse (front-end) trees as opposed to RTL-related info.
+
+ Here's an example of some of it's output:
+
+ compound_stmt:0xED4D0C line=74 0xED4D20
+ scope_stmt:0xED4D20 line=75 BEGIN block=0xED0300
+ block:0xED0300 vars=0xECD620 abs-orig=0x0 super=0xED0340 sub=0x0
+ var_decl:0xECD620 t=0xEA5310 {int} initial=0xED0260 line=75 comm
+ cntxt=0xECD3F0 sz=32(4) zzz
+ integer_cst:0xED0260 t=0xEA5310 {int} 0xFFFFFF9C = -100
+
+ decl_stmt:0xED4D84 line=75 var_decl=0xECD620 {int} zzz
+
+ expr_stmt:0xED4E24 line=76 0xED02E0
+ modify_expr:0xED02E0 t=0xEA5310 {int} 0xECD540 0xED4DFC
+ var_decl:0xECD540 t=0xEA5310 {int} cntxt=0xECD3F0 i
+ nop_expr:0xED4DFC t=0xEA5310 {int} 0xED02C0
+ plus_expr:0xED02C0 t=0xEA8540 {long unsigned int} 0xED4DE8 0xED02A0
+ nop_expr:0xED4DE8 t=0xEA8540 {long unsigned int} 0xED0280
+ trunc_div_expr:0xED0280 t=0xEA5310 {int} 0xECD540 0xECD620
+ var_decl:0xECD540 t=0xEA5310 {int} cntxt=0xECD3F0 i
+ var_decl:0xECD620 t=0xEA5310 {int} cntxt=0xECD3F0 zzz
+ call_expr:0xED02A0 t=0xEA8540 {long unsigned int} func=0xED4DAC args=0xED4DD4
+ addr_expr:0xED4DAC (func) t=0xECD690 {pointer_type} 0xEB0850
+ function_decl:0xEB0850 t=0xEABD90 {long unsigned int} BUILT_IN_NORMAL strlen
+ tree_list:0xED4DD4 (args) purpose=0x0 value=0xED4DC0 chain=0x0
+ nop_expr:0xED4DC0 (value) t=0xEAB1C0 {pointer_type} 0xECD4D0
+ var_decl:0xECD4D0 t=0xEA8CB0 {pointer_type} cntxt=0xECD3F0 lcl
+ scope_stmt:0xED4E38 line=77 END block=0xED0300
+
+ Each node is limited to a single line (unless it needs to be wrapped).
+ All nodes at the same nesting level are displayed at the same indenting
+ level. Each node is handled individually with code appropriate to what
+ it needs to display.
+
+ Note that unlike debug_tree() the details of the type info are not shown
+ in these trees when (as in this example) the initial node passed to
+ dmp_tree() is not a type. It is assumed that you are mainly interested
+ in the parse trees and their relationship to one another and don't need
+ the display cluttered up with each node's type info (other than it's
+ kind and address).
+
+ On the other hand you could be interested in the details of a particular
+ type. In that case call dmp_tree() specifying that type's address as
+ the initial node. When that is done a similarly formatted tree is
+ output, but now the details of that type and the types it uses are
+ shown. In the above example, 3 lines up from the bottom, there's a
+ pointer (which happens to be for a char*). Here's what
+ dmp_tree(0xEAB1C0) produces:
+
+ pointer_type:0xEAB1C0 t=0xEAB150 align=32 prec=32 sz=32(4)
+ integer_type:0xEAB150 uns const align=8 *this=0xEAB1C0 prec=8 sz=8(1)
+ min/max=0/255 char
+
+ Note, the type is fully followed (except for *this which is overkill).
+ Also illustrated is how lines are wrapped if too long for the display.
+ Here, it's illustrated assuming about a 72-character wrap point to
+ fit in these comments. In reality, the wrap point is normally the
+ terminal width. But the DMP_TREE_WRAP environment variable can be
+ set to the desired width. If neither the terminal width with nor the
+ environment variable can be accessed, or the value is outside the
+ range 72 to 512, the width is set to 130.
+
+ There are five language-specific routines that which MUST be uniquely
+ defined (via the language hooks) for that language to handle language-
+ specific attributes for certain kinds of tree nodes:
+
+ 1. void dump_identifier(FILE *file, tree node, int indent, int before_id);
+
+ Called twice for dmp_tree() for an IDENTIFIER_NODE. The first
+ call is after the common info for the node is generated but before
+ displaying the identifier (before_id==0) which is always assumed to
+ be the last thing on the line.
+
+ The second call is done after the id is displayed (before_id!=0).
+ This is for displaying any language-specific node information that
+ should be preceded by an newline_and_indent() call or a recursive
+ call to dump_tree() for nodes which are language specific operands
+ to a IDENTIFIER_NODE.
+
+ 2. void dump_decl(FILE *file, tree node, int indent, int before_id);
+
+ Called twice for dmp_tree() for a ..._DECL node. The first call
+ after the common info for the node is generated but before
+ displaying the identifier (before_id==0) which is always assumed
+ to be the last thing on the line.
+
+ The second call is done after the id is displayed (before_id!=0).
+ This is for displaying any language-specific node information that
+ should be preceded by an newline_and_indent() call or a recursive
+ call to dump_tree() for nodes which are language specific operands
+ to a ..._DECL node.
+
+ 3. void dump_type(FILE *file, tree node, int indent, int before_id);
+
+ Called twice for dmp_tree() for a ..._TYPE node. The first call
+ after the common info for the node is generated but before
+ displaying the identifier (before_id==0) which is always assumed
+ to be the last thing on the line.
+
+ The second call is done after the id is displayed (before_id!=0).
+ This is for displaying any language-specific node information that
+ should be preceded by an newline_and_indent() call or a recursive
+ call to dump_tree() for nodes which are language specific operands
+ to a ..._TYPE node.
+
+ 4. int dump_blank_line_p(tree previous_node, tree current_node);
+
+ Normally a blank line is inserted before each statement node (a
+ statement node is determined by calling statement_code_p()). This
+ makes the display easier to read by keeping each statement grouped
+ like a paragraph. There may, however, be some kinds of statements
+ where a blank line isn't desired (e.g., a begin SCOPE_STMT in C).
+ Thus dump_blank_line_p() is called to ask if a particular
+ statement should be preceded by a blank line dependent upon the
+ node that preceded it.
+
+ dump_blank_line_p() is called for each statement passing the
+ previous node (not necessarily a statement) and current node (a
+ statement node by definition). It should return 1 if a blank
+ line is to be inserted and 0 otherwise.
+
+ 5. int dump_lineno_p(FILE *file, tree node);
+
+ This is called for each node to display file and/or line number
+ information for those nodes that have such information. If it
+ is displayed the function should return 1. If not, 0.
+
+ The function generally does not have to handle ..._DECL nodes
+ unless there some special handling is reequired. They are
+ handled by print_lineno() (dump_lineno_p()'s caller).
+ It is defined to not repeat the filename if it does not
+ change from what's in dump_tree_state.curr_file and then
+ it only displays the basename (using lbasename()). The
+ format of the display is " line=nbr(basename)" where the
+ leading space is included as usual in these displays and
+ the parenthesized basename omitted if not needed or is
+ the same as before.
+*/
+
+#include "config.h"
+#include "system.h"
+#include "coretypes.h"
+#include "tree.h"
+#include "real.h"
+#include "c-common.h"
+#include <string.h>
+#include <ctype.h>
+#include <limits.h>
+#include "langhooks.h"
+
+/* c-common.h defines a macro called RETURN_EXPR. But we need to use it
+ as the enum defined by tree.def. */
+#undef RETURN_EXPR
+
+#define DMP_TREE
+#include "dmp-tree.h"
+
+#if defined(HAVE_UNISTD_H) && DMP_TREE_WRAPPED_OUTPUT
+#include <sys/ioctl.h>
+#endif
+
+#define MIN_LINE_WRAP 72 /* min wrapping column */
+#define MAX_LINE_WRAP 512 /* max wrapping column */
+#define DEFAULT_LINE_WRAP 130 /* default */
+#define DMP_TREE_LINE_WRAP "DMP_TREE_WRAP" /* environment variable */
+
+/* Notes to myself:
+
+ c-common.c, verify_tree(), c-decl.c, and cp/ptree.c look intersting!
+*/
+
+void dump_tree (FILE *file, const char *annotation, tree node, int indent);
+void dmp_tree (tree node);
+
+#define HASH_SIZE 37
+
+struct bucket
+{
+ tree node;
+ struct bucket *next;
+};
+
+static struct bucket **table;
+
+static tree *type_array = NULL;
+#define TYPE_ARRAY_INITIAL_SIZE 20000
+#define TYPE_ARRAY_INCR 10000
+static int type_array_size = 0;
+static int type_array_next = 0;
+static int type_array_incr = TYPE_ARRAY_INITIAL_SIZE;
+
+#if DMP_TREE_WRAPPED_OUTPUT
+static char curr_line[2 * MAX_LINE_WRAP];
+static int prefix_len;
+static int line_index;
+static int prev_line_was_null;
+static int prev_line_was_wrapped;
+static int wrap_column;
+#ifdef TIOCGWINSZ
+static struct winsize winsize;
+#endif
+#if defined(TIOCGSIZE) && !defined(TIOCGWINSZ)
+static struct ttysize winsize;
+#endif
+#endif /* DMP_TREE_WRAPPED_OUTPUT */
+
+dump_tree_state_t dump_tree_state = {
+ (int)LAST_AND_UNUSED_TREE_CODE, /* c */
+ -1, /* nesting_depth */
+ 0, /* dump_full_type */
+ 0, /* really_follow */
+ 0, /* doing_parm_decl */
+ 0, /* doing_call_expr */
+ NULL, /* curr_file */
+ 0, /* no_new_line */
+ 0, /* line_cnt */
+ 0, /* doing_tree_list */
+ INT_MAX, /* max_depth */
+ DMP_TREE_VISIT_ANY /* visit_only_once */
+};
+
+#define DEFTREECODE(SYM, NAME, TYPE, LENGTH) \
+static void print_ ## SYM (FILE *file, const char *annotation, tree node, int indent);
+#include "tree.def"
+#undef DEFTREECODE
+
+static void init_dump_state PARAMS ((tree node));
+static int no_dump_tree_p PARAMS ((FILE *file, const char *annotation, tree node, int indent));
+static void free_hash_table PARAMS ((void));
+
+static lang_dump_tree_p_t lang_dump_tree_p = no_dump_tree_p;
+
+#define CST_VALUE(node, ok) \
+ ((TREE_INT_CST_HIGH (node) == 0) \
+ ? (ok &= 1, TREE_INT_CST_LOW (node)) \
+ : ((TREE_INT_CST_HIGH (node) == -1 && TREE_INT_CST_LOW (node) != 0) \
+ ? (ok &= 1, -TREE_INT_CST_LOW (node)) \
+ : (ok = 0)))
+
+
+
+/*-------------------------------------------------------------------*/
+
+static void
+init_dump_state (node)
+ tree node;
+{
+ dump_tree_state.dump_full_type = TYPE_P (node);
+ /*dump_tree_state.nesting_depth = 0; */
+ dump_tree_state.really_follow = 1;
+ dump_tree_state.doing_parm_decl = 0;
+ dump_tree_state.doing_call_expr = 0;
+ dump_tree_state.no_new_line = 0;
+ dump_tree_state.line_cnt = 0;
+ dump_tree_state.curr_file = NULL;
+ dump_tree_state.doing_tree_list = 0;
+ /*dump_tree_state.max_depth = INT_MAX;*/
+ /*dump_tree_state.visit_only_once = DMP_TREE_VISIT_ANY;*/
+}
+
+/* Always end the current line by writing a '\n'.
+ If column > 0 then output column blanks to the next line.
+ Increment dump_tree_state.line_cnt to allow callers to
+ determine how many lines are output between any pair of
+ points. */
+
+void
+newline_and_indent (file, column)
+ FILE *file;
+ int column;
+{
+ fputc ('\n', file);
+ ++dump_tree_state.line_cnt;
+
+ if (column > 0)
+ fprintf (file, "%*c", column, ' ');
+}
+
+/* Return 1 if node has been previously seen and 0 otherwise.
+ If record_it is non-zero then record that the node was
+ seen. */
+int
+node_seen (node, record_it)
+ tree node;
+ int record_it;
+{
+ int hash;
+ struct bucket *b;
+
+ hash = ((unsigned long) node) % HASH_SIZE;
+
+ /* If node is in the table, just mention its address. */
+
+ for (b = table[hash]; b; b = b->next)
+ if (b->node == node)
+ return 1;
+
+ if (record_it)
+ {
+ b = (struct bucket *) xmalloc (sizeof (struct bucket));
+ b->node = node;
+ b->next = table[hash];
+ table[hash] = b;
+ }
+
+ return 0;
+}
+
+/* Free the hash table used to record visited nodes. */
+static void
+free_hash_table()
+{
+ int hash;
+ struct bucket *b, *next;
+
+ if (!table)
+ return;
+
+ for (hash = 0; hash < HASH_SIZE; ++hash)
+ {
+ b = table[hash];
+ while (b)
+ {
+ next = b->next;
+ free (b);
+ b = next;
+ }
+ }
+
+ free (table);
+ table = NULL;
+}
+
+
+/*-------------------------------------------------------------------*/
+
+void
+print_type (file, annotation, node, indent)
+ FILE *file;
+ const char *annotation ATTRIBUTE_UNUSED;
+ tree node;
+ int indent;
+{
+ int newline = 0;
+
+# define PRINT_TYPE_NAME(node) \
+ if (!newline && TYPE_NAME (node)) \
+ { \
+ if (TREE_CODE (TYPE_NAME (node)) == IDENTIFIER_NODE) \
+ fprintf (file, " %s", IDENTIFIER_POINTER (TYPE_NAME (node))); \
+ else if (TREE_CODE (TYPE_NAME (node)) == TYPE_DECL \
+ && DECL_NAME (TYPE_NAME (node))) \
+ fprintf (file, " %s", \
+ IDENTIFIER_POINTER (DECL_NAME (TYPE_NAME (node)))); \
+ newline = 1; \
+ }
+
+ if (TYPE_CONTEXT (node))
+ {
+ fprintf (file, " cntxt=");
+ fprintf (file, HOST_PTR_PRINTF,
+ HOST_PTR_PRINTF_VALUE (TYPE_CONTEXT (node)));
+ }
+
+ if (TYPE_NEEDS_CONSTRUCTING (node))
+ fputs (" need-ctor", file);
+ if (TYPE_PACKED (node))
+ fputs (" packed", file);
+ if (TREE_THIS_VOLATILE (node))
+ fputs (" volatile", file);
+ if (TYPE_READONLY (node))
+ fputs (" const", file);
+ if (TYPE_RESTRICT (node))
+ fputs (" restrict", file);
+
+ if (TYPE_LANG_FLAG_0 (node)
+ || TYPE_LANG_FLAG_1 (node)
+ || TYPE_LANG_FLAG_2 (node)
+ || TYPE_LANG_FLAG_3 (node)
+ || TYPE_LANG_FLAG_4 (node)
+ || TYPE_LANG_FLAG_5 (node)
+ || TYPE_LANG_FLAG_6 (node))
+ {
+ fputs (" type-flags=#", file);
+ if (TYPE_LANG_FLAG_0 (node))
+ fputc ('0', file);
+ if (TYPE_LANG_FLAG_1 (node))
+ fputc ('1', file);
+ if (TYPE_LANG_FLAG_2 (node))
+ fputc ('2', file);
+ if (TYPE_LANG_FLAG_3 (node))
+ fputc ('3', file);
+ if (TYPE_LANG_FLAG_4 (node))
+ fputc ('4', file);
+ if (TYPE_LANG_FLAG_5 (node))
+ fputc ('5', file);
+ if (TYPE_LANG_FLAG_6 (node))
+ fputc ('6', file);
+ }
+
+ if (TYPE_USER_ALIGN (node))
+ fprintf (file, " usr-algn");
+
+ fprintf (file, " align=%d", TYPE_ALIGN (node));
+
+ if (TYPE_SYMTAB_ADDRESS (node))
+ fprintf (file, " symtab=%d", TYPE_SYMTAB_ADDRESS (node));
+
+ if (TYPE_ALIAS_SET (node) != -1)
+ {
+ fprintf (file, " alias-set=");
+ fprintf (file, HOST_WIDE_INT_PRINT_DEC, TYPE_ALIAS_SET (node));
+ }
+
+ if (TYPE_POINTER_TO (node))
+ {
+ fprintf (file, " *this=");
+ fprintf (file, HOST_PTR_PRINTF,
+ HOST_PTR_PRINTF_VALUE (TYPE_POINTER_TO (node)));
+ }
+
+ if (TYPE_REFERENCE_TO (node))
+ {
+ fprintf (file, " &this=");
+ fprintf (file, HOST_PTR_PRINTF,
+ HOST_PTR_PRINTF_VALUE (TYPE_REFERENCE_TO (node)));
+ }
+
+ if (TREE_CODE (node) == ARRAY_TYPE || TREE_CODE (node) == SET_TYPE)
+ {
+ if (TYPE_DOMAIN (node))
+ {
+ fprintf (file, " domain=");
+ fprintf (file, HOST_PTR_PRINTF,
+ HOST_PTR_PRINTF_VALUE (TYPE_DOMAIN (node)));
+ }
+ }
+ else if (TREE_CODE (node) == ENUMERAL_TYPE)
+ {
+ if (TYPE_VALUES (node))
+ {
+ fprintf (file, " values=");
+ fprintf (file, HOST_PTR_PRINTF,
+ HOST_PTR_PRINTF_VALUE (TYPE_VALUES (node)));
+ }
+ }
+ else if (TREE_CODE (node) == VECTOR_TYPE)
+ {
+ if (TYPE_DEBUG_REPRESENTATION_TYPE (node))
+ {
+ fprintf (file, " values=");
+ fprintf (file, HOST_PTR_PRINTF,
+ HOST_PTR_PRINTF_VALUE (TYPE_DEBUG_REPRESENTATION_TYPE (node)));
+ }
+ }
+
+ if (TYPE_ATTRIBUTES (node))
+ {
+ fprintf (file, " attr=");
+ fprintf (file, HOST_PTR_PRINTF,
+ HOST_PTR_PRINTF_VALUE (TYPE_ATTRIBUTES (node)));
+ }
+
+ if (TYPE_PRECISION (node))
+ fprintf (file, " prec=%d", TYPE_PRECISION (node));
+
+ if (TYPE_MAIN_VARIANT (node) != node)
+ {
+ fprintf (file, " main-variant=");
+ fprintf (file, HOST_PTR_PRINTF,
+ HOST_PTR_PRINTF_VALUE (TYPE_MAIN_VARIANT (node)));
+ }
+ if (TYPE_NEXT_VARIANT (node))
+ {
+ fprintf (file, " next-variant=");
+ fprintf (file, HOST_PTR_PRINTF,
+ HOST_PTR_PRINTF_VALUE (TYPE_NEXT_VARIANT (node)));
+ }
+
+ if (TYPE_NAME (node) && TREE_CODE (TYPE_NAME (node)) == TYPE_DECL
+ && DECL_ORIGINAL_TYPE (TYPE_NAME (node)))
+ {
+ fprintf (file, " orig-type=");
+ fprintf (file, HOST_PTR_PRINTF,
+ HOST_PTR_PRINTF_VALUE (DECL_ORIGINAL_TYPE (TYPE_NAME (node))));
+ }
+
+ (void)node_seen (node, TRUE); /* prevent recursion on this node */
+
+ (*lang_hooks.dump_type) (file, node, indent, 0);
+
+ if (TYPE_SIZE (node)
+ && TREE_CODE (TYPE_SIZE (node)) == INTEGER_CST
+ && TYPE_SIZE_UNIT (node)
+ && TREE_CODE (TYPE_SIZE_UNIT (node)) == INTEGER_CST)
+ {
+ fputs (" sz=", file);
+ print_integer_constant (file, TYPE_SIZE (node), 0);
+ fputs ("(", file);
+ print_integer_constant (file, TYPE_SIZE_UNIT (node), 0);
+ fputs (")", file);
+ }
+ else
+ {
+ PRINT_TYPE_NAME(node);
+ dump_tree (file, "(size)", TYPE_SIZE (node), indent + INDENT);
+ dump_tree (file, "(unit size)", TYPE_SIZE_UNIT (node), indent + INDENT);
+ }
+
+ if (INTEGRAL_TYPE_P (node))
+ {
+ if (!newline &&
+ TREE_CODE (TYPE_MIN_VALUE (node)) == INTEGER_CST
+ && TREE_CODE (TYPE_MAX_VALUE (node)) == INTEGER_CST)
+ {
+ fputs (" min/max=", file);
+ print_integer_constant (file, TYPE_MIN_VALUE (node), 0);
+ fputc ('/', file);
+ print_integer_constant (file, TYPE_MAX_VALUE (node), 0);
+ }
+ else
+ {
+ PRINT_TYPE_NAME(node);
+ dump_tree (file, "(min)", TYPE_MIN_VALUE (node), indent + INDENT);
+ dump_tree (file, "(max)", TYPE_MAX_VALUE (node), indent + INDENT);
+ }
+ }
+
+ PRINT_TYPE_NAME(node);
+
+ if (TYPE_ATTRIBUTES (node))
+ dump_tree (file, NULL, TYPE_ATTRIBUTES (node), indent + INDENT);
+
+ (*lang_hooks.dump_type) (file, node, indent, 1);
+
+ if (TREE_CODE (node) == ARRAY_TYPE || TREE_CODE (node) == SET_TYPE)
+ {
+ if (TYPE_DOMAIN (node))
+ dump_tree (file, "(domain)", TYPE_DOMAIN (node), indent + INDENT);
+ }
+ else if (TREE_CODE (node) == ENUMERAL_TYPE)
+ {
+ if (TYPE_VALUES (node))
+ dump_tree (file, "(values)", TYPE_VALUES (node), indent + INDENT);
+ }
+
+#if 0
+ if (TYPE_MAIN_VARIANT (node) == node)
+ {
+ tree n = TYPE_MAIN_VARIANT (node);
+ dump_tree (file, "(main-variant)", n, indent + INDENT);
+ for (n = TYPE_NEXT_VARIANT (n); n; n = TYPE_NEXT_VARIANT (n))
+ dump_tree (file, "(next-variant)", n, indent + INDENT);
+ }
+#endif
+
+#if 0
+ if (TYPE_POINTER_TO (node))
+ dump_tree (file, "(ptr-to-this)", TYPE_POINTER_TO (node), indent + INDENT);
+
+ if (TYPE_REFERENCE_TO (node))
+ dump_tree (file, "(ref-to-this)", TYPE_REFERENCE_TO (node), indent + INDENT);
+#endif
+
+ if (TREE_TYPE (node))
+ dump_tree (file, NULL, TREE_TYPE (node), indent + INDENT);
+
+ /* I THINK SOME BINFO-RELATED MACROS NEED TO BE INVESTIGATED AND PUT HERE... */
+}
+
+void
+print_decl (file, annotation, node, indent)
+ FILE *file;
+ const char *annotation ATTRIBUTE_UNUSED;
+ tree node;
+ int indent ATTRIBUTE_UNUSED;
+{
+ int newline = 0;
+
+ if (!node_seen (node, FALSE))
+ {
+ if (TREE_SIDE_EFFECTS (node) || TREE_THIS_VOLATILE (node))
+ fputs (" volatile", file);
+ if (DECL_IGNORED_P (node))
+ fputs (" ignored", file);
+ if (DECL_ABSTRACT (node))
+ fputs (" abst", file);
+ if (DECL_IN_SYSTEM_HEADER (node))
+ fputs (" in-sys-hdr", file);
+ if (DECL_COMMON (node))
+ fputs (" comm", file);
+ if (DECL_NONLOCAL (node))
+ fputs (" nonlcl", file);
+#if 0
+ if (DECL_ARTIFICIAL (node))
+ fputs (" artifical", file);
+#endif
+ if (DECL_WEAK (node))
+ fputs (" weak", file);
+ /* APPLE LOCAL coalescing */
+ if (DECL_COALESCED (node))
+ fputs (" coal", file);
+ /* APPLE LOCAL begin weak_import (Radar 2809704) ilr */
+ if (DECL_WEAK_IMPORT (node))
+ fputs (" weak_import", file);
+ /* APPLE LOCAL end weak_import ilr */
+
+ if (DECL_LANG_FLAG_0 (node)
+ || DECL_LANG_FLAG_1 (node)
+ || DECL_LANG_FLAG_2 (node)
+ || DECL_LANG_FLAG_3 (node)
+ || DECL_LANG_FLAG_4 (node)
+ || DECL_LANG_FLAG_5 (node)
+ || DECL_LANG_FLAG_6 (node)
+ || DECL_LANG_FLAG_7 (node))
+ {
+ fputs (" lang-flags=#", file);
+ if (DECL_LANG_FLAG_0 (node))
+ fputc ('0', file);
+ if (DECL_LANG_FLAG_1 (node))
+ fputc ('1', file);
+ if (DECL_LANG_FLAG_2 (node))
+ fputc ('2', file);
+ if (DECL_LANG_FLAG_3 (node))
+ fputc ('3', file);
+ if (DECL_LANG_FLAG_4 (node))
+ fputc ('4', file);
+ if (DECL_LANG_FLAG_5 (node))
+ fputc ('5', file);
+ if (DECL_LANG_FLAG_6 (node))
+ fputc ('6', file);
+ if (DECL_LANG_FLAG_7 (node))
+ fputc ('7', file);
+ }
+ }
+
+ if (DECL_ATTRIBUTES (node))
+ {
+ fprintf (file, " attr=");
+ fprintf (file, HOST_PTR_PRINTF,
+ HOST_PTR_PRINTF_VALUE (DECL_ATTRIBUTES (node)));
+ }
+
+ if (DECL_CONTEXT (node))
+ {
+ fprintf (file, " cntxt=");
+ fprintf (file, HOST_PTR_PRINTF,
+ HOST_PTR_PRINTF_VALUE (DECL_CONTEXT (node)));
+ }
+
+ if (DECL_RTL_SET_P (node))
+ {
+ fprintf (file, " rtl=");
+ fprintf (file, HOST_PTR_PRINTF,
+ HOST_PTR_PRINTF_VALUE (DECL_RTL (node)));
+ }
+
+ (*lang_hooks.dump_decl) (file, node, indent, 0);
+
+ if (!node_seen (node, TRUE)) /* mark ..._DECL node seen b4 recursing */
+ {
+ if (TREE_CODE (node) == FIELD_DECL)
+ {
+ if (DECL_BIT_FIELD_TYPE (node))
+ {
+ tree bf_type = DECL_BIT_FIELD_TYPE (node);
+ fprintf (file, " bf-type=");
+ fprintf (file, HOST_PTR_PRINTF,
+ HOST_PTR_PRINTF_VALUE (bf_type));
+ if (TYPE_NAME (bf_type))
+ {
+ if (TREE_CODE (TYPE_NAME (bf_type)) == IDENTIFIER_NODE)
+ {
+ if (IDENTIFIER_POINTER (TYPE_NAME (bf_type))
+ && *IDENTIFIER_POINTER (TYPE_NAME (bf_type)))
+ fprintf (file, " {%s}", IDENTIFIER_POINTER (TYPE_NAME (bf_type)));
+ }
+ else if (TREE_CODE (TYPE_NAME (bf_type)) == TYPE_DECL
+ && DECL_NAME (TYPE_NAME (bf_type))
+ && IDENTIFIER_POINTER (DECL_NAME (TYPE_NAME (bf_type)))
+ && *IDENTIFIER_POINTER (DECL_NAME (TYPE_NAME (bf_type))))
+ fprintf (file, " {%s}",
+ IDENTIFIER_POINTER (DECL_NAME (TYPE_NAME (bf_type))));
+ }
+ else
+ fprintf (file, " {%s}", tree_code_name[(int)TREE_CODE (bf_type)]);
+ }
+
+ if (DECL_FIELD_OFFSET (node) && DECL_FIELD_BIT_OFFSET (node))
+ {
+ if (TREE_CODE (DECL_FIELD_OFFSET (node)) == INTEGER_CST
+ && TREE_CODE (DECL_FIELD_BIT_OFFSET (node)) == INTEGER_CST)
+ {
+ fputs (" off=", file);
+ print_integer_constant (file, DECL_FIELD_BIT_OFFSET (node), 0);
+ fputs ("(", file);
+ print_integer_constant (file, DECL_FIELD_OFFSET (node), 0);
+ fputs (")", file);
+ }
+ else
+ {
+ if (DECL_NAME (node))
+ fprintf (file, " %s", IDENTIFIER_POINTER (DECL_NAME (node)));
+ dump_tree (file, "(offset)", DECL_FIELD_OFFSET (node),
+ indent + INDENT);
+ dump_tree (file, "(bit offset)", DECL_FIELD_BIT_OFFSET (node),
+ indent + INDENT);
+ newline = 1;
+ }
+ }
+ else
+ {
+ if (DECL_FIELD_OFFSET (node))
+ {
+ if (TREE_CODE (DECL_FIELD_OFFSET (node)) == INTEGER_CST)
+ {
+ fputs (" off=", file);
+ print_integer_constant (file, DECL_FIELD_BIT_OFFSET (node), 0);
+ }
+ else
+ {
+ if (DECL_NAME (node))
+ fprintf (file, " %s", IDENTIFIER_POINTER (DECL_NAME (node)));
+ dump_tree (file, "(offset)", DECL_FIELD_OFFSET (node),
+ indent + INDENT);
+ newline = 1;
+ }
+ }
+ if (DECL_FIELD_BIT_OFFSET (node))
+ {
+ if (!newline
+ && TREE_CODE (DECL_FIELD_BIT_OFFSET (node)) == INTEGER_CST)
+ {
+ fputs (" bit-off=", file);
+ print_integer_constant (file, DECL_FIELD_BIT_OFFSET (node), 0);
+ }
+ else
+ {
+ if (!newline && DECL_NAME (node))
+ fprintf (file, " %s", IDENTIFIER_POINTER (DECL_NAME (node)));
+ dump_tree (file, "(bit offset)", DECL_FIELD_BIT_OFFSET (node),
+ indent + INDENT);
+ newline = 1;
+ }
+ }
+ }
+ }
+
+ if (!newline && DECL_SIZE (node) && DECL_SIZE_UNIT (node)
+ && TREE_CODE (DECL_SIZE (node)) == INTEGER_CST
+ && TREE_CODE (DECL_SIZE_UNIT (node)) == INTEGER_CST)
+ {
+ fputs (" sz=", file);
+ print_integer_constant (file, DECL_SIZE (node), 0);
+ fputs ("(", file);
+ print_integer_constant (file, DECL_SIZE_UNIT (node), 0);
+ fputs (")", file);
+ }
+ else
+ {
+ if (!newline && DECL_NAME (node))
+ fprintf (file, " %s", IDENTIFIER_POINTER (DECL_NAME (node)));
+ newline = 1;
+ dump_tree (file, "(size)", DECL_SIZE (node), indent + INDENT);
+ dump_tree (file, "(unit size)", DECL_SIZE_UNIT (node), indent + INDENT);
+ }
+ }
+
+ if (!newline && DECL_NAME (node))
+ fprintf (file, " %s", IDENTIFIER_POINTER (DECL_NAME (node)));
+
+ (*lang_hooks.dump_decl) (file, node, indent, 1);
+}
+
+void
+print_ref (file, annotation, node, indent)
+ FILE *file;
+ const char *annotation ATTRIBUTE_UNUSED;
+ tree node;
+ int indent ATTRIBUTE_UNUSED;
+{
+ if (TREE_THIS_VOLATILE (node))
+ fputs (" volatile", file);
+ if (TREE_READONLY (node))
+ fputs (" readonly", file);
+}
+
+#define MAX_COMMENT 50
+
+/* The "..." arguments are a list of zero or more strings with a NULL
+ as the last list item. They are used to annotate each respective
+ operand. The annotation convention is that if an string is not
+ enclosed in parentheses it will annotation it's operand display. If
+ it is enclosed in parentheses it will be appended to the kind:address
+ display. Examples:
+
+ annotation kind:address ....
+ or
+ kind:address (annotation) ....
+*/
+
+void
+print_operands VPARAMS ((FILE *file, tree node, int indent, int follow, ...))
+{
+#ifndef ANSI_PROTOTYPES
+ FILE *file;
+ tree node;
+ int indent, follow;
+#endif
+ int i, first_rtl, len, len1, nomore, maxlen;
+ va_list ap;
+ char *s, temp[MAX_COMMENT + 2];
+
+ VA_START (ap, follow);
+#ifndef ANSI_PROTOTYPES
+ file = va_arg (ap, FILE *);
+ node = va_arg (ap, tree);
+ indent = va_arg (ap, int);
+ follow = va_arg (ap, int);
+#endif
+
+ len = TREE_CODE_LENGTH (TREE_CODE (node));
+ first_rtl = first_rtl_op (TREE_CODE (node));
+
+ for (i = nomore = maxlen = 0; i < len && i < first_rtl; ++i)
+ {
+ s = nomore ? NULL : va_arg (ap, char *);
+ if (s == NULL)
+ {
+ nomore = 1;
+ fprintf (file, " ");
+ fprintf (file, HOST_PTR_PRINTF,
+ HOST_PTR_PRINTF_VALUE (TREE_OPERAND (node, i)));
+ }
+ else
+ {
+ if (s[0] != '(')
+ {
+ len1 = strlen (s);
+ if (len1 > maxlen)
+ maxlen = len1;
+ }
+ else
+ {
+ s = strcpy (temp, ++s);
+ temp[strlen (temp) - 1] = '\0';
+ }
+ fprintf (file, " %s=", s);
+ fprintf (file, HOST_PTR_PRINTF,
+ HOST_PTR_PRINTF_VALUE (TREE_OPERAND (node, i)));
+ }
+ }
+
+ va_end (ap);
+
+ if (first_rtl < len)
+ {
+ for (i = first_rtl; i < len; ++i)
+ if (TREE_OPERAND (node, i))
+ break;
+ if (i < len)
+ {
+ fputs (" [rtl=", file);
+ for (i = first_rtl; i < len; ++i)
+ {
+ if (i > first_rtl)
+ fputc (',', file);
+ fprintf (file, HOST_PTR_PRINTF,
+ HOST_PTR_PRINTF_VALUE (TREE_OPERAND (node, i)));
+ }
+ fputc (']', file);
+ }
+ }
+
+ if (follow && dump_tree_state.really_follow)
+ {
+ maxlen = MIN (maxlen, MAX_COMMENT);
+ temp[maxlen] = '\0';
+
+ /* Reusing the arg list -- does this work when !ANSI_PROTOTYPES? */
+ VA_START (ap, follow);
+# ifndef ANSI_PROTOTYPES
+ file = va_arg (ap, FILE *);
+ node = va_arg (ap, tree);
+ indent = va_arg (ap, int);
+# endif
+
+ for (i = nomore = 0; i < len && i < first_rtl; ++i)
+ {
+ s = nomore ? NULL : va_arg (ap, char *);
+ if (s == NULL)
+ {
+ nomore = 1;
+ if (maxlen > 0)
+ s = memset(temp, ' ', maxlen);
+ }
+ else if (s[0] != '(')
+ {
+ len = strlen (s);
+ if (maxlen < len)
+ len = maxlen;
+ if (len < maxlen)
+ {
+ memset(temp, ' ', maxlen);
+ s = memcpy(temp + maxlen - len - 1, s, len);
+ }
+ }
+ dump_tree (file, s, TREE_OPERAND (node, i), indent + INDENT);
+ }
+
+ va_end (ap);
+ }
+}
+
+void
+print_lineno (file, node)
+ FILE *file;
+ tree node;
+{
+ if (!(*lang_hooks.dump_lineno_p) (file, node)
+ && TREE_CODE_CLASS (TREE_CODE (node)) == 'd')
+ {
+ if (TREE_CODE (node) != FUNCTION_DECL || !DECL_BUILT_IN (node))
+ {
+ if (dump_tree_state.curr_file
+ && strcmp(dump_tree_state.curr_file, DECL_SOURCE_FILE (node)) == 0)
+ fprintf (file, " line=%d", DECL_SOURCE_LINE (node));
+ else
+ {
+ dump_tree_state.curr_file = (char *)DECL_SOURCE_FILE (node);
+ fprintf (file, " line=%d(%s)", DECL_SOURCE_LINE (node),
+ lbasename(DECL_SOURCE_FILE (node)));
+ }
+ }
+ }
+}
+
+void
+print_integer_constant (file, node, hex)
+ FILE *file;
+ tree node;
+ int hex;
+{
+ int ok = 1;
+ tree type = TREE_TYPE (node);
+ int size;
+
+ size = (TREE_CODE_CLASS (TREE_CODE (type)) == 't') ?
+ CST_VALUE (TYPE_SIZE_UNIT (type), ok)
+ : 4; /*CST_VALUE (type,ok);*/
+ if (!ok)
+ size = 4;
+
+ if (hex)
+ {
+ if (TREE_INT_CST_HIGH (node) == 0
+ || (TREE_INT_CST_HIGH (node) == -1 && TREE_INT_CST_LOW (node) != 0))
+ {
+ if (size == 1)
+ fprintf (file, "0x%.2lX = ", (unsigned long)(TREE_INT_CST_LOW (node) & 0xFF));
+ else if (size == 2)
+ fprintf (file, "0x%.4lX = ", (unsigned long)(TREE_INT_CST_LOW (node) & 0xFFFF));
+ else if (size == 4)
+ fprintf (file, "0x%.8lX = ", (unsigned long)TREE_INT_CST_LOW (node));
+ else
+ fprintf (file, HOST_WIDE_INT_PRINT_DOUBLE_HEX,
+ TREE_INT_CST_HIGH (node), TREE_INT_CST_LOW (node));
+ }
+ }
+
+ if (TREE_INT_CST_HIGH (node) == 0)
+ fprintf (file, HOST_WIDE_INT_PRINT_UNSIGNED, TREE_INT_CST_LOW (node));
+ else if (TREE_INT_CST_HIGH (node) == -1 && TREE_INT_CST_LOW (node) != 0)
+ {
+ fputs ("-", file);
+ fprintf (file, HOST_WIDE_INT_PRINT_UNSIGNED, -TREE_INT_CST_LOW (node));
+ }
+ else
+ fprintf (file, HOST_WIDE_INT_PRINT_DOUBLE_HEX,
+ TREE_INT_CST_HIGH (node), TREE_INT_CST_LOW (node));
+}
+
+void
+print_real_constant (file, node)
+ FILE *file;
+ tree node;
+{
+ char string[100];
+ real_to_decimal (string, &TREE_REAL_CST (node), sizeof (string), 0, 1);
+ fputs (string, file);
+}
+
+void
+print_string_constant (file, str, maxlen)
+ FILE *file;
+ const char *str;
+ int maxlen;
+{
+ char c, buf[1024+12+1], *s;
+ int i = 0, len;
+
+ if (!str)
+ {
+ fputs ("(null)", file);
+ return;
+ }
+
+ /* Buffer string so that we write it with a single fputs(). This is
+ required for our line wrapping code to know when it is "inside"
+ a string. */
+
+ len = strlen (str);
+ if (len > 1021)
+ len = 1021;
+
+ s = buf;
+ *s++ = '"';
+
+ while ((c = *str++) != '\0')
+ {
+ if (c == '\b') {
+ *s++ = '\\'; *s++ = 'b'; i += 2;
+ } else if (c == '\f') {
+ *s++ = '\\'; *s++ = 'f'; i += 2;
+ } else if (c == '\v') {
+ *s++ = '\\'; *s++ = 'v'; i += 2;
+ } else if (c == '\r') {
+ *s++ = '\\'; *s++ = 'r'; i += 2;
+ } else if (c == '\n') {
+ *s++ = '\\'; *s++ = 'n'; i += 2;
+ } else if (c == '\t') {
+ *s++ = '\\'; *s++ = 't'; i += 2;
+ } else if (!isprint (c)) {
+ s += sprintf (s, "\\%03o", c); i += 4;
+ } else {
+ *s++ = c; ++i;
+ }
+ if (i > maxlen && len > maxlen + 12)
+ {
+ strcpy (s, "...(more)...");
+ break;
+ }
+ }
+ *s++ = '"';
+ *s = '\0';
+ fputs (buf, file);
+}
+
+void
+print_tree_flags (file, node)
+ FILE *file;
+ tree node;
+{
+ if (TREE_SIDE_EFFECTS (node))
+ fputs ("side-effects", file);
+ if (TREE_CONSTANT (node))
+ fputs (" const", file);
+ if (TREE_ADDRESSABLE (node))
+ fputs (" addressable", file);
+ if (TREE_THIS_VOLATILE (node))
+ fputs (" volatile", file);
+ if (TREE_READONLY (node))
+ fputs (" readonly", file);
+ if (TREE_UNSIGNED (node))
+ fputs (" uns", file);
+ if (TREE_ASM_WRITTEN (node))
+ fputs (" asm-written", file);
+ if (TREE_USED (node))
+ fputs (" used", file);
+ if (TREE_NOTHROW (node))
+ fputs (" nothrow", file);
+ if (TREE_STATIC (node))
+ fputs (" static", file);
+ if (TREE_PUBLIC (node))
+ fputs (" public", file);
+ if (TREE_PRIVATE (node))
+ fputs (" private", file);
+ if (TREE_PROTECTED (node))
+ fputs (" protected", file);
+ if (TREE_BOUNDED (node))
+ fputs (" bounded", file);
+ if (TREE_DEPRECATED (node))
+ fputs (" deprecated", file);
+ /* APPLE LOCAL begin unavailable (Radar 2809697) ilr */
+ if (TREE_UNAVAILABLE (node))
+ fputs (" unavailable", file);
+ /* APPLE LOCAL end unavailable ilr */
+
+ if (TREE_LANG_FLAG_0 (node)
+ || TREE_LANG_FLAG_1 (node)
+ || TREE_LANG_FLAG_2 (node)
+ || TREE_LANG_FLAG_3 (node)
+ || TREE_LANG_FLAG_4 (node)
+ || TREE_LANG_FLAG_5 (node)
+ || TREE_LANG_FLAG_6 (node))
+ {
+ fputs (" tree-flags=#", file);
+ if (TREE_LANG_FLAG_0 (node))
+ fputc ('0', file);
+ if (TREE_LANG_FLAG_1 (node))
+ fputc ('1', file);
+ if (TREE_LANG_FLAG_2 (node))
+ fputc ('2', file);
+ if (TREE_LANG_FLAG_3 (node))
+ fputc ('3', file);
+ if (TREE_LANG_FLAG_4 (node))
+ fputc ('4', file);
+ if (TREE_LANG_FLAG_5 (node))
+ fputc ('5', file);
+ if (TREE_LANG_FLAG_6 (node))
+ fputc ('6', file);
+ }
+}
+
+/*-------------------------------------------------------------------*/
+
+/* Just in case print anything set in the common part of this node. */
+
+static void
+print_ERROR_MARK (file, annotation, node, indent)
+ FILE *file;
+ const char *annotation ATTRIBUTE_UNUSED;
+ tree node;
+ int indent ATTRIBUTE_UNUSED;
+{
+ if (TREE_CHAIN (node))
+ {
+ fprintf (file, " chain=");
+ fprintf (file, HOST_PTR_PRINTF,
+ HOST_PTR_PRINTF_VALUE (TREE_CHAIN (node)));
+ }
+ if (TREE_TYPE (node))
+ {
+ fprintf (file, " type=");
+ fprintf (file, HOST_PTR_PRINTF,
+ HOST_PTR_PRINTF_VALUE (TREE_TYPE (node)));
+ }
+ print_tree_flags (file, node);
+}
+
+static void
+print_IDENTIFIER_NODE (file, annotation, node, indent)
+ FILE *file;
+ const char *annotation ATTRIBUTE_UNUSED;
+ tree node;
+ int indent;
+{
+ if (TREE_PUBLIC (node))
+ fputs (" public", file);
+ if (TREE_ADDRESSABLE (node))
+ fputs (" addressable", file);
+
+ (*lang_hooks.dump_identifier) (file, node, indent, 0);
+ fprintf (file, " len=%d %s",
+ IDENTIFIER_LENGTH (node), IDENTIFIER_POINTER (node));
+ (*lang_hooks.dump_identifier) (file, node, indent, 1);
+}
+
+static void
+print_TREE_LIST (file, annotation, node, indent)
+ FILE *file;
+ const char *annotation;
+ tree node;
+ int indent;
+{
+ if (TREE_VIA_VIRTUAL (node))
+ fputs (" via-virt", file);
+ if (TREE_VIA_PUBLIC (node))
+ fputs (" via-public", file);
+ if (TREE_VIA_PRIVATE (node))
+ fputs (" via-private", file);
+ if (TREE_VIA_PROTECTED (node))
+ fputs (" via-protected", file);
+ fprintf (file, " purpose=");
+ fprintf (file, HOST_PTR_PRINTF, HOST_PTR_PRINTF_VALUE (TREE_PURPOSE (node)));
+ fprintf (file, " value=");
+ fprintf (file, HOST_PTR_PRINTF, HOST_PTR_PRINTF_VALUE (TREE_VALUE (node)));
+ fprintf (file, " chain=");
+ fprintf (file, HOST_PTR_PRINTF, HOST_PTR_PRINTF_VALUE (TREE_CHAIN (node)));
+
+ ++dump_tree_state.doing_tree_list;
+ (void)node_seen (node, TRUE);
+
+ dump_tree (file, "(purpose)", TREE_PURPOSE (node), indent + INDENT);
+ dump_tree (file, "(value)", TREE_VALUE (node), indent + INDENT);
+
+ for (node = TREE_CHAIN (node); node; node = TREE_CHAIN (node))
+ dump_tree (file, annotation, node, indent + 0); /* keep list at same indent */
+
+ --dump_tree_state.doing_tree_list;
+}
+
+static void
+print_TREE_VEC (file, annotation, node, indent)
+ FILE *file;
+ const char *annotation ATTRIBUTE_UNUSED;
+ tree node;
+ int indent;
+{
+ int i, skip_line, len = TREE_VEC_LENGTH (node);
+
+ if (TREE_VIA_VIRTUAL (node))
+ fputs (" via-virt", file);
+ if (TREE_VIA_PUBLIC (node))
+ fputs (" via-public", file);
+ if (TREE_VIA_PRIVATE (node))
+ fputs (" via-private", file);
+ if (TREE_VIA_PROTECTED (node))
+ fputs (" via-protected", file);
+
+ fprintf (file, " len=%d", len);
+
+ for (i = skip_line = 0; i < len; ++i)
+ if (TREE_VEC_ELT (node, i))
+ {
+ char temp[MAX_COMMENT + 20];
+
+ if (skip_line)
+ newline_and_indent (file, 0);
+ skip_line = 1;
+ if (annotation)
+ {
+ temp[0] = '(';
+ if (annotation[0] == '(')
+ {
+ strcpy (temp+1, annotation+1);
+ temp[strlen (temp) - 1] = '\0';
+ }
+ else
+ strcpy (temp+1, annotation);
+ sprintf (temp + strlen (temp), ":%i)", i);
+ }
+ else
+ sprintf (temp, "(%i)", i);
+ dump_tree (file, temp, TREE_VEC_ELT (node, i), indent + INDENT);
+ }
+
+ if (len > 1 && indent > 1)
+ newline_and_indent (file, 0);
+}
+
+static void
+print_BLOCK (file, annotation, node, indent)
+ FILE *file;
+ const char *annotation ATTRIBUTE_UNUSED;
+ tree node;
+ int indent ATTRIBUTE_UNUSED;
+{
+ tree n;
+
+ fprintf (file, " vars=");
+ fprintf (file, HOST_PTR_PRINTF, HOST_PTR_PRINTF_VALUE (BLOCK_VARS (node)));
+ fprintf (file, " abs-orig=");
+ fprintf (file, HOST_PTR_PRINTF, HOST_PTR_PRINTF_VALUE (BLOCK_ABSTRACT_ORIGIN (node)));
+ fprintf (file, " super=");
+ fprintf (file, HOST_PTR_PRINTF, HOST_PTR_PRINTF_VALUE (BLOCK_SUPERCONTEXT (node)));
+ fprintf (file, " sub=");
+ fprintf (file, HOST_PTR_PRINTF, HOST_PTR_PRINTF_VALUE (BLOCK_SUBBLOCKS (node)));
+ fprintf (file, " frag-origin=");
+ fprintf (file, HOST_PTR_PRINTF, HOST_PTR_PRINTF_VALUE (BLOCK_FRAGMENT_ORIGIN (node)));
+ fprintf (file, " frag-chain=");
+ fprintf (file, HOST_PTR_PRINTF, HOST_PTR_PRINTF_VALUE (BLOCK_FRAGMENT_CHAIN (node)));
+
+ if (BLOCK_HANDLER_BLOCK (node))
+ fputs (" handler_block_flag", file);
+ if (BLOCK_ABSTRACT (node))
+ fputs (" abstract_flag", file);
+
+ for (n = BLOCK_VARS (node); n; n = TREE_CHAIN (n))
+ if (!node_seen (n, FALSE))
+ dump_tree (file, NULL, n, indent + INDENT);
+
+#if 0
+ for (n = BLOCK_SUBBLOCKS (node); n; n = BLOCK_CHAIN (n))
+ if (!node_seen (n))
+ dump_tree (file, NULL, n, indent + INDENT);
+#endif
+
+ /*dump_tree (file, NULL, BLOCK_SUPERCONTEXT (node), indent + INDENT);*/
+
+ if (!node_seen (BLOCK_ABSTRACT_ORIGIN (node), FALSE))
+ dump_tree (file, NULL, BLOCK_ABSTRACT_ORIGIN (node), indent + INDENT);
+}
+
+static void
+print_VOID_TYPE (file, annotation, node, indent)
+ FILE *file;
+ const char *annotation;
+ tree node;
+ int indent;
+{
+ print_type (file, annotation, node, indent);
+}
+
+static void
+print_INTEGER_TYPE (file, annotation, node, indent)
+ FILE *file;
+ const char *annotation;
+ tree node;
+ int indent;
+{
+ if (TYPE_IS_SIZETYPE (node))
+ fputs (" sizetype", file);
+ if (TREE_UNSIGNED (node))
+ fputs (" uns", file);
+
+ print_type (file, annotation, node, indent);
+}
+
+static void
+print_REAL_TYPE (file, annotation, node, indent)
+ FILE *file;
+ const char *annotation;
+ tree node;
+ int indent;
+{
+ print_type (file, annotation, node, indent);
+}
+
+static void
+print_COMPLEX_TYPE (file, annotation, node, indent)
+ FILE *file;
+ const char *annotation;
+ tree node;
+ int indent;
+{
+ print_type (file, annotation, node, indent);
+}
+
+static void
+print_VECTOR_TYPE (file, annotation, node, indent)
+ FILE *file;
+ const char *annotation;
+ tree node;
+ int indent;
+{
+ print_type (file, annotation, node, indent);
+}
+
+static void
+print_ENUMERAL_TYPE (file, annotation, node, indent)
+ FILE *file;
+ const char *annotation;
+ tree node;
+ int indent;
+{
+ if (TREE_UNSIGNED (node))
+ fputs (" uns", file);
+
+ print_type (file, annotation, node, indent);
+}
+
+static void
+print_BOOLEAN_TYPE (file, annotation, node, indent)
+ FILE *file;
+ const char *annotation;
+ tree node;
+ int indent;
+{
+ print_type (file, annotation, node, indent);
+}
+
+static void
+print_CHAR_TYPE (file, annotation, node, indent)
+ FILE *file;
+ const char *annotation;
+ tree node;
+ int indent;
+{
+ print_type (file, annotation, node, indent);
+}
+
+static void
+print_POINTER_TYPE (file, annotation, node, indent)
+ FILE *file;
+ const char *annotation;
+ tree node;
+ int indent;
+{
+ print_type (file, annotation, node, indent);
+}
+
+static void
+print_OFFSET_TYPE (file, annotation, node, indent)
+ FILE *file;
+ const char *annotation;
+ tree node;
+ int indent;
+{
+ fprintf (file, " basetype=");
+ fprintf (file, HOST_PTR_PRINTF,
+ HOST_PTR_PRINTF_VALUE (TYPE_OFFSET_BASETYPE (node)));
+
+ print_type (file, annotation, node, indent);
+}
+
+static void
+print_REFERENCE_TYPE (file, annotation, node, indent)
+ FILE *file;
+ const char *annotation;
+ tree node;
+ int indent;
+{
+ print_type (file, annotation, node, indent);
+}
+
+static void
+print_METHOD_TYPE (file, annotation, node, indent)
+ FILE *file;
+ const char *annotation;
+ tree node;
+ int indent;
+{
+ tree n;
+
+ if (TYPE_METHOD_BASETYPE (node))
+ {
+ fprintf (file, " basetype=");
+ fprintf (file, HOST_PTR_PRINTF,
+ HOST_PTR_PRINTF_VALUE (TYPE_METHOD_BASETYPE (node)));
+ }
+ fprintf (file, " args=");
+ fprintf (file, HOST_PTR_PRINTF,
+ HOST_PTR_PRINTF_VALUE (TYPE_ARG_TYPES (node)));
+
+ print_type (file, annotation, node, indent);
+
+ for (n = TYPE_ARG_TYPES (node); n; n = TREE_CHAIN (n))
+ dump_tree (file, "(args)", n, indent + INDENT);
+}
+
+static void
+print_FILE_TYPE (file, annotation, node, indent)
+ FILE *file;
+ const char *annotation;
+ tree node;
+ int indent;
+{
+ print_type (file, annotation, node, indent);
+}
+
+static void
+print_ARRAY_TYPE (file, annotation, node, indent)
+ FILE *file;
+ const char *annotation;
+ tree node;
+ int indent;
+{
+ if (TYPE_STRING_FLAG (node))
+ fputs (" string-flag", file);
+ if (TYPE_NONALIASED_COMPONENT (node))
+ fputs (" nonaliased-component", file);
+
+ print_type (file, annotation, node, indent);
+}
+
+static void
+print_SET_TYPE (file, annotation, node, indent)
+ FILE *file;
+ const char *annotation;
+ tree node;
+ int indent;
+{
+ if (TYPE_STRING_FLAG (node))
+ fputs (" string-flag", file);
+
+ print_type (file, annotation, node, indent);
+}
+
+static void
+print_RECORD_TYPE (file, annotation, node, indent)
+ FILE *file;
+ const char *annotation;
+ tree node;
+ int indent;
+{
+ tree n;
+
+ if (TYPE_NO_FORCE_BLK (node))
+ fputs (" no-force-blk", file);
+ fprintf (file, " fields=");
+ fprintf (file, HOST_PTR_PRINTF,
+ HOST_PTR_PRINTF_VALUE (TYPE_FIELDS (node)));
+
+ print_type (file, annotation, node, indent);
+ (void)node_seen (node, TRUE);
+
+ for (n = TYPE_FIELDS (node); n; n = TREE_CHAIN (n))
+ dump_tree (file, NULL, n, indent + INDENT);
+}
+
+static void
+print_UNION_TYPE (file, annotation, node, indent)
+ FILE *file;
+ const char *annotation;
+ tree node;
+ int indent;
+{
+ if (TYPE_NO_FORCE_BLK (node))
+ fputs (" no-force-blk", file);
+ if (TYPE_TRANSPARENT_UNION (node))
+ fputs (" transparent-union", file);
+ fprintf (file, " fields=");
+ fprintf (file, HOST_PTR_PRINTF,
+ HOST_PTR_PRINTF_VALUE (TYPE_FIELDS (node)));
+
+ print_type (file, annotation, node, indent);
+ (void)node_seen (node, TRUE);
+
+ for (node = TYPE_FIELDS (node); node; node = TREE_CHAIN (node))
+ dump_tree (file, NULL, node, indent + INDENT);
+}
+
+static void
+print_QUAL_UNION_TYPE (file, annotation, node, indent)
+ FILE *file;
+ const char *annotation;
+ tree node;
+ int indent;
+{
+ if (TYPE_NO_FORCE_BLK (node))
+ fputs (" no-force-blk", file);
+ fprintf (file, " fields=");
+ fprintf (file, HOST_PTR_PRINTF,
+ HOST_PTR_PRINTF_VALUE (TYPE_FIELDS (node)));
+
+ print_type (file, annotation, node, indent);
+ (void)node_seen (node, TRUE);
+
+ for (node = TYPE_FIELDS (node); node; node = TREE_CHAIN (node))
+ dump_tree (file, NULL, node, indent + INDENT);
+}
+
+static void
+print_FUNCTION_TYPE (file, annotation, node, indent)
+ FILE *file;
+ const char *annotation;
+ tree node;
+ int indent;
+{
+ tree n;
+
+ if (TYPE_METHOD_BASETYPE (node))
+ {
+ fprintf (file, " basetype=");
+ fprintf (file, HOST_PTR_PRINTF,
+ HOST_PTR_PRINTF_VALUE (TYPE_METHOD_BASETYPE (node)));
+ }
+
+ if (TYPE_RETURNS_STACK_DEPRESSED (node))
+ fputs (" ret-stk-depressed", file);
+ if (TYPE_AMBIENT_BOUNDEDNESS (node))
+ fputs (" ambient-boundedness", file);
+ fprintf (file, " args=");
+ fprintf (file, HOST_PTR_PRINTF,
+ HOST_PTR_PRINTF_VALUE (TYPE_ARG_TYPES (node)));
+
+ print_type (file, annotation, node, indent);
+ (void)node_seen (node, TRUE);
+
+ for (n = TYPE_ARG_TYPES (node); n; n = TREE_CHAIN (n))
+ dump_tree (file, "(args)", n, indent + INDENT);
+}
+
+static void
+print_LANG_TYPE (file, annotation, node, indent)
+ FILE *file;
+ const char *annotation;
+ tree node;
+ int indent;
+{
+ print_type (file, annotation, node, indent);
+}
+
+static void
+print_INTEGER_CST (file, annotation, node, indent)
+ FILE *file;
+ const char *annotation ATTRIBUTE_UNUSED;
+ tree node;
+ int indent ATTRIBUTE_UNUSED;
+{
+ print_tree_flags (file, node);
+ fputc (' ', file);
+ print_integer_constant (file, node, 1);
+}
+
+static void
+print_REAL_CST (file, annotation, node, indent)
+ FILE *file;
+ const char *annotation ATTRIBUTE_UNUSED;
+ tree node;
+ int indent ATTRIBUTE_UNUSED;
+{
+ print_tree_flags (file, node);
+ fputc (' ', file);
+ print_real_constant (file, node);
+}
+
+static void
+print_COMPLEX_CST (file, annotation, node, indent)
+ FILE *file ATTRIBUTE_UNUSED;
+ const char *annotation ATTRIBUTE_UNUSED;
+ tree node;
+ int indent;
+{
+ print_tree_flags (file, node);
+ fprintf (file, " real=");
+ fprintf (file, HOST_PTR_PRINTF, HOST_PTR_PRINTF_VALUE (TREE_REALPART (node)));
+ fprintf (file, " imag=");
+ fprintf (file, HOST_PTR_PRINTF, HOST_PTR_PRINTF_VALUE (TREE_IMAGPART (node)));
+
+ dump_tree (file, "(real)", TREE_REALPART (node), indent + INDENT);
+ dump_tree (file, "(imag)", TREE_IMAGPART (node), indent + INDENT);
+}
+
+static void
+print_VECTOR_CST (file, annotation, node, indent)
+ FILE *file;
+ const char *annotation ATTRIBUTE_UNUSED;
+ tree node;
+ int indent;
+{
+ tree n, type = TREE_TYPE (node);
+ tree t1 = NULL;
+ int i, ok, size = 0;
+ int ok2 = 0;
+ char *fmt = (char *)"this is just to stop compiler warning";
+
+ union {
+ unsigned char uc[16];
+ unsigned short us[8];
+ unsigned long ul[4];
+ } vec_value;
+
+ print_tree_flags (file, node);
+
+ ok = (type && TREE_CODE (type) == VECTOR_TYPE);
+ if (ok)
+ {
+ type = TREE_TYPE (type);
+ n = TYPE_SIZE_UNIT (type);
+ size = CST_VALUE (n, ok);
+ t1 = TREE_VECTOR_CST_ELTS (node);
+
+ if (TREE_CODE (type) == INTEGER_TYPE
+ && (size == 1 || size == 2 || size == 4))
+ {
+ fmt = (char *) (TREE_UNSIGNED (type) ? "%u%s" : "%d%s");
+ if (TREE_CODE (TREE_VALUE (t1)) == INTEGER_CST)
+ {
+ vec_value.ul[0] = CST_VALUE (TREE_VALUE (t1), ok);
+ vec_value.ul[1] = CST_VALUE (TREE_VALUE (TREE_CHAIN (t1)), ok);
+ vec_value.ul[2] = CST_VALUE (TREE_VALUE (TREE_CHAIN (TREE_CHAIN (t1))), ok);
+ vec_value.ul[3] = CST_VALUE (TREE_VALUE (TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (t1)))), ok);
+ }
+ ok2 = ok;
+ }
+ else if (TREE_CODE (type) != REAL_TYPE
+ || TREE_CODE (TREE_VALUE (t1)) != REAL_CST
+ || size != 4)
+ ok2 = 0;
+ else
+ ok2 = ok;
+ }
+
+ if (ok2)
+ {
+ fprintf (file, " ");
+ fprintf (file, HOST_PTR_PRINTF, HOST_PTR_PRINTF_VALUE(TREE_VALUE (t1)));
+ fprintf (file, " ");
+ fprintf (file, HOST_PTR_PRINTF, HOST_PTR_PRINTF_VALUE(TREE_VALUE (TREE_CHAIN (t1))));
+ fprintf (file, " ");
+ fprintf (file, HOST_PTR_PRINTF,
+ HOST_PTR_PRINTF_VALUE(TREE_VALUE (TREE_CHAIN (TREE_CHAIN (t1)))));
+ fprintf (file, " ");
+ fprintf (file, HOST_PTR_PRINTF,
+ HOST_PTR_PRINTF_VALUE(TREE_VALUE (TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (t1))))));
+ newline_and_indent (file, indent + INDENT);
+ fputc ('(', file);
+
+ switch (size)
+ {
+ case 1:
+ for (i = 0; i < 16; ++i)
+ fprintf (file, fmt, vec_value.uc[i], (i < 15) ? "," : "");
+ break;
+
+ case 2:
+ for (i = 0; i < 8; ++i)
+ fprintf (file, fmt, vec_value.us[i], (i < 7) ? "," : "");
+ break;
+
+ case 4:
+ if (TREE_CODE (type) != REAL_TYPE)
+ for (i = 0; i < 4; ++i)
+ fprintf (file, fmt, vec_value.ul[i], (i < 3) ? "," : "");
+ else
+ {
+ print_real_constant (file, TREE_VALUE (t1));
+ fputc (',', file);
+ print_real_constant (file, TREE_VALUE (TREE_CHAIN (t1)));
+ fputc (',', file);
+ print_real_constant (file, TREE_VALUE (TREE_CHAIN (TREE_CHAIN (t1))));
+ fputc (',', file);
+ print_real_constant (file, TREE_VALUE (TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (t1)))));
+ }
+ break;
+ }
+
+ fputc (')', file);
+ }
+ else
+ {
+ dump_tree (file, NULL, TREE_VALUE (t1), indent + INDENT);
+ dump_tree (file, NULL, TREE_VALUE (TREE_CHAIN (t1)), indent + INDENT);
+ dump_tree (file, NULL, TREE_VALUE (TREE_CHAIN (TREE_CHAIN (t1))), indent + INDENT);
+ dump_tree (file, NULL, TREE_VALUE (TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (t1)))), indent + INDENT);
+ }
+}
+
+static void
+print_STRING_CST (file, annotation, node, indent)
+ FILE *file ATTRIBUTE_UNUSED;
+ const char *annotation ATTRIBUTE_UNUSED;
+ tree node ATTRIBUTE_UNUSED;
+ int indent ATTRIBUTE_UNUSED;
+{
+ print_tree_flags (file, node);
+ fprintf (file, " ptr=");
+ fprintf (file, HOST_PTR_PRINTF,
+ HOST_PTR_PRINTF_VALUE (TREE_STRING_POINTER (node)));
+ fprintf (file, " ");
+ print_string_constant (file, (char *)TREE_STRING_POINTER (node), 30);
+
+ if (TREE_CHAIN (node))
+ {
+ fprintf (file, " chain=");
+ fprintf (file, HOST_PTR_PRINTF,
+ HOST_PTR_PRINTF_VALUE (TREE_CHAIN (node)));
+
+ for (node = TREE_CHAIN (node); node; node = TREE_CHAIN (node))
+ dump_tree (file, NULL, node, indent + INDENT);
+ }
+}
+
+static void
+print_FUNCTION_DECL (file, annotation, node, indent)
+ FILE *file;
+ const char *annotation;
+ tree node;
+ int indent;
+{
+ tree n;
+
+ if (DECL_BUILT_IN (node))
+ {
+ if (DECL_BUILT_IN_CLASS (node) == BUILT_IN_MD)
+ fprintf (file, " BUILT_IN_MD %d", DECL_FUNCTION_CODE (node));
+ else
+ fprintf (file, " %s",
+ built_in_class_names[(int) DECL_BUILT_IN_CLASS (node)]);
+ }
+
+ if (DECL_BUILT_IN_NONANSI (node))
+ fputs (" builtin-nonansi", file);
+
+ if (dump_tree_state.doing_call_expr)
+ {
+ print_decl (file, annotation, node, indent);
+ return;
+ }
+
+ if (DECL_EXTERNAL (node))
+ fputs (" ext", file);
+ if (TREE_PUBLIC (node))
+ fputs (" pub", file);
+ if (TREE_PRIVATE (node))
+ fputs (" pvt", file);
+ if (TREE_PROTECTED (node))
+ fputs (" prot", file);
+#if 0
+ if (TREE_STATIC (node))
+ fputs (" def", file);
+ if (TREE_ADDRESSABLE (node))
+ fputs (" addrsable", file);
+#endif
+ if (TREE_ASM_WRITTEN (node))
+ fputs (" asm-wrtn", file);
+ if (TREE_NOTHROW (node))
+ fputs (" nothr", file);
+
+ if (DECL_INLINE (node))
+ fputs (" inline", file);
+ if (DECL_NO_STATIC_CHAIN (node))
+ fputs (" no-static-chain", file);
+ if (DECL_VIRTUAL_P (node))
+ fputs (" virt", file);
+ if (DECL_STATIC_CONSTRUCTOR (node))
+ fputs (" static-ctor", file);
+ if (DECL_STATIC_DESTRUCTOR (node))
+ fputs (" static-dtor", file);
+
+ if (DECL_INITIAL (node))
+ {
+ fprintf (file, " initial=");
+ fprintf (file, HOST_PTR_PRINTF,
+ HOST_PTR_PRINTF_VALUE (DECL_INITIAL (node)));
+ }
+
+ if (DECL_SAVED_INSNS (node))
+ {
+ fprintf (file, " saved-insns=");
+ fprintf (file, HOST_PTR_PRINTF,
+ HOST_PTR_PRINTF_VALUE (DECL_SAVED_INSNS (node)));
+ }
+
+ if (!DECL_EXTERNAL (node))
+ {
+ fprintf (file, " ");
+ fprintf (file, HOST_PTR_PRINTF, HOST_PTR_PRINTF_VALUE (DECL_RESULT (node)));
+ fprintf (file, "(");
+ fprintf (file, HOST_PTR_PRINTF, HOST_PTR_PRINTF_VALUE (DECL_ARGUMENTS (node)));
+ fprintf (file, "){");
+ fprintf (file, HOST_PTR_PRINTF,
+ HOST_PTR_PRINTF_VALUE (DECL_LANG_SPECIFIC(node)
+ ? DECL_SAVED_TREE (node) : 0));
+ fprintf (file, "}");
+ }
+ print_decl (file, annotation, node, indent);
+
+ /*if (DECL_LANG_SPECIFIC(node) && DECL_SAVED_TREE (node)) ?? */
+ if (DECL_RESULT (node))
+ dump_tree (file, NULL, DECL_RESULT (node), indent + INDENT);
+
+ dump_tree_state.doing_parm_decl = 1;
+ for (n = DECL_ARGUMENTS (node); n; n = TREE_CHAIN (n))
+ dump_tree (file, NULL, n, indent + INDENT);
+ dump_tree_state.doing_parm_decl = 0;
+
+ if (DECL_LANG_SPECIFIC(node)) /* saftey test, used by DECL_SAVED_TREE */
+ for (n = DECL_SAVED_TREE (node); n; n = TREE_CHAIN (n))
+ {
+ if (n == DECL_SAVED_TREE (node)
+ && TREE_CODE (n) == EXPR_STMT
+ && EXPR_STMT_EXPR (n) == void_zero_node)
+ {
+ dump_tree_state.really_follow = 0;
+ dump_tree (file, "(dummy, to be deleted)", n, indent + INDENT);
+ dump_tree_state.really_follow = 1;
+ }
+ else
+ dump_tree (file, NULL, n, indent + INDENT);
+ }
+
+ /* FIXME: DECL_VINDEX ?? */
+}
+
+static void
+print_LABEL_DECL (file, annotation, node, indent)
+ FILE *file;
+ const char *annotation;
+ tree node;
+ int indent;
+{
+ if (TREE_ADDRESSABLE (node))
+ fputs (" seen", file);
+ if (DECL_TOO_LATE (node))
+ fputs (" too-late", file);
+ if (DECL_ERROR_ISSUED (node))
+ fputs (" error-issued", file);
+ print_decl (file, annotation, node, indent);
+}
+
+static void
+print_CONST_DECL (file, annotation, node, indent)
+ FILE *file;
+ const char *annotation;
+ tree node;
+ int indent;
+{
+ print_decl (file, annotation, node, indent);
+}
+
+static void
+print_TYPE_DECL (file, annotation, node, indent)
+ FILE *file;
+ const char *annotation;
+ tree node;
+ int indent;
+{
+ if (DECL_ORIGINAL_TYPE (node))
+ {
+ fprintf (file, " orig_type=");
+ fprintf (file, HOST_PTR_PRINTF,
+ HOST_PTR_PRINTF_VALUE (DECL_ORIGINAL_TYPE (node)));
+ }
+ if (TYPE_DECL_SUPPRESS_DEBUG (node))
+ fputs (" suppress-debug", file);
+ print_decl (file, annotation, node, indent);
+}
+
+static void
+print_VAR_DECL (file, annotation, node, indent)
+ FILE *file;
+ const char *annotation;
+ tree node;
+ int indent;
+{
+ if (node_seen (node, FALSE))
+ {
+ print_decl (file, annotation, node, indent);
+ return;
+ }
+
+ if (TREE_CODE (node) == VAR_DECL && TREE_STATIC (node))
+ fputs (" static", file);
+ if (TREE_PUBLIC (node))
+ fputs (" pub", file);
+ if (DECL_EXTERNAL (node))
+ fputs (" ext", file);
+ if (DECL_REGISTER (node))
+ fputs (" regdcl", file);
+ if (TREE_CODE (node) == VAR_DECL && DECL_IN_TEXT_SECTION (node))
+ fputs (" in-txt-sect", file);
+ if (DECL_VIRTUAL_P (node))
+ fputs (" virt", file);
+ if (DECL_POINTER_ALIAS_SET_KNOWN_P (node))
+ {
+ fputs (" alias-set=", file);
+ fprintf (file, HOST_WIDE_INT_PRINT_DEC,
+ DECL_POINTER_ALIAS_SET (node));
+ }
+
+ if (TREE_CODE (node) == PARM_DECL && DECL_TRANSPARENT_UNION (node))
+ fputs (" transp-union", file);
+
+ if (TREE_CODE (node) != PARM_DECL)
+ {
+ fprintf (file, " initial=");
+ fprintf (file, HOST_PTR_PRINTF,
+ HOST_PTR_PRINTF_VALUE (DECL_INITIAL (node)));
+ print_decl (file, annotation, node, indent);
+ dump_tree (file, NULL, DECL_INITIAL (node), indent + INDENT);
+ }
+ else
+ print_decl (file, annotation, node, indent);
+}
+
+static void
+print_PARM_DECL (file, annotation, node, indent)
+ FILE *file;
+ const char *annotation;
+ tree node;
+ int indent;
+{
+ if (dump_tree_state.doing_parm_decl)
+ {
+ if (DECL_ARG_TYPE (node))
+ {
+ fprintf (file, " arg-type=");
+ fprintf (file, HOST_PTR_PRINTF,
+ HOST_PTR_PRINTF_VALUE (DECL_ARG_TYPE (node)));
+ }
+ if (DECL_ARG_TYPE_AS_WRITTEN (node))
+ {
+ fprintf (file, " as-written=");
+ fprintf (file, HOST_PTR_PRINTF,
+ HOST_PTR_PRINTF_VALUE (DECL_ARG_TYPE_AS_WRITTEN (node)));
+ }
+ if (DECL_INCOMING_RTL (node))
+ {
+ fprintf (file, " incoming-rtl=");
+ fprintf (file, HOST_PTR_PRINTF,
+ HOST_PTR_PRINTF_VALUE (DECL_INCOMING_RTL (node)));
+ }
+ }
+ print_VAR_DECL (file, annotation, node, indent);
+}
+
+static void
+print_RESULT_DECL (file, annotation, node, indent)
+ FILE *file;
+ const char *annotation;
+ tree node;
+ int indent;
+{
+ print_decl (file, annotation, node, indent);
+}
+
+static void
+print_FIELD_DECL (file, annotation, node, indent)
+ FILE *file;
+ const char *annotation;
+ tree node;
+ int indent;
+{
+ if (node_seen (node, FALSE))
+ {
+ print_decl (file, annotation, node, indent);
+ return;
+ }
+
+ if (TREE_ADDRESSABLE (node))
+ fputs (" addressable", file);
+ if (TREE_READONLY (node))
+ fputs (" readonly", file);
+
+ if (DECL_VIRTUAL_P (node))
+ fputs (" virt", file);
+ if (DECL_PACKED (node))
+ fputs (" packed", file);
+ if (TREE_UNSIGNED (node))
+ fputs (" uns", file);
+ if (DECL_BIT_FIELD (node))
+ fputs (" bitfield", file);
+ if (DECL_NONADDRESSABLE_P (node))
+ fputs (" nonaddr", file);
+ fprintf (file, " off-align=");
+ fprintf (file, HOST_WIDE_INT_PRINT_UNSIGNED,
+ DECL_OFFSET_ALIGN (node));
+ print_decl (file, annotation, node, indent);
+}
+
+static void
+print_NAMESPACE_DECL (file, annotation, node, indent)
+ FILE *file;
+ const char *annotation;
+ tree node;
+ int indent;
+{
+ print_decl (file, annotation, node, indent);
+}
+
+static void
+print_COMPONENT_REF (file, annotation, node, indent)
+ FILE *file;
+ const char *annotation;
+ tree node;
+ int indent;
+{
+ print_ref (file, annotation, node, indent);
+ print_operands (file, node, indent, TRUE, "(struct/union)", "(field)", NULL);
+}
+
+static void
+print_BIT_FIELD_REF (file, annotation, node, indent)
+ FILE *file;
+ const char *annotation;
+ tree node;
+ int indent;
+{
+ print_ref (file, annotation, node, indent);
+ print_operands (file, node, indent, TRUE, "(struct/union)", "(#bits)", "(pos)", NULL);
+}
+
+static void
+print_INDIRECT_REF (file, annotation, node, indent)
+ FILE *file;
+ const char *annotation;
+ tree node;
+ int indent;
+{
+ print_ref (file, annotation, node, indent);
+ print_operands (file, node, indent, TRUE, NULL);
+}
+
+static void
+print_BUFFER_REF (file, annotation, node, indent)
+ FILE *file;
+ const char *annotation;
+ tree node;
+ int indent;
+{
+ print_ref (file, annotation, node, indent);
+ print_operands (file, node, indent, TRUE, NULL);
+}
+
+static void
+print_ARRAY_REF (file, annotation, node, indent)
+ FILE *file;
+ const char *annotation;
+ tree node;
+ int indent;
+{
+ print_ref (file, annotation, node, indent);
+ print_operands (file, node, indent, TRUE, "(base)", "(index)", NULL);
+}
+
+static void
+print_ARRAY_RANGE_REF (file, annotation, node, indent)
+ FILE *file;
+ const char *annotation;
+ tree node;
+ int indent;
+{
+ print_ref (file, annotation, node, indent);
+ print_operands (file, node, indent, TRUE, "(base)", "(index)", NULL);
+}
+
+static void
+print_VTABLE_REF (file, annotation, node, indent)
+ FILE *file;
+ const char *annotation;
+ tree node;
+ int indent;
+{
+ print_ref (file, annotation, node, indent);
+ print_operands (file, node, indent, TRUE, "(base)", "(index)", NULL);
+}
+
+static void
+print_CONSTRUCTOR (file, annotation, node, indent)
+ FILE *file;
+ const char *annotation ATTRIBUTE_UNUSED;
+ tree node;
+ int indent;
+{
+ if (TREE_ADDRESSABLE (node))
+ fputs (" must-be-in-mem", file);
+ if (TREE_STATIC (node))
+ fputs (" static", file);
+ if (TREE_CONSTANT (node))
+ fputs (" const", file);
+ if (TREE_BOUNDED (node))
+ fputs (" bounded", file);
+
+ print_operands (file, node, indent, FALSE, NULL);
+
+ for (node = CONSTRUCTOR_ELTS (node); node; node = TREE_CHAIN (node))
+ dump_tree (file, NULL, node, indent + INDENT);
+}
+
+static void
+print_COMPOUND_EXPR (file, annotation, node, indent)
+ FILE *file;
+ const char *annotation ATTRIBUTE_UNUSED;
+ tree node;
+ int indent;
+{
+ if (TREE_NO_UNUSED_WARNING (node))
+ fputs (" no-unused", file);
+
+ print_operands (file, node, indent, TRUE, NULL);
+}
+
+static void
+print_MODIFY_EXPR (file, annotation, node, indent)
+ FILE *file;
+ const char *annotation ATTRIBUTE_UNUSED;
+ tree node;
+ int indent;
+{
+ print_operands (file, node, indent, TRUE, NULL);
+}
+
+static void
+print_INIT_EXPR (file, annotation, node, indent)
+ FILE *file;
+ const char *annotation ATTRIBUTE_UNUSED;
+ tree node;
+ int indent;
+{
+ print_operands (file, node, indent, TRUE, NULL);
+}
+
+static void
+print_TARGET_EXPR (file, annotation, node, indent)
+ FILE *file;
+ const char *annotation ATTRIBUTE_UNUSED;
+ tree node;
+ int indent;
+{
+ print_operands (file, node, indent, TRUE, "(target)", "(init)",
+ "(cleanup)", "(saved-init)", NULL);
+}
+
+static void
+print_COND_EXPR (file, annotation, node, indent)
+ FILE *file;
+ const char *annotation ATTRIBUTE_UNUSED;
+ tree node;
+ int indent;
+{
+ print_operands (file, node, indent, TRUE, "(cond)", "(?)", "(:)", NULL);
+}
+
+static void
+print_BIND_EXPR (file, annotation, node, indent)
+ FILE *file;
+ const char *annotation ATTRIBUTE_UNUSED;
+ tree node;
+ int indent;
+{
+ print_operands (file, node, indent, TRUE, "(vars)", "(body)", "(block)", NULL);
+}
+
+static void
+print_CALL_EXPR (file, annotation, node, indent)
+ FILE *file;
+ const char *annotation ATTRIBUTE_UNUSED;
+ tree node;
+ int indent;
+{
+ if (TREE_NOTHROW (node))
+ fputs (" nothrow", file);
+
+ dump_tree_state.doing_call_expr = 1;
+ print_operands (file, node, indent, TRUE, "(func)", "(args)", NULL);
+ dump_tree_state.doing_call_expr = 0;
+}
+
+static void
+print_METHOD_CALL_EXPR (file, annotation, node, indent)
+ FILE *file;
+ const char *annotation ATTRIBUTE_UNUSED;
+ tree node;
+ int indent;
+{
+ print_operands (file, node, indent, TRUE, "(self)", "(args)", NULL);
+}
+
+static void
+print_WITH_CLEANUP_EXPR (file, annotation, node, indent)
+ FILE *file;
+ const char *annotation ATTRIBUTE_UNUSED;
+ tree node;
+ int indent;
+{
+ print_operands (file, node, indent, TRUE, NULL);
+}
+
+static void
+print_CLEANUP_POINT_EXPR (file, annotation, node, indent)
+ FILE *file;
+ const char *annotation ATTRIBUTE_UNUSED;
+ tree node;
+ int indent;
+{
+ print_operands (file, node, indent, TRUE, NULL);
+}
+
+static void
+print_PLACEHOLDER_EXPR (file, annotation, node, indent)
+ FILE *file ATTRIBUTE_UNUSED;
+ const char *annotation ATTRIBUTE_UNUSED;
+ tree node ATTRIBUTE_UNUSED;
+ int indent ATTRIBUTE_UNUSED;
+{
+ /*print_operands (file, node, indent, FALSE, NULL);*/
+ /* this is an 'x' node, not an expr node */
+}
+
+static void
+print_WITH_RECORD_EXPR (file, annotation, node, indent)
+ FILE *file;
+ const char *annotation ATTRIBUTE_UNUSED;
+ tree node;
+ int indent;
+{
+ print_operands (file, node, indent, TRUE, NULL);
+}
+
+static void
+print_PLUS_EXPR (file, annotation, node, indent)
+ FILE *file;
+ const char *annotation ATTRIBUTE_UNUSED;
+ tree node;
+ int indent;
+{
+ print_operands (file, node, indent, TRUE, NULL);
+}
+
+static void
+print_MINUS_EXPR (file, annotation, node, indent)
+ FILE *file;
+ const char *annotation ATTRIBUTE_UNUSED;
+ tree node;
+ int indent;
+{
+ print_operands (file, node, indent, TRUE, NULL);
+}
+
+static void
+print_MULT_EXPR (file, annotation, node, indent)
+ FILE *file;
+ const char *annotation ATTRIBUTE_UNUSED;
+ tree node;
+ int indent;
+{
+ print_operands (file, node, indent, TRUE, NULL);
+}
+
+static void
+print_TRUNC_DIV_EXPR (file, annotation, node, indent)
+ FILE *file;
+ const char *annotation ATTRIBUTE_UNUSED;
+ tree node;
+ int indent;
+{
+ print_operands (file, node, indent, TRUE, NULL);
+}
+
+static void
+print_CEIL_DIV_EXPR (file, annotation, node, indent)
+ FILE *file;
+ const char *annotation ATTRIBUTE_UNUSED;
+ tree node;
+ int indent;
+{
+ print_operands (file, node, indent, TRUE, NULL);
+}
+
+static void
+print_FLOOR_DIV_EXPR (file, annotation, node, indent)
+ FILE *file;
+ const char *annotation ATTRIBUTE_UNUSED;
+ tree node;
+ int indent;
+{
+ print_operands (file, node, indent, TRUE, NULL);
+}
+
+static void
+print_ROUND_DIV_EXPR (file, annotation, node, indent)
+ FILE *file;
+ const char *annotation ATTRIBUTE_UNUSED;
+ tree node;
+ int indent;
+{
+ print_operands (file, node, indent, TRUE, NULL);
+}
+
+static void
+print_TRUNC_MOD_EXPR (file, annotation, node, indent)
+ FILE *file;
+ const char *annotation ATTRIBUTE_UNUSED;
+ tree node;
+ int indent;
+{
+ print_operands (file, node, indent, TRUE, NULL);
+}
+
+static void
+print_CEIL_MOD_EXPR (file, annotation, node, indent)
+ FILE *file;
+ const char *annotation ATTRIBUTE_UNUSED;
+ tree node;
+ int indent;
+{
+ print_operands (file, node, indent, TRUE, NULL);
+}
+
+static void
+print_FLOOR_MOD_EXPR (file, annotation, node, indent)
+ FILE *file;
+ const char *annotation ATTRIBUTE_UNUSED;
+ tree node;
+ int indent;
+{
+ print_operands (file, node, indent, TRUE, NULL);
+}
+
+static void
+print_ROUND_MOD_EXPR (file, annotation, node, indent)
+ FILE *file;
+ const char *annotation ATTRIBUTE_UNUSED;
+ tree node;
+ int indent;
+{
+ print_operands (file, node, indent, TRUE, NULL);
+}
+
+static void
+print_RDIV_EXPR (file, annotation, node, indent)
+ FILE *file;
+ const char *annotation ATTRIBUTE_UNUSED;
+ tree node;
+ int indent;
+{
+ print_operands (file, node, indent, TRUE, NULL);
+}
+
+static void
+print_EXACT_DIV_EXPR (file, annotation, node, indent)
+ FILE *file;
+ const char *annotation ATTRIBUTE_UNUSED;
+ tree node;
+ int indent;
+{
+ print_operands (file, node, indent, TRUE, NULL);
+}
+
+static void
+print_FIX_TRUNC_EXPR (file, annotation, node, indent)
+ FILE *file;
+ const char *annotation ATTRIBUTE_UNUSED;
+ tree node;
+ int indent;
+{
+ print_operands (file, node, indent, TRUE, NULL);
+}
+
+static void
+print_FIX_CEIL_EXPR (file, annotation, node, indent)
+ FILE *file;
+ const char *annotation ATTRIBUTE_UNUSED;
+ tree node;
+ int indent;
+{
+ print_operands (file, node, indent, TRUE, NULL);
+}
+
+static void
+print_FIX_FLOOR_EXPR (file, annotation, node, indent)
+ FILE *file;
+ const char *annotation ATTRIBUTE_UNUSED;
+ tree node;
+ int indent;
+{
+ print_operands (file, node, indent, TRUE, NULL);
+}
+
+static void
+print_FIX_ROUND_EXPR (file, annotation, node, indent)
+ FILE *file;
+ const char *annotation ATTRIBUTE_UNUSED;
+ tree node;
+ int indent;
+{
+ print_operands (file, node, indent, TRUE, NULL);
+}
+
+static void
+print_FLOAT_EXPR (file, annotation, node, indent)
+ FILE *file;
+ const char *annotation ATTRIBUTE_UNUSED;
+ tree node;
+ int indent;
+{
+ print_operands (file, node, indent, TRUE, NULL);
+}
+
+static void
+print_NEGATE_EXPR (file, annotation, node, indent)
+ FILE *file;
+ const char *annotation ATTRIBUTE_UNUSED;
+ tree node;
+ int indent;
+{
+ print_operands (file, node, indent, TRUE, NULL);
+}
+
+static void
+print_MIN_EXPR (file, annotation, node, indent)
+ FILE *file;
+ const char *annotation ATTRIBUTE_UNUSED;
+ tree node;
+ int indent;
+{
+ print_operands (file, node, indent, TRUE, NULL);
+}
+
+static void
+print_MAX_EXPR (file, annotation, node, indent)
+ FILE *file;
+ const char *annotation ATTRIBUTE_UNUSED;
+ tree node;
+ int indent;
+{
+ print_operands (file, node, indent, TRUE, NULL);
+}
+
+static void
+print_ABS_EXPR (file, annotation, node, indent)
+ FILE *file;
+ const char *annotation ATTRIBUTE_UNUSED;
+ tree node;
+ int indent;
+{
+ print_operands (file, node, indent, TRUE, NULL);
+}
+
+static void
+print_FFS_EXPR (file, annotation, node, indent)
+ FILE *file;
+ const char *annotation ATTRIBUTE_UNUSED;
+ tree node;
+ int indent;
+{
+ print_operands (file, node, indent, TRUE, NULL);
+}
+
+static void
+print_LSHIFT_EXPR (file, annotation, node, indent)
+ FILE *file;
+ const char *annotation ATTRIBUTE_UNUSED;
+ tree node;
+ int indent;
+{
+ print_operands (file, node, indent, TRUE, NULL);
+}
+
+static void
+print_RSHIFT_EXPR (file, annotation, node, indent)
+ FILE *file;
+ const char *annotation ATTRIBUTE_UNUSED;
+ tree node;
+ int indent;
+{
+ print_operands (file, node, indent, TRUE, NULL);
+}
+
+static void
+print_LROTATE_EXPR (file, annotation, node, indent)
+ FILE *file;
+ const char *annotation ATTRIBUTE_UNUSED;
+ tree node;
+ int indent;
+{
+ print_operands (file, node, indent, TRUE, NULL);
+}
+
+static void
+print_RROTATE_EXPR (file, annotation, node, indent)
+ FILE *file;
+ const char *annotation ATTRIBUTE_UNUSED;
+ tree node;
+ int indent;
+{
+ print_operands (file, node, indent, TRUE, NULL);
+}
+
+static void
+print_BIT_IOR_EXPR (file, annotation, node, indent)
+ FILE *file;
+ const char *annotation ATTRIBUTE_UNUSED;
+ tree node;
+ int indent;
+{
+ print_operands (file, node, indent, TRUE, NULL);
+}
+
+static void
+print_BIT_XOR_EXPR (file, annotation, node, indent)
+ FILE *file;
+ const char *annotation ATTRIBUTE_UNUSED;
+ tree node;
+ int indent;
+{
+ print_operands (file, node, indent, TRUE, NULL);
+}
+
+static void
+print_BIT_AND_EXPR (file, annotation, node, indent)
+ FILE *file;
+ const char *annotation ATTRIBUTE_UNUSED;
+ tree node;
+ int indent;
+{
+ print_operands (file, node, indent, TRUE, NULL);
+}
+
+static void
+print_BIT_ANDTC_EXPR (file, annotation, node, indent)
+ FILE *file;
+ const char *annotation ATTRIBUTE_UNUSED;
+ tree node;
+ int indent;
+{
+ print_operands (file, node, indent, TRUE, NULL);
+}
+
+static void
+print_BIT_NOT_EXPR (file, annotation, node, indent)
+ FILE *file;
+ const char *annotation ATTRIBUTE_UNUSED;
+ tree node;
+ int indent;
+{
+ print_operands (file, node, indent, TRUE, NULL);
+}
+
+static void
+print_TRUTH_ANDIF_EXPR (file, annotation, node, indent)
+ FILE *file;
+ const char *annotation ATTRIBUTE_UNUSED;
+ tree node;
+ int indent;
+{
+ print_operands (file, node, indent, TRUE, NULL);
+}
+
+static void
+print_TRUTH_ORIF_EXPR (file, annotation, node, indent)
+ FILE *file;
+ const char *annotation ATTRIBUTE_UNUSED;
+ tree node;
+ int indent;
+{
+ print_operands (file, node, indent, TRUE, NULL);
+}
+
+static void
+print_TRUTH_AND_EXPR (file, annotation, node, indent)
+ FILE *file;
+ const char *annotation ATTRIBUTE_UNUSED;
+ tree node;
+ int indent;
+{
+ print_operands (file, node, indent, TRUE, NULL);
+}
+
+static void
+print_TRUTH_OR_EXPR (file, annotation, node, indent)
+ FILE *file;
+ const char *annotation ATTRIBUTE_UNUSED;
+ tree node;
+ int indent;
+{
+ print_operands (file, node, indent, TRUE, NULL);
+}
+
+static void
+print_TRUTH_XOR_EXPR (file, annotation, node, indent)
+ FILE *file;
+ const char *annotation ATTRIBUTE_UNUSED;
+ tree node;
+ int indent;
+{
+ print_operands (file, node, indent, TRUE, NULL);
+}
+
+static void
+print_TRUTH_NOT_EXPR (file, annotation, node, indent)
+ FILE *file;
+ const char *annotation ATTRIBUTE_UNUSED;
+ tree node;
+ int indent;
+{
+ print_operands (file, node, indent, TRUE, NULL);
+}
+
+static void
+print_LT_EXPR (file, annotation, node, indent)
+ FILE *file;
+ const char *annotation ATTRIBUTE_UNUSED;
+ tree node;
+ int indent;
+{
+ print_operands (file, node, indent, TRUE, NULL);
+}
+
+static void
+print_LE_EXPR (file, annotation, node, indent)
+ FILE *file;
+ const char *annotation ATTRIBUTE_UNUSED;
+ tree node;
+ int indent;
+{
+ print_operands (file, node, indent, TRUE, NULL);
+}
+
+static void
+print_GT_EXPR (file, annotation, node, indent)
+ FILE *file;
+ const char *annotation ATTRIBUTE_UNUSED;
+ tree node;
+ int indent;
+{
+ print_operands (file, node, indent, TRUE, NULL);
+}
+
+static void
+print_GE_EXPR (file, annotation, node, indent)
+ FILE *file;
+ const char *annotation ATTRIBUTE_UNUSED;
+ tree node;
+ int indent;
+{
+ print_operands (file, node, indent, TRUE, NULL);
+}
+
+static void
+print_EQ_EXPR (file, annotation, node, indent)
+ FILE *file;
+ const char *annotation ATTRIBUTE_UNUSED;
+ tree node;
+ int indent;
+{
+ print_operands (file, node, indent, TRUE, NULL);
+}
+
+static void
+print_NE_EXPR (file, annotation, node, indent)
+ FILE *file;
+ const char *annotation ATTRIBUTE_UNUSED;
+ tree node;
+ int indent;
+{
+ print_operands (file, node, indent, TRUE, NULL);
+}
+
+static void
+print_UNORDERED_EXPR (file, annotation, node, indent)
+ FILE *file;
+ const char *annotation ATTRIBUTE_UNUSED;
+ tree node;
+ int indent;
+{
+ print_operands (file, node, indent, TRUE, NULL);
+}
+
+static void
+print_ORDERED_EXPR (file, annotation, node, indent)
+ FILE *file;
+ const char *annotation ATTRIBUTE_UNUSED;
+ tree node;
+ int indent;
+{
+ print_operands (file, node, indent, TRUE, NULL);
+}
+
+static void
+print_UNLT_EXPR (file, annotation, node, indent)
+ FILE *file;
+ const char *annotation ATTRIBUTE_UNUSED;
+ tree node;
+ int indent;
+{
+ print_operands (file, node, indent, TRUE, NULL);
+}
+
+static void
+print_UNLE_EXPR (file, annotation, node, indent)
+ FILE *file;
+ const char *annotation ATTRIBUTE_UNUSED;
+ tree node;
+ int indent;
+{
+ print_operands (file, node, indent, TRUE, NULL);
+}
+
+static void
+print_UNGT_EXPR (file, annotation, node, indent)
+ FILE *file;
+ const char *annotation ATTRIBUTE_UNUSED;
+ tree node;
+ int indent;
+{
+ print_operands (file, node, indent, TRUE, NULL);
+}
+
+static void
+print_UNGE_EXPR (file, annotation, node, indent)
+ FILE *file;
+ const char *annotation ATTRIBUTE_UNUSED;
+ tree node;
+ int indent;
+{
+ print_operands (file, node, indent, TRUE, NULL);
+}
+
+static void
+print_UNEQ_EXPR (file, annotation, node, indent)
+ FILE *file;
+ const char *annotation ATTRIBUTE_UNUSED;
+ tree node;
+ int indent;
+{
+ print_operands (file, node, indent, TRUE, NULL);
+}
+
+static void
+print_IN_EXPR (file, annotation, node, indent)
+ FILE *file;
+ const char *annotation ATTRIBUTE_UNUSED;
+ tree node;
+ int indent;
+{
+ print_operands (file, node, indent, TRUE, NULL);
+}
+
+static void
+print_SET_LE_EXPR (file, annotation, node, indent)
+ FILE *file;
+ const char *annotation ATTRIBUTE_UNUSED;
+ tree node;
+ int indent;
+{
+ print_operands (file, node, indent, TRUE, NULL);
+}
+
+static void
+print_CARD_EXPR (file, annotation, node, indent)
+ FILE *file;
+ const char *annotation ATTRIBUTE_UNUSED;
+ tree node;
+ int indent;
+{
+ print_operands (file, node, indent, TRUE, NULL);
+}
+
+static void
+print_RANGE_EXPR (file, annotation, node, indent)
+ FILE *file;
+ const char *annotation ATTRIBUTE_UNUSED;
+ tree node;
+ int indent;
+{
+ print_operands (file, node, indent, TRUE, NULL);
+}
+
+static void
+print_CONVERT_EXPR (file, annotation, node, indent)
+ FILE *file;
+ const char *annotation ATTRIBUTE_UNUSED;
+ tree node;
+ int indent;
+{
+ print_operands (file, node, indent, TRUE, NULL);
+}
+
+static void
+print_NOP_EXPR (file, annotation, node, indent)
+ FILE *file;
+ const char *annotation ATTRIBUTE_UNUSED;
+ tree node;
+ int indent;
+{
+ print_operands (file, node, indent, TRUE, NULL);
+}
+
+static void
+print_NON_LVALUE_EXPR (file, annotation, node, indent)
+ FILE *file;
+ const char *annotation ATTRIBUTE_UNUSED;
+ tree node;
+ int indent;
+{
+ print_operands (file, node, indent, TRUE, NULL);
+}
+
+static void
+print_SAVE_EXPR (file, annotation, node, indent)
+ FILE *file;
+ const char *annotation ATTRIBUTE_UNUSED;
+ tree node;
+ int indent;
+{
+ print_operands (file, node, indent, TRUE, NULL);
+}
+
+static void
+print_VIEW_CONVERT_EXPR (file, annotation, node, indent)
+ FILE *file;
+ const char *annotation ATTRIBUTE_UNUSED;
+ tree node;
+ int indent;
+{
+ print_operands (file, node, indent, TRUE, NULL);
+}
+
+static void
+print_UNSAVE_EXPR (file, annotation, node, indent)
+ FILE *file;
+ const char *annotation ATTRIBUTE_UNUSED;
+ tree node;
+ int indent;
+{
+ print_operands (file, node, indent, TRUE, NULL);
+}
+
+static void
+print_RTL_EXPR (file, annotation, node, indent)
+ FILE *file;
+ const char *annotation ATTRIBUTE_UNUSED;
+ tree node;
+ int indent;
+{
+ print_operands (file, node, indent, TRUE, NULL);
+}
+
+static void
+print_ADDR_EXPR (file, annotation, node, indent)
+ FILE *file;
+ const char *annotation ATTRIBUTE_UNUSED;
+ tree node;
+ int indent;
+{
+ print_operands (file, node, indent, TRUE, NULL);
+}
+
+static void
+print_REFERENCE_EXPR (file, annotation, node, indent)
+ FILE *file;
+ const char *annotation ATTRIBUTE_UNUSED;
+ tree node;
+ int indent;
+{
+ print_operands (file, node, indent, TRUE, NULL);
+}
+
+static void
+print_ENTRY_VALUE_EXPR (file, annotation, node, indent)
+ FILE *file;
+ const char *annotation ATTRIBUTE_UNUSED;
+ tree node;
+ int indent;
+{
+ print_operands (file, node, indent, TRUE, NULL);
+}
+
+static void
+print_FDESC_EXPR (file, annotation, node, indent)
+ FILE *file;
+ const char *annotation ATTRIBUTE_UNUSED;
+ tree node;
+ int indent;
+{
+ print_operands (file, node, indent, TRUE, NULL);
+}
+
+static void
+print_COMPLEX_EXPR (file, annotation, node, indent)
+ FILE *file;
+ const char *annotation ATTRIBUTE_UNUSED;
+ tree node;
+ int indent;
+{
+ print_operands (file, node, indent, TRUE, NULL);
+}
+
+static void
+print_CONJ_EXPR (file, annotation, node, indent)
+ FILE *file;
+ const char *annotation ATTRIBUTE_UNUSED;
+ tree node;
+ int indent;
+{
+ print_operands (file, node, indent, TRUE, NULL);
+}
+
+static void
+print_REALPART_EXPR (file, annotation, node, indent)
+ FILE *file;
+ const char *annotation ATTRIBUTE_UNUSED;
+ tree node;
+ int indent;
+{
+ print_operands (file, node, indent, TRUE, NULL);
+}
+
+static void
+print_IMAGPART_EXPR (file, annotation, node, indent)
+ FILE *file;
+ const char *annotation ATTRIBUTE_UNUSED;
+ tree node;
+ int indent;
+{
+ print_operands (file, node, indent, TRUE, NULL);
+}
+
+static void
+print_PREDECREMENT_EXPR (file, annotation, node, indent)
+ FILE *file;
+ const char *annotation ATTRIBUTE_UNUSED;
+ tree node;
+ int indent;
+{
+ print_operands (file, node, indent, TRUE, NULL);
+}
+
+static void
+print_PREINCREMENT_EXPR (file, annotation, node, indent)
+ FILE *file;
+ const char *annotation ATTRIBUTE_UNUSED;
+ tree node;
+ int indent;
+{
+ print_operands (file, node, indent, TRUE, NULL);
+}
+
+static void
+print_POSTDECREMENT_EXPR (file, annotation, node, indent)
+ FILE *file;
+ const char *annotation ATTRIBUTE_UNUSED;
+ tree node;
+ int indent;
+{
+ print_operands (file, node, indent, TRUE, NULL);
+}
+
+static void
+print_POSTINCREMENT_EXPR (file, annotation, node, indent)
+ FILE *file;
+ const char *annotation ATTRIBUTE_UNUSED;
+ tree node;
+ int indent;
+{
+ print_operands (file, node, indent, TRUE, NULL);
+}
+
+static void
+print_VA_ARG_EXPR (file, annotation, node, indent)
+ FILE *file;
+ const char *annotation ATTRIBUTE_UNUSED;
+ tree node;
+ int indent;
+{
+ print_operands (file, node, indent, TRUE, NULL);
+}
+
+static void
+print_TRY_CATCH_EXPR (file, annotation, node, indent)
+ FILE *file;
+ const char *annotation ATTRIBUTE_UNUSED;
+ tree node;
+ int indent;
+{
+ print_operands (file, node, indent, TRUE, "(try)", "(catch)", NULL);
+}
+
+static void
+print_TRY_FINALLY_EXPR (file, annotation, node, indent)
+ FILE *file;
+ const char *annotation ATTRIBUTE_UNUSED;
+ tree node;
+ int indent;
+{
+ print_operands (file, node, indent, TRUE, NULL);
+}
+
+static void
+print_GOTO_SUBROUTINE_EXPR (file, annotation, node, indent)
+ FILE *file;
+ const char *annotation ATTRIBUTE_UNUSED;
+ tree node;
+ int indent;
+{
+ print_operands (file, node, indent, TRUE, NULL);
+}
+
+static void
+print_LABEL_EXPR (file, annotation, node, indent)
+ FILE *file;
+ const char *annotation ATTRIBUTE_UNUSED;
+ tree node;
+ int indent;
+{
+ print_operands (file, node, indent, TRUE, NULL);
+}
+
+static void
+print_GOTO_EXPR (file, annotation, node, indent)
+ FILE *file;
+ const char *annotation ATTRIBUTE_UNUSED;
+ tree node;
+ int indent;
+{
+ print_operands (file, node, indent, TRUE, NULL);
+}
+
+static void
+print_RETURN_EXPR (file, annotation, node, indent)
+ FILE *file;
+ const char *annotation ATTRIBUTE_UNUSED;
+ tree node;
+ int indent;
+{
+ print_operands (file, node, indent, TRUE, NULL);
+}
+
+static void
+print_EXIT_EXPR (file, annotation, node, indent)
+ FILE *file;
+ const char *annotation ATTRIBUTE_UNUSED;
+ tree node;
+ int indent;
+{
+ print_operands (file, node, indent, TRUE, NULL);
+}
+
+static void
+print_LOOP_EXPR (file, annotation, node, indent)
+ FILE *file;
+ const char *annotation ATTRIBUTE_UNUSED;
+ tree node;
+ int indent;
+{
+ print_operands (file, node, indent, TRUE, NULL);
+}
+
+static void
+print_LABELED_BLOCK_EXPR (file, annotation, node, indent)
+ FILE *file;
+ const char *annotation ATTRIBUTE_UNUSED;
+ tree node;
+ int indent;
+{
+ print_operands (file, node, indent, TRUE, NULL);
+}
+
+static void
+print_EXIT_BLOCK_EXPR (file, annotation, node, indent)
+ FILE *file;
+ const char *annotation ATTRIBUTE_UNUSED;
+ tree node;
+ int indent;
+{
+ print_operands (file, node, indent, TRUE, NULL);
+}
+
+static void
+print_EXPR_WITH_FILE_LOCATION (file, annotation, node, indent)
+ FILE *file;
+ const char *annotation ATTRIBUTE_UNUSED;
+ tree node;
+ int indent;
+{
+ print_operands (file, node, indent, TRUE, NULL);
+}
+
+static void
+print_SWITCH_EXPR (file, annotation, node, indent)
+ FILE *file;
+ const char *annotation ATTRIBUTE_UNUSED;
+ tree node;
+ int indent;
+{
+ print_operands (file, node, indent, TRUE, NULL);
+}
+
+static void
+print_EXC_PTR_EXPR (file, annotation, node, indent)
+ FILE *file;
+ const char *annotation ATTRIBUTE_UNUSED;
+ tree node;
+ int indent;
+{
+ print_operands (file, node, indent, TRUE, NULL);
+}
+
+static void
+print_CLZ_EXPR (file, annotation, node, indent)
+ FILE *file ATTRIBUTE_UNUSED;
+ const char *annotation ATTRIBUTE_UNUSED;
+ tree node ATTRIBUTE_UNUSED;
+ int indent ATTRIBUTE_UNUSED;
+{
+ /* TO DO */
+}
+static void
+print_CTZ_EXPR (file, annotation, node, indent)
+ FILE *file ATTRIBUTE_UNUSED;
+ const char *annotation ATTRIBUTE_UNUSED;
+ tree node ATTRIBUTE_UNUSED;
+ int indent ATTRIBUTE_UNUSED;
+{
+ /* TO DO */
+}
+static void
+print_PARITY_EXPR (file, annotation, node, indent)
+ FILE *file ATTRIBUTE_UNUSED;
+ const char *annotation ATTRIBUTE_UNUSED;
+ tree node ATTRIBUTE_UNUSED;
+ int indent ATTRIBUTE_UNUSED;
+{
+ /* TO DO */
+}
+static void
+print_POPCOUNT_EXPR (file, annotation, node, indent)
+ FILE *file ATTRIBUTE_UNUSED;
+ const char *annotation ATTRIBUTE_UNUSED;
+ tree node ATTRIBUTE_UNUSED;
+ int indent ATTRIBUTE_UNUSED;
+{
+ /* TO DO */
+}
+
+/*-------------------------------------------------------------------*/
+
+/* Alaways the last lang_dump_tree_p to keep lang_dump_tree_p from being
+ NULL. A return of 0 always forces the tree node switch to go to its
+ default case. */
+
+static int
+no_dump_tree_p (file, annotation, node, indent)
+ FILE *file ATTRIBUTE_UNUSED;
+ const char *annotation ATTRIBUTE_UNUSED;
+ tree node ATTRIBUTE_UNUSED;
+ int indent ATTRIBUTE_UNUSED;
+{
+ return 0;
+}
+
+/* Language-specific initializers call this to add to the chain of language-
+ specific tree node dumpers. It is expected that their default node case
+ will call the function returned from here which was saved during their
+ initialization. */
+
+lang_dump_tree_p_t
+set_dump_tree_p (new_lang_dump_tree_p)
+ lang_dump_tree_p_t new_lang_dump_tree_p;
+{
+ lang_dump_tree_p_t old_lang_dump_tree_p = lang_dump_tree_p;
+ lang_dump_tree_p = new_lang_dump_tree_p;
+ return old_lang_dump_tree_p;
+}
+
+/* Annotations enclosed in parentheses are appended to the initial
+ kind:address display. Otherwise they prefix it. Note that a
+ prefix annotation is expected to have at least a trailing
+ space but a parenthesized annotation should end with it's
+ delimiting right parentheses. */
+
+void
+dump_tree (file, annotation, node, indent)
+ FILE *file;
+ const char *annotation;
+ tree node;
+ int indent;
+{
+ int good_node, no_new_line, plen = 0;
+ static tree previous_node;
+
+ no_new_line = dump_tree_state.no_new_line;
+ dump_tree_state.no_new_line = 0;
+
+ /* prefix_len contains the length of the fixed part of a tree node
+ display line and can be used by tree node dumpers to control
+ line wrapping if the line info for that node gets too long. */
+
+ if (node == NULL)
+ return;
+
+ if (dump_tree_state.nesting_depth < 0)
+ {
+ /* If not called from dmp_tree3() then create hash table to record
+ which nodes we visit. We still also do this for dmp_tree3()
+ but only the first time dmp_tree3() calls this routine. After
+ that it's dmp_tree3() responsibility to free the hash table. */
+ if (dump_tree_state.visit_only_once != DMP_TREE_VISIT_ONCE2)
+ {
+ init_dump_state(node);
+ table = (struct bucket **) xmalloc (HASH_SIZE * sizeof (struct bucket *));
+ memset ((char *) table, 0, HASH_SIZE * sizeof (struct bucket *));
+ if (dump_tree_state.visit_only_once == DMP_TREE_VISIT_ONCE1)
+ dump_tree_state.visit_only_once = DMP_TREE_VISIT_ONCE2;
+ }
+
+ indent = 0;
+ previous_node = NULL_TREE;
+#if DMP_TREE_WRAPPED_OUTPUT
+ {
+ char *wrap_str = getenv(DMP_TREE_LINE_WRAP);
+ line_index = prev_line_was_null = prev_line_was_wrapped = 0;
+ wrap_column = 0;
+ if (wrap_str)
+ wrap_column = strtol (wrap_str, NULL, 10);
+#if defined(TIOCGSIZE) || defined(TIOCGWINSZ)
+ if (wrap_column < MIN_LINE_WRAP || wrap_column > MAX_LINE_WRAP)
+ {
+#ifdef TIOCGWINSZ
+ wrap_column = ioctl (fileno(file), TIOCGWINSZ, &winsize);
+ if (wrap_column >= 0)
+ wrap_column = winsize.ws_col;
+#endif
+#if defined(TIOCGSIZE) && !defined(TIOCGWINSZ)
+ wrap_column = ioctl (fileno(file), TIOCGSIZE, &winsize);
+ if (wrap_column >= 0)
+ wrap_column = winsize.ts_cols;
+#endif
+ }
+ }
+#endif /* TIOCGSIZE || TIOCGWINSZ */
+ if (wrap_column < MIN_LINE_WRAP || wrap_column > MAX_LINE_WRAP)
+ wrap_column = DEFAULT_LINE_WRAP;
+#endif /* DMP_TREE_WRAPPED_OUTPUT */
+ }
+
+ if (dump_tree_state.visit_only_once != DMP_TREE_VISIT_ANY
+ && node_seen (node, TRUE))
+ return;
+
+ if (dump_tree_state.dump_full_type && node_seen (node, FALSE))
+ return;
+
+ if (dump_tree_state.doing_tree_list && node_seen (node, FALSE))
+ return;
+
+ if (dump_tree_state.nesting_depth >= dump_tree_state.max_depth)
+ return;
+
+ if (dump_tree_state.nesting_depth >= 0)
+ {
+ if (!no_new_line)
+ {
+ newline_and_indent (file, 0);
+ if (statement_code_p (TREE_CODE (node))
+ || (TREE_CODE (node) == TREE_VEC && TREE_VEC_LENGTH (node) > 1))
+ {
+ if (previous_node
+ && TREE_CODE (previous_node) != TREE_CODE (node)
+ && (*lang_hooks.dump_blank_line_p) (previous_node, node))
+ newline_and_indent (file, 0);
+ }
+ }
+ previous_node = node;
+ if (indent > 0)
+ fprintf (file, "%*c", indent, ' ');
+ }
+
+ ++dump_tree_state.nesting_depth;
+
+ plen = indent;
+ if (annotation && *annotation && *annotation != '(')
+ plen += fprintf (file, "%s", annotation);
+
+ good_node = ((int) TREE_CODE (node) < dump_tree_state.max_code);
+
+ if (good_node)
+ {
+ plen += fprintf (file, "%s:", tree_code_name[(int) TREE_CODE (node)]);
+ plen += fprintf (file, HOST_PTR_PRINTF, HOST_PTR_PRINTF_VALUE (node));
+ }
+ else
+ {
+ plen += fprintf (file, "%d (?):", (int) TREE_CODE (node));
+ plen += fprintf (file, HOST_PTR_PRINTF, HOST_PTR_PRINTF_VALUE (node));
+ }
+
+ if (annotation && *annotation == '(')
+ plen += fprintf (file, " %s", annotation);
+
+ if (good_node)
+ {
+ if (TREE_CODE_CLASS (TREE_CODE (node)) != 't'
+ && TREE_TYPE (node)
+ && TREE_CODE_CLASS (TREE_CODE (TREE_TYPE (node))) == 't')
+ {
+ tree type, type0 = TREE_TYPE (node);
+
+ if (dump_tree_state.doing_call_expr
+ && TREE_CODE (node) == FUNCTION_DECL && TREE_TYPE (type0))
+ type = TREE_TYPE (type0);
+ else
+ type = type0;
+
+ fprintf (file, " t=");
+ fprintf (file, HOST_PTR_PRINTF, HOST_PTR_PRINTF_VALUE (type0));
+
+ if (TYPE_NAME (type))
+ {
+ if (TREE_CODE (TYPE_NAME (type)) == IDENTIFIER_NODE)
+ {
+ if (IDENTIFIER_POINTER (TYPE_NAME (type))
+ && *IDENTIFIER_POINTER (TYPE_NAME (type)))
+ fprintf (file, " {%s}", IDENTIFIER_POINTER (TYPE_NAME (type)));
+ }
+ else if (TREE_CODE (TYPE_NAME (type)) == TYPE_DECL
+ && DECL_NAME (TYPE_NAME (type))
+ && IDENTIFIER_POINTER (DECL_NAME (TYPE_NAME (type)))
+ && *IDENTIFIER_POINTER (DECL_NAME (TYPE_NAME (type))))
+ fprintf (file, " {%s}",
+ IDENTIFIER_POINTER (DECL_NAME (TYPE_NAME (type))));
+ }
+ else
+ fprintf (file, " {%s}", tree_code_name[(int) TREE_CODE (type)]);
+
+ /* If doing a full program dump we also want to dump the types too.
+ So dmp_tree3() will do it after we dump all the decls's. All
+ we do here is record all the decl's types in an array. We won't
+ worry about dups here. That is taken care of when we process
+ this array. */
+
+ if (dump_tree_state.visit_only_once == DMP_TREE_VISIT_ONCE2
+ && !node_seen (type, FALSE))
+ {
+ if (type_array_next >= type_array_size)
+ {
+ type_array_size += type_array_incr;
+ type_array_incr = TYPE_ARRAY_INCR;
+ type_array = (tree *) xrealloc (type_array,
+ sizeof (tree) * type_array_size);
+ }
+
+ type_array[type_array_next++] = type;
+ }
+ }
+ else if (dump_tree_state.dump_full_type && TREE_TYPE (node))
+ {
+ fprintf (file, " t=");
+ fprintf (file, HOST_PTR_PRINTF,
+ HOST_PTR_PRINTF_VALUE (TREE_TYPE (node)));
+ }
+ }
+
+#if DMP_TREE_WRAPPED_OUTPUT
+ prefix_len = plen + 1; /* include blank following prefix */
+ prev_line_was_wrapped = 0;
+#endif
+
+ print_lineno (file, node); /* line nbr info where possible */
+
+ if (! (*lang_dump_tree_p) (file, annotation, node, indent))
+ {
+ switch (TREE_CODE (node))
+ {
+# define DEFTREECODE(SYM, NAME, TYPE, LENGTH) \
+ case SYM: print_ ## SYM (file, annotation, node, indent); break;
+# include "tree.def"
+# undef DEFTREECODE
+ default:
+ print_ERROR_MARK (file, annotation, node, indent);
+ break;
+ }
+ }
+
+ --dump_tree_state.nesting_depth;
+
+ if (dump_tree_state.nesting_depth < 0)
+ {
+ newline_and_indent (file, 0);
+ if (dump_tree_state.visit_only_once != DMP_TREE_VISIT_ONCE2)
+ free_hash_table ();
+ }
+ else
+ (void)node_seen (node, TRUE);
+
+}
+
+/* Called from debugger to dump the tree for a specific node. */
+void
+dmp_tree (node)
+ tree node;
+{
+ dump_tree_state.max_depth = INT_MAX;
+ dump_tree_state.visit_only_once = DMP_TREE_VISIT_ANY;
+ dump_tree (stderr, NULL, node, 0);
+}
+
+/* Same as dmp_tree() but limit the nesting to specified depth. */
+void
+dmp_tree1 (node, max_depth)
+ tree node;
+ int max_depth;
+{
+ if (max_depth <= 0)
+ max_depth = 1;
+ dump_tree_state.max_depth = max_depth;
+ dump_tree_state.visit_only_once = DMP_TREE_VISIT_ANY;
+ dump_tree (stderr, NULL, node, 0);
+}
+
+/* Same as dmp_tree() but displays never show a referenced node
+ more than once. */
+void
+dmp_tree2 (node)
+ tree node;
+{
+ dump_tree_state.max_depth = INT_MAX;
+ dump_tree_state.visit_only_once = DMP_TREE_VISIT_ONCE;
+ dump_tree (stderr, NULL, node, 0);
+}
+
+/* Called only from tree-dump.c to handle our dmp_tree() types of
+ displays when dumping an entire program to a file by specifying
+ -fdmp-translation-unit. */
+void
+dmp_tree3 (file, node, flags)
+ FILE *file;
+ tree node;
+ int flags ATTRIBUTE_UNUSED;
+{
+ int i;
+
+ dump_tree_state.max_depth = INT_MAX;
+ dump_tree_state.visit_only_once = DMP_TREE_VISIT_ONCE1;
+
+ while (node)
+ {
+ dump_tree (file, NULL, node, 0);
+ node = TREE_CHAIN (node);
+ }
+
+ newline_and_indent (file, 0);
+
+ if (type_array_next > 0)
+ {
+ for (i = 0; i < type_array_next; ++i)
+ dump_tree (file, NULL, type_array[i], 0);
+
+ free (type_array);
+ }
+
+ free_hash_table ();
+}
+
+/*-------------------------------------------------------------------*/
+
+#if DMP_TREE_WRAPPED_OUTPUT
+
+/* The three routines below here are what's actually called when fprintf,
+ fputc, or fputs are used in the tree dumper. These are used to
+ intercept the output to impose an appropriate line wrapping convention
+ on nodes that get too long for the display (lines > wrap_column). The
+ stdio.h names are redefined by macros to call these routines when
+ DMP_TREE_WRAPPED_OUTPUT is set.
+
+ The line wrap convention is to wrap only on blanks between the node's
+ info. Blanks within bracketed or quoted info does not count. The
+ wrapped portion is indented to start wherever the node's indented
+ kind:address portion of the display ends. */
+
+#undef fprintf
+#undef fputc
+#undef fputs
+
+int
+dmp_tree_fprintf VPARAMS ((FILE *file, const char *fmt, ...))
+{
+ int len;
+ va_list ap;
+
+#ifndef ANSI_PROTOTYPES
+ FILE *file;
+ char *fmt;
+#endif
+
+ VA_START (ap, fmt);
+#ifndef ANSI_PROTOTYPES
+ file = va_arg (ap, FILE *);
+ fmt = va_arg (ap, char *);
+#endif
+
+ len = vsprintf (&curr_line[line_index], fmt, ap);
+ line_index += len;
+
+ va_end (ap);
+
+ if (curr_line[line_index-1] == '\n')
+ {
+ if (line_index != 1 || !(prev_line_was_wrapped || prev_line_was_null))
+ {
+ curr_line[line_index] = '\0';
+ fputs (curr_line, file);
+ fflush (file);
+ }
+ prev_line_was_null = (line_index == 1);
+ line_index = 0;
+ }
+ else if (line_index >= wrap_column)
+ {
+ char c, unwritten_part[MAX_LINE_WRAP+2];
+ int i, end, delimiter, nesting;
+
+ prev_line_was_wrapped = 0;
+
+ /* Limit how far to the left we'll search to about wrap_column/2 */
+ end = wrap_column/2;
+ if (end < prefix_len)
+ end = prefix_len;
+
+ /* Search left the the first blank to the left of the wrap point.
+ We assume that bracketed entities (e.g., quoted strings,
+ parenthetical entities, etc.) are written with a single
+ fprintf() so that we know to ignore blanks embedded within
+ pairs of these things. */
+
+ i = line_index - 1;
+ delimiter = nesting = 0;
+ while (i >= end)
+ {
+ c = curr_line[i];
+ if (curr_line[i-1] == '\\')
+ --i;
+ else if (nesting)
+ {
+ if (c == delimiter && --nesting <= 0)
+ delimiter = 0;
+ }
+ else if (c == '"' || c == '\'') {
+ delimiter = c; ++nesting;
+ } else if (c == ')') {
+ delimiter = '('; ++nesting;
+ } else if (c == ']') {
+ delimiter = '['; ++nesting;
+ } else if (c == '>') {
+ delimiter = '<'; ++nesting;
+ } else if (c == '}') {
+ delimiter = '{'; ++nesting;
+ } else if (c == ' ' && i < wrap_column)
+ break;
+ --i;
+ }
+
+ if (i < end)
+ return len;
+
+ /* The wrapped (unwritten) part is everthing to the right of the
+ blank found above. */
+
+ strcpy (unwritten_part, &curr_line[i+1]);
+
+ /* Delete trailing blanks on the left part we are going to print
+ and print it... */
+
+ while (curr_line[i] == ' ' && i >= end)
+ --i;
+ if (i < end)
+ return len;
+
+ curr_line[i+1] = '\n';
+ curr_line[i+2] = '\0';
+ prev_line_was_wrapped = 1;
+ fputs (curr_line, file);
+ fflush (file);
+
+ /* Write the wrapped portion, indented by the current prefix_len... */
+
+ line_index = prefix_len;
+ memset(curr_line, ' ', line_index);
+ curr_line[line_index] = '\0';
+
+ dmp_tree_fprintf (file, "%s", unwritten_part);
+ }
+
+ return len;
+}
+
+int
+dmp_tree_fputc (c, file)
+ int c;
+ FILE *file;
+{
+ dmp_tree_fprintf (file, "%c", c);
+ return c;
+}
+
+int
+dmp_tree_fputs (s, file)
+ const char *s;
+ FILE *file;
+{
+ return dmp_tree_fprintf (file, "%s", s);
+}
+
+#endif /* DMP_TREE_WRAPPED_OUTPUT */
+
+/*-------------------------------------------------------------------*/
+
+/* Special routine called for debugging chains only. This is NOT a
+ tree node type. */
+
+void print_TREE_CHAIN PARAMS ((tree));
+
+void
+print_TREE_CHAIN (node)
+ tree node;
+{
+ while (node)
+ {
+ dump_tree (stderr, NULL, node, 0); /* keep list at same indent */
+ node = TREE_CHAIN (node);
+ }
+}
+
diff --git a/gcc/dmp-tree.h b/gcc/dmp-tree.h
new file mode 100644
index 00000000000..e45beb61e8c
--- /dev/null
+++ b/gcc/dmp-tree.h
@@ -0,0 +1,116 @@
+/* APPLE LOCAL new tree dump */
+/* Common condenced tree display routine definitions.
+ Copyright (C) 2001 Free Software Foundation, Inc.
+ Contributed by Ira L. Ruben (ira@apple.com)
+
+This file is part of GNU CC.
+
+GNU CC is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2, or (at your option)
+any later version.
+
+GNU CC is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+GNU General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with GNU CC; see the file COPYING. If not, write to
+the Free Software Foundation, 59 Temple Place - Suite 330,
+Boston, MA 02111-1307, USA. */
+
+#ifndef GCC_DMP_TREE_H
+#define GCC_DMP_TREE_H
+
+/* Language-specific initialization */
+typedef int (*lang_dump_tree_p_t) PARAMS ((FILE *, const char *, tree, int));
+extern lang_dump_tree_p_t set_dump_tree_p PARAMS ((lang_dump_tree_p_t));
+
+/* Main entry */
+extern void dmp_tree PARAMS ((tree));
+extern void dmp_tree1 PARAMS ((tree, int));
+extern void dmp_tree2 PARAMS ((tree));
+extern void dmp_tree3 PARAMS ((FILE *, tree, int));
+
+/* Recursive entry */
+extern void dump_tree PARAMS ((FILE *, const char *, tree, int));
+
+/* Special purpose node routines */
+extern int node_seen PARAMS ((tree, int));
+extern void newline_and_indent PARAMS ((FILE *, int));
+extern void print_type PARAMS ((FILE *, const char *, tree, int));
+extern void print_decl PARAMS ((FILE *, const char *, tree, int));
+extern void print_ref PARAMS ((FILE *, const char *, tree, int));
+extern void print_operands PARAMS ((FILE *file, tree, int, int, ...));
+extern void print_lineno PARAMS ((FILE *, tree));
+extern void print_integer_constant PARAMS ((FILE *, tree, int));
+extern void print_real_constant PARAMS ((FILE *, tree));
+extern void print_string_constant PARAMS ((FILE *, const char *, int));
+extern void print_tree_flags PARAMS ((FILE *, tree));
+
+/* State switches for dmp_tree() to tell it how to record and handle
+ previously visited nodes. */
+enum dmp_tree_visit_state {
+ DMP_TREE_VISIT_ANY, /* allow display of any node anytime */
+ DMP_TREE_VISIT_ONCE, /* only display once per dmp_tree() */
+ DMP_TREE_VISIT_ONCE1, /* only once, but need to init hash */
+ DMP_TREE_VISIT_ONCE2 /* only once, but do not clear hash */
+};
+
+typedef struct { /* dmp_tree.c state switches... */
+ int max_code; /* max_node_code must be 1st */
+ int nesting_depth;
+ int dump_full_type;
+ int really_follow;
+ int doing_parm_decl;
+ int doing_call_expr;
+ char *curr_file;
+ int no_new_line;
+ int line_cnt;
+ int doing_tree_list;
+ int max_depth;
+ enum dmp_tree_visit_state visit_only_once;
+} dump_tree_state_t;
+
+extern dump_tree_state_t dump_tree_state;
+
+#define SET_MAX_DMP_TREE_CODE(code) \
+ dump_tree_state.max_code = MAX(dump_tree_state.max_code, (int)(code))
+
+/*-------------------------------------------------------------------*/
+
+/* DMP_TREE is ONLY defined by the actual tree dumping code to cause
+ some common definitions that they specifically use. */
+
+#ifdef DMP_TREE
+
+/* The DMP_TREE_WRAPPED_OUTPUT switch is a master contol on wheter we
+ actually use these routines. */
+#define DMP_TREE_WRAPPED_OUTPUT 1
+
+#if DMP_TREE_WRAPPED_OUTPUT
+
+/* The following redefines fprintf, fputs, fputc as calls to our routines
+ which handle line wrapping of long node line displays. It is assumed
+ that this header is the last #include in the tree dump file's include
+ list and that DMP_TREE is defined by those files (e.g., dmp-tree.c)
+ that which to use these output routines. */
+
+extern int dmp_tree_fprintf PARAMS ((FILE *, const char *, ...));
+extern int dmp_tree_fputc PARAMS((int, FILE *));
+extern int dmp_tree_fputs PARAMS((const char *, FILE *));
+
+#define fprintf dmp_tree_fprintf
+#define fputc dmp_tree_fputc
+#define fputs dmp_tree_fputs
+#endif /* DMP_TREE_WRAPPED_OUTPUT */
+
+#define HOST_PTR_PRINTF_VALUE(p) (char *) (p)
+
+#define INDENT 1 /* controls nesting tab value */
+
+#endif /* DMP_TREE */
+
+
+#endif /* GCC_DMP_TREE_H */
diff --git a/gcc/doc/cppopts.texi b/gcc/doc/cppopts.texi
index fb8f5c72122..9d00bc03317 100644
--- a/gcc/doc/cppopts.texi
+++ b/gcc/doc/cppopts.texi
@@ -234,6 +234,12 @@ preprocessed output.
When used with the driver options @option{-MD} or @option{-MMD},
@option{-MF} overrides the default dependency output file.
+@c APPLE LOCAL begin -dependency-file
+@item -dependency-file
+@opindex dependency-file @var{name}
+Like @option{-MF}. (APPLE ONLY)
+@c APPLE LOCAL end -dependency-file
+
@item -MG
@opindex MG
In conjunction with an option such as @option{-M} requesting
@@ -327,13 +333,17 @@ header is used.
@item -x c
@itemx -x c++
@itemx -x objective-c
+@c APPLE LOCAL Objective-C++
+@itemx -x objective-c++
@itemx -x assembler-with-cpp
@opindex x
-Specify the source language: C, C++, Objective-C, or assembly. This has
+@c APPLE LOCAL Objective-C++
+Specify the source language: C, C++, Objective-C, Objective-C++, or assembly. This has
nothing to do with standards conformance or extensions; it merely
selects which base syntax to expect. If you give none of these options,
cpp will deduce the language from the extension of the source file:
-@samp{.c}, @samp{.cc}, @samp{.m}, or @samp{.S}. Some other common
+@c APPLE LOCAL Objective-C++
+@samp{.c}, @samp{.cc}, @samp{.m}, @samp{.mm}, or @samp{.S}. Some other common
extensions for C++ and assembly are also recognized. If cpp does not
recognize the extension, it will treat the file as C; this is the most
generic mode.
diff --git a/gcc/doc/extend.texi b/gcc/doc/extend.texi
index b396227bb84..ebb5e375d22 100644
--- a/gcc/doc/extend.texi
+++ b/gcc/doc/extend.texi
@@ -454,6 +454,10 @@ extensions, accepted by GCC in C89 mode and in C++.
* C++ Comments:: C++ comments are recognized.
* Dollar Signs:: Dollar sign is allowed in identifiers.
* Character Escapes:: @samp{\e} stands for the character @key{ESC}.
+@c APPLE LOCAL begin Pascal strings 2001-07-05 zll **
+* Pascal Strings:: Constructing string literals with a Pascal-style
+ length byte.
+@c APPLE LOCAL end Pascal strings 2001-07-05 zll **
* Variable Attributes:: Specifying attributes of variables.
* Type Attributes:: Specifying attributes of types.
* Alignment:: Inquiring about the alignment of a type or variable.
@@ -2389,7 +2393,9 @@ calls are necessary.
@item long_call/short_call
@cindex indirect calls on ARM
This attribute specifies how a particular function is called on
-ARM@. Both attributes override the @option{-mlong-calls} (@pxref{ARM Options})
+@c APPLE LOCAL prune man page
+ARM@. Both attributes override the @option{-mlong-calls}
+@c (@pxref{ARM Options})
command line switch and @code{#pragma long_calls} settings. The
@code{long_call} attribute causes the compiler to always call the
function by first loading its address into a register and then using the
@@ -2965,6 +2971,62 @@ machines, typically because the target assembler does not allow them.
You can use the sequence @samp{\e} in a string or character constant to
stand for the ASCII character @key{ESC}.
+@c APPLE LOCAL begin Pascal strings 2001-07-05 zll **
+@node Pascal Strings
+@section Constructing String Literals with a Pascal-style Length Byte
+@cindex Pascal length byte
+@cindex Pascal strings
+
+Specifying the @w{@option{-fpascal-strings}} option will cause the
+compiler to recognize and construct Pascal-style string literals. This
+functionality is disabled by default; furthermore, its use in new code
+is discouraged.
+
+Pascal string literals take the form @samp{"\pstring"}. The special
+escape sequence @samp{\p} denotes the Pascal length byte for the string,
+and will be replaced at compile time with the number of characters that
+follow. The @samp{\p} may only appear at the beginning of a string
+literal, and may @emph{not} appear in wide string literals or as an
+integral constant.
+
+As is the case with C string literals, Pascal string literals are
+terminated with a NUL character; this character is @emph{not} counted
+when computing the value of the length byte. The maximum @samp{unsigned
+char} value that can be stored in the length byte is also the maximum
+permissible length for the Pascal literal itself. On most target
+platforms, this value is 255 (excluding both the length byte and the
+terminating NUL).
+
+Pascal-style literals are treated by the compiler as being of type
+@samp{const unsigned char []} in C++ and @samp{unsigned char []} (or
+@samp{const unsigned char []}, if the @w{@option{-Wwrite-strings}}
+option is given) in C. Pascal string literals may be used as static
+initializers for @samp{char} arrays (whose elements need not be
+@samp{unsigned} or @samp{const}). They may also be converted to
+@samp{const unsigned char *} and, in the C language to @samp{const char
+*} of any signedness (In C, if the @w{@option{-Wwrite-strings}} is not
+given, then @samp{const} may be omitted as well). For example:
+
+@example
+const unsigned char a[] = "\pHello";
+char b[] = "\pGoodbye";
+const unsigned char *c = "\pHello";
+const signed char *d = "\pHello"; /* error in C++ */
+char *e = "\pHi"; /* error in C++; warning in C with -Wwrite-strings */
+unsigned char *f = "\pHello"; /* error in C++ */
+@end example
+
+@noindent
+In all other respects, Pascal-style string literals behave the same as
+ordinary string literals. For example, if a program attempts to modify
+the conents of a Pascal-style string literal at run-time, the behaviour
+is undefined, unless the @w{@option{-fwritable-strings}} option is used.
+
+Pascal-style literals are useful for calling external routines that
+expect Pascal strings as arguments, as is true with some Apple MacOS
+Toolbox calls.
+@c APPLE LOCAL end Pascal strings 2001-07-05 zll **
+
@node Alignment
@section Inquiring on Alignment of Types or Variables
@cindex alignment
@@ -6422,7 +6484,11 @@ vector unsigned int vec_mulo (vector unsigned short,
vector signed int vec_mulo (vector signed short, vector signed short);
vector float vec_nmsub (vector float, vector float, vector float);
+@c APPLE LOCAL begin fixhtml mrs
+@end smallexample
+@smallexample
+@c APPLE LOCAL end fixhtml mrs
vector float vec_nor (vector float, vector float);
vector signed int vec_nor (vector signed int, vector signed int);
vector unsigned int vec_nor (vector unsigned int, vector unsigned int);
@@ -6988,7 +7054,11 @@ vector signed int vec_any_eq (vector signed char, vector unsigned char);
vector signed int vec_any_eq (vector signed char, vector signed char);
vector signed int vec_any_eq (vector unsigned char, vector signed char);
+@c APPLE LOCAL begin fixhtml mrs
+@end smallexample
+@smallexample
+@c APPLE LOCAL end fixhtml mrs
vector signed int vec_any_eq (vector unsigned char,
vector unsigned char);
vector signed int vec_any_eq (vector signed short,
diff --git a/gcc/doc/gcc.texi b/gcc/doc/gcc.texi
index a682ee33822..c1b6d2c22d6 100644
--- a/gcc/doc/gcc.texi
+++ b/gcc/doc/gcc.texi
@@ -153,6 +153,8 @@ Introduction, gccint, GNU Compiler Collection (GCC) Internals}.
* Copying:: GNU General Public License says
how you can copy and share GCC.
+@c APPLE LOCAL GPL compliance
+* Source Code:: How to get the source code for this compiler.
* GNU Free Documentation License:: How you can copy and share this manual.
* Contributors:: People who have contributed to GCC.
@@ -174,6 +176,8 @@ Introduction, gccint, GNU Compiler Collection (GCC) Internals}.
@include funding.texi
@include gnu.texi
+@c APPLE LOCAL GPL compliance
+@include sourcecode.texi
@include gpl.texi
@c ---------------------------------------------------------------------
diff --git a/gcc/doc/include/sourcecode.texi b/gcc/doc/include/sourcecode.texi
new file mode 100644
index 00000000000..f2e867d2db4
--- /dev/null
+++ b/gcc/doc/include/sourcecode.texi
@@ -0,0 +1,35 @@
+@c APPLE LOCAL entire file
+@node Source Code
+@unnumbered Source Code
+
+The source code for Apple's versions of GCC is available using
+anonymous CVS, from
+@samp{:pserver:anonymous@@anoncvs.opensource.apple.com:/cvs/root}
+with password @samp{anonymous}, as module @samp{gcc3}.
+
+For example, you can fetch the latest version by entering:
+
+@smallexample
+$ cvs -d :pserver:anonymous@@anoncvs.opensource.apple.com:/cvs/root login
+Password: anonymous
+$ cvs -d :pserver:anonymous@@anoncvs.opensource.apple.com:/cvs/root -z6 \
+ co gcc3
+@end smallexample
+
+Each version will be tagged based on its build number, which
+you can find by executing @samp{gcc --version}; for instance, if this prints
+
+@smallexample
+gcc (GCC) 3.3 20030304 (Apple Computer, Inc. build 1402)
+@end smallexample
+
+then the build number is 1402. Some older compilers may require you
+use @samp{gcc -v} to obtain the build number. Most versions are
+tagged like @samp{gcc-1402}; you can find a list of suitable tags with
+a command like @samp{cvs log gcc3/gcc/version.c}. Once you have the
+tag, you can use the @samp{-r} flag to CVS, for instance
+
+@smallexample
+$ cvs -d :pserver:anonymous@@anoncvs.opensource.apple.com:/cvs/root -z6 \
+ co -r gcc-1402 gcc3
+@end smallexample
diff --git a/gcc/doc/invoke.texi b/gcc/doc/invoke.texi
index ebf7d711d50..82baeb07a97 100644
--- a/gcc/doc/invoke.texi
+++ b/gcc/doc/invoke.texi
@@ -40,6 +40,21 @@ gcc [@option{-c}|@option{-S}|@option{-E}] [@option{-std=}@var{standard}]
Only the most useful options are listed here; see below for the
remainder. @samp{g++} accepts mostly the same options as @samp{gcc}.
+
+@c APPLE LOCAL begin manual
+In Apple's version of GCC, both @samp{cc} and @samp{gcc} are actually
+symbolic links to a compiler named like @samp{gcc-3.4}; which compiler
+is linked to may be changed using the command @samp{gcc_select}.
+Similarly, @samp{c++} and @samp{g++} are links to a compiler named like
+@samp{g++-3.4}.
+
+Note that Apple's GCC includes a number of extensions to standard GCC
+(flagged below with ``APPLE ONLY''), and that not all generic GCC
+options are available or supported on Darwin / Mac OS X. In particular,
+Apple does not currently support the compilation of Fortran, Ada, or
+Java, although there are third parties who have made these work.
+@c APPLE LOCAL begin manual
+
@c man end
@c man begin SEEALSO
gpl(7), gfdl(7), fsf-funding(7),
@@ -48,9 +63,10 @@ and the Info entries for @file{gcc}, @file{cpp}, @file{g77}, @file{as},
@file{ld}, @file{binutils} and @file{gdb}.
@c man end
@c man begin BUGS
-For instructions on reporting bugs, see
-@w{@uref{http://gcc.gnu.org/bugs.html}}. Use of the @command{gccbug}
-script to report bugs is recommended.
+@c APPLE LOCAL begin report bugs to Apple
+To report bugs to Apple, see
+@w{@uref{http://developer.apple.com/bugreporter}}.
+@c APPLE LOCAL end report bugs to Apple
@c man end
@c man begin AUTHOR
See the Info entry for @command{gcc}, or
@@ -156,16 +172,40 @@ in the following sections.
@item Overall Options
@xref{Overall Options,,Options Controlling the Kind of Output}.
@gccoptlist{-c -S -E -o @var{file} -pipe -pass-exit-codes @gol
+@c APPLE LOCAL -ObjC 2001-08-03 sts **
+-ObjC (APPLE ONLY) -ObjC++ (APPLE ONLY) @gol
+@c APPLE LOCAL fat builds
+-arch @var{arch} (APPLE ONLY) @gol
-x @var{language} -v -### --help --target-help --version}
@item C Language Options
@xref{C Dialect Options,,Options Controlling C Dialect}.
@gccoptlist{-ansi -std=@var{standard} -aux-info @var{filename} @gol
+@c APPLE LOCAL AltiVec
+-faltivec (APPLE ONLY) @gol
-fno-asm -fno-builtin -fno-builtin-@var{function} @gol
-fhosted -ffreestanding -fms-extensions @gol
-trigraphs -no-integrated-cpp -traditional -traditional-cpp @gol
-fallow-single-precision -fcond-mismatch @gol
+@c APPLE LOCAL constant cfstrings mrs
+-fconstant-cfstrings (APPLE ONLY) @gol
+@c APPLE LOCAL pch distcc mrs
+-fpch-preprocess (APPLE ONLY) @gol
-fsigned-bitfields -fsigned-char @gol
+@c APPLE LOCAL Pascal strings 2001-07-05 zll **
+-fpascal-strings (APPLE ONLY) @gol
+@c APPLE LOCAL coalescing 2002-04-11 tur **
+-fcoalesce (APPLE ONLY) -fweak-coalesced (APPLE ONLY) @gol
+@c APPLE LOCAL -Wno-#warnings
+-Wno-#warnings (APPLE ONLY) @gol
+@c APPLE LOCAL -Wextra-tokens 2001-08-02 sts **
+-Wextra-tokens (APPLE ONLY) @gol
+@c APPLE LOCAL -Wpragma-once 2001-08-01 sts **
+-Wpragma-once (APPLE ONLY) @gol
+@c APPLE LOCAL -Wnewline-eof 2001-08-23 sts **
+-Wnewline-eof (APPLE ONLY) @gol
+@c APPLE LOCAL -Wno-altivec-long-deprecated ilr **
+-Wno-altivec-long-deprecated (APPLE ONLY)
-funsigned-bitfields -funsigned-char}
@item C++ Language Options
@@ -177,7 +217,14 @@ in the following sections.
-ffor-scope -fno-for-scope -fno-gnu-keywords @gol
-fno-implicit-templates @gol
-fno-implicit-inline-templates @gol
--fno-implement-inlines -fms-extensions @gol
+-fno-implement-inlines @gol
+@c APPLE LOCAL -findirect-virtual-calls 2001-10-30 sts **
+-findirect-virtual-calls (APPLE ONLY) @gol
+@c APPLE LOCAL -fapple-kext
+-fapple-kext (APPLE ONLY) @gol
+@c APPLE LOCAL coalescing 2002-04-11 tur **
+-fcoalesce-templates (APPLE ONLY) @gol
+-fms-extensions @gol
-fno-nonansi-builtins -fno-operator-names @gol
-fno-optional-diags -fpermissive @gol
-frepo -fno-rtti -fstats -ftemplate-depth-@var{n} @gol
@@ -214,15 +261,19 @@ in the following sections.
-Wconversion -Wno-deprecated-declarations @gol
-Wdisabled-optimization -Wno-div-by-zero -Wendif-labels @gol
-Werror -Werror-implicit-function-declaration @gol
--Wfloat-equal -Wformat -Wformat=2 @gol
+-Wfloat-equal -Wfour-char-constants -Wformat -Wformat=2 @gol
-Wno-format-extra-args -Wformat-nonliteral @gol
-Wformat-security -Wformat-y2k @gol
-Wimplicit -Wimplicit-function-declaration -Wimplicit-int @gol
-Wimport -Wno-import -Winit-self -Winline @gol
--Wno-invalid-offsetof -Winvalid-pch @gol
+-Wno-invalid-offsetof -Winvalid-pch -Winvalid-sr @gol
-Wlarger-than-@var{len} -Wlong-long @gol
+@c APPLE LOCAL -Wlong-double
+-Wno-long-double (APPLE ONLY) @gol
-Wmain -Wmissing-braces @gol
-Wmissing-format-attribute -Wmissing-noreturn @gol
+@c APPLE LOCAL -Wmost
+-Wmost (APPLE ONLY) @gol
-Wno-multichar -Wnonnull -Wpacked -Wpadded @gol
-Wparentheses -Wpointer-arith -Wredundant-decls @gol
-Wreturn-type -Wsequence-point -Wshadow @gol
@@ -270,7 +321,9 @@ in the following sections.
-p -pg -print-file-name=@var{library} -print-libgcc-file-name @gol
-print-multi-directory -print-multi-lib @gol
-print-prog-name=@var{program} -print-search-dirs -Q @gol
--save-temps -time}
+@c APPLE LOCAL Symbol Separation
+@c APPLE LOCAL -fsave-repository and -grepository
+-save-temps -time -fsave-repository=@var{location} -grepository}
@item Optimization Options
@xref{Optimize Options,,Options that Control Optimization}.
@@ -298,7 +351,7 @@ in the following sections.
-foptimize-sibling-calls -fprefetch-loop-arrays @gol
-fprofile-generate -fprofile-use @gol
-freduce-all-givs -fregmove -frename-registers @gol
--freorder-blocks -freorder-functions @gol
+-freorder-blocks -freorder-blocks-and-partition -freorder-functions @gol
-frerun-cse-after-loop -frerun-loop-opt @gol
-frounding-math -fschedule-insns -fschedule-insns2 @gol
-fno-sched-interblock -fno-sched-spec -fsched-spec-load @gol
@@ -338,6 +391,8 @@ in the following sections.
@item Linker Options
@xref{Link Options,,Options for Linking}.
@gccoptlist{@var{object-file-name} -l@var{library} @gol
+@c APPLE LOCAL radar 2466994 - -no-c++filt ilr
+-no-c++filt (APPLE ONLY) @gol
-nostartfiles -nodefaultlibs -nostdlib -pie @gol
-s -static -static-libgcc -shared -shared-libgcc -symbolic @gol
-Wl,@var{option} -Xlinker @var{option} @gol
@@ -345,7 +400,9 @@ in the following sections.
@item Directory Options
@xref{Directory Options,,Options for Directory Search}.
-@gccoptlist{-B@var{prefix} -I@var{dir} -I- -L@var{dir} -specs=@var{file}}
+@c APPLE LOCAL begin framework headers
+@gccoptlist{-B@var{prefix} -I@var{dir} -I- -L@var{dir} @gol
+-specs=@var{file} -F@var{dir} (APPLE ONLY)}
@item Target Options
@c I wrote this xref this way to avoid overfull hbox. -- rms
@@ -355,6 +412,9 @@ in the following sections.
@item Machine Dependent Options
@xref{Submodel Options,,Hardware Models and Configurations}.
+@c APPLE LOCAL prune man page
+@ignore
+
@emph{M680x0 Options}
@gccoptlist{-m68000 -m68020 -m68020-40 -m68020-60 -m68030 -m68040 @gol
-m68060 -mcpu32 -m5200 -m68881 -mbitfield -mc68000 -mc68020 @gol
@@ -425,6 +485,9 @@ in the following sections.
-mno-flush-trap -mflush-trap=@var{number} @gol
-G @var{num}}
+@c APPLE LOCAL prune man page
+@end ignore
+
@emph{RS/6000 and PowerPC Options}
@gccoptlist{-mcpu=@var{cpu-type} @gol
-mtune=@var{cpu-type} @gol
@@ -436,7 +499,8 @@ in the following sections.
-mnew-mnemonics -mold-mnemonics @gol
-mfull-toc -mminimal-toc -mno-fp-in-toc -mno-sum-in-toc @gol
-m64 -m32 -mxl-call -mno-xl-call -mpe @gol
--malign-power -malign-natural @gol
+@c APPLE LOCAL -malign-mac68k
+-malign-mac68k (APPLE ONLY) @gol
-msoft-float -mhard-float -mmultiple -mno-multiple @gol
-mstring -mno-string -mupdate -mno-update @gol
-mfused-madd -mno-fused-madd -mbit-align -mno-bit-align @gol
@@ -444,6 +508,8 @@ in the following sections.
-mno-relocatable -mrelocatable-lib -mno-relocatable-lib @gol
-mtoc -mno-toc -mlittle -mlittle-endian -mbig -mbig-endian @gol
-mdynamic-no-pic @gol
+@c APPLE LOCAL long-branch
+-mlong-branch (APPLE ONLY) @gol
-mprioritize-restricted-insns=@var{priority} @gol
-msched-costly-dep=@var{dependence_type} @gol
-minsert-sched-nops=@var{scheme} @gol
@@ -478,7 +544,10 @@ in the following sections.
-single_module -static -sub_library -sub_umbrella @gol
-twolevel_namespace -umbrella -undefined @gol
-unexported_symbols_list -weak_reference_mismatches @gol
--whatsloaded}
+-whatsloaded -F}
+
+@c APPLE LOCAL prune man page
+@ignore
@emph{MIPS Options}
@gccoptlist{-EL -EB -march=@var{arch} -mtune=@var{arch} @gol
@@ -499,6 +568,10 @@ in the following sections.
-mflush-func=@var{func} -mno-flush-func @gol
-mbranch-likely -mno-branch-likely}
+@c APPLE LOCAL prune man page
+@end ignore
+
+
@emph{i386 and x86-64 Options}
@gccoptlist{-mtune=@var{cpu-type} -march=@var{cpu-type} @gol
-mfpmath=@var{unit} @gol
@@ -514,6 +587,9 @@ in the following sections.
-mcmodel=@var{code-model} @gol
-m32 -m64}
+@c APPLE LOCAL prune man page
+@ignore
+
@emph{HPPA Options}
@gccoptlist{-march=@var{architecture-type} @gol
-mbig-switch -mdisable-fpregs -mdisable-indexing @gol
@@ -660,6 +736,8 @@ in the following sections.
-mmulti-cond-exec -mno-multi-cond-exec -mnested-cond-exec @gol
-mno-nested-cond-exec -mtomcat-stats @gol
-mcpu=@var{cpu}}
+@c APPLE LOCAL prune man page
+@end ignore
@item Code Generation Options
@xref{Code Gen Options,,Options for Code Generation Conventions}.
@@ -748,6 +826,15 @@ C++ source code which must be preprocessed. Note that in @samp{.cxx},
the last two letters must both be literally @samp{x}. Likewise,
@samp{.C} refers to a literal capital C@.
+@c APPLE LOCAL begin Objective-C++
+@item @var{file}.mm
+@itemx @var{file}.M
+Objective-C++ source code which must be preprocessed. (APPLE ONLY)
+
+@item @var{file}.mii
+Objective-C++ source code which should not be preprocessed. (APPLE ONLY)
+@c APPLE LOCAL end Objective-C++
+
@item @var{file}.hh
@itemx @var{file}.H
C++ header file to be turned into a precompiled header.
@@ -798,7 +885,9 @@ package body). Such files are also called @dfn{bodies}.
@c @var{file}.pas
@item @var{file}.s
-Assembler code.
+@c APPLE LOCAL preprocess .s files
+Assembler code. Apple's version of GCC runs the preprocessor
+on these files as well as those ending in @samp{.S}.
@item @var{file}.S
Assembler code which must be preprocessed.
@@ -821,6 +910,8 @@ the next @option{-x} option. Possible values for @var{language} are:
c c-header cpp-output
c++ c++-header c++-cpp-output
objective-c objective-c-header objc-cpp-output
+@c APPLE LOCAL Objective-C++
+objective-c++ (APPLE ONLY) objective-c++-header (APPLE ONLY)
assembler assembler-with-cpp
ada
f77 f77-cpp-input ratfor
@@ -834,6 +925,27 @@ Turn off any specification of a language, so that subsequent files are
handled according to their file name suffixes (as they are if @option{-x}
has not been used at all).
+@c APPLE LOCAL begin -ObjC 2001-08-03 sts **
+@item -ObjC
+@item -ObjC++
+@opindex ObjC
+@opindex ObjC++
+These are similar in effect to @option{-x objective-c} and @option{-x
+objective-c++}, but affect only the choice of compiler for files already
+identified as source files. (APPLE ONLY)
+@c APPLE LOCAL end -ObjC 2001-08-03 sts **
+
+@c APPLE LOCAL begin fat builds
+@item -arch @var{arch}
+Compile for the specified target architecture @var{arch}. The allowable
+values are @samp{i386} and @samp{ppc}. Multiple options work, and
+direct the compiler to produce ``fat'' binaries including object code
+for each architecture specified with @option{-arch}. This option only
+works if assembler and libraries are available for each architecture
+specified. (APPLE ONLY)
+@opindex arch
+@c APPLE LOCAL end fat builds
+
@item -pass-exit-codes
@opindex pass-exit-codes
Normally the @command{gcc} program will exit with the code of 1 if any
@@ -1088,6 +1200,16 @@ character). In the case of function definitions, a K&R-style list of
arguments followed by their declarations is also provided, inside
comments, after the declaration.
+@c APPLE LOCAL begin AltiVec
+@item -faltivec
+Enable the AltiVec language extensions, as defined in Motorola's AltiVec
+PIM. This includes the recognition of @code{vector} and @code{pixel} as
+(context-dependent) keywords, the definition of built-in functions such
+as @code{vec_add}, and other extensions. Note that unlike the option
+@samp{-maltivec}, the extensions do not require the inclusion of any
+special header files. (APPLE ONLY)
+@c APPLE LOCAL end AltiVec
+
@item -fno-asm
@opindex fno-asm
Do not recognize @code{asm}, @code{inline} or @code{typeof} as a
@@ -1195,6 +1317,12 @@ Allow conditional expressions with mismatched types in the second and
third arguments. The value of such an expression is void. This option
is not supported for C++.
+@c APPLE LOCAL BEGIN pch distcc mrs
+@item -fpch-preprocess
+@opindex fpch-preprocess
+Enable PCH processing even when @option{-E} or @option{-save-temps} is used.
+@c APPLE LOCAL END pch distcc mrs
+
@item -funsigned-char
@opindex funsigned-char
Let the type @code{char} be unsigned, like @code{unsigned char}.
@@ -1234,6 +1362,37 @@ These options control whether a bit-field is signed or unsigned, when the
declaration does not use either @code{signed} or @code{unsigned}. By
default, such a bit-field is signed, because this is consistent: the
basic integer types such as @code{int} are signed types.
+
+@c APPLE LOCAL begin constant cfstrings
+@item -fconstant-cfstrings
+@opindex fconstant-cfstrings
+Enable the automatic creation of a CoreFoundation-type constant string
+whenever a special builtin @code{__builtin__CFStringMakeConstantString}
+is called on a literal string. (APPLE ONLY)
+@c APPLE LOCAL end constant cfstrings
+
+@c APPLE LOCAL begin Pascal strings 2001-07-05 zll **
+@item -fpascal-strings
+Allow Pascal-style string literals to be constructed. (APPLE ONLY)
+
+@xref{Pascal Strings,,Constructing String Literals with a Pascal-style
+Length Byte}, for more information on the syntax and semantics of Pascal
+string literals.
+@c APPLE LOCAL end Pascal strings 2001-07-05 zll **
+
+@c APPLE LOCAL begin coalescing 2002-04-11 turly **
+@item -fcoalesce
+@opindex fcoalesce
+Coalesce duplicated functions and data. The linker will discard all
+but one, saving space. Enabled by default. (APPLE ONLY)
+
+@item -fweak-coalesced
+@opindex fweak-coalesced
+Use the new OS X "weak_definitions" section attribute for coalesced items.
+A single "normal" definition will be chosen by the linker over any number
+of weakly-coalesced ones. (APPLE ONLY)
+@c APPLE LOCAL end coalescing 2002-04-11 turly **
+
@end table
@node C++ Dialect Options
@@ -1365,6 +1524,30 @@ To save space, do not emit out-of-line copies of inline functions
controlled by @samp{#pragma implementation}. This will cause linker
errors if these functions are not inlined everywhere they are called.
+@c APPLE LOCAL begin -findirect-virtual-calls 2001-10-30 sts **
+@item -findirect-virtual-calls
+@opindex findirect-virtual-calls
+Do not make direct calls to virtual functions; instead, always
+go through the vtable. (APPLE ONLY)
+@c APPLE LOCAL end -findirect-virtual-calls 2001-10-30 sts **
+
+@c APPLE LOCAL begin -fapple-kext
+@item -fapple-kext
+@opindex fapple-kext
+Alter vtables, destructors, and other implementation details to more
+closely resemble the GCC 2.95 ABI. This is to make kernel extensions
+loadable by Darwin kernels, and is required to build any Darwin kernel
+extension. @option{-fno-exceptions} and @option{-static} must also be
+used with this flag. (APPLE ONLY)
+@c APPLE LOCAL end -fapple-kext
+
+@c APPLE LOCAL begin coalescing 2002-04-11 turly **
+@item -fcoalesce-templates
+@opindex fcoalesce-templates
+Mark instantiated templates as "coalesced": the linker will discard
+all but one, thus saving space. (APPLE ONLY)
+@c APPLE LOCAL end coalescing 2002-04-11 turly **
+
@item -fms-extensions
@opindex fms-extensions
Disable pedantic warnings about constructs used in MFC, such as implicit
@@ -1428,6 +1611,8 @@ Register destructors for objects with static storage duration with the
This option is required for fully standards-compliant handling of static
destructors, but will only work if your C library supports
@code{__cxa_atexit}.
+@c APPLE LOCAL manual
+This option is not supported on Mac OS X.
@item -fno-weak
@opindex fno-weak
@@ -2060,6 +2245,37 @@ Inhibit all warning messages.
@opindex Wno-import
Inhibit warning messages about the use of @samp{#import}.
+@c APPLE LOCAL begin -Wno-#warnings
+@item -Wno-#warnings
+@opindex Wno-#warnings
+Inhibit warning messages issued by @samp{#warning}.
+@c APPLE LOCAL end -Wno-#warnings
+
+@c APPLE LOCAL begin -Wpragma-once 2001-08-01 sts **
+@item -Wpragma-once
+@opindex Wpragma-once
+Warn about the use of @samp{#pragma once}. (APPLE ONLY)
+@c APPLE LOCAL end -Wpragma-once 2001-08-01 sts **
+
+@c APPLE LOCAL begin -Wextra-tokens 2001-08-02 sts **
+@item -Wextra-tokens
+@opindex Wextra-tokens
+Warn about extra tokens at the end of prepreprocessor directives. (APPLE ONLY)
+@c APPLE LOCAL end -Wextra-tokens 2001-08-02 sts **
+
+@c APPLE LOCAL begin -Wnewline-eof 2001-08-23 sts **
+@item -Wnewline-eof
+@opindex Wnewline-eof
+Warn about files missing a newline at the end of the file. (APPLE ONLY)
+@c APPLE LOCAL end -Wnewline-eof 2001-08-23 sts **
+
+@c APPLE LOCAL begin -Wno-altivec-long-deprecated ilr **
+@item -Wno-altivec-long-deprecated
+@opindex Wno-altivec-long-deprecated
+Do not warn about the use of the deprecated 'long' keyword in
+AltiVec data types. (APPLE ONLY)
+@c APPLE LOCAL end -Wno-altivec-long-deprecated ilr **
+
@item -Wchar-subscripts
@opindex Wchar-subscripts
Warn if an array subscript has type @code{char}. This is a common cause
@@ -2479,6 +2695,11 @@ that are easy to avoid (or modify to prevent the warning), even in
conjunction with macros. This also enables some language-specific
warnings described in @ref{C++ Dialect Options} and
@ref{Objective-C Dialect Options}.
+
+@c APPLE LOCAL -Wmost
+@item -Wmost
+@opindex Wmost
+This is equivalent to -Wall -Wno-parentheses. (APPLE ONLY)
@end table
The following @option{-W@dots{}} options are not implied by @option{-Wall}.
@@ -2635,6 +2856,13 @@ would check to see whether the two values have ranges that overlap; and
this is done with the relational operators, so equality comparisons are
probably mistaken.
+@c APPLE LOCAL begin four char constants
+@item -Wfour-char-constants
+@opindex Wfour-char-constants
+Warn about four char constants, e.g. OSType 'APPL'. This warning is
+disabled by default.
+@c APPLE LOCAL end four char constants
+
@item -Wtraditional @r{(C only)}
@opindex Wtraditional
Warn about certain constructs that behave differently in traditional and
@@ -2861,12 +3089,16 @@ case, and some functions for which @code{format} attributes are
appropriate may not be detected. This option has no effect unless
@option{-Wformat} is enabled (possibly by @option{-Wall}).
+@c APPLE LOCAL Begin -Wfour-char-constants
@item -Wno-multichar
@opindex Wno-multichar
@opindex Wmultichar
Do not warn if a multicharacter constant (@samp{'FOOF'}) is used.
Usually they indicate a typo in the user's code, as they have
implementation-defined values, and should not be used in portable code.
+This flag does not control warning for a constant with four character,
+instead -Wfour-char-constants controls it.
+@c APPLE LOCAL End -Wfour-char-constants
@item -Wno-deprecated-declarations
@opindex Wno-deprecated-declarations
@@ -2968,6 +3200,19 @@ of the C++ standard.
Warn if a precompiled header (@pxref{Precompiled Headers}) is found in
the search path but can't be used.
+@c APPLE LOCAL Begin Symbol Separation
+@item -Winvalid-sr
+@opindex Winvalid-sr
+Warn if a symbol repository is found in the search path but can't be
+used.
+@c APPLE LOCAL End Symbol Separation
+
+@c APPLE LOCAL begin -Wlong-double
+@item -Wno-long-double
+@opindex Wno-long-double
+Inhibit warning if the @samp{long double} type is used. (APPLE ONLY)
+@c APPLE LOCAL end -Wlong-double
+
@item -Wlong-long
@opindex Wlong-long
@opindex Wno-long-long
@@ -3017,8 +3262,9 @@ debugging information that only GDB can use; this extra information
makes debugging work better in GDB but will probably make other debuggers
crash or
refuse to read the program. If you want to control for certain whether
-to generate the extra information, use @option{-gstabs+}, @option{-gstabs},
-@option{-gxcoff+}, @option{-gxcoff}, or @option{-gvms} (see below).
+@c APPLE LOCAL prune man page
+to generate the extra information, use @option{-gstabs+} or @option{-gstabs}
+(see below).
Unlike most other C compilers, GCC allows you to use @option{-g} with
@option{-O}. The shortcuts taken by optimized code may occasionally
@@ -3061,6 +3307,11 @@ using GNU extensions understood only by the GNU debugger (GDB)@. The
use of these extensions is likely to make other debuggers crash or
refuse to read the program.
+@c APPLE LOCAL prune man page
+(Other debug formats, such as @option{-gcoff}, are not supported in
+Darwin or Mac OS X.)
+@ignore
+
@item -gcoff
@opindex gcoff
Produce debugging information in COFF format (if that is supported).
@@ -3090,12 +3341,19 @@ supported). This is the format used by DBX on IRIX 6.
Produce debugging information in VMS debug format (if that is
supported). This is the format used by DEBUG on VMS systems.
+@c APPLE LOCAL prune man page
+@end ignore
+
@item -g@var{level}
@itemx -ggdb@var{level}
@itemx -gstabs@var{level}
+@c APPLE LOCAL prune man page
+@ignore
@itemx -gcoff@var{level}
@itemx -gxcoff@var{level}
@itemx -gvms@var{level}
+@c APPLE LOCAL prune man page
+@end ignore
Request debugging information and also use @var{level} to specify how
much information. The default level is 2.
@@ -3619,6 +3877,19 @@ executing the program itself. The second number is ``system time,''
time spent executing operating system routines on behalf of the program.
Both numbers are in seconds.
+@c APPLE LOCAL begin Symbol Separation
+@item -fsave-repository=@var{location}
+@opindex fsave-repository
+Creates separate symbol repository at @var{location} for given input
+header file. Separate repository contains only debugging symbols in
+stabs format.
+
+@item -grepository
+@opindex grepository
+Instructs compiler to use separate symbol repository with debugging
+symbols. Compiler searches for such repositories in include paths.
+@c APPLE LOCAL end Symbol Separation
+
@item -fvar-tracking
@opindex fvar-tracking
Run variable tracking pass. It computes where variables are stored at each
@@ -3795,6 +4066,12 @@ also turns on the following optimization flags:
Please note the warning under @option{-fgcse} about
invoking @option{-O2} on programs that use computed gotos.
+@c APPLE LOCAL begin optimization
+In Apple's version of GCC, @option{-fstrict-aliasing},
+@option{-freorder-blocks}, and @option{-fsched-interblock}
+are disabled by default when optimizing.
+@c APPLE LOCAL end optimization
+
@item -O3
@opindex O3
Optimize yet more. @option{-O3} turns on all optimizations specified by
@@ -3813,7 +4090,7 @@ optimizations designed to reduce code size.
@option{-Os} disables the following optimization flags:
@gccoptlist{-falign-functions -falign-jumps -falign-loops @gol
--falign-labels -freorder-blocks -fprefetch-loop-arrays}
+-falign-labels -freorder-blocks -freorder-blocks-and-partition -fprefetch-loop-arrays}
If you use multiple @option{-O} options, with or without level numbers,
the last such option is the one that is effective.
@@ -4438,6 +4715,15 @@ taken branches and improve code locality.
Enabled at levels @option{-O2}, @option{-O3}.
+ Enabled at levels @option{-O2}, @option{-O3}.
+
+@item -freorder-blocks-and-partition
+@opindex freorder-blocks-and-partition
+In addition to reordering basic blocks in the compiled function, in order
+to reduce number of taken branches, partitions hot and cold basic blocks
+into separate sections of the assembly and .o files, to improve
+paging and cache locality performance.
+
@item -freorder-functions
@opindex freorder-functions
Reorder basic blocks in the compiled function in order to reduce number of
@@ -5169,6 +5455,14 @@ The @option{reorder-block-duplicate-feedback} is used only when profile
feedback is available and may be set to higher values than
@option{reorder-block-duplicate} since information about the hot spots is more
accurate.
+
+@item max-sched-region-blocks
+The maximum number of blocks in a region to be considered for
+interblock scheduling. The default value is 10.
+
+@item max-sched-region-insns",
+The maximum number of insns in a region to be considered for
+interblock scheduling. The default value is 100.
@end table
@end table
@@ -5241,6 +5535,15 @@ These options come into play when the compiler links object files into
an executable output file. They are meaningless if the compiler is
not doing a link step.
+@c APPLE LOCAL begin linker flags
+In addition to the options listed below, Apple's GCC also accepts and
+passes nearly all of the options defined by the linker @samp{ld} and by
+the library tool @samp{libtool}. Common options include
+@samp{-framework}, @samp{-dynamic}, @samp{-bundle},
+@samp{-flat_namespace}, and so forth. See the ld and libtool man pages
+for further details.
+@c APPLE LOCAL end linker flags
+
@table @gcctabopt
@cindex file names
@item @var{object-file-name}
@@ -5322,6 +5625,12 @@ BSD environments. These entries are usually resolved by entries in
libc. These entry points should be supplied through some other
mechanism when this option is specified.
+@c APPLE LOCAL begin radar 2466994 - -no-c++filt ilr
+@item -no-c++filt
+By default all linker diagnostic output is piped through c++filt.
+This option suppresses that behavior. (APPLE ONLY)
+@c APPLE LOCAL end radar 2466994 - -no-c++filt ilr
+
@cindex @option{-lgcc}, use with @option{-nostdlib}
@cindex @option{-nostdlib} and unresolved references
@cindex unresolved references and @option{-nostdlib}
@@ -5359,6 +5668,12 @@ Remove all symbol table and relocation information from the executable.
On systems that support dynamic linking, this prevents linking with the shared
libraries. On other systems, this option has no effect.
+@c APPLE LOCAL manual
+This option will not work on Mac OS X unless all libraries (including
+@file{libgcc.a}) have also been compiled with @option{-static}. Since
+neither a static version of libSystem.dylib nor crt0.o are provided, this
+option is not useful to most people.
+
@item -shared
@opindex shared
Produce a shared object which can then be linked with other objects to
@@ -5372,6 +5687,9 @@ libraries to link against. Failing to supply the correct flags may lead
to subtle defects. Supplying them in cases where they are not necessary
is innocuous.}
+@c APPLE LOCAL manual
+This option is not supported on Mac OS X.
+
@item -shared-libgcc
@itemx -static-libgcc
@opindex shared-libgcc
@@ -5499,6 +5817,23 @@ independent.
Add directory @var{dir} to the list of directories to be searched
for @option{-l}.
+@c APPLE LOCAL begin framework headers
+@item -F@var{dir}
+@opindex F
+In Apple's version of GCC only, add the directory @var{dir} to the head
+of the list of directories to be searched for frameworks.
+
+The framework search algorithm is, for an inclusion of
+@samp{<Fmwk/Header.h>}, to look for files named
+@file{@var{path}/Fmwk.framework/Headers/Header.h} or
+@file{@var{path}/Fmwk.framework/PrivateHeaders/Header.h} where
+@var{path} includes @file{/System/Library/Frameworks/}
+@file{/Library/Frameworks/}, and @file{/Local/Library/Frameworks/}, plus
+any additional paths specified by @option{-F}.
+
+All the @option{-F} options are also passed to the linker.
+@c APPLE LOCAL end framework headers
+
@item -B@var{prefix}
@opindex B
This option specifies where to find the executables, libraries,
@@ -6119,6 +6454,8 @@ machine description. The default for the options is also defined by
that macro, which enables you to change the defaults.
@menu
+@c APPLE LOCAL prune man page
+@ignore
* M680x0 Options::
* M68hc1x Options::
* VAX Options::
@@ -6126,10 +6463,18 @@ that macro, which enables you to change the defaults.
* ARM Options::
* MN10300 Options::
* M32R/D Options::
+@c APPLE LOCAL prune man page
+@end ignore
* RS/6000 and PowerPC Options::
* Darwin Options::
+@c APPLE LOCAL prune man page
+@ignore
* MIPS Options::
+@c APPLE LOCAL prune man page
+@end ignore
* i386 and x86-64 Options::
+@c APPLE LOCAL prune man page
+@ignore
* HPPA Options::
* DEC Alpha Options::
* DEC Alpha/VMS Options::
@@ -6150,8 +6495,12 @@ that macro, which enables you to change the defaults.
* Xstormy16 Options::
* Xtensa Options::
* FRV Options::
+@c APPLE LOCAL prune man page
+@end ignore
@end menu
+@c APPLE LOCAL prune man page
+@ignore
@node M680x0 Options
@subsection M680x0 Options
@cindex M680x0 options
@@ -6622,6 +6971,32 @@ With @option{-mvis}, GCC generates code that takes advantage of the UltraSPARC
Visual Instruction Set extensions. The default is @option{-mno-vis}.
@end table
+These @samp{-m} switches are supported in addition to the above
+on the SPARCLET processor.
+
+@table @gcctabopt
+@item -mlittle-endian
+@opindex mlittle-endian
+Generate code for a processor running in little-endian mode.
+
+@item -mlive-g0
+@opindex mlive-g0
+Treat register @code{%g0} as a normal register.
+GCC will continue to clobber it as necessary but will not assume
+it always reads as 0.
+
+@item -mbroken-saverestore
+@opindex mbroken-saverestore
+Generate code that does not use non-trivial forms of the @code{save} and
+@code{restore} instructions. Early versions of the SPARCLET processor do
+not correctly handle @code{save} and @code{restore} instructions used with
+arguments. They correctly handle them used without arguments. A @code{save}
+instruction used without arguments increments the current window pointer
+but does not allocate a new stack frame. It is assumed that the window
+overflow trap handler will properly handle this case as will interrupt
+handlers.
+@end table
+
These @samp{-m} options are supported in addition to the above
on SPARC-V9 processors in 64-bit environments:
@@ -6712,7 +7087,8 @@ and conforming to the function calling standards for the APCS 32-bit
option. This option replaces the @option{-m6} option of previous releases
of the compiler.
-@ignore
+@c APPLE LOCAL prune man page
+@c @ignore
@c not currently implemented
@item -mapcs-stack-check
@opindex mapcs-stack-check
@@ -6739,7 +7115,8 @@ size if @option{-mapcs-float} is used.
@opindex mapcs-reentrant
Generate reentrant, position independent code. The default is
@option{-mno-apcs-reentrant}.
-@end ignore
+@c APPLE LOCAL prune man page
+@c @end ignore
@item -mthumb-interwork
@opindex mthumb-interwork
@@ -7198,6 +7575,9 @@ Indicates that there is no OS function for flushing the cache.
@end table
+@c APPLE LOCAL prune man page
+@end ignore
+
@node RS/6000 and PowerPC Options
@subsection IBM RS/6000 and PowerPC Options
@cindex RS/6000 and PowerPC Options
@@ -7321,6 +7701,9 @@ The other options specify a specific processor. Code generated under
those options will run best on that processor, and may not run at all on
others.
+The @option{-mcpu} options automatically enable or disable other
+@option{-m} options as follows:
+
The @option{-mcpu} options automatically enable or disable the
following options: @option{-maltivec}, @option{-mhard-float},
@option{-mmfcrf}, @option{-mmultiple}, @option{-mnew-mnemonics},
@@ -7358,6 +7741,9 @@ allow access to the AltiVec instruction set. You may also need to set
@option{-mabi=altivec} to adjust the current ABI with AltiVec ABI
enhancements.
+@c APPLE LOCAL manual
+This option is not supported on Mac OS X; use @option{-faltivec} instead.
+
@item -mabi=spe
@opindex mabi=spe
Extend the current ABI with SPE ABI extensions. This does not change
@@ -7465,6 +7851,14 @@ types, such as floating-point doubles, on their natural size-based boundary.
The option @option{-malign-power} instructs GCC to follow the ABI-specified
alignment rules. GCC defaults to the standard alignment defined in the ABI.
+@c APPLE LOCAL begin -malign-mac68k
+@item -malign-mac68k
+@opindex malign-mac68k
+The option @option{-malign-mac68k} causes structure fields to be aligned
+on 2-byte boundaries, in order to be compatible with m68k compiler
+output. (APPLE ONLY)
+@c APPLE LOCAL end -malign-mac68k
+
@item -msoft-float
@itemx -mhard-float
@opindex msoft-float
@@ -7589,6 +7983,14 @@ relocatable, but that its external references are relocatable. The
resulting code is suitable for applications, but not shared
libraries.
+@c APPLE LOCAL begin long-branch
+@item -mlong-branch
+@opindex mlong-branch
+On Darwin and Mac OS X systems, compile calls to use a 32-bit
+destination address. This is to support kernel extensions, which may
+load anywhere within the kernel address space. (APPLE ONLY)
+@c APPLE LOCAL end long-branch
+
@item -mprioritize-restricted-insns=@var{priority}
@opindex mprioritize-restricted-insns
This option controls the priority that is assigned to
@@ -7672,10 +8074,16 @@ Extend the current ABI with AltiVec ABI extensions. This does not
change the default ABI, instead it adds the AltiVec ABI extensions to
the current ABI@.
+@c APPLE LOCAL manual
+This option is effectively permanently enabled on Mac OS X.
+
@item -mabi=no-altivec
@opindex mabi=no-altivec
Disable AltiVec ABI extensions for the current ABI.
+@c APPLE LOCAL manual
+This option will not work on Mac OS X.
+
@item -mprototype
@itemx -mno-prototype
@opindex mprototype
@@ -7855,6 +8263,34 @@ These options are defined for all architectures running the Darwin operating
system. They are useful for compatibility with other Mac OS compilers.
@table @gcctabopt
+@item -F@var{dir}
+@opindex F
+Add the framework directory @var{dir} to the head of the list of
+directories to be searched for header files. These directories are
+interleaved with those specified by @option{-I} options and are
+scanned in a left-to-right order.
+
+A framework directory is a directory with frameworks in it. A
+framework is a directory with a @samp{"Headers"} and/or
+@samp{"PrivateHeaders"} directory contained directly in it that ends
+in @samp{".framework"}. The name of a framework is the name of this
+directory excluding the @samp{".framework"}. Headers associated with
+the framework are found in one of those two directories, with
+@samp{"Headers"} being searched first. A subframework is a framework
+directory that is in a framework's @samp{"Frameworks"} directory.
+Includes of subframework headers can only appear in a header of a
+framework that contains the subframework, or in a sibling subframework
+header. Two subframeworks are siblings if they occur in the same
+framework. A subframework should not have the same name as a
+framework, a warning will be issued if this is violated. Currently a
+subframework cannot have subframeworks, in the future, the mechanism
+may be extended to support this. The standard frameworks can be found
+in @samp{"/System/Library/Frameworks"}, @samp{"/Library/Frameworks"}
+and @samp{"/Local/Library/Frameworks"}. An example include looks like
+@code{#include <Framework/header.h>}, where @samp{Framework} denotes
+the name of the framework and header.h is found in the
+@samp{"PrivateHeaders"} or @samp{"Headers"} directory.
+
@item -all_load
@opindex all_load
Loads all members of static archive libraries.
@@ -8000,6 +8436,9 @@ describes them in detail.
@end table
+@c APPLE LOCAL prune man page
+@ignore
+
@node MIPS Options
@subsection MIPS Options
@cindex MIPS options
@@ -8382,6 +8821,9 @@ Likely instructions will not be generated by default because the MIPS32
and MIPS64 architectures specifically deprecate their use.
@end table
+@c APPLE LOCAL prune man page
+@end ignore
+
@node i386 and x86-64 Options
@subsection Intel 386 and AMD x86-64 Options
@cindex i386 Options
@@ -8821,6 +9263,9 @@ about addresses and sizes of sections. Currently GCC does not implement
this model.
@end table
+@c APPLE LOCAL prune man page
+@ignore
+
@node HPPA Options
@subsection HPPA Options
@cindex HPPA Options
@@ -9064,6 +9509,120 @@ under HP-UX. This option sets flags for both the preprocessor and
linker.
@end table
+@node Intel 960 Options
+@subsection Intel 960 Options
+
+These @samp{-m} options are defined for the Intel 960 implementations:
+
+@table @gcctabopt
+@item -m@var{cpu-type}
+@opindex mka
+@opindex mkb
+@opindex mmc
+@opindex mca
+@opindex mcf
+@opindex msa
+@opindex msb
+Assume the defaults for the machine type @var{cpu-type} for some of
+the other options, including instruction scheduling, floating point
+support, and addressing modes. The choices for @var{cpu-type} are
+@samp{ka}, @samp{kb}, @samp{mc}, @samp{ca}, @samp{cf},
+@samp{sa}, and @samp{sb}.
+The default is
+@samp{kb}.
+
+@item -mnumerics
+@itemx -msoft-float
+@opindex mnumerics
+@opindex msoft-float
+The @option{-mnumerics} option indicates that the processor does support
+floating-point instructions. The @option{-msoft-float} option indicates
+that floating-point support should not be assumed.
+
+@item -mleaf-procedures
+@itemx -mno-leaf-procedures
+@opindex mleaf-procedures
+@opindex mno-leaf-procedures
+Do (or do not) attempt to alter leaf procedures to be callable with the
+@code{bal} instruction as well as @code{call}. This will result in more
+efficient code for explicit calls when the @code{bal} instruction can be
+substituted by the assembler or linker, but less efficient code in other
+cases, such as calls via function pointers, or using a linker that doesn't
+support this optimization.
+
+@item -mtail-call
+@itemx -mno-tail-call
+@opindex mtail-call
+@opindex mno-tail-call
+Do (or do not) make additional attempts (beyond those of the
+machine-independent portions of the compiler) to optimize tail-recursive
+calls into branches. You may not want to do this because the detection of
+cases where this is not valid is not totally complete. The default is
+@option{-mno-tail-call}.
+
+@item -mcomplex-addr
+@itemx -mno-complex-addr
+@opindex mcomplex-addr
+@opindex mno-complex-addr
+Assume (or do not assume) that the use of a complex addressing mode is a
+win on this implementation of the i960. Complex addressing modes may not
+be worthwhile on the K-series, but they definitely are on the C-series.
+The default is currently @option{-mcomplex-addr} for all processors except
+the CB and CC@.
+
+@item -mcode-align
+@itemx -mno-code-align
+@opindex mcode-align
+@opindex mno-code-align
+Align code to 8-byte boundaries for faster fetching (or don't bother).
+Currently turned on by default for C-series implementations only.
+
+@c APPLE LOCAL prune man page
+@c @ignore
+@item -mclean-linkage
+@itemx -mno-clean-linkage
+@opindex mclean-linkage
+@opindex mno-clean-linkage
+These options are not fully implemented.
+@c APPLE LOCAL prune man page
+@c @end ignore
+
+@item -mic-compat
+@itemx -mic2.0-compat
+@itemx -mic3.0-compat
+@opindex mic-compat
+@opindex mic2.0-compat
+@opindex mic3.0-compat
+Enable compatibility with iC960 v2.0 or v3.0.
+
+@item -masm-compat
+@itemx -mintel-asm
+@opindex masm-compat
+@opindex mintel-asm
+Enable compatibility with the iC960 assembler.
+
+@item -mstrict-align
+@itemx -mno-strict-align
+@opindex mstrict-align
+@opindex mno-strict-align
+Do not permit (do permit) unaligned accesses.
+
+@item -mold-align
+@opindex mold-align
+Enable structure-alignment compatibility with Intel's gcc release version
+1.3 (based on gcc 1.37). This option implies @option{-mstrict-align}.
+
+@item -mlong-double-64
+@opindex mlong-double-64
+Implement type @samp{long double} as 64-bit floating point numbers.
+Without the option @samp{long double} is implemented by 80-bit
+floating point numbers. The only reason we have it because there is
+no 128-bit @samp{long double} support in @samp{fp-bit.c} yet. So it
+is only useful for people using soft-float targets. Otherwise, we
+should recommend against use of it.
+
+@end table
+
@node DEC Alpha Options
@subsection DEC Alpha Options
@@ -9691,9 +10250,11 @@ instruction, it is disabled by default.
@opindex mloop-unsigned
@opindex mno-loop-unsigned
The maximum iteration count when using RPTS and RPTB (and DB on the C40)
-is @math{2^{31} + 1} since these instructions test if the iteration count is
+@c APPLE LOCAL work around a makeinfo complaint
+is @math{2^31 + 1} since these instructions test if the iteration count is
negative to terminate the loop. If the iteration count is unsigned
-there is a possibility than the @math{2^{31} + 1} maximum iteration count may be
+@c APPLE LOCAL work around a makeinfo complaint
+there is a possibility than the @math{2^31 + 1} maximum iteration count may be
exceeded. This switch allows an unsigned iteration count.
@item -mti
@@ -11013,6 +11574,9 @@ instructions. Note that the assembler will use an indirect call for
every cross-file call, not just those that really will be out of range.
@end table
+@c APPLE LOCAL prune man page
+@end ignore
+
@node Code Gen Options
@section Options for Code Generation Conventions
@cindex code generation conventions
@@ -11210,6 +11774,9 @@ only on certain machines. For the 386, GCC supports PIC for System V
but not for the Sun 386i. Code generated for the IBM RS/6000 is always
position-independent.
+@c APPLE LOCAL manual
+@option{-fpic} is not supported on Mac OS X.
+
@item -fPIC
@opindex fPIC
If supported for the target machine, emit position-independent code,
@@ -11220,6 +11787,9 @@ and the SPARC.
Position-independent code requires special support, and therefore works
only on certain machines.
+@c APPLE LOCAL manual
+@option{-fPIC} is the default on Darwin and Mac OS X.
+
@item -fpie
@itemx -fPIE
@opindex fpie
diff --git a/gcc/doc/rtl.texi b/gcc/doc/rtl.texi
index 533b0b9add5..c5e8d33c15b 100644
--- a/gcc/doc/rtl.texi
+++ b/gcc/doc/rtl.texi
@@ -3285,6 +3285,16 @@ This insn uses @var{op}, a @code{code_label} or a @code{note} of type
be held in a register. The presence of this note allows jump
optimization to be aware that @var{op} is, in fact, being used, and flow
optimization to build an accurate flow graph.
+
+@findex REG_CROSSING_JUMP
+@item REG_CROSSING_JUMP
+This insn is an branching instruction (either an unconditional jump or
+an indirect jump) which crosses between hot and cold sections, which
+could potentially be very far apart in the executable. The presence
+of this note indicates to other optimizations that this this branching
+instruction should not be ``collapsed'' into a simpler branching
+construct. It is used when the optimization to partition basic blocks
+into hot and cold sections is turned on.
@end table
The following notes describe attributes of outputs of an insn:
diff --git a/gcc/doc/tm.texi b/gcc/doc/tm.texi
index b5f11408dd0..9f5f87f8fe8 100644
--- a/gcc/doc/tm.texi
+++ b/gcc/doc/tm.texi
@@ -5755,6 +5755,13 @@ frequently executed functions of the program. If not defined, GCC will provide
a default definition if the target supports named sections.
@end defmac
+@defmac NORMAL_TEXT_SECTION_NAME
+If defined, a C string constant for the name of the section containing code
+that does not go into the ``unlikely executed text'' partition. This is used
+as part of the optimization that partitions hot and cold basic blocks into
+separate sections in the .o and executable files.
+@end defmac
+
@defmac UNLIKELY_EXECUTED_TEXT_SECTION_NAME
If defined, a C string constant for the name of the section containing unlikely
executed functions in the program.
@@ -5806,6 +5813,12 @@ finalization code. If not defined, GCC will assume such a section does
not exist.
@end defmac
+@defmac SECTION_FORMAT_STRING
+If defined, format string used by fprintf to write out the
+text section headers for the hot and cold sections of the
+assembly file, when hot and cold partitioning is being performed.
+@end defmac
+
@defmac CRT_CALL_STATIC_FUNCTION (@var{section_op}, @var{function})
If defined, an ASM statement that switches to a different section
via @var{section_op}, calls @var{function}, and switches back to
@@ -8378,6 +8391,24 @@ For each predicate function named in @code{PREDICATE_CODES}, a
declaration will be generated in @file{insn-codes.h}.
@end defmac
+@defmac HAS_LONG_COND_BRANCH
+Define this boolean macro to indicate whether or not your architecture
+has conditional branches that can span all of memory. It is used in
+conjunction with an optimization that partitions hot and cold basic
+blocks into separate sections of the executable. If this macro is
+set to false, gcc will convert any conditional branches that attempt
+to cross between sections into unconditional branches or indirect jumps.
+@end defmac
+
+@defmac HAS_LONG_UNCOND_BRANCH
+Define this boolean macro to indicate whether or not your architecture
+has unconditional branches that can span all of memory. It is used in
+conjunction with an optimization that partitions hot and cold basic
+blocks into separate sections of the executable. If this macro is
+set to false, gcc will convert any unconditional branches that attempt
+to cross between sections into indirect jumps.
+@end defmac
+
@defmac SPECIAL_MODE_PREDICATES
Define this if you have special predicates that know special things
about modes. Genrecog will warn about certain forms of
diff --git a/gcc/doloop.c b/gcc/doloop.c
deleted file mode 100644
index ba3137169e7..00000000000
--- a/gcc/doloop.c
+++ /dev/null
@@ -1,887 +0,0 @@
-/* Perform doloop optimizations
- Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004
- Free Software Foundation, Inc.
- Contributed by Michael P. Hayes (m.hayes@elec.canterbury.ac.nz)
-
-This file is part of GCC.
-
-GCC is free software; you can redistribute it and/or modify it under
-the terms of the GNU General Public License as published by the Free
-Software Foundation; either version 2, or (at your option) any later
-version.
-
-GCC is distributed in the hope that it will be useful, but WITHOUT ANY
-WARRANTY; without even the implied warranty of MERCHANTABILITY or
-FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
-for more details.
-
-You should have received a copy of the GNU General Public License
-along with GCC; see the file COPYING. If not, write to the Free
-Software Foundation, 59 Temple Place - Suite 330, Boston, MA
-02111-1307, USA. */
-
-#include "config.h"
-#include "system.h"
-#include "coretypes.h"
-#include "tm.h"
-#include "rtl.h"
-#include "flags.h"
-#include "expr.h"
-#include "loop.h"
-#include "hard-reg-set.h"
-#include "basic-block.h"
-#include "toplev.h"
-#include "tm_p.h"
-#include "cfgloop.h"
-
-
-/* This module is used to modify loops with a determinable number of
- iterations to use special low-overhead looping instructions.
-
- It first validates whether the loop is well behaved and has a
- determinable number of iterations (either at compile or run-time).
- It then modifies the loop to use a low-overhead looping pattern as
- follows:
-
- 1. A pseudo register is allocated as the loop iteration counter.
-
- 2. The number of loop iterations is calculated and is stored
- in the loop counter.
-
- 3. At the end of the loop, the jump insn is replaced by the
- doloop_end pattern. The compare must remain because it might be
- used elsewhere. If the loop-variable or condition register are
- used elsewhere, they will be eliminated by flow.
-
- 4. An optional doloop_begin pattern is inserted at the top of the
- loop.
-*/
-
-
-#ifdef HAVE_doloop_end
-
-static rtx doloop_condition_get (rtx);
-static unsigned HOST_WIDE_INT doloop_iterations_max (const struct loop_info *,
- enum machine_mode, int);
-static int doloop_valid_p (const struct loop *, rtx);
-static int doloop_modify (const struct loop *, rtx, rtx, rtx, rtx, rtx);
-static int doloop_modify_runtime (const struct loop *, rtx, rtx, rtx,
- enum machine_mode, rtx);
-
-
-/* Return the loop termination condition for PATTERN or zero
- if it is not a decrement and branch jump insn. */
-static rtx
-doloop_condition_get (rtx pattern)
-{
- rtx cmp;
- rtx inc;
- rtx reg;
- rtx condition;
-
- /* The canonical doloop pattern we expect is:
-
- (parallel [(set (pc) (if_then_else (condition)
- (label_ref (label))
- (pc)))
- (set (reg) (plus (reg) (const_int -1)))
- (additional clobbers and uses)])
-
- Some machines (IA-64) make the decrement conditional on
- the condition as well, so we don't bother verifying the
- actual decrement. In summary, the branch must be the
- first entry of the parallel (also required by jump.c),
- and the second entry of the parallel must be a set of
- the loop counter register. */
-
- if (GET_CODE (pattern) != PARALLEL)
- return 0;
-
- cmp = XVECEXP (pattern, 0, 0);
- inc = XVECEXP (pattern, 0, 1);
-
- /* Check for (set (reg) (something)). */
- if (GET_CODE (inc) != SET || ! REG_P (SET_DEST (inc)))
- return 0;
-
- /* Extract loop counter register. */
- reg = SET_DEST (inc);
-
- /* Check for (set (pc) (if_then_else (condition)
- (label_ref (label))
- (pc))). */
- if (GET_CODE (cmp) != SET
- || SET_DEST (cmp) != pc_rtx
- || GET_CODE (SET_SRC (cmp)) != IF_THEN_ELSE
- || GET_CODE (XEXP (SET_SRC (cmp), 1)) != LABEL_REF
- || XEXP (SET_SRC (cmp), 2) != pc_rtx)
- return 0;
-
- /* Extract loop termination condition. */
- condition = XEXP (SET_SRC (cmp), 0);
-
- if ((GET_CODE (condition) != GE && GET_CODE (condition) != NE)
- || GET_CODE (XEXP (condition, 1)) != CONST_INT)
- return 0;
-
- if (XEXP (condition, 0) == reg)
- return condition;
-
- if (GET_CODE (XEXP (condition, 0)) == PLUS
- && XEXP (XEXP (condition, 0), 0) == reg)
- return condition;
-
- /* ??? If a machine uses a funny comparison, we could return a
- canonicalised form here. */
-
- return 0;
-}
-
-
-/* Return an estimate of the maximum number of loop iterations for the
- loop specified by LOOP or zero if the loop is not normal.
- MODE is the mode of the iteration count and NONNEG is nonzero if
- the iteration count has been proved to be non-negative. */
-static unsigned HOST_WIDE_INT
-doloop_iterations_max (const struct loop_info *loop_info,
- enum machine_mode mode, int nonneg)
-{
- unsigned HOST_WIDE_INT n_iterations_max;
- enum rtx_code code;
- rtx min_value;
- rtx max_value;
- HOST_WIDE_INT abs_inc;
- int neg_inc;
-
- neg_inc = 0;
- abs_inc = INTVAL (loop_info->increment);
- if (abs_inc < 0)
- {
- abs_inc = -abs_inc;
- neg_inc = 1;
- }
-
- if (neg_inc)
- {
- code = swap_condition (loop_info->comparison_code);
- min_value = loop_info->final_equiv_value;
- max_value = loop_info->initial_equiv_value;
- }
- else
- {
- code = loop_info->comparison_code;
- min_value = loop_info->initial_equiv_value;
- max_value = loop_info->final_equiv_value;
- }
-
- /* Since the loop has a VTOP, we know that the initial test will be
- true and thus the value of max_value should be greater than the
- value of min_value. Thus the difference should always be positive
- and the code must be LT, LE, LTU, LEU, or NE. Otherwise the loop is
- not normal, e.g., `for (i = 0; i < 10; i--)'. */
- switch (code)
- {
- case LTU:
- case LEU:
- {
- unsigned HOST_WIDE_INT umax;
- unsigned HOST_WIDE_INT umin;
-
- if (GET_CODE (min_value) == CONST_INT)
- umin = INTVAL (min_value);
- else
- umin = 0;
-
- if (GET_CODE (max_value) == CONST_INT)
- umax = INTVAL (max_value);
- else
- umax = ((unsigned) 2 << (GET_MODE_BITSIZE (mode) - 1)) - 1;
-
- n_iterations_max = umax - umin;
- break;
- }
-
- case LT:
- case LE:
- {
- HOST_WIDE_INT smax;
- HOST_WIDE_INT smin;
-
- if (GET_CODE (min_value) == CONST_INT)
- smin = INTVAL (min_value);
- else
- smin = -((unsigned) 1 << (GET_MODE_BITSIZE (mode) - 1));
-
- if (GET_CODE (max_value) == CONST_INT)
- smax = INTVAL (max_value);
- else
- smax = ((unsigned) 1 << (GET_MODE_BITSIZE (mode) - 1)) - 1;
-
- n_iterations_max = smax - smin;
- break;
- }
-
- case NE:
- if (GET_CODE (min_value) == CONST_INT
- && GET_CODE (max_value) == CONST_INT)
- n_iterations_max = INTVAL (max_value) - INTVAL (min_value);
- else
- /* We need to conservatively assume that we might have the maximum
- number of iterations without any additional knowledge. */
- n_iterations_max = ((unsigned) 2 << (GET_MODE_BITSIZE (mode) - 1)) - 1;
- break;
-
- default:
- return 0;
- }
-
- n_iterations_max /= abs_inc;
-
- /* If we know that the iteration count is non-negative then adjust
- n_iterations_max if it is so large that it appears negative. */
- if (nonneg
- && n_iterations_max > ((unsigned) 1 << (GET_MODE_BITSIZE (mode) - 1)))
- n_iterations_max = ((unsigned) 1 << (GET_MODE_BITSIZE (mode) - 1)) - 1;
-
- return n_iterations_max;
-}
-
-
-/* Return nonzero if the loop specified by LOOP is suitable for
- the use of special low-overhead looping instructions. */
-static int
-doloop_valid_p (const struct loop *loop, rtx jump_insn)
-{
- const struct loop_info *loop_info = LOOP_INFO (loop);
-
- /* The loop must have a conditional jump at the end. */
- if (! any_condjump_p (jump_insn)
- || ! onlyjump_p (jump_insn))
- {
- if (loop_dump_stream)
- fprintf (loop_dump_stream,
- "Doloop: Invalid jump at loop end.\n");
- return 0;
- }
-
- /* Give up if a loop has been completely unrolled. */
- if (loop_info->n_iterations == loop_info->unroll_number)
- {
- if (loop_dump_stream)
- fprintf (loop_dump_stream,
- "Doloop: Loop completely unrolled.\n");
- return 0;
- }
-
- /* The loop must have a single exit target. A break or return
- statement within a loop will generate multiple loop exits.
- Another example of a loop that currently generates multiple exit
- targets is for (i = 0; i < (foo ? 8 : 4); i++) { }. */
- if (loop_info->has_multiple_exit_targets || loop->exit_count)
- {
- if (loop_dump_stream)
- fprintf (loop_dump_stream,
- "Doloop: Loop has multiple exit targets.\n");
- return 0;
- }
-
- /* An indirect jump may jump out of the loop. */
- if (loop_info->has_indirect_jump)
- {
- if (loop_dump_stream)
- fprintf (loop_dump_stream,
- "Doloop: Indirect jump in function.\n");
- return 0;
- }
-
- /* A called function may clobber any special registers required for
- low-overhead looping. */
- if (loop_info->has_call)
- {
- if (loop_dump_stream)
- fprintf (loop_dump_stream,
- "Doloop: Function call in loop.\n");
- return 0;
- }
-
- /* Some targets (eg, PPC) use the count register for branch on table
- instructions. ??? This should be a target specific check. */
- if (loop_info->has_tablejump)
- {
- if (loop_dump_stream)
- fprintf (loop_dump_stream,
- "Doloop: Computed branch in the loop.\n");
- return 0;
- }
-
- if (! loop_info->increment)
- {
- if (loop_dump_stream)
- fprintf (loop_dump_stream,
- "Doloop: Could not determine iteration info.\n");
- return 0;
- }
-
- if (GET_CODE (loop_info->increment) != CONST_INT)
- {
- if (loop_dump_stream)
- fprintf (loop_dump_stream,
- "Doloop: Increment not an integer constant.\n");
- return 0;
- }
-
- /* There is no guarantee that a NE loop will terminate if the
- absolute increment is not unity. ??? We could compute this
- condition at run-time and have an additional jump around the loop
- to ensure an infinite loop. */
- if (loop_info->comparison_code == NE
- && !loop_info->preconditioned
- && INTVAL (loop_info->increment) != -1
- && INTVAL (loop_info->increment) != 1)
- {
- if (loop_dump_stream)
- fprintf (loop_dump_stream,
- "Doloop: NE loop with non-unity increment.\n");
- return 0;
- }
-
- /* Check for loops that may not terminate under special conditions. */
- if (! loop_info->n_iterations
- && ((loop_info->comparison_code == LEU
- && INTVAL (loop_info->increment) > 0)
- || (loop_info->comparison_code == GEU
- && INTVAL (loop_info->increment) < 0)
- || (loop_info->comparison_code == LTU
- && INTVAL (loop_info->increment) > 1)
- || (loop_info->comparison_code == GTU
- && INTVAL (loop_info->increment) < -1)))
- {
- /* If the comparison is LEU and the comparison value is UINT_MAX
- then the loop will not terminate. Similarly, if the
- comparison code is GEU and the comparison value is 0, the
- loop will not terminate.
-
- If the absolute increment is not 1, the loop can be infinite
- even with LTU/GTU, e.g. for (i = 3; i > 0; i -= 2)
-
- Note that with LE and GE, the loop behavior is undefined
- (C++ standard section 5 clause 5) if an overflow occurs, say
- between INT_MAX and INT_MAX + 1. We thus don't have to worry
- about these two cases.
-
- ??? We could compute these conditions at run-time and have a
- additional jump around the loop to ensure an infinite loop.
- However, it is very unlikely that this is the intended
- behavior of the loop and checking for these rare boundary
- conditions would pessimize all other code.
-
- If the loop is executed only a few times an extra check to
- restart the loop could use up most of the benefits of using a
- count register loop. Note however, that normally, this
- restart branch would never execute, so it could be predicted
- well by the CPU. We should generate the pessimistic code by
- default, and have an option, e.g. -funsafe-loops that would
- enable count-register loops in this case. */
- if (loop_dump_stream)
- fprintf (loop_dump_stream,
- "Doloop: Possible infinite iteration case ignored.\n");
- }
-
- return 1;
-}
-
-
-/* Modify the loop to use the low-overhead looping insn where LOOP
- describes the loop, ITERATIONS is an RTX containing the desired
- number of loop iterations, ITERATIONS_MAX is a CONST_INT specifying
- the maximum number of loop iterations, and DOLOOP_INSN is the
- low-overhead looping insn to emit at the end of the loop. This
- returns nonzero if it was successful. */
-static int
-doloop_modify (const struct loop *loop, rtx iterations, rtx iterations_max,
- rtx doloop_seq, rtx start_label, rtx condition)
-{
- rtx counter_reg;
- rtx count;
- rtx sequence;
- rtx jump_insn;
- int nonneg = 0;
- int decrement_count;
-
- jump_insn = prev_nonnote_insn (loop->end);
-
- if (loop_dump_stream)
- {
- fprintf (loop_dump_stream, "Doloop: Inserting doloop pattern (");
- if (GET_CODE (iterations) == CONST_INT)
- fprintf (loop_dump_stream, HOST_WIDE_INT_PRINT_DEC,
- INTVAL (iterations));
- else
- fputs ("runtime", loop_dump_stream);
- fputs (" iterations).", loop_dump_stream);
- }
-
- /* Emit the label that will delimit the top of the loop.
- This has to be done before the delete_insn call below, to prevent
- delete_insn from deleting too much. */
- emit_label_after (start_label, loop->top ? loop->top : loop->start);
- LABEL_NUSES (start_label)++;
-
- /* Discard original jump to continue loop. The original compare
- result may still be live, so it cannot be discarded explicitly. */
- delete_related_insns (jump_insn);
-
- counter_reg = XEXP (condition, 0);
- if (GET_CODE (counter_reg) == PLUS)
- counter_reg = XEXP (counter_reg, 0);
-
- start_sequence ();
-
- count = iterations;
- decrement_count = 0;
- switch (GET_CODE (condition))
- {
- case NE:
- /* Currently only NE tests against zero and one are supported. */
- if (XEXP (condition, 1) == const0_rtx)
- decrement_count = 1;
- else if (XEXP (condition, 1) != const1_rtx)
- abort ();
- break;
-
- case GE:
- /* Currently only GE tests against zero are supported. */
- if (XEXP (condition, 1) != const0_rtx)
- abort ();
-
- /* The iteration count needs decrementing for a GE test. */
- decrement_count = 1;
-
- /* Determine if the iteration counter will be non-negative.
- Note that the maximum value loaded is iterations_max - 1. */
- if ((unsigned HOST_WIDE_INT) INTVAL (iterations_max)
- <= ((unsigned) 1 << (GET_MODE_BITSIZE (GET_MODE (counter_reg)) - 1)))
- nonneg = 1;
- break;
-
- /* Abort if an invalid doloop pattern has been generated. */
- default:
- abort ();
- }
-
- if (decrement_count)
- {
- if (GET_CODE (count) == CONST_INT)
- count = GEN_INT (INTVAL (count) - 1);
- else
- count = expand_simple_binop (GET_MODE (counter_reg), MINUS,
- count, const1_rtx,
- 0, 0, OPTAB_LIB_WIDEN);
- }
-
- /* Insert initialization of the count register into the loop header. */
- convert_move (counter_reg, count, 1);
- sequence = get_insns ();
- end_sequence ();
- emit_insn_before (sequence, loop->start);
-
- /* Some targets (eg, C4x) need to initialize special looping
- registers. */
-#ifdef HAVE_doloop_begin
- {
- rtx init;
-
- init = gen_doloop_begin (counter_reg,
- GET_CODE (iterations) == CONST_INT
- ? iterations : const0_rtx, iterations_max,
- GEN_INT (loop->level));
- if (init)
- {
- start_sequence ();
- emit_insn (init);
- sequence = get_insns ();
- end_sequence ();
- emit_insn_after (sequence, loop->start);
- }
- }
-#endif
-
- /* Insert the new low-overhead looping insn. */
- emit_jump_insn_before (doloop_seq, loop->end);
- jump_insn = prev_nonnote_insn (loop->end);
- JUMP_LABEL (jump_insn) = start_label;
-
- /* Add a REG_NONNEG note if the actual or estimated maximum number
- of iterations is non-negative. */
- if (nonneg)
- {
- REG_NOTES (jump_insn)
- = gen_rtx_EXPR_LIST (REG_NONNEG, NULL_RTX, REG_NOTES (jump_insn));
- }
- return 1;
-}
-
-
-/* Handle the more complex case, where the bounds are not known at
- compile time. In this case we generate a run_time calculation of
- the number of iterations. We rely on the existence of a run-time
- guard to ensure that the loop executes at least once, i.e.,
- initial_value obeys the loop comparison condition. If a guard is
- not present, we emit one. The loop to modify is described by LOOP.
- ITERATIONS_MAX is a CONST_INT specifying the estimated maximum
- number of loop iterations. DOLOOP_INSN is the low-overhead looping
- insn to insert. Returns nonzero if loop successfully modified. */
-static int
-doloop_modify_runtime (const struct loop *loop, rtx iterations_max,
- rtx doloop_seq, rtx start_label,
- enum machine_mode mode, rtx condition)
-{
- const struct loop_info *loop_info = LOOP_INFO (loop);
- HOST_WIDE_INT abs_inc;
- HOST_WIDE_INT abs_loop_inc;
- int neg_inc;
- rtx diff;
- rtx sequence;
- rtx iterations;
- rtx initial_value;
- rtx final_value;
- rtx increment;
- int unsigned_p;
- enum rtx_code comparison_code;
-
- increment = loop_info->increment;
- initial_value = loop_info->initial_value;
- final_value = loop_info->final_value;
-
- neg_inc = 0;
- abs_inc = INTVAL (increment);
- if (abs_inc < 0)
- {
- abs_inc = -abs_inc;
- neg_inc = 1;
- }
-
- comparison_code = loop_info->comparison_code;
- unsigned_p = (comparison_code == LTU
- || comparison_code == LEU
- || comparison_code == GTU
- || comparison_code == GEU
- || comparison_code == NE);
-
- /* The number of iterations (prior to any loop unrolling) is given by:
-
- n = (abs (final - initial) + abs_inc - 1) / abs_inc.
-
- However, it is possible for the summation to overflow, and a
- safer method is:
-
- n = abs (final - initial) / abs_inc;
- n += (abs (final - initial) % abs_inc) != 0;
-
- But when abs_inc is a power of two, the summation won't overflow
- except in cases where the loop never terminates. So we don't
- need to use this more costly calculation.
-
- If the loop has been unrolled, the full calculation is
-
- t1 = abs_inc * unroll_number; increment per loop
- n = (abs (final - initial) + abs_inc - 1) / t1; full loops
- n += (abs (final - initial) + abs_inc - 1) % t1) >= abs_inc;
- partial loop
- which works out to be equivalent to
-
- n = (abs (final - initial) + t1 - 1) / t1;
-
- In the case where the loop was preconditioned, a few iterations
- may have been executed earlier; but 'initial' was adjusted as they
- were executed, so we don't need anything special for that case here.
- As above, when t1 is a power of two we don't need to worry about
- overflow.
-
- The division and modulo operations can be avoided by requiring
- that the increment is a power of 2 (precondition_loop_p enforces
- this requirement). Nevertheless, the RTX_COSTS should be checked
- to see if a fast divmod is available. */
-
- start_sequence ();
- /* abs (final - initial) */
- diff = expand_simple_binop (mode, MINUS,
- copy_rtx (neg_inc ? initial_value : final_value),
- copy_rtx (neg_inc ? final_value : initial_value),
- NULL_RTX, unsigned_p, OPTAB_LIB_WIDEN);
-
- /* Some code transformations can result in code akin to
-
- tmp = i + 1;
- ...
- goto scan_start;
- top:
- tmp = tmp + 1;
- scan_start:
- i = tmp;
- if (i < n) goto top;
-
- We'll have already detected this form of loop in scan_loop,
- and set loop->top and loop->scan_start appropriately.
-
- In this situation, we skip the increment the first time through
- the loop, which results in an incorrect estimate of the number
- of iterations. Adjust the difference to compensate. */
- /* ??? Logically, it would seem this belongs in loop_iterations.
- However, this causes regressions e.g. on x86 execute/20011008-3.c,
- so I do not believe we've properly characterized the exact nature
- of the problem. In the meantime, this fixes execute/20011126-2.c
- on ia64 and some Ada front end miscompilation on ppc. */
-
- if (loop->scan_start)
- {
- rtx iteration_var = loop_info->iteration_var;
- struct loop_ivs *ivs = LOOP_IVS (loop);
- struct iv_class *bl;
-
- if (REG_IV_TYPE (ivs, REGNO (iteration_var)) == BASIC_INDUCT)
- bl = REG_IV_CLASS (ivs, REGNO (iteration_var));
- else if (REG_IV_TYPE (ivs, REGNO (iteration_var)) == GENERAL_INDUCT)
- {
- struct induction *v = REG_IV_INFO (ivs, REGNO (iteration_var));
- bl = REG_IV_CLASS (ivs, REGNO (v->src_reg));
- }
- else
- /* Iteration var must be an induction variable to get here. */
- abort ();
-
- if (INSN_UID (bl->biv->insn) < max_uid_for_loop
- && INSN_LUID (bl->biv->insn) < INSN_LUID (loop->scan_start))
- {
- if (loop_dump_stream)
- fprintf (loop_dump_stream,
- "Doloop: Basic induction var skips initial incr.\n");
-
- diff = expand_simple_binop (mode, PLUS, diff, GEN_INT (abs_inc),
- diff, unsigned_p, OPTAB_LIB_WIDEN);
- }
- }
-
- abs_loop_inc = abs_inc * loop_info->unroll_number;
- if (abs_loop_inc != 1)
- {
- int shift_count;
-
- shift_count = exact_log2 (abs_loop_inc);
- if (shift_count < 0)
- abort ();
-
- /* (abs (final - initial) + abs_inc * unroll_number - 1) */
- diff = expand_simple_binop (GET_MODE (diff), PLUS,
- diff, GEN_INT (abs_loop_inc - 1),
- diff, 1, OPTAB_LIB_WIDEN);
-
- /* (abs (final - initial) + abs_inc * unroll_number - 1)
- / (abs_inc * unroll_number) */
- diff = expand_simple_binop (GET_MODE (diff), LSHIFTRT,
- diff, GEN_INT (shift_count),
- diff, 1, OPTAB_LIB_WIDEN);
- }
- iterations = diff;
-
- /* If there is a NOTE_INSN_LOOP_VTOP, we have a `for' or `while'
- style loop, with a loop exit test at the start. Thus, we can
- assume that the loop condition was true when the loop was
- entered.
-
- `do-while' loops require special treatment since the exit test is
- not executed before the start of the loop. We need to determine
- if the loop will terminate after the first pass and to limit the
- iteration count to one if necessary. */
- if (! loop->vtop)
- {
- if (loop_dump_stream)
- fprintf (loop_dump_stream, "Doloop: Do-while loop.\n");
-
- /* A `do-while' loop must iterate at least once. For code like
- i = initial; do { ... } while (++i < final);
- we will calculate a bogus iteration count if initial > final.
- So detect this and set the iteration count to 1.
- Note that if the loop has been unrolled, then the loop body
- is guaranteed to execute at least once. Also, when the
- comparison is NE, our calculated count will be OK. */
- if (loop_info->unroll_number == 1 && comparison_code != NE)
- {
- rtx label;
-
- /* Emit insns to test if the loop will immediately
- terminate and to set the iteration count to 1 if true. */
- label = gen_label_rtx();
- emit_cmp_and_jump_insns (copy_rtx (initial_value),
- copy_rtx (loop_info->comparison_value),
- comparison_code, NULL_RTX, mode, 0,
- label);
- JUMP_LABEL (get_last_insn ()) = label;
- LABEL_NUSES (label)++;
- emit_move_insn (iterations, const1_rtx);
- emit_label (label);
- }
- }
-
- sequence = get_insns ();
- end_sequence ();
- emit_insn_before (sequence, loop->start);
-
- return doloop_modify (loop, iterations, iterations_max, doloop_seq,
- start_label, condition);
-}
-
-
-/* This is the main entry point. Process loop described by LOOP
- validating that the loop is suitable for conversion to use a low
- overhead looping instruction, replacing the jump insn where
- suitable. We distinguish between loops with compile-time bounds
- and those with run-time bounds. Information from LOOP is used to
- compute the number of iterations and to determine whether the loop
- is a candidate for this optimization. Returns nonzero if loop
- successfully modified. */
-int
-doloop_optimize (const struct loop *loop)
-{
- struct loop_info *loop_info = LOOP_INFO (loop);
- rtx initial_value;
- rtx final_value;
- rtx increment;
- rtx jump_insn;
- enum machine_mode mode;
- unsigned HOST_WIDE_INT n_iterations;
- unsigned HOST_WIDE_INT n_iterations_max;
- rtx doloop_seq, doloop_pat, doloop_reg;
- rtx iterations;
- rtx iterations_max;
- rtx start_label;
- rtx condition;
-
- if (loop_dump_stream)
- fprintf (loop_dump_stream,
- "Doloop: Processing loop %d, enclosed levels %d.\n",
- loop->num, loop->level);
-
- jump_insn = prev_nonnote_insn (loop->end);
-
- /* Check that loop is a candidate for a low-overhead looping insn. */
- if (! doloop_valid_p (loop, jump_insn))
- return 0;
-
- /* Determine if the loop can be safely, and profitably,
- preconditioned. While we don't precondition the loop in a loop
- unrolling sense, this test ensures that the loop is well behaved
- and that the increment is a constant integer. */
- if (! precondition_loop_p (loop, &initial_value, &final_value,
- &increment, &mode))
- {
- if (loop_dump_stream)
- fprintf (loop_dump_stream,
- "Doloop: Cannot precondition loop.\n");
- return 0;
- }
-
- /* Determine or estimate the maximum number of loop iterations. */
- n_iterations = loop_info->n_iterations;
- if (n_iterations)
- {
- /* See the comment in doloop_modify_runtime. */
- if (loop->top)
- n_iterations += loop_info->unroll_number;
-
- /* This is the simple case where the initial and final loop
- values are constants. */
- n_iterations_max = n_iterations;
- }
- else
- {
- int nonneg = find_reg_note (jump_insn, REG_NONNEG, 0) != 0;
-
- /* This is the harder case where the initial and final loop
- values may not be constants. */
- n_iterations_max = doloop_iterations_max (loop_info, mode, nonneg);
-
- if (! n_iterations_max)
- {
- /* We have something like `for (i = 0; i < 10; i--)'. */
- if (loop_dump_stream)
- fprintf (loop_dump_stream,
- "Doloop: Not normal loop.\n");
- return 0;
- }
- }
-
- /* Account for loop unrolling in the iteration count. This will
- have no effect if loop_iterations could not determine the number
- of iterations. */
- n_iterations /= loop_info->unroll_number;
- n_iterations_max /= loop_info->unroll_number;
-
- if (n_iterations && n_iterations < 3)
- {
- if (loop_dump_stream)
- fprintf (loop_dump_stream,
- "Doloop: Too few iterations (%ld) to be profitable.\n",
- (long int) n_iterations);
- return 0;
- }
-
- iterations = GEN_INT (n_iterations);
- iterations_max = GEN_INT (n_iterations_max);
-
- /* Generate looping insn. If the pattern FAILs then give up trying
- to modify the loop since there is some aspect the back-end does
- not like. */
- start_label = gen_label_rtx ();
- doloop_reg = gen_reg_rtx (mode);
- doloop_seq = gen_doloop_end (doloop_reg, iterations, iterations_max,
- GEN_INT (loop->level), start_label);
- if (! doloop_seq && mode != word_mode)
- {
- PUT_MODE (doloop_reg, word_mode);
- doloop_seq = gen_doloop_end (doloop_reg, iterations, iterations_max,
- GEN_INT (loop->level), start_label);
- }
- if (! doloop_seq)
- {
- if (loop_dump_stream)
- fprintf (loop_dump_stream,
- "Doloop: Target unwilling to use doloop pattern!\n");
- return 0;
- }
-
- /* If multiple instructions were created, the last must be the
- jump instruction. Also, a raw define_insn may yield a plain
- pattern. */
- doloop_pat = doloop_seq;
- if (INSN_P (doloop_pat))
- {
- while (NEXT_INSN (doloop_pat) != NULL_RTX)
- doloop_pat = NEXT_INSN (doloop_pat);
- if (GET_CODE (doloop_pat) == JUMP_INSN)
- doloop_pat = PATTERN (doloop_pat);
- else
- doloop_pat = NULL_RTX;
- }
-
- if (! doloop_pat
- || ! (condition = doloop_condition_get (doloop_pat)))
- {
- if (loop_dump_stream)
- fprintf (loop_dump_stream,
- "Doloop: Unrecognizable doloop pattern!\n");
- return 0;
- }
-
- if (n_iterations != 0)
- /* Handle the simpler case, where we know the iteration count at
- compile time. */
- return doloop_modify (loop, iterations, iterations_max, doloop_seq,
- start_label, condition);
- else
- /* Handle the harder case, where we must add additional runtime tests. */
- return doloop_modify_runtime (loop, iterations_max, doloop_seq,
- start_label, mode, condition);
-}
-
-#endif /* HAVE_doloop_end */
diff --git a/gcc/dwarf2out.c b/gcc/dwarf2out.c
index cdc70258c29..e67db07d1eb 100644
--- a/gcc/dwarf2out.c
+++ b/gcc/dwarf2out.c
@@ -248,6 +248,15 @@ typedef struct dw_fde_struct GTY(())
const char *dw_fde_end;
dw_cfi_ref dw_fde_cfi;
unsigned funcdef_number;
+ /* APPLE LOCAL begin coalescing */
+ const char *dw_real_name;
+ /* Is this symbol coalesced? */
+ unsigned coalesced : 1;
+ /* Is this symbol an explicit instantiation? */
+ unsigned explicit : 1;
+ unsigned public : 1;
+ unsigned private_extern : 1;
+ /* APPLE LOCAL end coalescing */
unsigned all_throwers_are_sibcalls : 1;
unsigned nothrow : 1;
unsigned uses_eh_lsda : 1;
@@ -1589,9 +1598,100 @@ dwarf2out_frame_debug_expr (rtx expr, const char *label)
case PLUS:
case MINUS:
case LO_SUM:
- if (GET_CODE (XEXP (XEXP (dest, 0), 1)) != CONST_INT)
+ /* APPLE LOCAL begin 'reg + index' reg case. */
+ /* MERGE fixme 3537126 */
+ offset = 0x696b6c6c;
+ if (GET_CODE (XEXP (XEXP (dest, 0), 1)) == CONST_INT)
+ offset = INTVAL (XEXP (XEXP (dest, 0), 1));
+#if 1
+ /* If it's a 'reg + index', we need to find out what value
+ the index reg has at this point. (This can happen because
+ some architectures have registers which can only be stored
+ using a "reg + index" mode.)
+ This method of finding out the index value is VERY FRAGILE.
+ Ideally we'd try to add a note to the save insn, but... */
+ else if (GET_CODE (XEXP (XEXP (dest, 0), 1)) == REG)
+ {
+ unsigned the_reg = REGNO (XEXP (XEXP (dest, 0), 1));
+ rtx insn;
+
+ /* The REG_FRAME_RELATED_EXPR can sometimes be out-of-date
+ after the optimiser/inliner has done its stuff. For example,
+
+ (insn: (set (mem:V16QI (plus:SI (reg/f:SI 1 r1)
+ (reg:SI 6 r6)) [0 S16 A8])
+ (reg:V16QI 108 v31))
+ ...
+ (expr_list:REG_FRAME_RELATED_EXPR
+ (set (mem:V16QI (plus:SI (reg/f:SI 1 r1)
+ (reg:SI 0 r0)) [0 S16 A8])
+ (reg:V16QI 108 v31))
+
+ Note that the optimiser has used R6 instead of the original
+ R0 to store the SP offset. Alas, we blindly look for R0
+ here, since DEST is the REG_FRAME_RELATED_EXPR, so we need
+ to check for that.
+
+ This needs a rework from scratch, but it'll do for now. */
+
+ insn = XEXP (XEXP (XEXP (PATTERN (current_output_insn),
+ 0), 0), 1);
+ if (GET_CODE (insn) == REG)
+ the_reg = REGNO (insn);
+
+ insn = PREV_INSN (current_output_insn);
+ for (; insn != NULL; insn = PREV_INSN (insn))
+ {
+ if (GET_CODE (insn) != INSN
+ || PATTERN (insn) == NULL)
+ ;
+ else if (GET_CODE (PATTERN (insn)) == SET)
+ {
+ rtx p = PATTERN (insn);
+ if (SET_DEST (p) != NULL
+ && GET_CODE (SET_DEST (p)) == REG
+ && REGNO (SET_DEST (p)) == the_reg)
+ {
+ if (GET_CODE (SET_SRC (p)) == CONST_INT)
+ {
+ offset = INTVAL (SET_SRC (p));
+ break;
+ }
+ else
+ abort ();
+ }
+ }
+ else
+ /* A label? All bets are off. */
+ if (GET_CODE (PATTERN (insn)) == CODE_LABEL)
+ abort ();
+ }
+
+ /* DEST can also be something like:
+
+ (mem:V16QI (plus:SI (plus:SI (reg/f:SI 1 r1)
+ (const_int 147792 [0x24150]))
+ (reg:SI 0 r0)) [0 S16 A8])
+
+ This is handled here by adjusting the offset appropriately. */
+
+ insn = XEXP (XEXP (dest, 0), 0);
+ if (GET_CODE (insn) == PLUS && GET_CODE (XEXP (insn, 0)) == REG
+ && GET_CODE (XEXP (insn, 1)) == CONST_INT)
+ {
+ offset += INTVAL (XEXP (insn, 1));
+
+ /* Set DEST to be the inner PLUS so that
+ REGNO (XEXP (XEXP (dest, 0), 0) will be sensible. */
+
+ dest = XEXP (dest, 0);
+ }
+ }
+#endif
+ else
abort ();
- offset = INTVAL (XEXP (XEXP (dest, 0), 1));
+ /* APPLE LOCAL end 'reg + index' case. */
+
if (GET_CODE (XEXP (dest, 0)) == MINUS)
offset = -offset;
@@ -1970,6 +2070,14 @@ output_call_frame_info (int for_eh)
else
named_section_flags (DEBUG_FRAME_SECTION, SECTION_DEBUG);
+ /* APPLE LOCAL begin coalescing */
+#ifdef COALESCED_UNWIND_INFO
+ /* We could probably mark the CIE as coalesced as well, since they're
+ all the same (or are they?!) */
+ ASM_OUTPUT_LABEL (asm_out_file, "EH_unwind_info");
+#endif
+ /* APPLE LOCAL end coalescing */
+
ASM_GENERATE_INTERNAL_LABEL (section_start_label, FRAME_BEGIN_LABEL, for_eh);
ASM_OUTPUT_LABEL (asm_out_file, section_start_label);
@@ -2004,7 +2112,11 @@ output_call_frame_info (int for_eh)
P Indicates the presence of an encoding + language
personality routine in the CIE augmentation. */
- fde_encoding = ASM_PREFERRED_EH_DATA_FORMAT (/*code=*/1, /*global=*/0);
+ /* APPLE LOCAL coalescing */
+ fde_encoding = flag_export_coalesced
+ ? ASM_PREFERRED_EH_DATA_FORMAT (/*code=*/2, /*global=*/1)
+ : ASM_PREFERRED_EH_DATA_FORMAT (/*code=*/1, /*global=*/0);
+ /* APPLE LOCAL end coalescing */
per_encoding = ASM_PREFERRED_EH_DATA_FORMAT (/*code=*/2, /*global=*/1);
lsda_encoding = ASM_PREFERRED_EH_DATA_FORMAT (/*code=*/0, /*global=*/0);
@@ -2098,6 +2210,18 @@ output_call_frame_info (int for_eh)
&& !fde->uses_eh_lsda)
continue;
+ /* APPLE LOCAL begin coalescing */
+#ifdef COALESCED_UNWIND_INFO
+ ASM_OUTPUT_COAL_UNWIND_LABEL (asm_out_file, fde->dw_real_name,
+ fde->coalesced,
+ fde->public && !fde->private_extern,
+ fde->coalesced
+ || fde->public
+ || fde->private_extern
+ || fde->explicit);
+#endif
+ /* APPLE LOCAL end coalescing */
+
(*targetm.asm_out.internal_label) (asm_out_file, FDE_LABEL, for_eh + i * 2);
ASM_GENERATE_INTERNAL_LABEL (l1, FDE_AFTER_SIZE_LABEL, for_eh + i * 2);
ASM_GENERATE_INTERNAL_LABEL (l2, FDE_END_LABEL, for_eh + i * 2);
@@ -2113,6 +2237,15 @@ output_call_frame_info (int for_eh)
if (for_eh)
{
+ /* APPLE LOCAL begin coalescing */
+#ifdef COALESCED_UNWIND_INFO
+ if (fde->coalesced)
+ dw2_asm_output_encoded_addr_rtx (fde_encoding,
+ gen_rtx_SYMBOL_REF (Pmode, fde->dw_real_name),
+ "FDE initial location");
+ else
+#endif
+ /* APPLE LOCAL end coalescing */
dw2_asm_output_encoded_addr_rtx (fde_encoding,
gen_rtx_SYMBOL_REF (Pmode, fde->dw_fde_begin),
"FDE initial location");
@@ -2257,6 +2390,22 @@ dwarf2out_begin_prologue (unsigned int line ATTRIBUTE_UNUSED,
fde->uses_eh_lsda = cfun->uses_eh_lsda;
fde->all_throwers_are_sibcalls = cfun->all_throwers_are_sibcalls;
+ /* APPLE LOCAL begin coalescing */
+#ifdef COALESCED_UNWIND_INFO
+ fde->coalesced = DECL_COALESCED (current_function_decl);
+ /* Sorry about this hackery: this is the only way I can figure out
+ whether this is an explicit template instantiation. Ick.
+ DECL_LANG_FLAG_1 is DECL_TEMPLATE_INSTANTIATED in cp-tree.h. */
+ fde->explicit = !fde->coalesced && TREE_PUBLIC (current_function_decl)
+ && (strstr (lang_hooks.name, "C++") != NULL)
+ && DECL_LANG_FLAG_1 (current_function_decl);
+ fde->dw_real_name = xstrdup (IDENTIFIER_POINTER
+ (DECL_ASSEMBLER_NAME (current_function_decl)));
+ fde->public = TREE_PUBLIC(current_function_decl);
+ fde->private_extern = DECL_VISIBILITY(current_function_decl) == VISIBILITY_HIDDEN;
+#endif
+ /* APPLE LOCAL end coalescing */
+
args_size = old_args_size = 0;
/* We only want to output line number information for the genuine dwarf2
@@ -3286,6 +3435,9 @@ const struct gcc_debug_hooks dwarf2_debug_hooks =
dwarf2out_abstract_function, /* outlining_inline_function */
debug_nothing_rtx, /* label */
debug_nothing_int, /* handle_pch */
+ /* APPLE LOCAL begin Symbol Separation */
+ NULL, NULL, NULL, NULL,
+ /* APPLE LOCAL end Symbol Separation */
dwarf2out_var_location
};
#endif
@@ -3504,7 +3656,6 @@ struct var_loc_list_def GTY (())
};
typedef struct var_loc_list_def var_loc_list;
-
/* Table of decl location linked lists. */
static GTY ((param_is (var_loc_list))) htab_t decl_loc_table;
diff --git a/gcc/expmed.c b/gcc/expmed.c
index 4158f92b08e..7b133b8705c 100644
--- a/gcc/expmed.c
+++ b/gcc/expmed.c
@@ -634,8 +634,15 @@ store_bit_field (rtx str_rtx, unsigned HOST_WIDE_INT bitsize,
/* Fetch that unit, store the bitfield in it, then store
the unit. */
tempreg = copy_to_reg (op0);
- store_bit_field (tempreg, bitsize, bitpos, fieldmode, value,
- total_size);
+ /* APPLE LOCAL begin do not use float fieldmode */
+ /* If value was float, we munged it to be int above, so it
+ is never appropriate to use a float fieldmode here. */
+ store_bit_field (tempreg, bitsize, bitpos,
+ (GET_MODE_CLASS (fieldmode) != MODE_INT
+ && GET_MODE_CLASS (fieldmode) != MODE_PARTIAL_INT)
+ ? GET_MODE (value) : fieldmode,
+ value, total_size);
+ /* APPLE LOCAL end do not use float fieldmode */
emit_move_insn (op0, tempreg);
return value;
}
diff --git a/gcc/expr.c b/gcc/expr.c
index 789c9a5a5a0..7e0692bfca4 100644
--- a/gcc/expr.c
+++ b/gcc/expr.c
@@ -6459,6 +6459,15 @@ expand_expr_real_1 (tree exp, rtx target, enum machine_mode tmode,
int ignore;
tree context;
+ /* Handle ERROR_MARK before anybody tries to access its type. */
+ if (TREE_CODE (exp) == ERROR_MARK || TREE_CODE (type) == ERROR_MARK)
+ {
+ op0 = CONST0_RTX (tmode);
+ if (op0 != 0)
+ return op0;
+ return const0_rtx;
+ }
+
mode = TYPE_MODE (type);
/* Use subtarget as the target for operand 0 of a binary operation. */
subtarget = get_subtarget (target);
diff --git a/gcc/f/Make-lang.in b/gcc/f/Make-lang.in
index 052adfcaab9..a7d04ee218d 100644
--- a/gcc/f/Make-lang.in
+++ b/gcc/f/Make-lang.in
@@ -92,9 +92,9 @@ F77_OBJS = f/bad.o f/bit.o f/bld.o f/com.o f/data.o f/equiv.o f/expr.o \
# Use loose warnings for this front end.
f-warn = $(WERROR)
-f771$(exeext): $(F77_OBJS) $(BACKEND) $(LIBDEPS)
+f771$(exeext): $(F77_OBJS) $(BACKEND) $(LIBDEPS)
rm -f f771$(exeext)
- $(CC) $(ALL_CFLAGS) $(LDFLAGS) -o $@ $(F77_OBJS) $(BACKEND) $(LIBS)
+ $(CC) $(ALL_CFLAGS) $(LDFLAGS) -o $@ $(F77_OBJS) $(BACKEND) $(LIBS)
# Keyword tables.
f/stamp-str: f/str-1t.h f/str-1t.j f/str-2t.h f/str-2t.j \
diff --git a/gcc/f/com.c b/gcc/f/com.c
index ebfce0a5670..5b24ee20caf 100644
--- a/gcc/f/com.c
+++ b/gcc/f/com.c
@@ -636,6 +636,37 @@ static GTY(()) tree named_labels;
static GTY(()) tree shadowed_labels;
+/* APPLE LOCAL begin AltiVec */
+/* Placeholders to make linking work, remove when altivec support is correct */
+
+int
+comptypes (type1, type2)
+ tree type1, type2;
+{
+ register tree t1 = type1;
+ register tree t2 = type2;
+ if (t1 == t2 || !t1 || !t2
+ || TREE_CODE (t1) == ERROR_MARK || TREE_CODE (t2) == ERROR_MARK)
+ return 1;
+ return 0;
+}
+
+tree
+default_conversion (exp)
+ tree exp;
+{
+ return exp;
+}
+
+tree
+lang_build_type_variant (type, constp, volatilep)
+ tree type;
+ int constp, volatilep;
+{
+ return type;
+}
+/* APPLE LOCAL end AltiVec */
+
/* Return the subscript expression, modified to do range-checking.
`array' is the array type to be checked against.
diff --git a/gcc/final.c b/gcc/final.c
index f3e793d6643..1e85eebe1ad 100644
--- a/gcc/final.c
+++ b/gcc/final.c
@@ -1621,6 +1621,37 @@ output_alternate_entry_point (FILE *file, rtx insn)
}
}
+/* APPLE LOCAL begin hot/cold partitioning */
+/* Return boolean indicating if there is a NOTE_INSN_UNLIKELY_EXECUTED_CODE
+ note in the instruction chain (going forward) between the current
+ instruction, and the next 'executable' instruction. */
+
+bool
+scan_ahead_for_unlikely_executed_note (rtx insn)
+{
+ rtx temp;
+ int bb_note_count = 0;
+
+ for (temp = insn; temp; temp = NEXT_INSN (temp))
+ {
+ if (GET_CODE (temp) == NOTE
+ && NOTE_LINE_NUMBER (temp) == NOTE_INSN_UNLIKELY_EXECUTED_CODE)
+ return true;
+ if (GET_CODE (temp) == NOTE
+ && NOTE_LINE_NUMBER (temp) == NOTE_INSN_BASIC_BLOCK)
+ {
+ bb_note_count++;
+ if (bb_note_count > 1)
+ return false;
+ }
+ if (INSN_P (temp))
+ return false;
+ }
+
+ return false;
+}
+/* APPLE LOCAL end hot/cold partitioning */
+
/* The final scan for one insn, INSN.
Args are same as in `final', except that INSN
is the insn being scanned.
@@ -1670,7 +1701,32 @@ final_scan_insn (rtx insn, FILE *file, int optimize ATTRIBUTE_UNUSED,
case NOTE_INSN_EXPECTED_VALUE:
break;
- case NOTE_INSN_BASIC_BLOCK:
+ /* APPLE LOCAL begin hot/cold partitioning */
+ case NOTE_INSN_UNLIKELY_EXECUTED_CODE:
+
+ /* The presence of this note indicates that this basic block
+ belongs in the "cold" section of the .o file. If we are
+ not already writing to the cold section we need to change
+ to it. */
+
+ unlikely_text_section ();
+ break;
+
+ case NOTE_INSN_BASIC_BLOCK:
+
+ /* If we are performing the optimization that paritions
+ basic blocks into hot & cold sections of the .o file,
+ then at the start of each new basic block, before
+ beginning to write code for the basic block, we need to
+ check to see whether the basic block belongs in the hot
+ or cold section of the .o file, and change the section we
+ are writing to appropriately. */
+
+ if (flag_reorder_blocks_and_partition
+ && !scan_ahead_for_unlikely_executed_note (insn))
+ text_section ();
+ /* APPLE LOCAL end hot/cold partitioning */
+
#ifdef IA64_UNWIND_INFO
IA64_UNWIND_EMIT (asm_out_file, insn);
#endif
@@ -1857,6 +1913,27 @@ final_scan_insn (rtx insn, FILE *file, int optimize ATTRIBUTE_UNUSED,
if (LABEL_NAME (insn))
(*debug_hooks->label) (insn);
+ /* APPLE LOCAL begin hot/cold partitioning */
+ /* If we are doing the optimization that partitions hot & cold
+ basic blocks into separate sections of the .o file, we need
+ to ensure the jump table ends up in the correct section... */
+
+ if (flag_reorder_blocks_and_partition
+ && targetm.have_named_sections)
+ {
+ rtx tmp_table, tmp_label;
+ if (GET_CODE (insn) == CODE_LABEL
+ && tablejump_p (NEXT_INSN (insn), &tmp_label, &tmp_table))
+ {
+ /* Do nothing; Do NOT change the current section. */
+ }
+ else if (scan_ahead_for_unlikely_executed_note (insn))
+ unlikely_text_section ();
+ else
+ text_section ();
+ }
+ /* APPLE LOCAL end hot/cold partitioning */
+
if (app_on)
{
fputs (ASM_APP_OFF, file);
diff --git a/gcc/flags.h b/gcc/flags.h
index 29134834502..ce9272dfb6c 100644
--- a/gcc/flags.h
+++ b/gcc/flags.h
@@ -39,6 +39,13 @@ enum debug_info_type
/* Specify which kind of debugging info to generate. */
extern enum debug_info_type write_symbols;
+/* APPLE LOCAL begin Symbol Separation */
+extern enum debug_info_type orig_write_symbols;
+
+/* Nonzero means, try to look for separate symbol repositories. */
+extern int flag_grepository;
+/* APPLE LOCAL end Symbol Separation */
+
/* Names of debug_info_type, for error messages. */
extern const char *const debug_type_names[];
@@ -210,6 +217,13 @@ extern int flag_branch_probabilities;
extern int flag_reorder_blocks;
+/* APPLE LOCAL begin hot/cold partitioning */
+/* Nonzero if basic blocks should be partitioned into hot and cold
+ sections of the .o file, in addition to being reordered. */
+
+extern int flag_reorder_blocks_and_partition;
+/* APPLE LOCAL end hot/cold partitioning */
+
/* Nonzero if functions should be reordered. */
extern int flag_reorder_functions;
@@ -239,10 +253,32 @@ extern int flag_print_asm_name;
extern int flag_signed_char;
+/* APPLE LOCAL coalescing */
+extern int flag_export_coalesced;
+
+/* APPLE LOCAL begin Pascal strings 2001-07-05 zll */
+/* Nonzero means initial "\p" in string becomes a length byte and
+ string type becomes _unsigned_ char* . */
+
+extern int flag_pascal_strings;
+/* APPLE LOCAL end Pascal strings 2001-07-05 zll */
+
/* Nonzero means give an enum type only as many bytes as it needs. */
extern int flag_short_enums;
+/* APPLE LOCAL begin constant cfstrings */
+/* Nonzero means that: (1) the __CONSTANT_CFSTRINGS__ manifest constant
+ is defined, possibly allowing for conditional use of the
+ __builtin__CFStringMakeConstantString function (the latter is always
+ available, regardless of the setting of this flag), and (2) use
+ the CFString layout to create @"..." strings in ObjC/ObjC++. */
+extern int flag_constant_cfstrings;
+/* Nonzero means that we should warn whenever non-ASCII characters appear
+ inside of @"..." literals (as they may be non-portable). */
+extern int warn_nonportable_cfstrings;
+/* APPLE LOCAL end constant cfstrings */
+
/* Nonzero for -fcaller-saves: allocate values in regs that need to
be saved across function calls, if that produces overall better code.
Optional now, so people can test it. */
@@ -378,6 +414,13 @@ extern int flag_rerun_loop_opt;
extern int flag_inline_functions;
+/* APPLE LOCAL begin -fobey-inline */
+/* Nonzero for -fobey-inline: 'inline' keyword must be obeyed, regardless
+ of codesize. */
+
+extern int flag_obey_inline;
+/* APPLE LOCAL end -fobey-inline */
+
/* Nonzero for -fkeep-inline-functions: even if we make a function
go inline everywhere, keep its definition around for debugging
purposes. */
@@ -826,4 +869,33 @@ extern int flag_abi_version;
#define HONOR_SIGN_DEPENDENT_ROUNDING(MODE) \
(MODE_HAS_SIGN_DEPENDENT_ROUNDING (MODE) && flag_rounding_math)
+/* APPLE LOCAL begin -fast or -fastf or -fastcp */
+/* Nonzero if we should perform SPEC oriented optimizations for C. */
+extern int flag_fast;
+/* Nonzero if we should perform SPEC oriented optimizations for C that is
+ produced by the NAG Fortan-to-C translator. */
+extern int flag_fastf;
+/* Nonzero if we should perform SPEC oriented optimizations for C++. */
+extern int flag_fastcp;
+/* APPLE LOCAL end -fast or -fastf -fastcp */
+
+/* APPLE LOCAL gdb only used symbols */
+#ifdef DBX_ONLY_USED_SYMBOLS
+/* Nonzero if generating debugger info for used symbols only. */
+extern int flag_debug_only_used_symbols;
+#endif
+
+/* APPLE LOCAL BEGIN pch distcc mrs */
+/* True if PCH should omit from the -E output all lines from PCH files
+ found in PCH files. */
+extern int flag_pch_preprocess;
+/* APPLE LOCAL END pch distcc mrs */
+
+/* APPLE LOCAL begin loop transpose */
+/* Nonzero if we should perform automatic loop transposition. */
+extern int flag_loop_transpose;
+/* APPLE LOCAL end loop transpose */
+
+extern int disable_typechecking_for_spec_flag;
+
#endif /* ! GCC_FLAGS_H */
diff --git a/gcc/fold-const.c b/gcc/fold-const.c
index 966a3ae6c26..041a586957b 100644
--- a/gcc/fold-const.c
+++ b/gcc/fold-const.c
@@ -5367,13 +5367,23 @@ fold (tree expr)
tree tem;
tree type = TREE_TYPE (expr);
tree arg0 = NULL_TREE, arg1 = NULL_TREE;
- enum tree_code code = TREE_CODE (t);
- int kind = TREE_CODE_CLASS (code);
-
+ /* APPLE LOCAL begin AltiVec */
+ enum tree_code code;
+ int kind, invert;
+ /* APPLE LOCAL end AltiVec */
/* WINS will be nonzero when the switch is done
if all operands are constant. */
int wins = 1;
+ /* APPLE LOCAL begin AltiVec */
+ /* Fold constant comma expressions. */
+ while (TREE_CODE (t) == COMPOUND_EXPR && TREE_CONSTANT (t))
+ t = TREE_OPERAND (t, 1);
+
+ code = TREE_CODE (t);
+ kind = TREE_CODE_CLASS (code);
+ /* APPLE LOCAL end AltiVec */
+
/* Don't try to process an RTL_EXPR since its operands aren't trees.
Likewise for a SAVE_EXPR that's already been evaluated. */
if (code == RTL_EXPR || (code == SAVE_EXPR && SAVE_EXPR_RTL (t) != 0))
@@ -6063,6 +6073,34 @@ fold (tree expr)
TREE_OPERAND (arg0, 0),
build_real (type, c1)));
}
+ /* Convert a + (b*c + d*e) into (a + b*c) + d*e */
+ if (flag_unsafe_math_optimizations
+ && TREE_CODE (arg1) == PLUS_EXPR
+ && TREE_CODE (arg0) != MULT_EXPR)
+ {
+ tree tree10 = TREE_OPERAND (arg1, 0);
+ tree tree11 = TREE_OPERAND (arg1, 1);
+ if (TREE_CODE (tree11) == MULT_EXPR)
+ {
+ tree tree0;
+ tree0 = fold (build (PLUS_EXPR, type, arg0, tree10));
+ return fold (build (PLUS_EXPR, type, tree0, tree11));
+ }
+ }
+ /* Convert (b*c + d*e) + a into b*c + (d*e +a) */
+ if (flag_unsafe_math_optimizations
+ && TREE_CODE (arg0) == PLUS_EXPR
+ && TREE_CODE (arg1) != MULT_EXPR)
+ {
+ tree tree00 = TREE_OPERAND (arg0, 0);
+ tree tree01 = TREE_OPERAND (arg0, 1);
+ if (TREE_CODE (tree01) == MULT_EXPR)
+ {
+ tree tree0;
+ tree0 = fold (build (PLUS_EXPR, type, tree01, arg1));
+ return fold (build (PLUS_EXPR, type, tree00, tree0));
+ }
+ }
}
bit_rotate:
diff --git a/gcc/function.c b/gcc/function.c
index fd0fb54bfdd..3c6466b5281 100644
--- a/gcc/function.c
+++ b/gcc/function.c
@@ -602,6 +602,23 @@ assign_stack_local (enum machine_mode mode, HOST_WIDE_INT size, int align)
{
return assign_stack_local_1 (mode, size, align, cfun);
}
+
+/* APPLE LOCAL begin new function for rs6000 consumption */
+/* Wrapper around assign_stack_local_1; assign a local stack slot for the
+ current function, then set the mem_alias to a new alias set.
+ This can be used only in situations where the target code can
+ guarantee that the slot is used in a way that cannot conflict
+ with anything else. */
+
+rtx
+assign_stack_local_with_alias (enum machine_mode mode, HOST_WIDE_INT size,
+ int align)
+{
+ rtx mem = assign_stack_local_1 (mode, size, align, cfun);
+ set_mem_alias_set (mem, new_alias_set ());
+ return mem;
+}
+/* APPLE LOCAL end new function for rs6000 consumption */
/* Allocate a temporary stack slot and record it for possible later
reuse.
@@ -5205,6 +5222,8 @@ assign_parms (tree fndecl)
/* We have aligned all the args, so add space for the pretend args. */
stack_args_size.constant += extra_pretend_bytes;
current_function_args_size = stack_args_size.constant;
+ /* APPLE LOCAL sibcall 3007352 */
+ cfun->unrounded_args_size = stack_args_size.constant;
/* Adjust function incoming argument size for alignment and
minimum length. */
diff --git a/gcc/function.h b/gcc/function.h
index eaa7b980da7..63988f20b08 100644
--- a/gcc/function.h
+++ b/gcc/function.h
@@ -398,6 +398,9 @@ struct function GTY(())
final flowgraph size. */
int max_jumptable_ents;
+ /* APPLE LOCAL sibcall 3007352 */
+ int unrounded_args_size;
+
/* UIDs for LABEL_DECLs. */
int last_label_uid;
diff --git a/gcc/gcc.c b/gcc/gcc.c
index 6b487c2ba92..6af2d16a7a2 100644
--- a/gcc/gcc.c
+++ b/gcc/gcc.c
@@ -235,6 +235,32 @@ static const char *const spec_version = DEFAULT_TARGET_VERSION;
static const char *spec_machine = DEFAULT_TARGET_MACHINE;
+/* APPLE LOCAL begin constant cfstrings */
+static int use_constant_cfstrings = 0;
+/* The deployment target (i.e., the minimum version of MacOS X that
+ the binary is expected to be used on). */
+static const char *macosx_deployment_target = 0;
+unsigned int macosx_version_min_required = 0;
+
+/* APPLE LOCAL 3313335 */
+static char *cc_print_options = 0;
+static char *cc_print_options_filename;
+/* The following table should be NULL-terminated and kept in
+ lexicographic order. */
+
+static struct macosx_vers {
+ const char *vers_str;
+ unsigned int vers_num;
+} macosx_vers_tbl[] = {
+ { "10.0", 1000 },
+ { "10.1", 1010 },
+ { "10.2", 1020 },
+ { "10.3", 1030 },
+ { "10.4", 1040 },
+ { NULL, 0 }
+};
+/* APPLE LOCAL end constant cfstrings */
+
/* Nonzero if cross-compiling.
When -b is used, the value comes from the `specs' file. */
@@ -259,6 +285,38 @@ static const struct modify_target
modify_target[] = MODIFY_TARGET_NAME;
#endif
+/* APPLE LOCAL begin fat builds */
+
+/* This is a mapping of arch strings to strings that config.guess map to. */
+#define MAX_CONFIG_MAPS 2
+struct arch_config_out
+{
+ const char *arch_name;
+ const char *config_string;
+} arch_config_map[MAX_CONFIG_MAPS] = {
+ {"ppc", "powerpc"},
+ {"i386", "i686" }
+};
+
+/* Limit to a small number, which is OK because there aren't many. */
+#define MAX_ARCHES 10
+
+struct arch_out
+{
+ const char *name;
+ const char *config_string;
+ const char *merge_file;
+} arches[MAX_ARCHES];
+
+int num_arches;
+
+int current_arch;
+
+/* Default name to use in the -final_output linker flag in case the -o
+ flag is absent. */
+char *final_output = "a.out";
+/* APPLE LOCAL end fat builds */
+
/* The number of errors that have occurred; the link phase will not be
run if this is nonzero. */
static int error_count = 0;
@@ -319,6 +377,8 @@ static const char *eval_spec_function (const char *, const char *);
static const char *handle_spec_function (const char *);
static char *save_string (const char *, int);
static void set_collect_gcc_options (void);
+/* APPLE LOCAL %b/save-temps can clobber input file (radar 2871891) ilr */
+static const char *check_basename_derived_file (const char *string);
static int do_spec_1 (const char *, int, const char *);
static int do_spec_2 (const char *);
static void do_option_spec (const char *, const char *);
@@ -355,6 +415,9 @@ static const char *convert_filename (const char *, int, int);
static const char *if_exists_spec_function (int, const char **);
static const char *if_exists_else_spec_function (int, const char **);
+/* APPLE LOCAL begin fat builds */
+static void set_new_arch (const char *);
+/* APPLE LOCAL end fat builds */
/* The Specs Language
@@ -445,9 +508,24 @@ or with constant text in a single argument.
%I Substitute any of -iprefix (made from GCC_EXEC_PREFIX), -isysroot
(made from TARGET_SYSTEM_ROOT), and -isystem (made from COMPILER_PATH
and -B options) as necessary.
+ APPLE LOCAL framework headers
+ %Q Substitute -iframework default paths.
+ APPLE LOCAL constant cfstrings
+ %yC Emit '-fconstant-cfstrings' option, if needed.
%s current argument is the name of a library or startup file of some sort.
Search for that file in a standard list of directories
and substitute the full name found.
+ APPLE LOCAL begin fat builds
+ %f marks the argument following the %f as the "output file" of this
+ compilation for multi-architecture builds. This puts the argument
+ into the sequence of arguments that %F will substitute later.
+
+ %F substitutes the names of all the intermediate architecture files,
+ with spaces automatically placed around them. You should write spaces
+ around the %F as well or the results are undefined.
+ %F is for use in the specs for running the architecture merger.
+ %T substitutes the name of the current architecture.
+ APPLE LOCAL end fat builds
%eSTR Print STR as an error message. STR is terminated by a newline.
Use this when inconsistent options are detected.
%nSTR Print STR as a notice. STR is terminated by a newline.
@@ -515,6 +593,10 @@ or with constant text in a single argument.
combined with !, ., and * as above binding stronger than the OR.
If %* appears in X, all of the alternatives must be starred, and
only the first matching alternative is substituted.
+ APPLE LOCAL begin fat builds
+ %{@:X} substitutes X, but only if processing multiple architectures.
+ %{!@:X} substitutes X, but only if NOT processing multiple architectures.
+ APPLE LOCAL end fat builds
%{S:X; if S was given to CC, substitutes X;
T:Y; else if T was given to CC, substitutes Y;
:D} else substitutes D. There can be as many clauses as you need.
@@ -743,6 +825,22 @@ static const char *startfile_prefix_spec = STARTFILE_PREFIX_SPEC;
static const char *sysroot_suffix_spec = SYSROOT_SUFFIX_SPEC;
static const char *sysroot_hdrs_suffix_spec = SYSROOT_HEADERS_SUFFIX_SPEC;
+/* APPLE LOCAL begin fat builds */
+/* The spec for running the architecture merger. This is run whenever
+ compiling multiple architectures and the output is a .o or an
+ executable. */
+/* APPLE LCOAL Symbol Separation */
+/* Add fsave-repository constructs for Symbol Separation */
+static char *ofile_merge_spec = "\
+%{!fdump=*:%{!M:%{!MM:%{!E:%{!S:\
+ lipo -create %F%{c:%W{o}%{!o:%{!fsave-repository*:-o %w%b%O} %{fsave-repository*:-o %w%i%O}}}\
+ %{!c:%{!fsave-repository*:-o %w%u%O} %{fsave-repository*:-o %w%i%O}}\n}}}}}";
+
+static char *exec_merge_spec = "\
+%{!fdump=*:%{!M:%{!MM:%{!E:%{!S:%{!c:lipo -create %F \
+ %{o}%{!o:-o a.out}\n}}}}}}}";
+/* APPLE LOCAL end fat builds */
+
/* Standard options to cpp, cc1, and as, to reduce duplication in specs.
There should be no need to override these in target dependent files,
but we need to copy them to the specs file so that newer versions
@@ -755,11 +853,22 @@ static const char *sysroot_hdrs_suffix_spec = SYSROOT_HEADERS_SUFFIX_SPEC;
static const char *trad_capable_cpp =
"cc1 -E %{traditional|ftraditional|traditional-cpp:-traditional-cpp}";
+/* When making PCH file use this. */
+/* APPLE LOCAL Symbol Separation */
+/* Add fsave-repository constructs for Symbol Separation */
+static const char *pch =
+"%{!fsave-repository*:-o %g.s %{!o*:--output-pch=%i.pch} %W{o*:--output-pch=%*}%V}";
+
+/* APPLE LOCAL Symbol Separation */
+static const char *dbg_ss= "%{fsave-repository*: -gfull %(invoke_as)}";
+
/* We don't wrap .d files in %W{} since a missing .d file, and
therefore no dependency entry, confuses make into thinking a .o
file that happens to exist is up-to-date. */
static const char *cpp_unique_options =
"%{C|CC:%{!E:%eGCC does not support -C or -CC without -E}}\
+"/* APPLE LOCAL framework headers */"\
+ %{!traditional:%{!ftraditional:%{!traditional-cpp:%Q}}} %{F*}\
%{!Q:-quiet} %{nostdinc*} %{C} %{CC} %{v} %{I*&F*} %{P} %I\
%{MD:-MD %{!o:%b.d}%{o*:%.d%*}}\
%{MMD:-MMD %{!o:%b.d}%{o*:%.d%*}}\
@@ -785,7 +894,23 @@ static const char *cpp_debug_options = "%{d*}";
/* NB: This is shared amongst all front-ends. */
static const char *cc1_options =
+/* APPLE LOCAL begin fat builds */
+/* Note that -arch %T must precede %{m*} in this spec list so that
+ toplev.c knows to ignore incompatible -m options for a given
+ architecture when multiple architectures are specified. */
+"%{@:-arch %T}"
+/* APPLE LOCAL end fat builds */
+/* APPLE LOCAL constant cfstrings */
+/* APPLE LOCAL Symbol Separation */
+/* Add fsave-repository construct for Symbol Separation */
+"%yC"
+/* APPLE LOCAL begin -fast option */
+"%{fast:-O3}\
+ %{fastf:-O3}\
+ %{fastcp:-O3}"
+/* APPLE LOCAL end -fast option */
"%{pg:%{fomit-frame-pointer:%e-pg and -fomit-frame-pointer are incompatible}}\
+ %{fsave-repository*:-gfull}\
%1 %{!Q:-quiet} -dumpbase %B %{d*} %{m*} %{a*}\
%{c|S:%{o*:-auxbase-strip %*}%{!o*:-auxbase %b}}%{!c:%{!S:-auxbase %b}}\
%{g*} %{O*} %{W*&pedantic*} %{w} %{std*} %{ansi}\
@@ -797,7 +922,17 @@ static const char *cc1_options =
%{fmudflap|fmudflapth:-fno-builtin -fno-merge-constants}";
static const char *asm_options =
-"%a %Y %{c:%W{o*}%{!o*:-o %w%b%O}}%{!c:-o %d%w%u%O}";
+/* APPLE LOCAL -fast */
+/* APPLE LOCAL fat builds */
+/* APPLE LOCAL Symbol Separation */
+/* Add fsave-repository constructs for Symbol Separation */
+"%a %Y \
+ %{fast:-force_cpusubtype_ALL}\
+ %{fastf:-force_cpusubtype_ALL}\
+ %{fastcp:-force_cpusubtype_ALL}\
+ %{@:-o %f%u%O}\
+ %{!@:%{c:%W{o*}%{!o*:%{!fsave-repository*:-o %w%b%O} %{fsave-repository*:-o %w%i%O}}}\
+ %{!c:%{!fsave-repository*:-o %d%w%u%O} %{fsave-repository*:%W{o*}%{!o*:-o %w%i%O}}}}";
static const char *invoke_as =
#ifdef AS_NEEDS_DASH_FOR_PIPED_INPUT
@@ -924,16 +1059,19 @@ static const struct compiler default_compilers[] =
/* cc1 has an integrated ISO C preprocessor. We should invoke the
external preprocessor if -save-temps is given. */
"%{E|M|MM:%(trad_capable_cpp) %(cpp_options) %(cpp_debug_options)}\
+ "/* APPLE LOCAL fat builds */"\
+ %{E|S:%{@:%e-E and -S are not allowed with multiple -arch flags}}\
+ "/* APPLE LOCAL cpp-precomp compatibility */"\
+ %{precomp:%ecpp-precomp not supported}%{no-cpp-precomp:}%{Wno-precomp:}\
%{!E:%{!M:%{!MM:\
%{traditional|ftraditional:\
%eGNU C no longer supports -traditional without -E}\
%{save-temps|traditional-cpp|no-integrated-cpp:%(trad_capable_cpp) \
- %(cpp_options) -o %{save-temps:%b.i} %{!save-temps:%g.i} \n\
- cc1 -fpreprocessed %{save-temps:%b.i} %{!save-temps:%g.i} \
- %(cc1_options)}\
+ %(cpp_options) -o %{save-temps:%b.i} %{!save-temps:%g.i}}\
%{!save-temps:%{!traditional-cpp:%{!no-integrated-cpp:\
- cc1 %(cpp_unique_options) %(cc1_options)}}}\
- %{!fsyntax-only:%(invoke_as)}}}}", 0},
+ cc1 %(cpp_unique_options) %(cc1_options)}}\
+ %{!fsyntax-only:\
+ %{!traditional-cpp:%(invoke_as)}}}}}}", 0},
{"-",
"%{!E:%e-E required when input is from standard input}\
%(trad_capable_cpp) %(cpp_options) %(cpp_debug_options)", 0},
@@ -947,16 +1085,23 @@ static const struct compiler default_compilers[] =
%(cpp_options) -o %{save-temps:%b.i} %{!save-temps:%g.i} \n\
cc1 -fpreprocessed %{save-temps:%b.i} %{!save-temps:%g.i} \
%(cc1_options)\
- -o %g.s %{!o*:--output-pch=%i.gch}\
- %W{o*:--output-pch=%*}%V}\
+ "/* APPLE LOCAL symbol separation */"\
+ %(dbg_ss) %(pch)}\
%{!save-temps:%{!traditional-cpp:%{!no-integrated-cpp:\
cc1 %(cpp_unique_options) %(cc1_options)\
- -o %g.s %{!o*:--output-pch=%i.gch}\
- %W{o*:--output-pch=%*}%V}}}}}}", 0},
+ "/* APPLE LOCAL symbol separation */"\
+ %(dbg_ss) %(pch)}}}}}}", 0},
{".i", "@cpp-output", 0},
{"@cpp-output",
"%{!M:%{!MM:%{!E:cc1 -fpreprocessed %i %(cc1_options) %{!fsyntax-only:%(invoke_as)}}}}", 0},
- {".s", "@assembler", 0},
+ /* APPLE LOCAL preprocess .s files 2001-07-24 sts */
+ /* This is kind of lame; the purpose of having .s and .S be treated
+ differently is so that we can control whether to run the
+ preprocessor on assembly files. The standard behavior would
+ still work even on HFS filesystems, because they preserve case,
+ but we'd have to get a number of projects to change their files,
+ and of course that's just *too* *hard*. */
+ {".s", "@assembler-with-cpp", 0},
{"@assembler",
"%{!M:%{!MM:%{!E:%{!S:as %(asm_debug) %(asm_options) %i %A }}}}", 0},
{".S", "@assembler-with-cpp", 0},
@@ -983,6 +1128,12 @@ static const struct compiler default_compilers[] =
static const int n_default_compilers = ARRAY_SIZE (default_compilers) - 1;
+/* APPLE LOCAL begin -ObjC 2001-08-03 sts */
+/* -ObjC is not the same as -x objective-c, since it only affects the
+ expectation of the language in files already thought to be source
+ code. */
+static char *default_language;
+/* APPLE LOCAL end -ObjC 2001-08-03 sts */
/* A vector of options to give to the linker.
These options are accumulated by %x,
and substituted into the linker command with %X. */
@@ -1025,6 +1176,10 @@ static const struct option_map option_map[] =
{
{"--all-warnings", "-Wall", 0},
{"--ansi", "-ansi", 0},
+ /* APPLE LOCAL begin fat builds */
+ {"--arch", "-arch", "a"},
+ {"--arch_multiple", "-arch_multiple", 0},
+ /* APPLE LOCAL end fat builds */
{"--assemble", "-S", 0},
{"--assert", "-A", "a"},
{"--classpath", "-fclasspath=", "aj"},
@@ -1070,6 +1225,8 @@ static const struct option_map option_map[] =
{"--pedantic-errors", "-pedantic-errors", 0},
{"--pie", "-pie", 0},
{"--pipe", "-pipe", 0},
+ /* APPLE LOCAL -precomp-trustfile */
+ {"--precomp-trustfile", "-precomp-trustfile", "a"},
{"--prefix", "-B", "a"},
{"--preprocess", "-E", 0},
{"--print-search-dirs", "-print-search-dirs", 0},
@@ -1085,6 +1242,8 @@ static const struct option_map option_map[] =
{"--quiet", "-q", 0},
{"--resource", "-fcompile-resource=", "aj"},
{"--save-temps", "-save-temps", 0},
+ /* APPLE LOCAL Symbol Separation */
+ {"--save-repository", "-fsave-repository=", "aj"},
{"--shared", "-shared", 0},
{"--silent", "-q", 0},
{"--specs", "-specs=", "aj"},
@@ -1386,6 +1545,13 @@ static struct path_prefix startfile_prefixes = { 0, 0, "startfile" };
static struct path_prefix include_prefixes = { 0, 0, "include" };
+/* APPLE LOCAL begin framework headers */
+#ifdef FRAMEWORK_HEADERS
+/* A vector of the frameworks to search. */
+static struct path_prefix default_framework_paths = {0, 0, "default_frameworks"};
+#endif /* FRAMEWORK_HEADERS */
+/* APPLE LOCAL end framework headers */
+
/* Suffix to attach to directories searched for commands.
This looks like `MACHINE/VERSION/'. */
@@ -1486,6 +1652,9 @@ static struct spec_list static_specs[] =
INIT_STATIC_SPEC ("cpp_debug_options", &cpp_debug_options),
INIT_STATIC_SPEC ("cpp_unique_options", &cpp_unique_options),
INIT_STATIC_SPEC ("trad_capable_cpp", &trad_capable_cpp),
+ INIT_STATIC_SPEC ("pch", &pch),
+ /* APPLE LOCAL Symbol Separtion */
+ INIT_STATIC_SPEC ("dbg_ss", &dbg_ss),
INIT_STATIC_SPEC ("cc1", &cc1_spec),
INIT_STATIC_SPEC ("cc1_options", &cc1_options),
INIT_STATIC_SPEC ("cc1plus", &cc1plus_spec),
@@ -2308,7 +2477,8 @@ build_search_list (struct path_prefix *paths, const char *prefix,
|| is_directory (pprefix->prefix, machine_suffix, 0)))
{
if (!first_time)
- obstack_1grow (&collect_obstack, PATH_SEPARATOR);
+ /* APPLE LOCAL fat builds readability */
+ obstack_1grow (&collect_obstack, '\n'/*PATH_SEPARATOR*/);
first_time = FALSE;
obstack_grow (&collect_obstack, pprefix->prefix, len);
@@ -2321,7 +2491,8 @@ build_search_list (struct path_prefix *paths, const char *prefix,
|| is_directory (pprefix->prefix, just_machine_suffix, 0)))
{
if (! first_time)
- obstack_1grow (&collect_obstack, PATH_SEPARATOR);
+ /* APPLE LOCAL fat builds readability */
+ obstack_1grow (&collect_obstack, '\n'/*PATH_SEPARATOR*/);
first_time = FALSE;
obstack_grow (&collect_obstack, pprefix->prefix, len);
@@ -2332,7 +2503,8 @@ build_search_list (struct path_prefix *paths, const char *prefix,
if (! pprefix->require_machine_suffix)
{
if (! first_time)
- obstack_1grow (&collect_obstack, PATH_SEPARATOR);
+ /* APPLE LOCAL fat builds readability */
+ obstack_1grow (&collect_obstack, '\n'/*PATH_SEPARATOR*/);
first_time = FALSE;
obstack_grow (&collect_obstack, pprefix->prefix, len);
@@ -2665,6 +2837,11 @@ execute (void)
X_OK, 0);
if (string)
commands[n_commands].argv[0] = string;
+ /* APPLE LOCAL begin radar 2466994 - pass linker output through c++filt ilr */
+ else if (strcmp (commands[n_commands].prog, "c++filt3") == 0
+ && access ("/usr/bin/c++filt3", X_OK) != 0)
+ continue;
+ /* APPLE LOCAL end radar 2466994 - pass linker output through c++filt ilr */
n_commands++;
}
@@ -2672,7 +2849,8 @@ execute (void)
/* If -v, print what we are about to do, and maybe query. */
- if (verbose_flag)
+ /* APPLE LOCAL 3313335 */
+ if (verbose_flag || cc_print_options)
{
/* For help listings, put a blank line between sub-processes. */
if (print_help_list)
@@ -2683,29 +2861,50 @@ execute (void)
{
const char *const *j;
- if (verbose_only_flag)
+ /* APPLE LOCAL begin 3313335 and 3360444 */
+ FILE *f = stderr;
+ if (cc_print_options)
+ {
+ if (cc_print_options_filename)
+ {
+ f = fopen (cc_print_options_filename, "a");
+ if (!f)
+ {
+ fprintf (stderr, "can not open CC_PRINT_OPTIONS_FILE %s\n",
+ cc_print_options_filename);
+ exit (1);
+ }
+ }
+ fprintf (f, "[Logging gcc options]");
+ }
+
+ if (verbose_only_flag || cc_print_options)
{
for (j = commands[i].argv; *j; j++)
{
const char *p;
- fprintf (stderr, " \"");
+ fprintf (f, " \"");
for (p = *j; *p; ++p)
{
if (*p == '"' || *p == '\\' || *p == '$')
- fputc ('\\', stderr);
- fputc (*p, stderr);
+ fputc ('\\', f);
+ fputc (*p, f);
}
- fputc ('"', stderr);
+ fputc ('"', f);
}
}
else
for (j = commands[i].argv; *j; j++)
- fprintf (stderr, " %s", *j);
+ fprintf (f, " %s", *j);
/* Print a pipe symbol after all but the last command. */
if (i + 1 != n_commands)
- fprintf (stderr, " |");
- fprintf (stderr, "\n");
+ fprintf (f, " |");
+ fprintf (f, "\n");
+
+ if (cc_print_options_filename)
+ fclose (f);
+ /* APPLE LOCAL end 3313335 and 3360444 */
}
fflush (stderr);
if (verbose_only_flag != 0)
@@ -2764,6 +2963,17 @@ execute (void)
char *errmsg_fmt, *errmsg_arg;
const char *string = commands[i].argv[0];
+ /* APPLE LOCAL begin 2920964 */
+ if (verbose_flag && print_help_list
+ && (!strcmp ("/usr/libexec/gcc/darwin/ppc/as", string)
+ || !strcmp ("/usr/libexec/gcc/darwin/i386/as", string)
+ || !strcmp ("ld", string)))
+ {
+ /* Do nothing.
+ as and ld do not entertain --help. */
+ }
+ else
+ /* APPLE LOCAL end 2920964 */
/* For some bizarre reason, the second argument of execvp() is
char *const *, not const char *const *. */
commands[i].pid = pexecute (string, (char *const *) commands[i].argv,
@@ -2803,6 +3013,16 @@ execute (void)
int status;
int pid;
+ /* APPLE LOCAL begin 2920964 */
+ if (verbose_flag && print_help_list
+ && (!strcmp ("as", commands[i].prog)
+ || !strcmp ("ld", commands[i].prog)))
+ {
+ /* as and ld do not entertain --help. */
+ i++;
+ continue;
+ }
+ /* APPLE LOCAL end 2920964 */
pid = pwait (commands[i].pid, &status, 0);
if (pid < 0)
abort ();
@@ -2882,12 +3102,19 @@ See %s for instructions.",
1 if the switch is true in a conditional spec,
-1 if false (overridden by a later switch)
-2 if this switch should be ignored (used in %<S)
+ APPLE LOCAL begin fat builds
+ -3 if this switch should be ignored now and restored later.
+ (used in %{!<s} for fat builds)
+ APPLE LOCAL end fat builds
The `validated' field is nonzero if any spec has looked at this switch;
if it remains zero at the end of the run, it must be meaningless. */
#define SWITCH_OK 0
#define SWITCH_FALSE -1
#define SWITCH_IGNORE -2
+/* APPLE LOCAL fat builds */
+/* Ignore now and restore later */
+#define SWITCH_IGNORE_RESTORE -3
#define SWITCH_LIVE 1
struct switchstr
@@ -2907,6 +3134,14 @@ struct infile
{
const char *name;
const char *language;
+ /* APPLE LOCAL begin IMI */
+ struct compiler *incompiler;
+
+ /* Use separate temp file for each input file. */
+ const char *temp_filename;
+ bool compiled;
+ bool preprocessed;
+ /* APPLE LOCAL end IMI */
};
/* Also a vector of input files specified. */
@@ -2920,6 +3155,22 @@ int n_infiles;
static bool combine_inputs;
+/* True if input files are assembly files. (.s or .S extension) */
+static bool assembly_input;
+
+/* True if "-c" appears on commandline. */
+static int have_c = 0;
+
+/* True if "-o" appears on commandline. */
+
+static int have_o = 0;
+
+/* True if "-traditional-cpp" appears on commandline. */
+static int traditional_cpp_flag = 0;
+
+/* True if "-E" appears on commandline. */
+static int capital_e_flag = 0;
+
/* This counts the number of libraries added by lang_specific_driver, so that
we can tell if there were any user supplied any files or libraries. */
@@ -3095,6 +3346,35 @@ add_linker_option (const char *option, int len)
linker_options [n_linker_options - 1] = save_string (option, len);
}
+/* APPLE LOCAL begin fat builds */
+
+static void
+set_new_arch (const char *name)
+{
+ int i;
+
+ for (i = 0; i < num_arches; i++)
+ if (strcmp (arches[i].name, name) == 0)
+ return;
+
+ if (num_arches + 1 >= MAX_ARCHES)
+ fatal ("more than %d architectures specified", MAX_ARCHES);
+ arches[num_arches].name = name;
+
+ for (i = 0; i < MAX_CONFIG_MAPS; i++)
+ if (strcmp (arch_config_map[i].arch_name, name) == 0)
+ {
+ arches[num_arches++].config_string = arch_config_map[i].config_string;
+ return;
+ }
+
+ /* If we reached here, there is no config mapping for the arch name. Just
+ set them to be the same. */
+ arches[num_arches++].config_string = name;
+}
+
+/* APPLE LOCAL end fat builds */
+
/* Create the vector `switches' and its contents.
Store its length in `n_switches'. */
@@ -3106,8 +3386,6 @@ process_command (int argc, const char **argv)
char *temp1;
const char *spec_lang = 0;
int last_language_n_infiles;
- int have_c = 0;
- int have_o = 0;
int lang_n_infiles = 0;
#ifdef MODIFY_TARGET_NAME
int is_modify_target_name;
@@ -3133,6 +3411,13 @@ process_command (int argc, const char **argv)
}
}
+ /* APPLE LOCAL begin */
+ /* FSF patch pending. Move translate_options() call before -b processing
+ so that -bundle like options can be translated, if required. */
+ /* Convert new-style -- options to old-style. */
+ translate_options (&argc, &argv);
+ /* APPLE LOCAL end */
+
/* If there is a -V or -b option (or both), process it now, before
trying to interpret the rest of the command line. */
if (argc > 1 && argv[1][0] == '-'
@@ -3336,6 +3621,24 @@ process_command (int argc, const char **argv)
}
}
+ /* APPLE LOCAL begin constant cfstrings */
+ /* Retrieve the deployment target from the environment, and then decide
+ whether to enable '-fconstant-cfstrings' by default. */
+ macosx_deployment_target = getenv ("MACOSX_DEPLOYMENT_TARGET");
+ if (macosx_deployment_target)
+ {
+ struct macosx_vers *v = macosx_vers_tbl;
+
+ while (v->vers_str && strcmp (macosx_deployment_target, v->vers_str))
+ v++;
+ if (v->vers_str)
+ {
+ macosx_version_min_required = v->vers_num;
+ use_constant_cfstrings = (macosx_version_min_required >= 1020);
+ }
+ }
+ /* APPLE LOCAL end constant cfstrings */
+
/* Convert new-style -- options to old-style. */
translate_options (&argc, (const char *const **) &argv);
@@ -3391,8 +3694,15 @@ warranty; not even for MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.\n\n"
/* CPP driver cannot obtain switch from cc1_options. */
if (is_cpp_driver)
add_preprocessor_option ("--help", 6);
+ /* APPLE LOCAL begin 2920964 */
+#if 0
+ /* Our assembler and linkder do not support --help. */
+ /* APPLE LOCAL end 2920964 */
add_assembler_option ("--help", 6);
add_linker_option ("--help", 6);
+ /* APPLE LOCAL begin 2920964 */
+#endif
+ /* APPLE LOCAL end 2920964 */
}
else if (strcmp (argv[i], "-ftarget-help") == 0)
{
@@ -3409,6 +3719,17 @@ warranty; not even for MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.\n\n"
add_assembler_option ("--target-help", 13);
add_linker_option ("--target-help", 13);
}
+ /* APPLE LOCAL begin fat builds */
+ else if (strcmp (argv[i], "-arch") == 0)
+ {
+ int a;
+
+ if (++i >= argc)
+ fatal ("argument to `-arch' is missing");
+
+ set_new_arch (argv[i]);
+ }
+ /* APPLE LOCAL end fat builds */
else if (! strcmp (argv[i], "-pass-exit-codes"))
{
pass_exit_codes = 1;
@@ -3509,6 +3830,46 @@ warranty; not even for MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.\n\n"
save_temps_flag = 1;
n_switches++;
}
+ /* APPLE LOCAL begin IMA */
+ else if (strcmp (argv[i], "-traditional-cpp") == 0)
+ {
+ traditional_cpp_flag = 1;
+ n_switches++;
+ }
+ else if (strcmp (argv[i], "-E") == 0)
+ {
+ capital_e_flag = 1;
+ n_switches++;
+ }
+ /* APPLE LOCAL end IMA */
+ /* APPLE LOCAL begin 3235250 */
+ else if (strcmp (argv[i], "-weak_library") == 0)
+ {
+ if (i + 1 == argc)
+ fatal ("argument to `-weak_library' is missing");
+
+ n_infiles += 2;
+ i++;
+ }
+ else if (strcmp (argv[i], "-weak_framework") == 0)
+ {
+ if (i + 1 == argc)
+ fatal ("argument to `-weak_framework' is missing");
+
+ n_infiles += 2;
+ i++;
+ }
+ /* APPLE LOCAL end 3235250 */
+ /* APPLE LOCAL begin Symbol Separation */
+ else if (strcmp (argv[i], "-save-repository") == 0)
+ {
+ if (i + 1 == argc)
+ fatal ("argument to `-save-repository' is missing");
+
+ n_infiles++;
+ i++;
+ }
+ /* APPLE LOCAL end Symbol Separation */
else if (strcmp (argv[i], "-specs") == 0)
{
struct user_specs *user = xmalloc (sizeof (struct user_specs));
@@ -3555,6 +3916,22 @@ warranty; not even for MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.\n\n"
verbose_only_flag++;
verbose_flag++;
}
+ /* APPLE LOCAL begin constant cfstrings */
+ else if (strcmp (argv[i], "-fconstant-cfstrings") == 0)
+ use_constant_cfstrings = 1;
+ else if (strcmp (argv[i], "-fno-constant-cfstrings") == 0)
+ use_constant_cfstrings = 0;
+ /* APPLE LOCAL end constant cfstrings */
+ /* APPLE LOCAL begin framework */
+ else if (strcmp (argv[i], "-framework") == 0)
+ {
+ if (i + 1 == argc)
+ fatal ("argument to `-framework' is missing");
+
+ n_infiles += 2;
+ i++;
+ }
+ /* APPLE LOCAL end framework */
else if (argv[i][0] == '-' && argv[i][1] != 0)
{
const char *p = &argv[i][1];
@@ -3687,6 +4064,11 @@ warranty; not even for MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.\n\n"
else
argv[i] = convert_filename (argv[i], ! have_c, 0);
#endif
+ /* APPLE LOCAL begin fat builds */
+ if (p[1] == '\0')
+ /* Name to use in the -final_output linker flag. */
+ final_output = argv[i + 1];
+ /* APPLE LOCAL end fat builds */
goto normal_switch;
default:
@@ -3744,8 +4126,6 @@ warranty; not even for MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.\n\n"
}
}
- combine_inputs = (have_c && have_o && lang_n_infiles > 1);
-
if ((save_temps_flag || report_times) && use_pipes)
{
/* -save-temps overrides -pipe, so that temp files are produced */
@@ -3844,6 +4224,30 @@ warranty; not even for MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.\n\n"
/* More prefixes are enabled in main, after we read the specs file
and determine whether this is cross-compilation or not. */
+ /* APPLE LOCAL begin constant cfstrings */
+ /* Check if '-fconstant-cfstrings' usage is valid, given our deployment
+ target. If not, issue a warning and then suppress the option. */
+ if (use_constant_cfstrings)
+ {
+ if (macosx_version_min_required && macosx_version_min_required < 1020)
+ {
+ error ("warning: `-fconstant-cfstrings' ignored because MACOSX_DEPLOYMENT_TARGET is \"%s\"",
+ macosx_deployment_target);
+ use_constant_cfstrings = 0;
+ }
+ else
+ add_preprocessor_option ("-D__CONSTANT_CFSTRINGS__", 24);
+ }
+ /* Synthesize the deployment target manifest constant. */
+ if (macosx_version_min_required)
+ {
+ char macro_def[40];
+
+ sprintf (macro_def, "-DMAC_OS_X_VERSION_MIN_REQUIRED=%d", macosx_version_min_required);
+ add_preprocessor_option (macro_def, strlen (macro_def));
+ }
+ /* APPLE LOCAL end constant cfstrings */
+
/* Then create the space for the vectors and scan again. */
switches = xmalloc ((n_switches + 1) * sizeof (struct switchstr));
@@ -3874,6 +4278,10 @@ warranty; not even for MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.\n\n"
;
else if (! strncmp (argv[i], "-Wp,", 4))
;
+ /* APPLE LOCAL begin fat builds */
+ else if (strcmp (argv[i], "-arch") == 0)
+ ++i;
+ /* APPLE LOCAL end fat builds */
else if (! strcmp (argv[i], "-pass-exit-codes"))
;
else if (! strcmp (argv[i], "-print-search-dirs"))
@@ -3950,14 +4358,62 @@ warranty; not even for MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.\n\n"
infiles[n_infiles].language = "*";
infiles[n_infiles++].name = argv[i];
}
+ /* APPLE LOCAL begin 3235250 */
+ else if (strncmp (argv[i], "-weak-l", 7) == 0)
+ {
+ infiles[n_infiles].language = "*";
+ infiles[n_infiles++].name = argv[i];
+ }
+ else if (strcmp (argv[i], "-weak_library") == 0)
+ {
+ infiles[n_infiles].language = "*";
+ infiles[n_infiles++].name = argv[i];
+ infiles[n_infiles].language = "*";
+ infiles[n_infiles++].name = argv[++i];
+ }
+ else if (strcmp (argv[i], "-weak_framework") == 0)
+ {
+ infiles[n_infiles].language = "*";
+ infiles[n_infiles++].name = argv[i];
+ infiles[n_infiles].language = "*";
+ infiles[n_infiles++].name = argv[++i];
+ }
+ /* APPLE LOCAL end 3235250 */
else if (strcmp (argv[i], "-specs") == 0)
i++;
else if (strncmp (argv[i], "-specs=", 7) == 0)
;
+ /* APPLE LOCAL begin -ObjC 2001-08-03 sts */
+ else if (!strcmp (argv[i], "-ObjC") || !strcmp (argv[i], "-fobjc"))
+ {
+ default_language = "objective-c";
+ add_linker_option ("-ObjC", 5);
+ }
+ else if (strcmp (argv[i], "-ObjC++") == 0)
+ {
+ default_language = "objective-c++";
+ add_linker_option ("-ObjC", 5);
+ }
+ /* APPLE LOCAL end -ObjC 2001-08-03 sts */
else if (strcmp (argv[i], "-time") == 0)
;
else if (strcmp (argv[i], "-###") == 0)
;
+ /* APPLE LOCAL begin constant cfstrings */
+ else if (strcmp (argv[i], "-fconstant-cfstrings") == 0)
+ ;
+ else if (strcmp (argv[i], "-fno-constant-cfstrings") == 0)
+ ;
+ /* APPLE LOCAL end constant cfstrings */
+ /* APPLE LOCAL begin framework */
+ else if (strcmp (argv[i], "-framework") == 0)
+ {
+ infiles[n_infiles].language = "*";
+ infiles[n_infiles++].name = argv[i];
+ infiles[n_infiles].language = "*";
+ infiles[n_infiles++].name = argv[++i];
+ }
+ /* APPLE LOCAL end framework */
else if (argv[i][0] == '-' && argv[i][1] != 0)
{
const char *p = &argv[i][1];
@@ -4117,7 +4573,9 @@ set_collect_gcc_options (void)
first_time = FALSE;
/* Ignore elided switches. */
- if (switches[i].live_cond == SWITCH_IGNORE)
+ /* APPLE LOCAL fat builds */
+ if (switches[i].live_cond == SWITCH_IGNORE
+ || switches[i].live_cond == SWITCH_IGNORE_RESTORE)
continue;
obstack_grow (&collect_obstack, "'-", 2);
@@ -4185,6 +4643,20 @@ static int delete_this_arg;
is the output file name of this compilation. */
static int this_is_output_file;
+/* APPLE LOCAL begin fat builds */
+/* Nonzero means %f has been seen; the next arg to be terminated
+ is the output file name of the compilation of this architecture. */
+static int this_is_arch_merge_file;
+/* APPLE LOCAL end fat builds */
+
+/* APPLE LOCAL begin %b/save-temps can clobber input file (radar 2871891) ilr */
+/* Nonzero if %b or %B has been seen; the next arg to be terminated
+ is a temp file based on the input file's basename. This has
+ the potential to be the same as the input file itself so we
+ need to take precautions if it is. */
+static int this_is_basename_derived_file = 0;
+/* APPLE LOCAL begin %b/save-temps can clobber input file (radar 2871891) ilr */
+
/* Nonzero means %s has been seen; the next arg to be terminated
is the name of a library file and we should try the standard
search dirs for it. */
@@ -4205,6 +4677,11 @@ do_spec (const char *spec)
{
int value;
+ /* APPLE LOCAL fat builds */
+ this_is_arch_merge_file = 0;
+ /* APPLE LOCAL %b/save-temps can clobber input file (radar 2871891) ilr */
+ this_is_basename_derived_file = 0;
+
value = do_spec_2 (spec);
/* Force out any unfinished command.
@@ -4223,6 +4700,82 @@ do_spec (const char *spec)
return value;
}
+/* APPLE LOCAL begin %b/save-temps can clobber input file (radar 2871891) ilr */
+/* For %b and %B specs, which create a filename based on the input
+ file's basename, there is a possibility that the resulting file
+ is the same as the input file. Assuming that such names are
+ intended to be used as intermediate (temporary) files there is
+ the risk of clobbering the input file. We check for that here
+ and use a temp file instead if that would happen. */
+
+static const char *
+check_basename_derived_file (string)
+ const char *string;
+{
+ int suffix_length, string_length;
+ const char *suffix;
+
+ static struct base_temp_name {
+ int suffix_length;
+ int filename_length;
+ const char *filename;
+ struct base_temp_name *next;
+ } *t, *base_temp_names = NULL;
+
+ if (strcmp (string, input_filename) != 0)
+ {
+ struct stat st_temp;
+
+ /* Note, set_input() resets input_stat_set to 0. This can also
+ be done buy or for %U, %u, and %g. */
+ if (input_stat_set == 0)
+ {
+ input_stat_set = stat (input_filename, &input_stat);
+ if (input_stat_set >= 0)
+ input_stat_set = 1;
+ }
+
+ if (input_stat_set != 1
+ || stat (string, &st_temp) < 0
+ || input_stat.st_dev != st_temp.st_dev
+ || input_stat.st_ino != st_temp.st_ino)
+ {
+ this_is_basename_derived_file = 0;
+ return string;
+ }
+ }
+
+ string_length = strlen (string);
+ suffix_length = string_length - basename_length;
+ suffix = string + string_length - suffix_length;
+
+ if (suffix_length > 0)
+ {
+ for (t = base_temp_names; t; t = t->next)
+ if (t->suffix_length == suffix_length
+ && strcmp (t->filename + t->filename_length - suffix_length,
+ suffix) == 0)
+ break;
+ }
+ else
+ t = NULL;
+
+ if (!t)
+ {
+ t = (struct base_temp_name *) xmalloc (sizeof (struct base_temp_name));
+ t->next = base_temp_names;
+ base_temp_names = t;
+
+ t->filename = make_temp_file (suffix);
+ t->filename_length = strlen (t->filename);
+ t->suffix_length = suffix_length;
+ }
+
+ delete_this_arg = 1;
+ return t->filename;
+}
+/* APPLE LOCAL end %b/save-temps can clobber input file (radar 2871891) ilr */
+
static int
do_spec_2 (const char *spec)
{
@@ -4375,11 +4928,23 @@ do_spec_1 (const char *spec, int inswitch, const char *soft_matched_part)
{
obstack_1grow (&obstack, 0);
string = obstack_finish (&obstack);
- if (this_is_library_file)
+ /* APPLE LOCAL begin %b/save-temps can clobber input file (radar 2871891) ilr */
+ if (this_is_basename_derived_file)
+ string = check_basename_derived_file (string);
+ else if (this_is_library_file)
+ /* APPLE LOCAL end %b/save-temps can clobber input file (radar 2871891) ilr */
string = find_file (string);
- store_arg (string, delete_this_arg, this_is_output_file);
+ /* APPLE LOCAL fat builds */
+ /* APPLE LOCAL %b/save-temps can clobber input file (radar 2871891) ilr */
+ store_arg (string, delete_this_arg, this_is_output_file
+ || this_is_arch_merge_file
+ || this_is_basename_derived_file);
if (this_is_output_file)
outfiles[input_file_number] = string;
+ /* APPLE LOCAL begin fat builds */
+ else if (this_is_arch_merge_file)
+ arches[current_arch].merge_file = string;
+ /* APPLE LOCAL end fat builds */
}
arg_going = 0;
@@ -4410,6 +4975,10 @@ do_spec_1 (const char *spec, int inswitch, const char *soft_matched_part)
arg_going = 0;
delete_this_arg = 0;
this_is_output_file = 0;
+ /* APPLE LOCAL fat builds */
+ this_is_arch_merge_file = 0;
+ /* APPLE LOCAL %b/save-temps can clobber input file (radar 2871891) ilr */
+ this_is_basename_derived_file = 0;
this_is_library_file = 0;
input_from_pipe = 0;
break;
@@ -4420,11 +4989,23 @@ do_spec_1 (const char *spec, int inswitch, const char *soft_matched_part)
{
obstack_1grow (&obstack, 0);
string = obstack_finish (&obstack);
- if (this_is_library_file)
+ /* APPLE LOCAL begin %b/save-temps can clobber input file (radar 2871891) ilr */
+ if (this_is_basename_derived_file)
+ string = check_basename_derived_file (string);
+ else if (this_is_library_file)
+ /* APPLE LOCAL end %b/save-temps can clobber input file (radar 2871891) ilr */
string = find_file (string);
- store_arg (string, delete_this_arg, this_is_output_file);
+ /* APPLE LOCAL fat builds */
+ /* APPLE LOCAL radar 2871891 - %b/%B & -save-temps can clobber input file ilr */
+ store_arg (string, delete_this_arg, this_is_output_file
+ || this_is_arch_merge_file
+ || this_is_basename_derived_file);
if (this_is_output_file)
outfiles[input_file_number] = string;
+ /* APPLE LOCAL begin fat builds */
+ else if (this_is_arch_merge_file)
+ arches[current_arch].merge_file = string;
+ /* APPLE LOCAL end fat builds */
}
/* Use pipe */
@@ -4439,16 +5020,32 @@ do_spec_1 (const char *spec, int inswitch, const char *soft_matched_part)
{
obstack_1grow (&obstack, 0);
string = obstack_finish (&obstack);
- if (this_is_library_file)
+ /* APPLE LOCAL begin %b/save-temps can clobber input file (radar 2871891) ilr */
+ if (this_is_basename_derived_file)
+ string = check_basename_derived_file (string);
+ else if (this_is_library_file)
+ /* APPLE LOCAL end %b/save-temps can clobber input file (radar 2871891) ilr */
string = find_file (string);
- store_arg (string, delete_this_arg, this_is_output_file);
+ /* APPLE LOCAL fat builds */
+ /* APPLE LOCAL %b/save-temps can clobber input file (radar 2871891) ilr */
+ store_arg (string, delete_this_arg, this_is_output_file
+ || this_is_arch_merge_file
+ || this_is_basename_derived_file);
if (this_is_output_file)
outfiles[input_file_number] = string;
+ /* APPLE LOCAL begin fat builds */
+ else if (this_is_arch_merge_file)
+ arches[current_arch].merge_file = string;
+ /* APPLE LOCAL end fat builds */
}
/* Reinitialize for a new argument. */
arg_going = 0;
delete_this_arg = 0;
this_is_output_file = 0;
+ /* APPLE LOCAL fat builds */
+ this_is_arch_merge_file = 0;
+ /* APPLE LOCAL %b/save-temps can clobber input file (radar 2871891) ilr */
+ this_is_basename_derived_file = 0;
this_is_library_file = 0;
break;
@@ -4459,11 +5056,14 @@ do_spec_1 (const char *spec, int inswitch, const char *soft_matched_part)
fatal ("invalid specification! Bug in cc");
case 'b':
+ /* APPLE LOCAL %b/save-temps can clobber input file (radar 2871891) ilr */
+ this_is_basename_derived_file = 1;
obstack_grow (&obstack, input_basename, basename_length);
arg_going = 1;
break;
case 'B':
+ /* APPLE LOCAL %b/save-temps can clobber input file (radar 2871891) ilr */
obstack_grow (&obstack, input_basename, suffixed_basename_length);
arg_going = 1;
break;
@@ -4751,6 +5351,11 @@ do_spec_1 (const char *spec, int inswitch, const char *soft_matched_part)
suffix. */
for (t = temp_names; t; t = t->next)
if (t->length == suffix_length
+ /* APPLE LOCAL begin IMA */
+ /* Create new temp file for each source file. */
+ && strcmp (suffix, ".i")
+ && strcmp (suffix, ".ii")
+ /* APPLE LOCAL end IMA */
&& strncmp (t->suffix, suffix, suffix_length) == 0
&& t->unique == (c == 'u' || c == 'U' || c == 'j'))
break;
@@ -4778,22 +5383,33 @@ do_spec_1 (const char *spec, int inswitch, const char *soft_matched_part)
temp_filename_length = strlen (temp_filename);
t->filename = temp_filename;
t->filename_length = temp_filename_length;
+ /* APPLE LOCAL begin IMA */
+ infiles[input_file_number].temp_filename = temp_filename;
+ /* APPLE LOCAL end IMA */
}
if (saved_suffix)
free (saved_suffix);
obstack_grow (&obstack, t->filename, t->filename_length);
- delete_this_arg = 1;
+ /* APPLE LOCAL what is this for? */
+ delete_this_arg = (save_temps_flag == 0);
}
arg_going = 1;
break;
case 'i':
+/* APPLE LOCAL begin IMI */
if (combine_inputs)
{
for (i = 0; (int) i < n_infiles; i++)
- store_arg (infiles[i].name, 0, 0);
+ if ((!infiles[i].language) || (infiles[i].language[0] != '*'))
+ if (infiles[i].incompiler == input_file_compiler)
+ {
+ store_arg (infiles[i].name, 0, 0);
+ infiles[i].compiled = TRUE;
+ }
+/* APPLE LOCAL end IMI */
}
else
{
@@ -4838,6 +5454,45 @@ do_spec_1 (const char *spec, int inswitch, const char *soft_matched_part)
}
break;
+ /* APPLE LOCAL begin framework headers */
+ case 'Q':
+#ifdef FRAMEWORK_HEADERS
+ {
+ struct prefix_list *dfpl = default_framework_paths.plist;
+
+ for (; dfpl; dfpl = dfpl->next)
+ {
+ char *tmpstr = xmalloc (strlen (dfpl->prefix) + 5);
+ sprintf (tmpstr, "-F%s", dfpl->prefix);
+ do_spec_1 (tmpstr, 1, NULL);
+ do_spec_1 (" ", 0, NULL); /* fh */
+ free (tmpstr);
+ }
+ }
+#endif /* FRAMEWORK_HEADERS */
+ break;
+ /* APPLE LOCAL end framework headers */
+
+ /* APPLE LOCAL begin constant cfstrings */
+ case 'y':
+ {
+ int c1 = *p++;
+
+ if (c1 == 'C')
+ {
+ if (use_constant_cfstrings)
+ {
+ do_spec_1 (" ", 0, NULL);
+ do_spec_1 ("-fconstant-cfstrings", 1, NULL);
+ do_spec_1 (" ", 0, NULL);
+ }
+ }
+ else
+ abort ();
+ }
+ break;
+ /* APPLE LOCAL end constant cfstrings */
+
case 'o':
{
int max = n_infiles;
@@ -4846,6 +5501,13 @@ do_spec_1 (const char *spec, int inswitch, const char *soft_matched_part)
for (i = 0; i < max; i++)
if (outfiles[i])
store_arg (outfiles[i], 0, 0);
+ /* APPLE LOCAL begin fat builds */
+ if (num_arches > 1)
+ {
+ store_arg ("-final_output", 0, 0);
+ store_arg (final_output, 0, 0);
+ }
+ /* APPLE LOCAL end fat builds */
break;
}
@@ -4858,6 +5520,28 @@ do_spec_1 (const char *spec, int inswitch, const char *soft_matched_part)
this_is_library_file = 1;
break;
+ /* APPLE LOCAL begin fat builds */
+ case 'f':
+ this_is_arch_merge_file = 1;
+ break;
+ case 'F':
+ {
+ int a;
+ for (a = 0; a < num_arches; ++a)
+ {
+ store_arg ("-arch", 0, 0);
+ store_arg (arches[a].name, 0, 0);
+ store_arg ((arches[a].merge_file ? arches[a].merge_file : "???"), 0, 0);
+ }
+ }
+ break;
+ case 'T':
+ obstack_grow (&obstack, arches[current_arch].name,
+ strlen (arches[current_arch].name));
+ arg_going = 1;
+ break;
+ /* APPLE LOCAL end fat builds */
+
case 'V':
outfiles[input_file_number] = NULL;
break;
@@ -5761,7 +6445,9 @@ check_live_switch (int switchnum, int prefix_length)
static void
give_switch (int switchnum, int omit_first_word)
{
- if (switches[switchnum].live_cond == SWITCH_IGNORE)
+ /* APPLE LOCAL fat builds */
+ if (switches[switchnum].live_cond == SWITCH_IGNORE
+ ||switches[switchnum].live_cond == SWITCH_IGNORE_RESTORE)
return;
if (!omit_first_word)
@@ -5941,6 +6627,11 @@ main (int argc, const char **argv)
const char *p;
struct user_specs *uptr;
+ /* APPLE LOCAL begin 3313335 */
+ cc_print_options = getenv ("CC_PRINT_OPTIONS");
+ cc_print_options_filename = getenv ("CC_PRINT_OPTIONS_FILE");
+ /* APPLE LOCAL end 3313335 */
+
p = argv[0] + strlen (argv[0]);
while (p != argv[0] && !IS_DIR_SEPARATOR (p[-1]))
--p;
@@ -6046,8 +6737,22 @@ main (int argc, const char **argv)
memcpy (compilers, default_compilers, sizeof default_compilers);
n_compilers = n_default_compilers;
+ /* APPLE LOCAL begin fat builds */
+#ifdef DEFAULT_TARGET_ARCH
+ if (num_arches == 0) {
+ set_new_arch (DEFAULT_TARGET_ARCH);
+ }
+#else
+ #error Must have a DEFAULT_TARGET_ARCH!
+#endif
+ /* APPLE LOCAL end fat builds */
+
/* Read specs from a file if there is one. */
+ /* APPLE LOCAL begin fat builds */
+ spec_machine = concat (arches[0].config_string,
+ strchr (DEFAULT_TARGET_MACHINE, '-'), NULL);
+ /* APPLE LOCAL end fat builds */
machine_suffix = concat (spec_machine, dir_separator_str,
spec_version, dir_separator_str, NULL);
just_machine_suffix = concat (spec_machine, dir_separator_str, NULL);
@@ -6330,28 +7035,136 @@ main (int argc, const char **argv)
explicit_link_files = xcalloc (1, n_infiles);
- if (combine_inputs)
+/* APPLE LOCAL begin IMI */
{
int lang_n_infiles = 0;
+ bool singular_input_language = TRUE;
for (i = 0; (int) i < n_infiles; i++)
{
const char *name = infiles[i].name;
- struct compiler *compiler
- = lookup_compiler (name, strlen (name), infiles[i].language);
- if (compiler == NULL)
- error ("%s: linker input file unused because linking not done",
- name);
- else if (lang_n_infiles > 0 && compiler != input_file_compiler)
- fatal ("cannot specify -o with -c or -S and multiple languages");
- else
+ struct compiler *compiler = lookup_compiler (name, strlen (name), infiles[i].language);
+ if (lang_n_infiles > 0 && compiler != input_file_compiler
+ && infiles[i].language && infiles[i].language[0] != '*')
+ {
+ singular_input_language = FALSE;
+ infiles[i].incompiler = compiler;
+ }
+ else if (infiles[i].language && infiles[i].language[0] == '*')
+ {
+ explicit_link_files[i] = 1;
+ infiles[i].incompiler = NULL;
+ }
+ else if (compiler)
{
lang_n_infiles++;
input_file_compiler = compiler;
+ infiles[i].incompiler = compiler;
}
+ else
+ {
+ /* Since there is no compiler for this input file, assume it is a
+ linker file. */
+ explicit_link_files[i] = 1;
+ infiles[i].incompiler = NULL;
+ }
+ infiles[i].compiled = FALSE;
+ infiles[i].preprocessed = FALSE;
}
}
- for (i = 0; (int) i < (combine_inputs ? 1 : n_infiles); i++)
+ if (save_temps_flag || traditional_cpp_flag || capital_e_flag)
+ {
+ /* Must do a separate pre-processing pass for C & Objective-C files, to
+ obtain individual .i files. */
+
+ for (i=0; (int) i < n_infiles; i++)
+ {
+ int this_file_error = 0;
+
+ input_file_number = i;
+ set_input (infiles[i].name);
+ if ((infiles[i].incompiler)
+ && (strcmp(infiles[i].incompiler->suffix, "@c") == 0
+ || strcmp (infiles[i].incompiler->suffix, ".m") == 0
+ || strcmp (infiles[i].incompiler->suffix, ".c") == 0))
+ {
+ input_file_compiler = infiles[i].incompiler;
+ }
+ else
+ continue;
+
+ /* outfiles[i] = input_filename;*/
+
+ if (input_file_compiler)
+ {
+ {
+ value = do_spec (input_file_compiler->spec);
+ infiles[i].preprocessed = TRUE;
+
+ if (infiles[i].preprocessed && !capital_e_flag)
+ {
+ if (save_temps_flag)
+ {
+ char *name = (char *) xmalloc ((strlen(infiles[i].name) + 1)
+ * sizeof (char));
+ char *dot, *p;
+ strcpy (name, infiles[i].name);
+ dot = strrchr (name, '.');
+ dot++;
+ if (*dot == 'c')
+ *dot = 'i';
+ else if (*dot == 'm')
+ {
+ dot++;
+ *dot = 'i';
+ dot++;
+ *dot = '\0';
+ }
+
+ infiles[i].incompiler = lookup_compiler (name,
+ strlen (name),
+ infiles[i].language);
+
+ /* Save temps files are created in current working directory.
+ Extract basename by removing directory names from input
+ file name. */
+ for (p = name; *p; p++)
+ if (IS_DIR_SEPARATOR (*p))
+ name = p + 1;
+ infiles[i].name = name;
+
+ }
+ else if (traditional_cpp_flag)
+ {
+ /* Temp file name is stored in infiles->temp_filename.
+ Use it as input file name. */
+ infiles[i].name = infiles[i].temp_filename;
+ infiles[i].incompiler = lookup_compiler (infiles[i].name,
+ strlen (infiles[i].name),
+ infiles[i].language);
+ }
+ }
+
+ if (value < 0)
+ {
+ this_file_error = 1;
+ break;
+ }
+ }
+
+ }
+
+ if (this_file_error)
+ {
+ delete_failure_queue ();
+ error_count++;
+ }
+ clear_failure_queue ();
+ }
+ }
+/* APPLE LOCAL end IMI */
+
+ for (i = 0; (int) i < n_infiles; i++)
{
int this_file_error = 0;
@@ -6360,16 +7173,49 @@ main (int argc, const char **argv)
input_file_number = i;
set_input (infiles[i].name);
- /* Use the same thing in %o, unless cp->spec says otherwise. */
+/* APPLE LOCAL begin IMI */
- outfiles[i] = input_filename;
+ if (infiles[i].compiled)
+ continue;
+ else
+ {
+ const char *name = infiles[i].name;
+ char *dot = strrchr (name, '.');
+ int len = strlen (name);
+ char *ext = (char *) xmalloc (len*sizeof(char));
+
+ if (dot)
+ strcpy (ext, dot);
+ else
+ ext[0] = '\0';
+
+ /* IMI currently only works for C and Objective-C, so make sure the
+ source file belongs to one of those, or don't attempt IMI. */
+
+ if ((strcmp (ext, ".m") == 0)
+ || (strcmp (ext, ".c") == 0)
+ || (strcmp (ext, ".i") == 0)
+ || (strcmp (ext, ".s") == 0)
+ || (strcmp (ext, ".S") == 0))
+ combine_inputs = TRUE;
+ else
+ combine_inputs = FALSE;
+
+ if (combine_inputs)
+ {
+ if ((strcmp (ext, ".s") == 0) || strcmp (ext, ".S") == 0)
+ assembly_input = TRUE;
+ else
+ assembly_input = FALSE;
+ }
+ input_file_compiler = infiles[i].incompiler;
+ }
- /* Figure out which compiler from the file's suffix. */
+/* APPLE LOCAL end IMI */
+
+ /* Use the same thing in %o, unless cp->spec says otherwise. */
- if (! combine_inputs)
- input_file_compiler
- = lookup_compiler (infiles[i].name, input_filename_length,
- infiles[i].language);
+ outfiles[i] = input_filename;
if (input_file_compiler)
{
@@ -6381,12 +7227,71 @@ main (int argc, const char **argv)
input_filename, &input_file_compiler->spec[1]);
this_file_error = 1;
}
- else
+ /* APPLE LOCAL begin IMA */
+ /* Check if -E is not used on command line OR input file is
+ assembly file. If -E is used then do not invoke compiler
+ again, because preprocessed output is already generated
+ above. However
+ 1) If -E is used with assembly input file then continue.
+ 2) If inputs are not combined then continue. */
+ else if (!capital_e_flag || assembly_input || !combine_inputs)
+ /* APPLE LOCAL end IMA */
+ {
+ /* APPLE LOCAL begin fat builds */
+ /* Clear all the merge file names, in preparation for a
+ %F in the merge spec. */
+ int j;
+ for (current_arch = 0; current_arch < num_arches; ++current_arch)
+ arches[current_arch].merge_file = NULL;
+ for (current_arch = 0; current_arch < num_arches; ++current_arch)
+ {
+ if (num_arches > 1)
+ {
+ machine_suffix = concat (arches[current_arch]
+ .config_string,
+ strchr (DEFAULT_TARGET_MACHINE,
+ '-'),
+ dir_separator_str, spec_version,
+ dir_separator_str, NULL);
+ just_machine_suffix = concat (arches[current_arch]
+ .config_string,
+ strchr (DEFAULT_TARGET_MACHINE,
+ '-'),
+ dir_separator_str, NULL);
+ specs_file = find_a_file (&startfile_prefixes,
+ "specs", R_OK, 0);
+ /* Read the specs file unless it is a default one. */
+ if (specs_file != 0 && strcmp (specs_file, "specs"))
+ read_specs (specs_file, FALSE);
+ else
+ fatal ("cannot read specs file for arch `%s'",
+ arches[current_arch].name);
+ }
+ value = do_spec (input_file_compiler->spec);
+ /* APPLE LOCAL begin IMI */
+ infiles[i].compiled = TRUE;
+ /* APPLE LOCAL end IMI */
+ if (value < 0)
+ {
+ this_file_error = 1;
+ break;
+ }
+ /* Restore any ignore_restore {!<S} switches */
+ for (j = 0; j < n_switches; j++)
+ if (switches[j].live_cond == SWITCH_IGNORE_RESTORE)
+ switches[j].live_cond = SWITCH_LIVE;
+ }
+ /* APPLE LOCAL end fat builds */
+ }
+ /* APPLE LOCAL begin fat builds */
+ /* Do lipo-ing on object files or precomps. */
+ if (num_arches > 1 && !this_file_error)
{
- value = do_spec (input_file_compiler->spec);
- if (value < 0)
- this_file_error = 1;
+ value = do_spec (ofile_merge_spec);
+ if (value < 0)
+ this_file_error = 1;
}
+ /* APPLE LOCAL end fat builds */
}
/* If this file's name does not contain a recognized suffix,
@@ -6446,11 +7351,38 @@ main (int argc, const char **argv)
putenv_from_prefixes (&exec_prefixes, "COMPILER_PATH");
putenv_from_prefixes (&startfile_prefixes, LIBRARY_PATH_ENV);
- value = do_spec (link_command_spec);
+ /* APPLE LOCAL begin fat builds */
+ /* Clear all the merge file names, in preparation for a %F in the
+ merge spec. */
+ for (current_arch = 0; current_arch < num_arches; ++current_arch)
+ arches[current_arch].merge_file = NULL;
+ for (current_arch = 0; current_arch < num_arches; ++current_arch)
+ {
+ machine_suffix = concat (arches[current_arch].config_string,
+ strchr (DEFAULT_TARGET_MACHINE,
+ '-'),
+ dir_separator_str, spec_version,
+ dir_separator_str, NULL);
+ value = do_spec (link_command_spec);
+ if (value < 0)
+ {
+ error_count = 1;
+ break;
+ }
+ }
+ /* APPLE LOCAL end fat builds */
+ linker_was_run = (tmp != execution_count);
+ }
+
+ /* APPLE LOCAL begin fat builds */
+ /* Run the merger after linking all architectures. */
+ if (num_arches > 1 && error_count == 0)
+ {
+ value = do_spec (exec_merge_spec);
if (value < 0)
error_count = 1;
- linker_was_run = (tmp != execution_count);
}
+ /* APPLE LOCAL end fat builds */
/* If options said don't run linker,
complain about input files to be given to the linker. */
@@ -6536,6 +7468,27 @@ lookup_compiler (const char *name, size_t length, const char *language)
if (cp >= compilers)
{
+ /* APPLE LOCAL begin -ObjC 2001-08-03 sts */
+ /* We found a language, but because we set a default language,
+ override with the default. */
+ if (default_language)
+ {
+ struct compiler *ncomp = lookup_compiler (NULL, 0, default_language);
+#if 0 /* unhelpful without docs to educate users, skip for now -sts 2002-01-01 */
+ if (cp == ncomp
+ || (cp->spec[0] == '@'
+ && ncomp
+ && strcmp (cp->spec, ncomp->suffix) == 0))
+ {
+ if (strcmp (default_language, "objective-c") == 0)
+ error ("Warning: -ObjC/-fobjc option is redundant");
+ if (strcmp (default_language, "objective-c++") == 0)
+ error ("Warning: -ObjC++ option is redundant");
+ }
+#endif
+ return ncomp;
+ }
+ /* APPLE LOCAL end -ObjC 2001-08-03 sts */
if (cp->spec[0] != '@')
/* A non-alias entry: return it. */
return cp;
diff --git a/gcc/gcc.h b/gcc/gcc.h
index 9df9ffd1252..ad70e9cdd1f 100644
--- a/gcc/gcc.h
+++ b/gcc/gcc.h
@@ -38,10 +38,14 @@ struct spec_function
|| (CHAR) == 'e' || (CHAR) == 'T' || (CHAR) == 'u' \
|| (CHAR) == 'I' || (CHAR) == 'm' || (CHAR) == 'x' \
|| (CHAR) == 'L' || (CHAR) == 'A' || (CHAR) == 'V' \
+ /* APPLE LOCAL framework headers */ \
+ || (CHAR) == 'F' \
|| (CHAR) == 'B' || (CHAR) == 'b')
/* This defines which multi-letter switches take arguments. */
+/* APPLE LOCAL Symbol Separation */
+/* Add save-repository in the list. */
#define DEFAULT_WORD_SWITCH_TAKES_ARG(STR) \
(!strcmp (STR, "Tdata") || !strcmp (STR, "Ttext") \
|| !strcmp (STR, "Tbss") || !strcmp (STR, "include") \
@@ -49,7 +53,7 @@ struct spec_function
|| !strcmp (STR, "idirafter") || !strcmp (STR, "iprefix") \
|| !strcmp (STR, "iwithprefix") || !strcmp (STR, "iwithprefixbefore") \
|| !strcmp (STR, "isystem") || !strcmp (STR, "-param") \
- || !strcmp (STR, "specs") \
+ || !strcmp (STR, "save-repository") || !strcmp (STR, "specs") \
|| !strcmp (STR, "MF") || !strcmp (STR, "MT") || !strcmp (STR, "MQ"))
diff --git a/gcc/gcse.c b/gcc/gcse.c
index 69f12fae9e9..cd61170a97d 100644
--- a/gcc/gcse.c
+++ b/gcc/gcse.c
@@ -788,6 +788,17 @@ gcse_main (rtx f, FILE *file)
during this pass. */
changed = one_cprop_pass (pass + 1, 0, 0);
+ /* APPLE LOCAL begin div by const */
+ /* div by const optimization can introduce new instructions.
+ All this stuff needs to be recomputed. */
+ free_gcse_mem ();
+ max_gcse_regno = max_reg_num ();
+ alloc_gcse_mem (f);
+ free_reg_set_mem ();
+ alloc_reg_set_mem (max_reg_num ());
+ compute_sets (f);
+ /* APPLE LOCAL end div by const */
+
if (optimize_size)
changed |= one_classic_gcse_pass (pass + 1);
else
@@ -4204,6 +4215,64 @@ cprop_insn (rtx insn, int alter_jumps)
if (INSN_DELETED_P (insn))
return 1;
}
+ /* APPLE LOCAL begin div by const */
+ /* Look for int div by constant and expand if found. */
+ if ( GET_CODE (insn) == INSN
+ && GET_CODE (PATTERN (insn)) == SET
+ && ( GET_CODE (XEXP (PATTERN (insn), 1)) == DIV
+ || GET_CODE (XEXP (PATTERN (insn), 1)) == UDIV)
+ && GET_MODE (XEXP (PATTERN (insn), 1)) == SImode
+ && GET_CODE (XEXP (XEXP (PATTERN (insn), 1), 1)) == CONST_INT )
+ {
+ rtx seq, result, target;
+ target = XEXP (PATTERN (insn), 0);
+ start_sequence ();
+ result = expand_divmod (0, TRUNC_DIV_EXPR, SImode,
+ XEXP (XEXP (PATTERN (insn), 1), 0),
+ XEXP (XEXP (PATTERN (insn), 1), 1),
+ target,
+ GET_CODE (XEXP (PATTERN (insn), 1))==DIV ? 0 : 1);
+ if ( result != target )
+ emit_move_insn (target, result);
+ seq = get_insns ();
+ end_sequence ();
+ emit_insn_after (seq, insn);
+ PUT_CODE (insn, NOTE);
+ NOTE_LINE_NUMBER (insn) = NOTE_INSN_DELETED;
+ NOTE_SOURCE_FILE (insn) = 0;
+ update_bb_for_insn (BLOCK_FOR_INSN (insn));
+ changed = 1;
+ break;
+ }
+ else if ( GET_CODE (insn) == INSN
+ && GET_CODE (PATTERN (insn)) == SET
+ && (note = find_reg_equal_equiv_note (insn))
+ && (GET_CODE (XEXP (note, 0)) == DIV
+ || GET_CODE (XEXP (note, 0)) == UDIV)
+ && GET_MODE (XEXP (note, 0)) == SImode
+ && GET_CODE (XEXP (XEXP (note, 0), 1)) == CONST_INT )
+ {
+ rtx seq, result, target;
+ target = XEXP (PATTERN (insn), 0);
+ start_sequence ();
+ result = expand_divmod (0, TRUNC_DIV_EXPR, SImode,
+ XEXP (XEXP (note, 0), 0),
+ XEXP (XEXP (note, 0), 1),
+ target,
+ GET_CODE (XEXP (note, 0))==DIV ? 0 : 1);
+ if ( result != target )
+ emit_move_insn (target, result);
+ seq = get_insns ();
+ end_sequence ();
+ emit_insn_after (seq, insn);
+ PUT_CODE (insn, NOTE);
+ NOTE_LINE_NUMBER (insn) = NOTE_INSN_DELETED;
+ NOTE_SOURCE_FILE (insn) = 0;
+ update_bb_for_insn (BLOCK_FOR_INSN (insn));
+ changed = 1;
+ break;
+ }
+ /* APPLE LOCAL end div by const */
}
else if (GET_CODE (src) == REG
&& REGNO (src) >= FIRST_PSEUDO_REGISTER
@@ -6070,7 +6139,7 @@ delete_null_pointer_checks_1 (unsigned int *block_reg, sbitmap *nonnull_avin,
delete_insn (last_insn);
#ifdef HAVE_cc0
if (compare_and_branch == 2)
- delete_insn (earliest);
+ delete_insn (earliest);
#endif
purge_dead_edges (bb);
diff --git a/gcc/gengtype.c b/gcc/gengtype.c
index 73aba41c621..148b27b511a 100644
--- a/gcc/gengtype.c
+++ b/gcc/gengtype.c
@@ -1124,6 +1124,11 @@ get_file_basename (const char *f)
int l1;
int l2;
s1 = basename - strlen (lang_dir_names [i]) - 1;
+ /* APPLE LOCAL begin Objective-C++ */
+ /* Don't confuse "objcp/" with "cp/". */
+ if (s1[-1] != '/')
+ continue;
+ /* APPLE LOCAL end Objective-C++ */
s2 = lang_dir_names [i];
l1 = strlen (s1);
l2 = strlen (s2);
@@ -1150,26 +1155,16 @@ get_file_basename (const char *f)
unsigned
get_base_file_bitmap (const char *input_file)
{
- const char *basename = get_file_basename (input_file);
- const char *slashpos = strchr (basename, '/');
+ /* APPLE LOCAL Objective-C++ */
+ /* Variables were here. */
unsigned j;
unsigned k;
unsigned bitmap;
- if (slashpos)
- {
- size_t i;
- for (i = 1; i < NUM_BASE_FILES; i++)
- if ((size_t)(slashpos - basename) == strlen (lang_dir_names [i])
- && memcmp (basename, lang_dir_names[i], strlen (lang_dir_names[i])) == 0)
- {
- /* It's in a language directory, set that language. */
- bitmap = 1 << i;
- return bitmap;
- }
-
- abort (); /* Should have found the language. */
- }
+ /* APPLE LOCAL begin Objective-C++ */
+ /* Lose the subdirectory-based scanning, it's redundant
+ if the config-lang.in lists are correct. */
+ /* APPLE LOCAL end Objective-C++ */
/* If it's in any config-lang.in, then set for the languages
specified. */
@@ -1235,6 +1230,17 @@ get_output_file_with_visibility (const char *input_file)
output_name = "gt-c-common.h", for_name = "c-common.c";
else if (strcmp (basename, "c-tree.h") == 0)
output_name = "gt-c-decl.h", for_name = "c-decl.c";
+ /* APPLE LOCAL begin Objective-C++ */
+ /* Put all lang-specific header roots in their own .h files. */
+ else if (strcmp (basename, "cp/cp-tree.h") == 0)
+ output_name = "gt-cp-cp-tree-h.h", for_name = "cp/cp-tree.h";
+ else if (strcmp (basename, "cp/decl.h") == 0)
+ output_name = "gt-cp-decl-h.h", for_name = "cp/decl.h";
+ else if (strcmp (basename, "cp/lex.h") == 0)
+ output_name = "gt-cp-lex-h.h", for_name = "cp/lex.h";
+ else if (strcmp (basename, "objc/objc-act.h") == 0)
+ output_name = "gt-objc-objc-act-h.h", for_name = "objc/objc-act.h";
+ /* APPLE LOCAL end Objective-C++ */
else
{
size_t i;
diff --git a/gcc/ginclude/stdarg.h b/gcc/ginclude/stdarg.h
index f178505e892..203a2174980 100644
--- a/gcc/ginclude/stdarg.h
+++ b/gcc/ginclude/stdarg.h
@@ -28,6 +28,11 @@ Boston, MA 02111-1307, USA. */
* ISO C Standard: 7.15 Variable arguments <stdarg.h>
*/
+/* APPLE LOCAL begin MW compatibility */
+#ifdef __MWERKS__
+#include "mw_stdarg.h"
+#else
+/* APPLE LOCAL end MW compatibility */
#ifndef _STDARG_H
#ifndef _ANSI_STDARG_H_
#ifndef __need___va_list
@@ -131,3 +136,5 @@ typedef __gnuc_va_list va_list;
#endif /* not _ANSI_STDARG_H_ */
#endif /* not _STDARG_H */
+/* APPLE LOCAL MW compatibility */
+#endif /* __MWERKS__ */
diff --git a/gcc/ginclude/varargs.h b/gcc/ginclude/varargs.h
index 4b9803e71ac..a25a3628787 100644
--- a/gcc/ginclude/varargs.h
+++ b/gcc/ginclude/varargs.h
@@ -1,3 +1,9 @@
+/* APPLE LOCAL begin MW compatibility */
+#ifdef __MWERKS__
+#include "mw_varargs.h"
+#else
+/* APPLE LOCAL end MW compatibility */
+
#ifndef _VARARGS_H
#define _VARARGS_H
@@ -5,3 +11,5 @@
#error "Revise your code to use <stdarg.h>."
#endif
+/* APPLE LOCAL MW compatibility */
+#endif /* __MWERKS__ */
diff --git a/gcc/global.c b/gcc/global.c
index 6f84ebffa8b..59cb642f959 100644
--- a/gcc/global.c
+++ b/gcc/global.c
@@ -38,6 +38,14 @@ Software Foundation, 59 Temple Place - Suite 330, Boston, MA
#include "output.h"
#include "toplev.h"
+/* APPLE LOCAL begin rewrite weight computation */
+/* The rewritten weight computation works fine on Darwin, but causes
+ bootstrap compares to fail on Linux. */
+#ifdef CONFIG_DARWIN_H
+#define REWRITE_WEIGHT_COMPUTATION
+#endif
+/* APPLE LOCAL end rewrite weight computation */
+
/* This pass of the compiler performs global register allocation.
It assigns hard register numbers to all the pseudo registers
that were not handled in local_alloc. Assignments are recorded
@@ -226,6 +234,18 @@ static HARD_REG_SET regs_used_so_far;
static int local_reg_n_refs[FIRST_PSEUDO_REGISTER];
+/* APPLE LOCAL begin rewrite weight computation */
+#ifdef REWRITE_WEIGHT_COMPUTATION
+/* Overall weight of each hard reg, as used by local alloc.
+ This was formerly computed once as
+ SUM(REG_FREQ(i))/SUM(REG_LIVE_LENGTH(i)) where the sums
+ are computed over all uses. But that computation produces very
+ wrong answers when a reg is used both inside and outside a loop.
+ Now it is computed as
+ SUM (REG_FREQ(i)/REG_LIVE_LENGTH(i)) over all uses. */
+
+static double local_reg_weight[FIRST_PSEUDO_REGISTER];
+#else
/* Frequency of uses of given hard reg. */
static int local_reg_freq[FIRST_PSEUDO_REGISTER];
@@ -233,6 +253,8 @@ static int local_reg_freq[FIRST_PSEUDO_REGISTER];
This is actually the sum of the live lengths of the specific regs. */
static int local_reg_live_length[FIRST_PSEUDO_REGISTER];
+#endif /* REWRITE_WEIGHT_COMPUTATION */
+/* APPLE LOCAL end rewrite weight computation */
/* Set to 1 a bit in a vector TABLE of HARD_REG_SETs, for vector
element I, and hard register number J. */
@@ -478,9 +500,17 @@ global_alloc (FILE *file)
/* Calculate amount of usage of each hard reg by pseudos
allocated by local-alloc. This is to see if we want to
override it. */
+ /* APPLE LOCAL begin rewrite weight computation */
+#ifndef REWRITE_WEIGHT_COMPUTATION
memset (local_reg_live_length, 0, sizeof local_reg_live_length);
+#endif /* REWRITE_WEIGHT_COMPUTATION */
memset (local_reg_n_refs, 0, sizeof local_reg_n_refs);
+#ifdef REWRITE_WEIGHT_COMPUTATION
+ memset (local_reg_weight, 0, sizeof local_reg_weight);
+#else
memset (local_reg_freq, 0, sizeof local_reg_freq);
+#endif /* REWRITE_WEIGHT_COMPUTATION */
+ /* APPLE LOCAL end rewrite weight computation */
for (i = FIRST_PSEUDO_REGISTER; i < (size_t) max_regno; i++)
if (reg_renumber[i] >= 0)
{
@@ -491,15 +521,29 @@ global_alloc (FILE *file)
for (j = regno; j < endregno; j++)
{
local_reg_n_refs[j] += REG_N_REFS (i);
+ /* APPLE LOCAL begin rewrite weight computation */
+#ifdef REWRITE_WEIGHT_COMPUTATION
+ if ( REG_LIVE_LENGTH (i) > 0 )
+ local_reg_weight[j] += (double)REG_FREQ (i)
+ / (double) REG_LIVE_LENGTH (i);
+#else
local_reg_freq[j] += REG_FREQ (i);
local_reg_live_length[j] += REG_LIVE_LENGTH (i);
+#endif /* REWRITE_WEIGHT_COMPUTATION */
+ /* APPLE LOCAL end rewrite weight computation */
}
}
/* We can't override local-alloc for a reg used not just by local-alloc. */
for (i = 0; i < FIRST_PSEUDO_REGISTER; i++)
if (regs_ever_live[i])
+ /* APPLE LOCAL begin rewrite weight computation */
+#ifdef REWRITE_WEIGHT_COMPUTATION
+ local_reg_n_refs[i] = 0;
+#else
local_reg_n_refs[i] = 0, local_reg_freq[i] = 0;
+#endif /* REWRITE_WEIGHT_COMPUTATION */
+ /* APPLE LOCAL end rewrite weight computation */
allocno_row_words = (max_allocno + INT_BITS - 1) / INT_BITS;
@@ -1249,6 +1293,15 @@ find_reg (int num, HARD_REG_SET losers, int alt_regs_p, int accept_call_clobbere
#endif
)
{
+ /* APPLE LOCAL begin rewrite weight computation */
+#ifdef REWRITE_WEIGHT_COMPUTATION
+ /* We explicitly evaluate the divide result into a temporary
+ variable so as to avoid excess precision problems that occur
+ on an i386-unknown-sysv4.2 (unixware) host. */
+ double tmp = ((double) allocno[num].freq
+ / allocno[num].live_length);
+#else
+ /* APPLE LOCAL end rewrite weight computation */
/* We explicitly evaluate the divide results into temporary
variables so as to avoid excess precision problems that occur
on an i386-unknown-sysv4.2 (unixware) host. */
@@ -1257,8 +1310,15 @@ find_reg (int num, HARD_REG_SET losers, int alt_regs_p, int accept_call_clobbere
/ local_reg_live_length[regno]);
double tmp2 = ((double) allocno[num].freq
/ allocno[num].live_length);
+ /* APPLE LOCAL begin rewrite weight computation */
+#endif /* REWRITE_WEIGHT_COMPUTATION */
+#ifdef REWRITE_WEIGHT_COMPUTATION
+ if (local_reg_weight[regno] < tmp)
+#else
if (tmp1 < tmp2)
+#endif /* REWRITE_WEIGHT_COMPUTATION */
+ /* APPLE LOCAL end rewrite weight computation */
{
/* Hard reg REGNO was used less in total by local regs
than it would be used by this one allocno! */
@@ -1305,7 +1365,11 @@ find_reg (int num, HARD_REG_SET losers, int alt_regs_p, int accept_call_clobbere
SET_HARD_REG_BIT (regs_used_so_far, j);
/* This is no longer a reg used just by local regs. */
local_reg_n_refs[j] = 0;
+ /* APPLE LOCAL begin rewrite weight computation */
+#ifndef REWRITE_WEIGHT_COMPUTATION
local_reg_freq[j] = 0;
+#endif /* REWRITE_WEIGHT_COMPUTATION */
+ /* APPLE LOCAL end rewrite weight computation */
}
/* For each other pseudo-reg conflicting with this one,
mark it as conflicting with the hard regs this one occupies. */
diff --git a/gcc/hooks.c b/gcc/hooks.c
index cb6efd4bb6a..001d769f046 100644
--- a/gcc/hooks.c
+++ b/gcc/hooks.c
@@ -226,3 +226,19 @@ hook_tree_tree_identity (tree a)
{
return a;
}
+
+/* Generic hook that takes a tree and returns a NULL string. */
+const char *
+hook_constcharptr_tree_null (tree t ATTRIBUTE_UNUSED)
+{
+ return NULL;
+}
+
+/* APPLE LOCAL begin AltiVec */
+/* Generic hook that takes a cpp_token pointer and returns false. */
+bool
+hook_bool_constcpp_tokenp_false (const struct cpp_token * tok ATTRIBUTE_UNUSED)
+{
+ return false;
+}
+/* APPLE LOCAL end AltiVec */
diff --git a/gcc/hooks.h b/gcc/hooks.h
index a72f6c88013..cea9ec357c1 100644
--- a/gcc/hooks.h
+++ b/gcc/hooks.h
@@ -60,5 +60,7 @@ extern rtx hook_rtx_tree_int_null (tree, int);
extern void * hook_voidp_size_t_null (size_t);
extern bool hook_bool_voidp_size_t_false (void *, size_t);
extern tree hook_tree_tree_identity (tree a);
-
+extern const char *hook_constcharptr_tree_null (tree);
+/* APPLE LOCAL AltiVec */
+extern bool hook_bool_constcpp_tokenp_false (const struct cpp_token *);
#endif
diff --git a/gcc/idebug.c b/gcc/idebug.c
new file mode 100644
index 00000000000..398cc06359a
--- /dev/null
+++ b/gcc/idebug.c
@@ -0,0 +1,639 @@
+/* APPLE LOCAL file debugging */
+/* C tree & rtl accessors defined as functions for use in a debugger.
+ Copyright (C) 2001 Free Software Foundation, Inc.
+ Contributed by Ira L. Ruben (ira@apple.com)
+
+This file is part of GNU CC.
+
+GNU CC is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2, or (at your option)
+any later version.
+
+GNU CC is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+GNU General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with GNU CC; see the file COPYING. If not, write to
+the Free Software Foundation, 59 Temple Place - Suite 330,
+Boston, MA 02111-1307, USA. */
+
+/* What we do here is to instantiate each macro as a function *BY
+ THE SAME NAME*. Depends on the macro not being expanded when
+ it is surrounded by parens.
+
+ Note that this file represents the common accessors for both
+ C and C++. It is included as part of c-idebug.c and also
+ as part of cp/cp-idebug.c where these files are built for
+ their respective compilers and contain the language specific
+ accessors for their language (i.e., c-idebug.c have the
+ accessors for c-tree.h and cp/cp-idebug.c have the accessors
+ for cp-tree.h. */
+
+#include "config.h"
+
+#ifdef ENABLE_IDEBUG
+
+#include "system.h"
+#include "coretypes.h"
+#include "tm.h"
+#include "tree.h"
+#include "rtl.h"
+#include "flags.h"
+#include "c-common.h"
+
+#define fn_0(name,rt) rt (name) (void); \
+ rt (name) (void) { return name(); }
+#define fn_1(name,rt,p1) rt (name)(p1); \
+ rt (name) (p1 a) { return name(a); }
+#define fn_2(name,rt,p1,p2) rt (name)(p1,p2); \
+ rt (name) (p1 a,p2 b) { return name(a,b); }
+#define fn_3(name,rt,p1,p2,p3) rt (name)(p1,p2,p3); \
+ rt (name) (p1 a,p2 b,p3 c) { return name(a,b,c); }
+#define fn_4(name,rt,p1,p2,p3,p4) rt (name) (p1,p2,p3,p4); \
+ rt (name) (p1 a,p2 b,p3 c,p4 d) { return name(a,b,c,d); }
+
+fn_1( RP, tree, tree )
+
+/* Macros from tree.h */
+
+fn_1( TREE_CODE_CLASS, int, int )
+fn_1( IS_EXPR_CODE_CLASS, char, int )
+fn_1( TREE_CODE_LENGTH, int, int )
+fn_1( TREE_CODE, enum tree_code, tree )
+fn_1( TREE_TYPE, tree, tree )
+fn_1( TREE_CHAIN, tree, tree )
+fn_1( INTEGRAL_TYPE_P, int, tree )
+fn_1( FLOAT_TYPE_P, int, tree )
+fn_1( AGGREGATE_TYPE_P, int, tree )
+fn_1( POINTER_TYPE_P, int, tree )
+fn_1( BOUNDED_INDIRECT_TYPE_P, int, tree )
+fn_1( BOUNDED_POINTER_TYPE_P, int, tree )
+fn_1( BOUNDED_REFERENCE_TYPE_P, int, tree )
+fn_1( MAYBE_BOUNDED_INDIRECT_TYPE_P, int, tree )
+fn_1( MAYBE_BOUNDED_POINTER_TYPE_P, int, tree )
+fn_1( MAYBE_BOUNDED_REFERENCE_TYPE_P, int, tree )
+fn_1( COMPLETE_TYPE_P, int, tree )
+fn_1( VOID_TYPE_P, int, tree )
+fn_1( COMPLETE_OR_VOID_TYPE_P, int, tree )
+fn_1( COMPLETE_OR_UNBOUND_ARRAY_TYPE_P, int, tree )
+fn_1( TYPE_P, int, tree )
+fn_1( TREE_ADDRESSABLE, int, tree )
+fn_1( TREE_STATIC, int, tree )
+fn_1( TREE_NO_UNUSED_WARNING, int, tree )
+fn_1( TREE_VIA_VIRTUAL, int, tree )
+fn_1( TREE_CONSTANT_OVERFLOW, int, tree )
+fn_1( TREE_SYMBOL_REFERENCED, int, tree )
+fn_1( TREE_OVERFLOW, int, tree )
+fn_1( TREE_PUBLIC, int, tree )
+fn_1( TREE_VIA_PUBLIC, int, tree )
+fn_1( TREE_VIA_PRIVATE, int, tree )
+fn_1( TREE_VIA_PROTECTED, int, tree )
+fn_1( TREE_SIDE_EFFECTS, int, tree )
+fn_1( TREE_THIS_VOLATILE, int, tree )
+fn_1( TREE_READONLY, int, tree )
+fn_1( TREE_READONLY_DECL_P, int, tree )
+fn_1( TREE_CONSTANT, int, tree )
+fn_1( TREE_UNSIGNED, int, tree )
+fn_1( TYPE_TRAP_SIGNED, int, tree )
+fn_1( TREE_ASM_WRITTEN, int, tree )
+fn_1( TREE_USED, int, tree )
+fn_1( TREE_NOTHROW, int, tree )
+fn_1( TREE_PRIVATE, int, tree )
+fn_1( TREE_PROTECTED, int, tree )
+fn_1( TREE_BOUNDED, int, tree )
+fn_1( TREE_DEPRECATED, int, tree )
+/* APPLE LOCAL unavailable (Radar 2809697) ilr */
+fn_1( TREE_UNAVAILABLE, int, tree )
+fn_1( TREE_LANG_FLAG_0, int, tree )
+fn_1( TREE_LANG_FLAG_1, int, tree )
+fn_1( TREE_LANG_FLAG_2, int, tree )
+fn_1( TREE_LANG_FLAG_3, int, tree )
+fn_1( TREE_LANG_FLAG_4, int, tree )
+fn_1( TREE_LANG_FLAG_5, int, tree )
+fn_1( TREE_LANG_FLAG_6, int, tree )
+fn_1( TREE_INT_CST_LOW, unsigned HOST_WIDE_INT, tree )
+fn_1( TREE_INT_CST_HIGH, HOST_WIDE_INT, tree )
+fn_2( INT_CST_LT, int, tree, tree )
+fn_2( INT_CST_LT_UNSIGNED, int, tree, tree )
+fn_1( TREE_CST_RTL, rtx, tree )
+ /* APPLE FIXME */
+ /* fn_1( TREE_REAL_CST, REAL_VALUE_TYPE, tree ) */
+fn_1( TREE_STRING_LENGTH, int, tree )
+fn_1( TREE_STRING_POINTER, char*, tree )
+fn_1( TREE_REALPART, tree, tree )
+fn_1( TREE_IMAGPART, tree, tree )
+fn_1( IDENTIFIER_LENGTH, int, tree )
+fn_1( IDENTIFIER_POINTER, char*, tree )
+fn_1( TREE_PURPOSE, tree, tree )
+fn_1( TREE_VALUE, tree, tree )
+fn_1( TREE_VEC_LENGTH, int, tree )
+fn_2( TREE_VEC_ELT, tree, tree, int )
+fn_1( SAVE_EXPR_CONTEXT, tree, tree )
+fn_1( SAVE_EXPR_RTL, rtx, tree )
+fn_1( SAVE_EXPR_NOPLACEHOLDER, int, tree )
+fn_1( SAVE_EXPR_PERSISTENT_P, int, tree )
+fn_1( RTL_EXPR_SEQUENCE, rtx, tree )
+fn_1( RTL_EXPR_RTL, rtx, tree )
+fn_1( CONSTRUCTOR_ELTS, tree, tree )
+fn_2( TREE_OPERAND, tree, tree, int )
+fn_1( TREE_COMPLEXITY, int, tree )
+fn_1( LABELED_BLOCK_LABEL, tree, tree )
+fn_1( LABELED_BLOCK_BODY, tree, tree )
+fn_1( EXIT_BLOCK_LABELED_BLOCK, tree, tree )
+fn_1( EXIT_BLOCK_RETURN, tree, tree )
+fn_1( LOOP_EXPR_BODY, tree, tree )
+fn_1( EXPR_WFL_NODE, tree, tree )
+fn_1( EXPR_WFL_FILENAME, char*, tree )
+fn_1( EXPR_WFL_FILENAME_NODE, tree, tree )
+fn_1( EXPR_WFL_LINENO, int, tree )
+fn_1( EXPR_WFL_COLNO, int, tree )
+fn_1( EXPR_WFL_LINECOL, int, tree )
+fn_3( EXPR_WFL_SET_LINECOL, int, tree, int, int )
+fn_1( EXPR_WFL_EMIT_LINE_NOTE, int, tree )
+fn_1( BLOCK_VARS, tree, tree )
+fn_1( BLOCK_SUBBLOCKS, tree, tree )
+fn_1( BLOCK_SUPERCONTEXT, tree, tree )
+fn_1( BLOCK_CHAIN, tree, tree )
+fn_1( BLOCK_ABSTRACT_ORIGIN, tree, tree )
+fn_1( BLOCK_ABSTRACT, int, tree )
+fn_1( BLOCK_HANDLER_BLOCK, int, tree )
+fn_1( BLOCK_NUMBER, int, tree )
+fn_1( TYPE_UID, int, tree )
+fn_1( TYPE_SIZE, tree, tree )
+fn_1( TYPE_SIZE_UNIT, tree, tree )
+fn_1( TYPE_MODE, int, tree )
+fn_1( TYPE_VALUES, tree, tree )
+fn_1( TYPE_DOMAIN, tree, tree )
+fn_1( TYPE_FIELDS, tree, tree )
+fn_1( TYPE_METHODS, tree, tree )
+fn_1( TYPE_VFIELD, tree, tree )
+fn_1( TYPE_ARG_TYPES, tree, tree )
+fn_1( TYPE_METHOD_BASETYPE, tree, tree )
+fn_1( TYPE_OFFSET_BASETYPE, tree, tree )
+fn_1( TYPE_POINTER_TO, tree, tree )
+fn_1( TYPE_REFERENCE_TO, tree, tree )
+fn_1( TYPE_MIN_VALUE, tree, tree )
+fn_1( TYPE_MAX_VALUE, tree, tree )
+fn_1( TYPE_PRECISION, int, tree )
+fn_1( TYPE_SYMTAB_ADDRESS, int, tree )
+fn_1( TYPE_SYMTAB_POINTER, char*, tree )
+fn_1( TYPE_NAME, tree, tree )
+fn_1( TYPE_NEXT_VARIANT, tree, tree )
+fn_1( TYPE_MAIN_VARIANT, tree, tree )
+fn_1( TYPE_CONTEXT, tree, tree )
+fn_1( TYPE_LANG_SPECIFIC, struct lang_type*, tree )
+fn_1( TYPE_DEBUG_REPRESENTATION_TYPE, tree, tree )
+fn_2( TYPE_MAIN_VARIANTS_PHYSICALLY_EQUAL_P, int, tree, tree )
+fn_1( TYPE_MAIN_PHYSICAL_VARIANT, tree, tree )
+fn_1( TYPE_BINFO, tree, tree )
+fn_1( TYPE_ALIAS_SET, int, tree )
+fn_1( TYPE_ALIAS_SET_KNOWN_P, int, tree )
+fn_1( TYPE_ATTRIBUTES, tree, tree )
+fn_1( TYPE_ALIGN, int, tree )
+fn_1( TYPE_USER_ALIGN, int, tree )
+fn_1( TYPE_ALIGN_UNIT, int, tree )
+fn_1( TYPE_STUB_DECL, tree, tree )
+fn_1( TYPE_NO_FORCE_BLK, int, tree )
+fn_1( TYPE_IS_SIZETYPE, int, tree )
+fn_1( TYPE_RETURNS_STACK_DEPRESSED, int, tree )
+fn_1( TYPE_VOLATILE, int, tree )
+fn_1( TYPE_READONLY, int, tree )
+fn_1( TYPE_RESTRICT, int, tree )
+fn_1( TYPE_BOUNDED, int, tree )
+fn_1( TYPE_QUALS, int, tree )
+fn_1( TREE_EXPR_QUALS, int, tree )
+fn_1( TREE_FUNC_QUALS, int, tree )
+fn_1( TYPE_LANG_FLAG_0, int, tree )
+fn_1( TYPE_LANG_FLAG_1, int, tree )
+fn_1( TYPE_LANG_FLAG_2, int, tree )
+fn_1( TYPE_LANG_FLAG_3, int, tree )
+fn_1( TYPE_LANG_FLAG_4, int, tree )
+fn_1( TYPE_LANG_FLAG_5, int, tree )
+fn_1( TYPE_LANG_FLAG_6, int, tree )
+fn_1( TYPE_STRING_FLAG, int, tree )
+fn_1( TYPE_ARRAY_MAX_SIZE, tree, tree )
+fn_1( TYPE_VECTOR_SUBPARTS, int, tree )
+fn_1( TYPE_NEEDS_CONSTRUCTING, int, tree )
+fn_1( TYPE_TRANSPARENT_UNION, int, tree )
+fn_1( TYPE_NONALIASED_COMPONENT, int, tree )
+fn_1( TYPE_PACKED, int, tree )
+fn_1( TYPE_BOUNDED_VALUE, tree, tree )
+fn_1( TYPE_BOUNDED_BASE, tree, tree )
+fn_1( TYPE_BOUNDED_EXTENT, tree, tree )
+fn_1( TYPE_BOUNDED_SUBTYPE, tree, tree )
+fn_1( TYPE_UNBOUNDED_VARIANT, tree, tree )
+fn_1( TYPE_POINTER_DEPTH, int, tree )
+fn_1( TYPE_AMBIENT_BOUNDEDNESS, int, tree )
+fn_1( BINFO_TYPE, tree, tree )
+fn_1( BINFO_OFFSET, tree, tree )
+fn_1( TYPE_BINFO_OFFSET, tree, tree )
+fn_1( BINFO_OFFSET_ZEROP, int, tree )
+fn_1( BINFO_VTABLE, tree, tree )
+fn_1( TYPE_BINFO_VTABLE, tree, tree )
+fn_1( BINFO_VIRTUALS, tree, tree )
+fn_1( TYPE_BINFO_VIRTUALS, tree, tree )
+fn_1( BINFO_BASETYPES, tree, tree )
+fn_1( TYPE_BINFO_BASETYPES, tree, tree )
+fn_1( BINFO_N_BASETYPES, int, tree )
+fn_2( BINFO_BASETYPE, tree, tree, int )
+fn_2( TYPE_BINFO_BASETYPE, tree, tree, int )
+fn_1( BINFO_VPTR_FIELD, tree, tree )
+fn_1( BINFO_SIZE, tree, tree )
+fn_1( BINFO_SIZE_UNIT, tree, tree )
+fn_1( TYPE_BINFO_SIZE, tree, tree )
+fn_1( TYPE_BINFO_SIZE_UNIT, tree, tree )
+fn_1( BINFO_INHERITANCE_CHAIN, tree, tree )
+fn_1( DECL_P, int, tree )
+fn_1( DECL_NAME, tree, tree )
+fn_1( DECL_ASSEMBLER_NAME, tree, tree )
+fn_1( DECL_ASSEMBLER_NAME_SET_P, int, tree )
+fn_1( DECL_SECTION_NAME, tree, tree )
+fn_1( DECL_CONTEXT, tree, tree )
+fn_1( DECL_FIELD_CONTEXT, tree, tree )
+fn_1( DECL_ATTRIBUTES, tree, tree )
+fn_1( DECL_FIELD_OFFSET, tree, tree )
+fn_1( DECL_FIELD_BIT_OFFSET, tree, tree )
+fn_1( DECL_BIT_FIELD_TYPE, tree, tree )
+fn_1( DECL_ARGUMENTS, tree, tree )
+fn_1( DECL_RESULT_FLD, tree, tree )
+fn_1( DECL_RESULT, tree, tree )
+fn_1( DECL_ORIGINAL_TYPE, tree, tree )
+fn_1( DECL_ARG_TYPE_AS_WRITTEN, tree, tree )
+fn_1( DECL_INITIAL, tree, tree )
+fn_1( DECL_ARG_TYPE, tree, tree )
+fn_1( DECL_QUALIFIER, tree, tree )
+fn_1( DECL_SOURCE_FILE, char*, tree )
+fn_1( DECL_SOURCE_LINE, int, tree )
+fn_1( DECL_SIZE, tree, tree )
+fn_1( DECL_SIZE_UNIT, tree, tree )
+fn_1( DECL_ALIGN, int, tree )
+fn_1( DECL_ALIGN_UNIT, int, tree )
+fn_1( DECL_OFFSET_ALIGN, int, tree )
+fn_1( DECL_USER_ALIGN, int, tree )
+fn_1( DECL_MODE, int, tree )
+fn_1( DECL_RTL, rtx, tree )
+fn_1( DECL_RTL_SET_P, int, tree )
+fn_2( COPY_DECL_RTL, rtx, tree, tree )
+fn_1( DECL_RTL_IF_SET, rtx, tree )
+fn_1( DECL_LIVE_RANGE_RTL, rtx, tree )
+fn_1( DECL_INCOMING_RTL, rtx, tree )
+fn_1( DECL_SAVED_INSNS, struct function *, tree )
+fn_1( DECL_FUNCTION_CODE, enum built_in_function, tree )
+fn_1( DECL_VINDEX, tree, tree )
+fn_1( DECL_FCONTEXT, tree, tree )
+fn_1( DECL_UID, int, tree )
+fn_1( DECL_ABSTRACT_ORIGIN, tree, tree )
+fn_1( DECL_ORIGIN, tree,tree )
+fn_1( DECL_FROM_INLINE, int, tree )
+fn_1( DECL_IGNORED_P, int, tree )
+fn_1( DECL_ABSTRACT, int, tree )
+fn_1( DECL_IN_SYSTEM_HEADER, int, tree )
+fn_1( DECL_COMMON, int, tree )
+fn_1( DECL_COALESCED, int, tree )
+fn_1( DECL_LANG_SPECIFIC, struct lang_decl *, tree )
+fn_1( DECL_EXTERNAL, int, tree )
+fn_1( TYPE_DECL_SUPPRESS_DEBUG, int, tree )
+fn_1( DECL_REGISTER, int, tree )
+fn_1( DECL_ERROR_ISSUED, int, tree )
+fn_1( DECL_PACKED, int, tree )
+fn_1( DECL_NO_STATIC_CHAIN, int, tree )
+fn_1( DECL_NONLOCAL, int, tree )
+fn_1( DECL_INLINE, int, tree )
+fn_1( DECL_UNINLINABLE, int, tree )
+fn_1( DECL_BUILT_IN_NONANSI, int, tree )
+fn_1( DECL_IS_MALLOC, int, tree )
+fn_1( DECL_IS_PURE, int, tree )
+fn_1( DECL_BIT_FIELD, int, tree )
+fn_1( DECL_TOO_LATE, int, tree )
+fn_1( DECL_IN_TEXT_SECTION, int, tree )
+fn_1( DECL_BUILT_IN, int, tree )
+fn_1( DECL_BUILT_IN_CLASS, int, tree )
+fn_1( DECL_VIRTUAL_P, int, tree )
+fn_1( DECL_DEFER_OUTPUT, int, tree )
+fn_1( DECL_TRANSPARENT_UNION, int, tree )
+fn_1( DECL_STATIC_CONSTRUCTOR, int, tree )
+fn_1( DECL_STATIC_DESTRUCTOR, int, tree )
+fn_1( DECL_ARTIFICIAL, int, tree )
+fn_1( DECL_WEAK, int, tree )
+/* APPLE LOCAL begin weak_import (Radar 2809704) ilr */
+fn_1( DECL_WEAK_IMPORT, int, tree )
+fn_1( DECL_ONE_ONLY, int, tree )
+fn_1( DECL_COMDAT, int, tree )
+fn_1( DECL_NO_INSTRUMENT_FUNCTION_ENTRY_EXIT, int, tree )
+fn_1( DECL_NO_CHECK_MEMORY_USAGE, int, tree )
+fn_1( DECL_NO_LIMIT_STACK, int, tree )
+fn_1( DECL_LANG_FLAG_0, int, tree )
+fn_1( DECL_LANG_FLAG_1, int, tree )
+fn_1( DECL_LANG_FLAG_2, int, tree )
+fn_1( DECL_LANG_FLAG_3, int, tree )
+fn_1( DECL_LANG_FLAG_4, int, tree )
+fn_1( DECL_LANG_FLAG_5, int, tree )
+fn_1( DECL_LANG_FLAG_6, int, tree )
+fn_1( DECL_LANG_FLAG_7, int, tree )
+fn_1( DECL_NON_ADDR_CONST_P, int, tree )
+fn_1( DECL_NONADDRESSABLE_P, int, tree )
+fn_1( DECL_POINTER_ALIAS_SET, int, tree )
+fn_1( DECL_POINTER_ALIAS_SET_KNOWN_P, int, tree )
+fn_1( DECL_POINTER_DEPTH, int, tree )
+fn_1( MAIN_NAME_P, int, tree )
+
+/* Macros from rtl.h */
+
+fn_1( GET_RTX_LENGTH, int, rtx )
+fn_1( GET_RTX_NAME, char*, rtx )
+fn_1( GET_RTX_FORMAT, char*, rtx )
+fn_1( GET_RTX_CLASS, char, rtx )
+fn_1( GET_CODE, int, rtx )
+fn_1( GET_MODE, int, rtx )
+fn_1( RTX_INTEGRATED_P, int, rtx )
+fn_1( RTX_UNCHANGING_P, int, rtx )
+fn_1( RTX_FRAME_RELATED_P, int, rtx )
+fn_1( GET_NUM_ELEM, int, rtvec )
+fn_1( REG_P, int, rtx )
+fn_1( LABEL_P, int, rtx )
+fn_1( JUMP_P, int, rtx )
+fn_1( NOTE_P, int, rtx )
+fn_1( BARRIER_P, int, rtx )
+fn_1( JUMP_TABLE_DATA_P, int, rtx )
+fn_1( CONSTANT_P, int, rtx )
+fn_2( RTVEC_ELT, rtx, rtvec, int )
+fn_2( XWINT, HOST_WIDE_INT, rtx, int )
+fn_2( XINT, int, rtx, int )
+fn_2( XSTR, char*, rtx, int )
+fn_2( XEXP, rtx, rtx, int )
+fn_2( XVEC, rtvec, rtx, int )
+fn_2( XMODE, enum machine_mode, rtx, int )
+fn_2( XBITMAP, struct bitmap_head_def *, rtx, int )
+fn_2( XTREE, tree, rtx, int )
+fn_2( XBBDEF, struct basic_block_def *, rtx, int )
+fn_3( XVECEXP, rtx, rtx, int, int )
+fn_2( XVECLEN, int, rtx, int )
+fn_2( X0WINT, HOST_WIDE_INT, rtx, int )
+fn_2( X0INT, int, rtx, int )
+fn_2( X0UINT, unsigned int, rtx, int )
+fn_2( X0STR, char *, rtx, int )
+fn_2( X0EXP, rtx, rtx, int )
+fn_2( X0VEC, rtvec, rtx, int )
+fn_2( X0MODE, enum machine_mode, rtx, int )
+fn_2( X0BITMAP, struct bitmap_head_def *, rtx, int )
+fn_2( X0TREE, tree, rtx, int )
+fn_2( X0BBDEF, struct basic_block_def *, rtx, int )
+fn_2( X0ADVFLAGS, addr_diff_vec_flags, rtx, int )
+fn_2( X0CSELIB, struct cselib_val_struct *, rtx, int )
+fn_2( X0MEMATTR, mem_attrs *, rtx, int)
+fn_3( XCWINT, HOST_WIDE_INT, rtx, int, int )
+fn_3( XCINT, int, rtx, int, int )
+fn_3( XCUINT, unsigned int, rtx, int, int )
+fn_3( XCSTR, char *, rtx, int, int )
+fn_3( XCEXP, rtx, rtx, int, int )
+fn_3( XCVEC, rtvec, rtx, int, int )
+fn_3( XCMODE, enum machine_mode, rtx, int, int )
+fn_3( XCBITMAP, struct bitmap_head_def *, rtx, int, int )
+fn_3( XCTREE, tree, rtx, int, int )
+fn_3( XCBBDEF, struct basic_block_def *, rtx, int, int )
+fn_3( XCADVFLAGS, addr_diff_vec_flags, rtx, int, int )
+fn_3( XCCSELIB, struct cselib_val_struct *, rtx, int, int )
+fn_4( XCVECEXP, rtx, rtx, int, int, int )
+fn_3( XCVECLEN, int, rtx, int, int )
+fn_4( XC2EXP, rtx, rtx, int, int, int )
+fn_1( INSN_P, int, rtx )
+fn_1( INSN_UID, int, rtx )
+fn_1( PREV_INSN, rtx, rtx )
+fn_1( NEXT_INSN, rtx, rtx )
+fn_1( PATTERN, rtx, rtx )
+fn_1( INSN_CODE, int, rtx )
+fn_1( LOG_LINKS, rtx, rtx )
+fn_1( INSN_DELETED_P, int, rtx )
+fn_1( CONST_CALL_P, int, rtx )
+fn_1( SIBLING_CALL_P, int, rtx )
+fn_1( INSN_ANNULLED_BRANCH_P, int, rtx )
+fn_1( INSN_DEAD_CODE_P, int, rtx )
+fn_1( INSN_FROM_TARGET_P, int, rtx )
+fn_1( ADDR_DIFF_VEC_FLAGS, addr_diff_vec_flags, rtx )
+fn_1( CSELIB_VAL_PTR, struct cselib_val_struct *, rtx )
+fn_1( REG_NOTES, rtx, rtx )
+fn_1( REG_NOTE_KIND, enum reg_note, rtx )
+fn_1( GET_REG_NOTE_NAME, char *, rtx )
+fn_1( CALL_INSN_FUNCTION_USAGE, rtx, rtx )
+fn_1( CODE_LABEL_NUMBER, int, rtx )
+fn_1( NOTE_SOURCE_FILE, char *, rtx )
+fn_1( NOTE_BLOCK, tree, rtx )
+fn_1( NOTE_EH_HANDLER, int, rtx )
+fn_1( NOTE_RANGE_INFO, rtx, rtx )
+fn_1( NOTE_LIVE_INFO, rtx, rtx )
+fn_1( NOTE_BASIC_BLOCK, struct basic_block_def *, rtx )
+fn_1( NOTE_EXPECTED_VALUE, rtx, rtx )
+fn_1( NOTE_LINE_NUMBER, int, rtx )
+fn_1( NOTE_INSN_BASIC_BLOCK_P, int, rtx )
+fn_1( GET_NOTE_INSN_NAME, char*, int )
+fn_1( LABEL_NAME, char*, rtx )
+fn_1( LABEL_NUSES, int, rtx )
+fn_1( LABEL_ALTERNATE_NAME, char *, rtx )
+fn_1( ADDRESSOF_REGNO, int, rtx )
+fn_1( ADDRESSOF_DECL, tree, rtx )
+fn_1( JUMP_LABEL, rtx, rtx )
+fn_1( LABEL_REFS, rtx, rtx )
+fn_1( LABEL_NEXTREF, rtx, rtx )
+fn_1( CONTAINING_INSN, rtx, rtx )
+fn_1( REGNO, int, rtx )
+fn_1( ORIGINAL_REGNO, unsigned int, rtx )
+fn_1( REG_FUNCTION_VALUE_P, int, rtx )
+fn_1( REG_USERVAR_P, int, rtx )
+fn_1( REG_POINTER, int, rtx )
+fn_1( HARD_REGISTER_P, int, rtx )
+fn_1( HARD_REGISTER_NUM_P, int, int )
+fn_1( INTVAL, HOST_WIDE_INT, rtx )
+fn_1( CONST_DOUBLE_LOW, HOST_WIDE_INT, rtx )
+fn_1( CONST_DOUBLE_HIGH, HOST_WIDE_INT, rtx )
+fn_1( CONST_DOUBLE_CHAIN, rtx, rtx )
+fn_1( CONST_DOUBLE_MEM, rtx, rtx )
+fn_1( SUBREG_REG, rtx, rtx )
+fn_1( SUBREG_BYTE, unsigned int, rtx )
+fn_1( SUBREG_PROMOTED_VAR_P, int, rtx )
+fn_1( SUBREG_PROMOTED_UNSIGNED_P, int, rtx )
+fn_1( ASM_OPERANDS_TEMPLATE, char *, rtx )
+fn_1( ASM_OPERANDS_OUTPUT_CONSTRAINT, char *, rtx )
+fn_1( ASM_OPERANDS_OUTPUT_IDX, int, rtx )
+fn_1( ASM_OPERANDS_INPUT_VEC, rtvec, rtx )
+fn_1( ASM_OPERANDS_INPUT_CONSTRAINT_VEC, rtvec, rtx )
+fn_2( ASM_OPERANDS_INPUT, rtx, rtx, int )
+fn_1( ASM_OPERANDS_INPUT_LENGTH, int, rtx )
+fn_2( ASM_OPERANDS_INPUT_CONSTRAINT_EXP, rtx, rtx, int )
+fn_2( ASM_OPERANDS_INPUT_CONSTRAINT, char*, rtx, int )
+fn_2( ASM_OPERANDS_INPUT_MODE, int, rtx, int )
+fn_1( ASM_OPERANDS_SOURCE_FILE, char *, rtx )
+fn_1( ASM_OPERANDS_SOURCE_LINE, int, rtx )
+fn_1( MEM_VOLATILE_P, int, rtx )
+fn_1( MEM_IN_STRUCT_P, int, rtx )
+fn_1( MEM_SCALAR_P, int, rtx )
+fn_1( MEM_ATTRS, mem_attrs *, rtx)
+fn_1( MEM_ALIAS_SET, int, rtx )
+fn_1( MEM_DECL, tree, rtx)
+fn_1( MEM_OFFSET, rtx, rtx)
+fn_1( MEM_SIZE, rtx, rtx)
+fn_1( MEM_ALIGN, unsigned int, rtx)
+fn_2( MEM_COPY_ATTRIBUTES, int, rtx, rtx )
+fn_1( LABEL_OUTSIDE_LOOP_P, int, rtx )
+fn_1( LABEL_REF_NONLOCAL_P, int, rtx )
+fn_1( LABEL_PRESERVE_P, int, rtx )
+fn_1( REG_LOOP_TEST_P, int, rtx )
+fn_1( SCHED_GROUP_P, int, rtx )
+fn_1( LINK_COST_ZERO, int, rtx )
+fn_1( LINK_COST_FREE, int, rtx )
+fn_1( SET_DEST, rtx, rtx )
+fn_1( SET_SRC, rtx, rtx )
+fn_1( TRAP_CONDITION, rtx, rtx )
+fn_1( TRAP_CODE, rtx, rtx )
+fn_1( COND_EXEC_TEST, rtx, rtx )
+fn_1( COND_EXEC_CODE, rtx, rtx )
+fn_1( CONSTANT_POOL_ADDRESS_P, int, rtx )
+fn_1( STRING_POOL_ADDRESS_P, int, rtx )
+fn_1( SYMBOL_REF_FLAG, int, rtx )
+fn_1( SYMBOL_REF_USED, int, rtx )
+fn_2( FIND_REG_INC_NOTE, rtx, rtx, rtx )
+fn_1( RANGE_INFO_NOTE_START, rtx, rtx )
+fn_1( RANGE_INFO_NOTE_END, rtx, rtx )
+fn_1( RANGE_INFO_REGS, rtvec, rtx )
+fn_2( RANGE_INFO_REGS_REG, rtx, rtx, int )
+fn_1( RANGE_INFO_NUM_REGS, int, rtx )
+fn_1( RANGE_INFO_NCALLS, int, rtx )
+fn_1( RANGE_INFO_NINSNS, int, rtx )
+fn_1( RANGE_INFO_UNIQUE, int, rtx )
+fn_1( RANGE_INFO_BB_START, int, rtx )
+fn_1( RANGE_INFO_BB_END, int, rtx )
+fn_1( RANGE_INFO_LOOP_DEPTH, int, rtx )
+fn_1( RANGE_INFO_LIVE_START, struct bitmap_head_def *, rtx )
+fn_1( RANGE_INFO_LIVE_END, struct bitmap_head_def *, rtx )
+fn_1( RANGE_INFO_MARKER_START, int, rtx )
+fn_1( RANGE_INFO_MARKER_END, int, rtx )
+fn_2( RANGE_REG_PSEUDO, int, rtx, int )
+fn_2( RANGE_REG_COPY, int, rtx, int )
+fn_2( RANGE_REG_REFS, int, rtx, int )
+fn_2( RANGE_REG_SETS, int, rtx, int )
+fn_2( RANGE_REG_DEATHS, int, rtx, int )
+fn_2( RANGE_REG_COPY_FLAGS, int, rtx, int )
+fn_2( RANGE_REG_LIVE_LENGTH, int, rtx, int )
+fn_2( RANGE_REG_N_CALLS, int, rtx, int )
+fn_2( RANGE_REG_SYMBOL_NODE, tree, rtx, int )
+fn_2( RANGE_REG_BLOCK_NODE, tree, rtx, int )
+fn_1( RANGE_VAR_LIST, rtx, rtx )
+fn_1( RANGE_VAR_BLOCK, tree, rtx )
+fn_1( RANGE_VAR_NUM, int, rtx )
+fn_1( RANGE_LIVE_BITMAP, struct bitmap_head_def *, rtx )
+fn_1( RANGE_LIVE_ORIG_BLOCK, int, rtx )
+fn_1( PHI_NODE_P, int, rtx )
+fn_1( CONST0_RTX, rtx, rtx )
+fn_1( CONST1_RTX, rtx, rtx )
+fn_1( CONST2_RTX, rtx, rtx )
+fn_1( GEN_INT, rtx, int )
+fn_1( COSTS_N_INSNS, int, int )
+
+/* Macros from c-common.h */
+
+fn_1( DECL_SAVED_TREE, tree, tree)
+fn_1( DECL_INLINED_FNS, tree, tree )
+fn_1( DECL_NUM_STMTS, HOST_WIDE_INT, tree)
+fn_1( C_TYPE_OBJECT_P, int, tree)
+fn_1( C_TYPE_INCOMPLETE_P, int, tree)
+fn_1( C_TYPE_FUNCTION_P, int, tree)
+fn_1( C_TYPE_QUALS, int, tree)
+fn_1( C_TYPE_OBJECT_OR_INCOMPLETE_P, int, tree)
+fn_1( C_EXP_ORIGINAL_CODE, enum tree_code, tree)
+fn_1( C_PROMOTING_INTEGER_TYPE_P, int, tree)
+fn_1( STMT_IS_FULL_EXPR_P, int, tree)
+fn_1( IF_COND, tree, tree)
+fn_1( THEN_CLAUSE, tree, tree)
+fn_1( ELSE_CLAUSE, tree, tree)
+fn_1( WHILE_COND, tree, tree)
+fn_1( WHILE_BODY, tree, tree)
+fn_1( DO_COND, tree, tree)
+fn_1( DO_BODY, tree, tree)
+/*fn_1( RETURN_EXPR, tree, tree)*/
+fn_1( EXPR_STMT_EXPR, tree, tree)
+fn_1( FOR_INIT_STMT, tree, tree)
+fn_1( FOR_COND, tree, tree)
+fn_1( FOR_EXPR, tree, tree)
+fn_1( FOR_BODY, tree, tree)
+fn_1( SWITCH_COND, tree, tree)
+fn_1( SWITCH_BODY, tree, tree)
+fn_1( CASE_LOW, tree, tree)
+fn_1( CASE_HIGH, tree, tree)
+fn_1( CASE_LABEL_DECL, tree, tree)
+fn_1( GOTO_DESTINATION, tree, tree)
+fn_1( COMPOUND_BODY, tree, tree)
+fn_1( ASM_CV_QUAL, tree, tree)
+fn_1( ASM_STRING, tree, tree)
+fn_1( ASM_OUTPUTS, tree, tree)
+fn_1( ASM_INPUTS, tree, tree)
+fn_1( ASM_CLOBBERS, tree, tree)
+fn_1( DECL_STMT_DECL, tree, tree)
+fn_1( STMT_EXPR_STMT, tree, tree)
+fn_1( LABEL_STMT_LABEL, tree, tree)
+fn_1( SCOPE_BEGIN_P, int, tree)
+fn_1( SCOPE_END_P, int, tree)
+fn_1( SCOPE_STMT_BLOCK, tree, tree)
+fn_1( SCOPE_NULLIFIED_P, int, tree)
+fn_1( SCOPE_NO_CLEANUPS_P, int, tree)
+fn_1( SCOPE_PARTIAL_P, int, tree)
+fn_1( ASM_VOLATILE_P, int, tree)
+fn_1( STMT_LINENO, int, tree)
+fn_1( STMT_LINENO_FOR_FN_P, int, tree)
+fn_1( NEW_FOR_SCOPE_P, int, tree)
+fn_1( ASM_INPUT_P, int, tree)
+fn_1( DECL_ANON_UNION_ELEMS, tree, tree)
+fn_1( DECL_C_BIT_FIELD, int, tree)
+fn_1( SET_DECL_C_BIT_FIELD, int, tree)
+fn_1( CLEAR_DECL_C_BIT_FIELD, int, tree)
+fn_1( DECL_C_HARD_REGISTER, int, tree)
+fn_1( COMPOUND_STMT_NO_SCOPE, int, tree)
+fn_1( OBJC_IS_AT_KEYWORD, int, enum rid);
+fn_1( OBJC_IS_PQ_KEYWORD, int, enum rid);
+/* APPLE LOCAL begin AltiVec */
+fn_1( ALTIVEC_IS_CONTEXT_KEYWORD, int, enum rid);
+fn_1( ALTIVEC_IS_QUALIFIER, int, enum rid);
+/* APPLE LOCAL end AltiVec */
+
+tree is__test_point PARAMS ((tree));
+
+/* The following is intended to be called only by a debugger or
+ debugging code. The function will always return 0 if the input
+ node is not a decl node for the identifier "__test_point". In that
+ case it returns the node for a constant "1".
+
+ You can use the identifer "__test_point" any place in a test proram
+ where a constant int 1 is allowed. By using the debugger or
+ debugging code to call this routine to conditionally stop or do
+ something when "__test_point" is seen makes it easier to up skip to
+ the point in question if that point is heavly used for stuff you are
+ not interested in.
+
+ The function returns 0 if the node is not an IDENTIFIER_NODE for
+ "__test_point" or not a decl node for "__test_point". If it is
+ a integer_one_node is returned.
+
+ Note, currently it is up to the caller to determine what to do with
+ the returned integer_one_node or 0. */
+
+tree __test_point (node)
+ tree node;
+{
+ if (!node)
+ return 0;
+
+ if (TREE_CODE (node) != IDENTIFIER_NODE
+ || strcmp (IDENTIFIER_POINTER (node), "__test_point") != 0)
+ {
+ if (TREE_CODE_CLASS (TREE_CODE (node)) != 'd'
+ || !DECL_NAME (node)
+ || !IDENTIFIER_POINTER (DECL_NAME (node))
+ || strcmp (IDENTIFIER_POINTER (DECL_NAME (node)), "__test_point") != 0)
+ return 0;
+ }
+
+ return integer_one_node;
+}
+
+#endif /* ENABLE_IDEBUG */
diff --git a/gcc/ifcvt.c b/gcc/ifcvt.c
index ca5221a5821..c8a07e23b40 100644
--- a/gcc/ifcvt.c
+++ b/gcc/ifcvt.c
@@ -2783,6 +2783,20 @@ find_if_case_1 (basic_block test_bb, edge then_edge, edge else_edge)
edge then_succ = then_bb->succ;
int then_bb_index;
+ /* APPLE LOCAL begin hot/cold partitioning */
+ /* If we are partitioning hot/cold basic blocks, we don't want to
+ mess up unconditional or indirect jumps that cross between hot
+ and cold sections. */
+
+ if (flag_reorder_blocks_and_partition
+ && ((BB_END (then_bb)
+ && find_reg_note (BB_END (then_bb), REG_CROSSING_JUMP, NULL_RTX))
+ || (BB_END (else_bb)
+ && find_reg_note (BB_END (else_bb), REG_CROSSING_JUMP,
+ NULL_RTX))))
+ return FALSE;
+ /* APPLE LOCAL end hot/cold partitioning */
+
/* THEN has one successor. */
if (!then_succ || then_succ->succ_next != NULL)
return FALSE;
@@ -2851,6 +2865,20 @@ find_if_case_2 (basic_block test_bb, edge then_edge, edge else_edge)
edge else_succ = else_bb->succ;
rtx note;
+ /* APPLE LOCAL begin hot/cold partitioning */
+ /* If we are partitioning hot/cold basic blocks, we don't want to
+ mess up unconditional or indirect jumps that cross between hot
+ and cold sections. */
+
+ if (flag_reorder_blocks_and_partition
+ && ((BB_END (then_bb)
+ && find_reg_note (BB_END (then_bb), REG_CROSSING_JUMP, NULL_RTX))
+ || (BB_END (else_bb)
+ && find_reg_note (BB_END (else_bb), REG_CROSSING_JUMP,
+ NULL_RTX))))
+ return FALSE;
+ /* APPLE LOCAL end hot/cold partitioning */
+
/* ELSE has one successor. */
if (!else_succ || else_succ->succ_next != NULL)
return FALSE;
@@ -3195,8 +3223,12 @@ if_convert (int x_life_data_ok)
num_true_changes = 0;
life_data_ok = (x_life_data_ok != 0);
- if (! (* targetm.cannot_modify_jumps_p) ())
+ /* APPLE LOCAL begin hot/cold partitioning */
+ if ((! (* targetm.cannot_modify_jumps_p) ())
+ && (!flag_reorder_blocks_and_partition || !no_new_pseudos
+ || !targetm.have_named_sections))
mark_loop_exit_edges ();
+ /* APPLE LOCAL end hot/cold partitioning */
/* Free up basic_block_for_insn so that we don't have to keep it
up to date, either here or in merge_blocks. */
diff --git a/gcc/java/Make-lang.in b/gcc/java/Make-lang.in
index db3ac9d5531..1d4f5926d71 100644
--- a/gcc/java/Make-lang.in
+++ b/gcc/java/Make-lang.in
@@ -123,10 +123,10 @@ java-warn = $(WERROR)
# String length warnings
jvspec.o-warn = -Wno-error
-jc1$(exeext): $(JAVA_OBJS) $(BACKEND) $(LIBDEPS)
+jc1$(exeext): $(JAVA_OBJS) $(BACKEND) $(LIBDEPS)
rm -f $@
$(CC) $(ALL_CFLAGS) $(LDFLAGS) -o $@ \
- $(JAVA_OBJS) $(BACKEND) $(ZLIB) $(LIBICONV) $(LIBS)
+ $(JAVA_OBJS) $(BACKEND) $(ZLIB) $(LIBICONV) $(LIBS)
gcjh$(exeext): $(GCJH_OBJS) $(LIBDEPS)
rm -f $@
diff --git a/gcc/java/lang.c b/gcc/java/lang.c
index 178f3ecf3bd..4378522b7ff 100644
--- a/gcc/java/lang.c
+++ b/gcc/java/lang.c
@@ -869,6 +869,37 @@ java_unsafe_for_reeval (tree t)
return -1;
}
+/* APPLE LOCAL begin AltiVec */
+/* Placeholders to make linking work, remove when altivec support is correct */
+
+int
+comptypes (type1, type2)
+ tree type1, type2;
+{
+ register tree t1 = type1;
+ register tree t2 = type2;
+ if (t1 == t2 || !t1 || !t2
+ || TREE_CODE (t1) == ERROR_MARK || TREE_CODE (t2) == ERROR_MARK)
+ return 1;
+ return 0;
+}
+
+tree
+default_conversion (exp)
+ tree exp;
+{
+ return exp;
+}
+
+tree
+lang_build_type_variant (type, constp, volatilep)
+ tree type;
+ int constp, volatilep;
+{
+ return type;
+}
+/* APPLE LOCAL end AltiVec */
+
/* Every call to a static constructor has an associated boolean
variable which is in the outermost scope of the calling method.
This variable is used to avoid multiple calls to the static
diff --git a/gcc/langhooks-def.h b/gcc/langhooks-def.h
index 746143c4d0b..97e06f8287b 100644
--- a/gcc/langhooks-def.h
+++ b/gcc/langhooks-def.h
@@ -54,6 +54,12 @@ extern int lhd_staticp (tree);
extern int lhd_unsafe_for_reeval (tree);
extern void lhd_clear_binding_stack (void);
extern void lhd_print_tree_nothing (FILE *, tree, int);
+/* APPLE LOCAL new tree dump */
+extern void lhd_dump_tree_do_nothing (FILE *, tree, int, int);
+extern int lhd_dump_tree_blank_line_do_nothing (tree, tree);
+extern int lhd_dump_tree_lineno_do_nothing (FILE *, tree);
+extern int lhd_dmp_tree3_do_nothing (FILE *, tree, int);
+/* APPLE LOCAL end new tree dump */
extern const char *lhd_decl_printable_name (tree, int);
extern int lhd_types_compatible_p (tree, tree);
extern rtx lhd_expand_expr (tree, rtx, enum machine_mode, int, rtx *);
@@ -97,6 +103,8 @@ extern int lhd_gimplify_expr (tree *, tree *, tree *);
#define LANG_HOOKS_IDENTIFIER_SIZE sizeof (struct lang_identifier)
#define LANG_HOOKS_INIT hook_bool_void_false
#define LANG_HOOKS_FINISH lhd_do_nothing
+/* APPLE LOCAL Objective-C++ */
+#define LANG_HOOKS_FINISH_FILE lhd_do_nothing
#define LANG_HOOKS_PARSE_FILE lhd_do_nothing_i
#define LANG_HOOKS_CLEAR_BINDING_STACK lhd_clear_binding_stack
#define LANG_HOOKS_INIT_OPTIONS hook_uint_uint_constcharptrptr_0
@@ -124,6 +132,14 @@ extern int lhd_gimplify_expr (tree *, tree *, tree *);
#define LANG_HOOKS_PRINT_DECL lhd_print_tree_nothing
#define LANG_HOOKS_PRINT_TYPE lhd_print_tree_nothing
#define LANG_HOOKS_PRINT_IDENTIFIER lhd_print_tree_nothing
+/* APPLE LOCAL begin new tree dump */
+#define LANG_HOOKS_DUMP_DECL lhd_dump_tree_do_nothing
+#define LANG_HOOKS_DUMP_TYPE lhd_dump_tree_do_nothing
+#define LANG_HOOKS_DUMP_IDENTIFIER lhd_dump_tree_do_nothing
+#define LANG_HOOKS_DUMP_BLANK_LINE_P lhd_dump_tree_blank_line_do_nothing
+#define LANG_HOOKS_DUMP_LINENO_P lhd_dump_tree_lineno_do_nothing
+#define LANG_HOOKS_DMP_TREE3 lhd_dmp_tree3_do_nothing
+/* APPLE LOCAL end new tree dump */
#define LANG_HOOKS_PRINT_ERROR_FUNCTION lhd_print_error_function
#define LANG_HOOKS_DECL_PRINTABLE_NAME lhd_decl_printable_name
#define LANG_HOOKS_GET_CALLEE_FNDECL lhd_return_null_tree
@@ -286,6 +302,8 @@ extern tree lhd_make_node (enum tree_code);
LANG_HOOKS_POST_OPTIONS, \
LANG_HOOKS_INIT, \
LANG_HOOKS_FINISH, \
+ /* APPLE LOCAL Objective-C++ */ \
+ LANG_HOOKS_FINISH_FILE, \
LANG_HOOKS_PARSE_FILE, \
LANG_HOOKS_CLEAR_BINDING_STACK, \
LANG_HOOKS_GET_ALIAS_SET, \
@@ -318,6 +336,14 @@ extern tree lhd_make_node (enum tree_code);
LANG_HOOKS_ATTRIBUTE_TABLE, \
LANG_HOOKS_COMMON_ATTRIBUTE_TABLE, \
LANG_HOOKS_FORMAT_ATTRIBUTE_TABLE, \
+/* APPLE LOCAL begin new tree dump */ \
+ LANG_HOOKS_DUMP_DECL, \
+ LANG_HOOKS_DUMP_TYPE, \
+ LANG_HOOKS_DUMP_IDENTIFIER, \
+ LANG_HOOKS_DUMP_BLANK_LINE_P, \
+ LANG_HOOKS_DUMP_LINENO_P, \
+ LANG_HOOKS_DMP_TREE3, \
+/* APPLE LOCAL end new tree dump */ \
LANG_HOOKS_FUNCTION_INITIALIZER, \
LANG_HOOKS_TREE_INLINING_INITIALIZER, \
LANG_HOOKS_CALLGRAPH_INITIALIZER, \
diff --git a/gcc/langhooks.c b/gcc/langhooks.c
index d48a0c9033f..d4bfa8f534f 100644
--- a/gcc/langhooks.c
+++ b/gcc/langhooks.c
@@ -420,6 +420,39 @@ lhd_tree_inlining_anon_aggr_type_p (tree t ATTRIBUTE_UNUSED)
return 0;
}
+/* APPLE LOCAL new tree dump */
+/* Do nothing language hooks for dmp_tree(). */
+void
+lhd_dump_tree_do_nothing (FILE *file ATTRIBUTE_UNUSED,
+ tree node ATTRIBUTE_UNUSED,
+ int indent ATTRIBUTE_UNUSED,
+ int after_id ATTRIBUTE_UNUSED)
+{
+}
+
+int
+lhd_dump_tree_blank_line_do_nothing (tree previous_node ATTRIBUTE_UNUSED,
+ tree current_node ATTRIBUTE_UNUSED)
+{
+ return 0;
+}
+
+int
+lhd_dump_tree_lineno_do_nothing (FILE *file ATTRIBUTE_UNUSED,
+ tree node ATTRIBUTE_UNUSED)
+{
+ return 0;
+}
+
+int
+lhd_dmp_tree3_do_nothing (FILE *file ATTRIBUTE_UNUSED,
+ tree node ATTRIBUTE_UNUSED,
+ int flags ATTRIBUTE_UNUSED)
+{
+ return 0;
+}
+/* APPLE LOCAL end new tree dump */
+
/* lang_hooks.tree_inlining.start_inlining and end_inlining perform any
language-specific bookkeeping necessary for processing
FN. start_inlining returns nonzero if inlining should proceed, zero if
diff --git a/gcc/langhooks.h b/gcc/langhooks.h
index e46bbf54613..a184ae3a821 100644
--- a/gcc/langhooks.h
+++ b/gcc/langhooks.h
@@ -265,6 +265,10 @@ struct lang_hooks
/* Called at the end of compilation, as a finalizer. */
void (*finish) (void);
+ /* APPLE LOCAL Objective-C++ */
+ /* Called at the end of the translation unit. */
+ void (*finish_file) PARAMS ((void));
+
/* Parses the entire file. The argument is nonzero to cause bison
parsers to dump debugging information during parsing. */
void (*parse_file) (int);
@@ -408,6 +412,19 @@ struct lang_hooks
const struct attribute_spec *common_attribute_table;
const struct attribute_spec *format_attribute_table;
+ /* APPLE LOCAL begin new tree dump */
+ /* Called to tree dump language-dependent parts of a class 'd',
+ class 't', IDENTIFIER_NODE nodes, conditional blank lines before
+ statements, and statment line numbers. See dmp-tree.c for
+ documentation. */
+ void (*dump_decl) PARAMS ((FILE *, tree, int, int));
+ void (*dump_type) PARAMS ((FILE *, tree, int, int));
+ void (*dump_identifier) PARAMS ((FILE *, tree, int, int));
+ int (*dump_blank_line_p) PARAMS ((tree, tree));
+ int (*dump_lineno_p) PARAMS ((FILE *, tree));
+ int (*dmp_tree3) PARAMS ((FILE *, tree, int));
+ /* APPLE LOCAL end new tree dump */
+
/* Function-related language hooks. */
struct lang_hooks_for_functions function;
diff --git a/gcc/libgcc2.c b/gcc/libgcc2.c
index 34171ad9002..d127df16cd0 100644
--- a/gcc/libgcc2.c
+++ b/gcc/libgcc2.c
@@ -47,6 +47,14 @@ Software Foundation, 59 Temple Place - Suite 330, Boston, MA
#undef abort
#endif
+/* APPLE LOCAL begin libcc_kext */
+#ifdef LIBCC_KEXT
+/* Make aborts into panics (kernel panics presumably) */
+#define abort() panic()
+extern void panic (void);
+#endif
+/* APPLE LOCAL end libcc_kext */
+
#ifdef HAVE_GAS_HIDDEN
#define ATTRIBUTE_HIDDEN __attribute__ ((__visibility__ ("hidden")))
#else
diff --git a/gcc/loop-doloop.c b/gcc/loop-doloop.c
new file mode 100644
index 00000000000..1d7c471b2af
--- /dev/null
+++ b/gcc/loop-doloop.c
@@ -0,0 +1,552 @@
+/* Perform doloop optimizations
+ Copyright (C) 2004 Free Software Foundation, Inc.
+ Based on code by Michael P. Hayes (m.hayes@elec.canterbury.ac.nz)
+
+This file is part of GCC.
+
+GCC is free software; you can redistribute it and/or modify it under
+the terms of the GNU General Public License as published by the Free
+Software Foundation; either version 2, or (at your option) any later
+version.
+
+GCC is distributed in the hope that it will be useful, but WITHOUT ANY
+WARRANTY; without even the implied warranty of MERCHANTABILITY or
+FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+for more details.
+
+You should have received a copy of the GNU General Public License
+along with GCC; see the file COPYING. If not, write to the Free
+Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+02111-1307, USA. */
+
+#include "config.h"
+#include "system.h"
+#include "coretypes.h"
+#include "tm.h"
+#include "rtl.h"
+#include "flags.h"
+#include "expr.h"
+#include "hard-reg-set.h"
+#include "basic-block.h"
+#include "toplev.h"
+#include "tm_p.h"
+#include "cfgloop.h"
+#include "output.h"
+#include "params.h"
+
+/* This module is used to modify loops with a determinable number of
+ iterations to use special low-overhead looping instructions.
+
+ It first validates whether the loop is well behaved and has a
+ determinable number of iterations (either at compile or run-time).
+ It then modifies the loop to use a low-overhead looping pattern as
+ follows:
+
+ 1. A pseudo register is allocated as the loop iteration counter.
+
+ 2. The number of loop iterations is calculated and is stored
+ in the loop counter.
+
+ 3. At the end of the loop, the jump insn is replaced by the
+ doloop_end pattern. The compare must remain because it might be
+ used elsewhere. If the loop-variable or condition register are
+ used elsewhere, they will be eliminated by flow.
+
+ 4. An optional doloop_begin pattern is inserted at the top of the
+ loop.
+
+ TODO The optimization should only performed when either the biv used for exit
+ condition is unused at all except for the exit test, or if we do not have to
+ change its value, since otherwise we have to add a new induction variable,
+ which usually will not pay up (unless the cost of the doloop pattern is
+ somehow extremely lower than the cost of compare & jump, or unless the bct
+ register cannot be used for anything else but doloop -- ??? detect these
+ cases). */
+
+#ifdef HAVE_doloop_end
+
+/* Return the loop termination condition for PATTERN or zero
+ if it is not a decrement and branch jump insn. */
+
+static rtx
+doloop_condition_get (rtx pattern)
+{
+ rtx cmp;
+ rtx inc;
+ rtx reg;
+ rtx condition;
+
+ /* The canonical doloop pattern we expect is:
+
+ (parallel [(set (pc) (if_then_else (condition)
+ (label_ref (label))
+ (pc)))
+ (set (reg) (plus (reg) (const_int -1)))
+ (additional clobbers and uses)])
+
+ Some machines (IA-64) make the decrement conditional on
+ the condition as well, so we don't bother verifying the
+ actual decrement. In summary, the branch must be the
+ first entry of the parallel (also required by jump.c),
+ and the second entry of the parallel must be a set of
+ the loop counter register. */
+
+ if (GET_CODE (pattern) != PARALLEL)
+ return 0;
+
+ cmp = XVECEXP (pattern, 0, 0);
+ inc = XVECEXP (pattern, 0, 1);
+
+ /* Check for (set (reg) (something)). */
+ if (GET_CODE (inc) != SET || ! REG_P (SET_DEST (inc)))
+ return 0;
+
+ /* Extract loop counter register. */
+ reg = SET_DEST (inc);
+
+ /* Check for (set (pc) (if_then_else (condition)
+ (label_ref (label))
+ (pc))). */
+ if (GET_CODE (cmp) != SET
+ || SET_DEST (cmp) != pc_rtx
+ || GET_CODE (SET_SRC (cmp)) != IF_THEN_ELSE
+ || GET_CODE (XEXP (SET_SRC (cmp), 1)) != LABEL_REF
+ || XEXP (SET_SRC (cmp), 2) != pc_rtx)
+ return 0;
+
+ /* Extract loop termination condition. */
+ condition = XEXP (SET_SRC (cmp), 0);
+
+ if ((GET_CODE (condition) != GE && GET_CODE (condition) != NE)
+ || GET_CODE (XEXP (condition, 1)) != CONST_INT)
+ return 0;
+
+ if (XEXP (condition, 0) == reg)
+ return condition;
+
+ if (GET_CODE (XEXP (condition, 0)) == PLUS
+ && XEXP (XEXP (condition, 0), 0) == reg)
+ return condition;
+
+ /* ??? If a machine uses a funny comparison, we could return a
+ canonicalised form here. */
+
+ return 0;
+}
+
+/* Return nonzero if the loop specified by LOOP is suitable for
+ the use of special low-overhead looping instructions. DESC
+ describes the number of iterations of the loop. */
+
+static bool
+doloop_valid_p (struct loop *loop, struct niter_desc *desc)
+{
+ basic_block *body = get_loop_body (loop), bb;
+ rtx insn;
+ unsigned i;
+
+ /* Check for loops that may not terminate under special conditions. */
+ if (!desc->simple_p
+ || desc->assumptions
+ || desc->infinite)
+ {
+ /* There are some cases that would require a special attention.
+ For example if the comparison is LEU and the comparison value
+ is UINT_MAX then the loop will not terminate. Similarly, if the
+ comparison code is GEU and the comparison value is 0, the
+ loop will not terminate.
+
+ If the absolute increment is not 1, the loop can be infinite
+ even with LTU/GTU, e.g. for (i = 3; i > 0; i -= 2)
+
+ ??? We could compute these conditions at run-time and have a
+ additional jump around the loop to ensure an infinite loop.
+ However, it is very unlikely that this is the intended
+ behavior of the loop and checking for these rare boundary
+ conditions would pessimize all other code.
+
+ If the loop is executed only a few times an extra check to
+ restart the loop could use up most of the benefits of using a
+ count register loop. Note however, that normally, this
+ restart branch would never execute, so it could be predicted
+ well by the CPU. We should generate the pessimistic code by
+ default, and have an option, e.g. -funsafe-loops that would
+ enable count-register loops in this case. */
+ if (dump_file)
+ fprintf (dump_file, "Doloop: Possible infinite iteration case.\n");
+ return false;
+ }
+
+ for (i = 0; i < loop->num_nodes; i++)
+ {
+ bb = body[i];
+
+ for (insn = BB_HEAD (bb);
+ insn != NEXT_INSN (BB_END (bb));
+ insn = NEXT_INSN (insn))
+ {
+ /* A called function may clobber any special registers required for
+ low-overhead looping. */
+ if (GET_CODE (insn) == CALL_INSN)
+ {
+ if (dump_file)
+ fprintf (dump_file, "Doloop: Function call in loop.\n");
+ return false;
+ }
+
+ /* Some targets (eg, PPC) use the count register for branch on table
+ instructions. ??? This should be a target specific check. */
+ if (GET_CODE (insn) == JUMP_INSN
+ && (GET_CODE (PATTERN (insn)) == ADDR_DIFF_VEC
+ || GET_CODE (PATTERN (insn)) == ADDR_VEC))
+ {
+ if (dump_file)
+ fprintf (dump_file, "Doloop: Computed branch in the loop.\n");
+ return false;
+ }
+ }
+ }
+ free (body);
+
+ return true;
+}
+
+/* Adds test of COND jumping to DEST to the end of BB. */
+
+static void
+add_test (rtx cond, basic_block bb, basic_block dest)
+{
+ rtx seq, jump, label;
+ enum machine_mode mode;
+ rtx op0 = XEXP (cond, 0), op1 = XEXP (cond, 1);
+ enum rtx_code code = GET_CODE (cond);
+
+ mode = GET_MODE (XEXP (cond, 0));
+ if (mode == VOIDmode)
+ mode = GET_MODE (XEXP (cond, 1));
+
+ start_sequence ();
+ op0 = force_operand (op0, NULL_RTX);
+ op1 = force_operand (op1, NULL_RTX);
+ label = block_label (dest);
+ do_compare_rtx_and_jump (op0, op1, code, 0, mode, NULL_RTX, NULL_RTX, label);
+
+ jump = get_last_insn ();
+ JUMP_LABEL (jump) = label;
+
+ /* The jump is supposed to handle an unlikely special case. */
+ REG_NOTES (jump)
+ = gen_rtx_EXPR_LIST (REG_BR_PROB,
+ GEN_INT (0), REG_NOTES (jump));
+
+ LABEL_NUSES (label)++;
+
+ seq = get_insns ();
+ end_sequence ();
+ emit_insn_after (seq, BB_END (bb));
+}
+
+/* Modify the loop to use the low-overhead looping insn where LOOP
+ describes the loop, DESC describes the number of iterations of the
+ loop, and DOLOOP_INSN is the low-overhead looping insn to emit at the
+ end of the loop. CONDITION is the condition separated from the
+ DOLOOP_SEQ. */
+
+static void
+doloop_modify (struct loop *loop, struct niter_desc *desc,
+ rtx doloop_seq, rtx condition)
+{
+ rtx counter_reg;
+ rtx count, tmp, noloop = NULL_RTX;
+ rtx sequence;
+ rtx jump_insn;
+ rtx jump_label;
+ int nonneg = 0, irr;
+ bool increment_count;
+ basic_block loop_end = desc->out_edge->src;
+
+ jump_insn = BB_END (loop_end);
+
+ if (dump_file)
+ {
+ fprintf (dump_file, "Doloop: Inserting doloop pattern (");
+ if (desc->const_iter)
+ fprintf (dump_file, HOST_WIDEST_INT_PRINT_DEC, desc->niter);
+ else
+ fputs ("runtime", dump_file);
+ fputs (" iterations).\n", dump_file);
+ }
+
+ /* Discard original jump to continue loop. The original compare
+ result may still be live, so it cannot be discarded explicitly. */
+ delete_insn (jump_insn);
+
+ counter_reg = XEXP (condition, 0);
+ if (GET_CODE (counter_reg) == PLUS)
+ counter_reg = XEXP (counter_reg, 0);
+
+ count = desc->niter_expr;
+ increment_count = false;
+ switch (GET_CODE (condition))
+ {
+ case NE:
+ /* Currently only NE tests against zero and one are supported. */
+ if (XEXP (condition, 1) == const1_rtx)
+ {
+ increment_count = true;
+ noloop = const1_rtx;
+ }
+ else if (XEXP (condition, 1) == const0_rtx)
+ noloop = const0_rtx;
+ else
+ abort ();
+ break;
+
+ case GE:
+ /* Currently only GE tests against zero are supported. */
+ if (XEXP (condition, 1) != const0_rtx)
+ abort ();
+
+ noloop = constm1_rtx;
+
+ /* The iteration count does not need incrementing for a GE test. */
+ increment_count = false;
+
+ /* Determine if the iteration counter will be non-negative.
+ Note that the maximum value loaded is iterations_max - 1. */
+ if (desc->niter_max
+ <= ((unsigned HOST_WIDEST_INT) 1
+ << (GET_MODE_BITSIZE (GET_MODE (counter_reg)) - 1)))
+ nonneg = 1;
+ break;
+
+ /* Abort if an invalid doloop pattern has been generated. */
+ default:
+ abort ();
+ }
+
+ if (increment_count)
+ count = simplify_gen_binary (PLUS, desc->mode, count, const1_rtx);
+
+ /* Insert initialization of the count register into the loop header. */
+ start_sequence ();
+ tmp = force_operand (count, counter_reg);
+ convert_move (counter_reg, tmp, 1);
+ sequence = get_insns ();
+ end_sequence ();
+ emit_insn_after (sequence, BB_END (loop_preheader_edge (loop)->src));
+
+ if (desc->noloop_assumptions)
+ {
+ rtx ass = desc->noloop_assumptions;
+ basic_block preheader = loop_preheader_edge (loop)->src;
+ basic_block set_zero
+ = loop_split_edge_with (loop_preheader_edge (loop), NULL_RTX);
+ basic_block new_preheader
+ = loop_split_edge_with (loop_preheader_edge (loop), NULL_RTX);
+ basic_block bb;
+ edge te;
+ gcov_type cnt;
+
+ /* Expand the condition testing the assumptions and if it does not pass,
+ reset the count register to 0. */
+ add_test (XEXP (ass, 0), preheader, set_zero);
+ preheader->succ->flags &= ~EDGE_FALLTHRU;
+ cnt = preheader->succ->count;
+ preheader->succ->probability = 0;
+ preheader->succ->count = 0;
+ irr = preheader->succ->flags & EDGE_IRREDUCIBLE_LOOP;
+ te = make_edge (preheader, new_preheader, EDGE_FALLTHRU | irr);
+ te->probability = REG_BR_PROB_BASE;
+ te->count = cnt;
+ set_immediate_dominator (CDI_DOMINATORS, new_preheader, preheader);
+
+ set_zero->count = 0;
+ set_zero->frequency = 0;
+
+ for (ass = XEXP (ass, 1); ass; ass = XEXP (ass, 1))
+ {
+ bb = loop_split_edge_with (te, NULL_RTX);
+ te = bb->succ;
+ add_test (XEXP (ass, 0), bb, set_zero);
+ make_edge (bb, set_zero, irr);
+ }
+
+ start_sequence ();
+ convert_move (counter_reg, noloop, 0);
+ sequence = get_insns ();
+ end_sequence ();
+ emit_insn_after (sequence, BB_END (set_zero));
+ }
+
+ /* Some targets (eg, C4x) need to initialize special looping
+ registers. */
+#ifdef HAVE_doloop_begin
+ {
+ rtx init;
+ unsigned level = get_loop_level (loop) + 1;
+ init = gen_doloop_begin (counter_reg,
+ desc->const_iter ? desc->niter_expr : const0_rtx,
+ desc->niter_max,
+ GEN_INT (level));
+ if (init)
+ {
+ start_sequence ();
+ emit_insn (init);
+ sequence = get_insns ();
+ end_sequence ();
+ emit_insn_after (sequence, BB_END (loop_preheader_edge (loop)->src));
+ }
+ }
+#endif
+
+ /* Insert the new low-overhead looping insn. */
+ emit_jump_insn_after (doloop_seq, BB_END (loop_end));
+ jump_insn = BB_END (loop_end);
+ jump_label = block_label (desc->in_edge->dest);
+ JUMP_LABEL (jump_insn) = jump_label;
+ LABEL_NUSES (jump_label)++;
+
+ /* Ensure the right fallthru edge is marked, for case we have reversed
+ the condition. */
+ desc->in_edge->flags &= ~EDGE_FALLTHRU;
+ desc->out_edge->flags |= EDGE_FALLTHRU;
+
+ /* Add a REG_NONNEG note if the actual or estimated maximum number
+ of iterations is non-negative. */
+ if (nonneg)
+ {
+ REG_NOTES (jump_insn)
+ = gen_rtx_EXPR_LIST (REG_NONNEG, NULL_RTX, REG_NOTES (jump_insn));
+ }
+}
+
+/* Process loop described by LOOP validating that the loop is suitable for
+ conversion to use a low overhead looping instruction, replacing the jump
+ insn where suitable. Returns true if the loop was successfully
+ modified. */
+
+static bool
+doloop_optimize (struct loop *loop)
+{
+ enum machine_mode mode;
+ rtx doloop_seq, doloop_pat, doloop_reg;
+ rtx iterations;
+ rtx iterations_max;
+ rtx start_label;
+ rtx condition;
+ unsigned level, est_niter;
+ struct niter_desc *desc;
+
+ if (dump_file)
+ fprintf (dump_file, "Doloop: Processing loop %d.\n", loop->num);
+
+ iv_analysis_loop_init (loop);
+
+ /* Find the simple exit of a LOOP. */
+ desc = get_simple_loop_desc (loop);
+
+ /* Check that loop is a candidate for a low-overhead looping insn. */
+ if (!doloop_valid_p (loop, desc))
+ {
+ if (dump_file)
+ fprintf (dump_file, "Doloop: The loop is not suitable.\n");
+ return false;
+ }
+ mode = desc->mode;
+
+ est_niter = 3;
+ if (desc->const_iter)
+ est_niter = desc->niter;
+ /* If the estimate on number of iterations is reliable (comes from profile
+ feedback), use it. Do not use it normally, since the expected number
+ of iterations of an unrolled loop is 2. */
+ if (loop->header->count)
+ est_niter = expected_loop_iterations (loop);
+
+ if (est_niter < 3)
+ {
+ if (dump_file)
+ fprintf (dump_file,
+ "Doloop: Too few iterations (%u) to be profitable.\n",
+ est_niter);
+ return false;
+ }
+
+ iterations = desc->const_iter ? desc->niter_expr : const0_rtx;
+ iterations_max = GEN_INT (desc->niter_max);
+ level = get_loop_level (loop) + 1;
+
+ /* Generate looping insn. If the pattern FAILs then give up trying
+ to modify the loop since there is some aspect the back-end does
+ not like. */
+ start_label = block_label (desc->in_edge->dest);
+ doloop_reg = gen_reg_rtx (mode);
+ doloop_seq = gen_doloop_end (doloop_reg, iterations, iterations_max,
+ GEN_INT (level), start_label);
+ if (! doloop_seq && mode != word_mode)
+ {
+ PUT_MODE (doloop_reg, word_mode);
+ doloop_seq = gen_doloop_end (doloop_reg, iterations, iterations_max,
+ GEN_INT (level), start_label);
+ }
+ if (! doloop_seq)
+ {
+ if (dump_file)
+ fprintf (dump_file,
+ "Doloop: Target unwilling to use doloop pattern!\n");
+ return false;
+ }
+
+ /* If multiple instructions were created, the last must be the
+ jump instruction. Also, a raw define_insn may yield a plain
+ pattern. */
+ doloop_pat = doloop_seq;
+ if (INSN_P (doloop_pat))
+ {
+ while (NEXT_INSN (doloop_pat) != NULL_RTX)
+ doloop_pat = NEXT_INSN (doloop_pat);
+ if (GET_CODE (doloop_pat) == JUMP_INSN)
+ doloop_pat = PATTERN (doloop_pat);
+ else
+ doloop_pat = NULL_RTX;
+ }
+
+ if (! doloop_pat
+ || ! (condition = doloop_condition_get (doloop_pat)))
+ {
+ if (dump_file)
+ fprintf (dump_file, "Doloop: Unrecognizable doloop pattern!\n");
+ return false;
+ }
+
+ doloop_modify (loop, desc, doloop_seq, condition);
+ return true;
+}
+
+/* This is the main entry point. Process all LOOPS using doloop_optimize. */
+
+void
+doloop_optimize_loops (struct loops *loops)
+{
+ unsigned i;
+ struct loop *loop;
+
+ for (i = 1; i < loops->num; i++)
+ {
+ loop = loops->parray[i];
+ if (!loop)
+ continue;
+
+ doloop_optimize (loop);
+ }
+
+ iv_analysis_done ();
+
+#ifdef ENABLE_CHECKING
+ verify_dominators (CDI_DOMINATORS);
+ verify_loop_structure (loops);
+#endif
+}
+#endif /* HAVE_doloop_end */
+
diff --git a/gcc/loop-iv.c b/gcc/loop-iv.c
index 97cfdf7c07e..face41d3f32 100644
--- a/gcc/loop-iv.c
+++ b/gcc/loop-iv.c
@@ -2281,6 +2281,10 @@ iv_number_of_iterations (struct loop *loop, rtx insn, rtx condition,
simplify_using_initial_values (loop, IOR, &desc->infinite);
simplify_using_initial_values (loop, NIL, &desc->niter_expr);
+ if (desc->noloop_assumptions
+ && XEXP (desc->noloop_assumptions, 0) == const_true_rtx)
+ goto zero_iter;
+
if (GET_CODE (desc->niter_expr) == CONST_INT)
{
unsigned HOST_WIDEST_INT val = INTVAL (desc->niter_expr);
diff --git a/gcc/loop.c b/gcc/loop.c
index 5d458cbabc8..0f9c562b042 100644
--- a/gcc/loop.c
+++ b/gcc/loop.c
@@ -154,12 +154,25 @@ Software Foundation, 59 Temple Place - Suite 330, Boston, MA
#define PREFETCH_CONDITIONAL 1
#endif
+/* APPLE LOCAL begin avoid out-of-bounds refs */
+/* If the first or last uid lies outside the loop, assume the
+ lifetime extends to that end of the loop. */
#define LOOP_REG_LIFETIME(LOOP, REGNO) \
-((REGNO_LAST_LUID (REGNO) - REGNO_FIRST_LUID (REGNO)))
-
+(((REGNO_LAST_UID (REGNO) > max_uid_for_loop) \
+ ? (INSN_LUID ((LOOP)->end)) \
+ : (REGNO_LAST_LUID (REGNO))) \
+ - ((REGNO_FIRST_UID (REGNO) > max_uid_for_loop) \
+ ? (INSN_LUID ((LOOP)->start)) \
+ : (REGNO_FIRST_LUID (REGNO))))
+
+/* uid's that are too big are derived from nested loops and are
+ not referenced outside this loop, hence they are not global. */
#define LOOP_REG_GLOBAL_P(LOOP, REGNO) \
-((REGNO_LAST_LUID (REGNO) > INSN_LUID ((LOOP)->end) \
- || REGNO_FIRST_LUID (REGNO) < INSN_LUID ((LOOP)->start)))
+((REGNO_LAST_UID (REGNO) > max_uid_for_loop) ? 0 : \
+(((REGNO_FIRST_UID (REGNO) > max_uid_for_loop) ? 0 : \
+((((REGNO_LAST_LUID (REGNO) > INSN_LUID ((LOOP)->end) \
+ || REGNO_FIRST_LUID (REGNO) < INSN_LUID ((LOOP)->start))))))))
+/* APPLE LOCAL end avoid out-of-bounds refs */
#define LOOP_REGNO_NREGS(REGNO, SET_DEST) \
((REGNO) < FIRST_PSEUDO_REGISTER \
@@ -1541,6 +1554,8 @@ combine_movables (struct loop_movables *movables, struct loop_regs *regs)
&& GET_MODE_CLASS (GET_MODE (m1->set_dest)) == MODE_INT
&& (GET_MODE_BITSIZE (GET_MODE (m->set_dest))
>= GET_MODE_BITSIZE (GET_MODE (m1->set_dest)))))
+ /* APPLE LOCAL combine hoisted consts */
+ && m1->regno >= FIRST_PSEUDO_REGISTER
/* See if the source of M1 says it matches M. */
&& ((GET_CODE (m1->set_src) == REG
&& matched_regs[REGNO (m1->set_src)])
@@ -4699,13 +4714,26 @@ loop_givs_reduce (struct loop *loop, struct iv_class *bl)
this is an address giv, then try to put the increment
immediately after its use, so that flow can create an
auto-increment addressing mode. */
+ /* APPLE LOCAL begin check loop->top */
+ /* Don't do this for loops entered at the bottom, to avoid
+ this invalid transformation:
+ jmp L; -> jmp L;
+ TOP: TOP:
+ use giv use giv
+ L: inc giv
+ inc biv L:
+ test biv test giv
+ cbr TOP cbr TOP
+ */
if (v->giv_type == DEST_ADDR && bl->biv_count == 1
&& bl->biv->always_executed && ! bl->biv->maybe_multiple
/* We don't handle reversed biv's because bl->biv->insn
does not have a valid INSN_LUID. */
&& ! bl->reversed
&& v->always_executed && ! v->maybe_multiple
- && INSN_UID (v->insn) < max_uid_for_loop)
+ && INSN_UID (v->insn) < max_uid_for_loop
+ && !loop->top)
+ /* APPLE LOCAL end check loop->top */
{
/* If other giv's have been combined with this one, then
this will work only if all uses of the other giv's occur
@@ -4986,6 +5014,24 @@ loop_giv_reduce_benefit (struct loop *loop ATTRIBUTE_UNUSED,
determining code size than run-time benefits. */
benefit -= add_cost * bl->biv_count;
+ /* APPLE LOCAL better induction variable selection */
+#ifdef TARGET_POWERPC
+ /* Adjust this computation to allow for the likelihood that the
+ original increment of the biv will be deleted. This permits
+ induction variables to be selected correctly in simple
+ cases like for(i){a[i]=42;} Without this, choice of induction
+ variables is sensitive to whether the relative stack offset of
+ a is 0 or not(!) On x86 it is probably superior to be more
+ conservative, as there aren't enough registers. */
+ if ( v->replaceable && bl->eliminable )
+ {
+ int orig_add_cost = iv_add_mult_cost (bl->biv->add_val,
+ bl->biv->mult_val, test_reg, test_reg);
+ benefit += orig_add_cost * bl->biv_count;
+ }
+#endif
+ /* APPLE LOCAL end better induction variable selection */
+
/* Decide whether to strength-reduce this giv or to leave the code
unchanged (recompute it from the biv each time it is used). This
decision can be made independently for each giv. */
@@ -4998,7 +5044,8 @@ loop_giv_reduce_benefit (struct loop *loop ATTRIBUTE_UNUSED,
/* Increasing the benefit is risky, since this is only a guess.
Avoid increasing register pressure in cases where there would
be no other benefit from reducing this giv. */
- && benefit > 0
+ /* APPLE LOCAL compare >= 0, not > 0. */
+ && benefit >= 0
&& GET_CODE (v->mult_val) == CONST_INT)
{
int size = GET_MODE_SIZE (GET_MODE (v->mem));
@@ -5288,10 +5335,25 @@ strength_reduce (struct loop *loop, int flags)
value, so we don't need another one. We can't calculate the
proper final value for such a biv here anyways. */
if (bl->final_value && ! bl->reversed)
- loop_insn_sink_or_swim (loop,
- gen_load_of_final_value (bl->biv->dest_reg,
- bl->final_value));
-
+ /* APPLE LOCAL begin put this insn after the loop in all cases */
+ /* Putting it before the loop can cause problems in an
+ obscure case. "a" is the variable we're currently
+ looking at:
+ b <- a
+ loop beginning
+ b++; and references
+ a++; no references
+ if we put the final value for a before the loop, then
+ eliminate b in favor of c later on, we'll get this
+ before the loop:
+ b <- a
+ a <- final value
+ c <- a
+ which is no good. */
+ loop_insn_sink (loop, gen_load_of_final_value (bl->biv->dest_reg,
+ bl->final_value));
+ /* APPLE LOCAL end put this insn after the loop in all cases */
+
if (loop_dump_stream)
fprintf (loop_dump_stream, "Reg %d: biv eliminated\n",
bl->regno);
@@ -5352,23 +5414,6 @@ strength_reduce (struct loop *loop, int flags)
&& unrolled_insn_copies <= insn_count))
unroll_loop (loop, insn_count, 1);
-#ifdef HAVE_doloop_end
- if (HAVE_doloop_end && (flags & LOOP_BCT) && flag_branch_on_count_reg)
- doloop_optimize (loop);
-#endif /* HAVE_doloop_end */
-
- /* In case number of iterations is known, drop branch prediction note
- in the branch. Do that only in second loop pass, as loop unrolling
- may change the number of iterations performed. */
- if (flags & LOOP_BCT)
- {
- unsigned HOST_WIDE_INT n
- = loop_info->n_iterations / loop_info->unroll_number;
- if (n > 1)
- predict_insn (prev_nonnote_insn (loop->end), PRED_LOOP_ITERATIONS,
- REG_BR_PROB_BASE - REG_BR_PROB_BASE / n);
- }
-
if (loop_dump_stream)
fprintf (loop_dump_stream, "\n");
diff --git a/gcc/loop.h b/gcc/loop.h
index 2a7f3ec816e..bd88bb8c90e 100644
--- a/gcc/loop.h
+++ b/gcc/loop.h
@@ -26,9 +26,8 @@ Software Foundation, 59 Temple Place - Suite 330, Boston, MA
/* Flags passed to loop_optimize. */
#define LOOP_UNROLL 1
-#define LOOP_BCT 2
-#define LOOP_PREFETCH 4
-#define LOOP_AUTO_UNROLL 8
+#define LOOP_PREFETCH 2
+#define LOOP_AUTO_UNROLL 4
/* Get the loop info pointer of a loop. */
#define LOOP_INFO(LOOP) ((struct loop_info *) (LOOP)->aux)
diff --git a/gcc/mkinstalldirs b/gcc/mkinstalldirs
new file mode 100644
index 00000000000..e69de29bb2d
--- /dev/null
+++ b/gcc/mkinstalldirs
diff --git a/gcc/move-if-change b/gcc/move-if-change
new file mode 100755
index 00000000000..e69de29bb2d
--- /dev/null
+++ b/gcc/move-if-change
diff --git a/gcc/objc/Make-lang.in b/gcc/objc/Make-lang.in
index 12a20569c67..ecb35b19b5f 100644
--- a/gcc/objc/Make-lang.in
+++ b/gcc/objc/Make-lang.in
@@ -49,12 +49,23 @@ objc-warn = $(STRICT_WARN)
# Bison-1.75 output yields (harmless) -Wtraditional warnings
objc/objc-parse.o-warn = -Wno-error
+# APPLE LOCAL begin order files ilr
+ifeq ($(ORDER_FILES),yes)
+CC1OBJ_ORDER_FLAGS = `if [ -f $(srcdir)/../order-files/cc1obj.order ]; then \
+ echo -sectorder __TEXT __text $(srcdir)/../order-files/cc1obj.order -e start ; fi`
+else
+CC1OBJ_ORDER_FLAGS =
+endif
+# APPLE LOCAL end order files ilr
+
# Language-specific object files for Objective C.
OBJC_OBJS = objc/objc-lang.o objc/objc-parse.o objc/objc-act.o
+# APPLE LOCAL order files ilr
cc1obj$(exeext): $(OBJC_OBJS) $(C_AND_OBJC_OBJS) $(BACKEND) $(LIBDEPS)
$(CC) $(ALL_CFLAGS) $(LDFLAGS) -o $@ \
- $(OBJC_OBJS) $(C_AND_OBJC_OBJS) $(BACKEND) $(LIBS)
+ $(OBJC_OBJS) $(C_AND_OBJC_OBJS) $(BACKEND) $(LIBS) \
+ $(CC1OBJ_ORDER_FLAGS)
# Objective C language specific files.
@@ -83,7 +94,24 @@ objc/objc-parse.y: c-parse.in
echo '/*WARNING: This file is automatically generated!*/' >tmp-objc-prs.y
sed -e "/^@@ifc.*/,/^@@end_ifc.*/d" \
-e "/^@@ifobjc.*/d" -e "/^@@end_ifobjc.*/d" < $< >>tmp-objc-prs.y
- $(SHELL) $(srcdir)/../move-if-change tmp-objc-prs.y $@
+ $(SHELL) $(srcdir)/move-if-change tmp-objc-prs.y $@
+
+# APPLE LOCAL debugging
+objc/objc-idebug.o : $(srcdir)/objc/objc-idebug.c $(CONFIG_H) $(SYSTEM_H) \
+ coretypes.h $(TM_H) $(TREE_H) $(C_TREE_H) \
+ $(RTL_H) $(srcdir)/objc/objc-act.h flags.h c-idebug.c idebug.c
+ $(CC) $(ALL_CFLAGS) $(ALL_CPPFLAGS) $(INCLUDES) -I$(srcdir)/objc \
+ -c -Wno-traditional -w $(srcdir)/objc/objc-idebug.c $(OUTPUT_OPTION)
+
+# APPLE LOCAL new tree dump
+# APPLE LOCAL separate outputdir
+objc/objc-dmp-tree.o: objc/objc-dmp-tree.c c-dmp-tree.c dmp-tree.c \
+ $(CONFIG_H) $(TREE_H) $(SYSTEM_H) $(srcdir)/c-common.h $(TM_H) coretypes.h \
+ $(srcdir)/objc/objc-act.h \
+ $(srcdir)/c-tree.h \
+ $(srcdir)/dmp-tree.h
+ $(CC) $(ALL_CFLAGS) $(ALL_CPPFLAGS) $(INCLUDES) -I$(srcdir)/objc \
+ -c $(srcdir)/objc/objc-dmp-tree.c $(OUTPUT_OPTION)
gtype-objc.h : s-gtype ; @true
gt-objc-objc-act.h : s-gtype ; @true
diff --git a/gcc/objc/config-lang.in b/gcc/objc/config-lang.in
index 91b86d8d573..996c914cd86 100644
--- a/gcc/objc/config-lang.in
+++ b/gcc/objc/config-lang.in
@@ -32,6 +32,10 @@ compilers="cc1obj\$(exeext)"
stagestuff="cc1obj\$(exeext)"
-target_libs=target-libobjc
+# APPLE LOCAL begin libobjc
+# We use libobjc4 instead. To build libobjc anyway, add
+# '--enable-libobjc' to the 'configure' command line.
+# target_libs=target-libobjc
+# APPLE LOCAL end libobjc
gtfiles="\$(srcdir)/objc/objc-act.h \$(srcdir)/c-parse.in \$(srcdir)/c-tree.h \$(srcdir)/c-decl.c \$(srcdir)/c-objc-common.c \$(srcdir)/c-common.c \$(srcdir)/c-common.h \$(srcdir)/c-pragma.c \$(srcdir)/objc/objc-act.c"
diff --git a/gcc/objc/objc-act.c b/gcc/objc/objc-act.c
index 3fe26d3fd87..574adf044de 100644
--- a/gcc/objc/objc-act.c
+++ b/gcc/objc/objc-act.c
@@ -47,7 +47,14 @@ Boston, MA 02111-1307, USA. */
#include "rtl.h"
#include "tm_p.h"
#include "expr.h"
+/* APPLE LOCAL begin Objective-C++ */
+#ifdef OBJCPLUS
+#include "cp-tree.h"
+#include "lex.h"
+#else
#include "c-tree.h"
+#endif
+/* APPLE LOCAL end Objective-C++ */
#include "c-common.h"
#include "flags.h"
#include "langhooks.h"
@@ -66,6 +73,23 @@ Boston, MA 02111-1307, USA. */
#define OBJC_VOID_AT_END build_tree_list (NULL_TREE, void_type_node)
+/* APPLE LOCAL begin Objective-C++ */
+/* When building Objective-C++, we are not linking against the C front-end
+ and so need to replicate the C tree-construction functions in some way. */
+#ifdef OBJCPLUS
+#define OBJCP_REMAP_FUNCTIONS
+#include "objcp-decl.h"
+#endif /* OBJCPLUS */
+/* APPLE LOCAL end Objective-C++ */
+
+/* APPLE LOCAL new tree dump */
+#ifdef ENABLE_DMP_TREE
+#include "dmp-tree.h"
+extern int c_dump_tree_p PARAMS ((FILE *, const char *, tree, int));
+extern int objc_dump_tree_p PARAMS ((FILE *, const char *, tree, int));
+extern lang_dump_tree_p_t objc_prev_lang_dump_tree_p;
+#endif
+
/* This is the default way of generating a method name. */
/* I am not sure it is really correct.
Perhaps there's a danger that it will make name conflicts
@@ -186,7 +210,8 @@ static void hash_add_attr (hash, tree);
static tree lookup_method (tree, tree);
static tree lookup_method_static (tree, tree, int);
static void add_method_to_hash_list (hash *, tree);
-static tree add_class (tree);
+/* APPLE LOCAL objc speedup dpatel */
+static tree add_class (tree, tree);
static void add_category (tree, tree);
static inline tree lookup_category (tree, tree);
@@ -495,6 +520,19 @@ objc_init (void)
not to be built in. */
input_line = 0;
+/* APPLE LOCAL new tree dump */
+#ifdef ENABLE_DMP_TREE
+ if (!objc_prev_lang_dump_tree_p)
+ objc_prev_lang_dump_tree_p = set_dump_tree_p (objc_dump_tree_p);
+ /* At this point, objc_prev_lang_dump_tree_p should point at the C tree
+ dump routine (which, in the case of Objective-C++, points at the C++
+ tree dump routine in turn). */
+ if (objc_prev_lang_dump_tree_p != &c_dump_tree_p)
+ abort ();
+
+ SET_MAX_DMP_TREE_CODE (LAST_OBJC_TREE_CODE);
+#endif
+
/* If gen_declaration desired, open the output file. */
if (flag_gen_declaration)
{
@@ -1141,6 +1179,12 @@ synth_module_prologue (void)
{
tree temp_type;
+ /* APPLE LOCAL begin Objective-C++ */
+#ifdef OBJCPLUS
+ push_lang_context (lang_name_c); /* extern "C" */
+#endif
+ /* APPLE LOCAL end Objective-C++ */
+
/* Defined in `objc.h' */
objc_object_id = get_identifier (TAG_OBJECT);
@@ -1320,7 +1364,13 @@ synth_module_prologue (void)
#ifndef OBJCPLUS
/* The C++ front-end does not appear to grok __attribute__((__unused__)). */
unused_list = build_tree_list (get_identifier ("__unused__"), NULL_TREE);
-#endif
+#endif
+
+ /* APPLE LOCAL begin Objective-C++ */
+#ifdef OBJCPLUS
+ pop_lang_context ();
+#endif
+ /* APPLE LOCAL end Objective-C++ */
}
/* Ensure that the ivar list for NSConstantString/NXConstantString
@@ -1384,6 +1434,13 @@ build_objc_string_object (tree string)
string = fix_string_type (string);
+ /* APPLE LOCAL begin constant cfstrings */
+ /* The '-fconstant-cfstrings' switch trumps any '-fconstant-string-class'
+ setting. We must, however, cast the CFStringRef to id. */
+ if (flag_constant_cfstrings)
+ return build_c_cast (id_type, build_cfstring_ascii (string));
+ /* APPLE LOCAL end constant cfstrings */
+
constant_string_class = lookup_interface (constant_string_id);
if (!constant_string_class
|| !(constant_string_type
@@ -1804,6 +1861,12 @@ build_module_descriptor (void)
{
tree decl_specs, field_decl, field_decl_chain;
+ /* APPLE LOCAL begin Objective-C++ */
+#ifdef OBJCPLUS
+ push_lang_context (lang_name_c); /* extern "C" */
+#endif
+ /* APPLE LOCAL end Objective-C++ */
+
objc_module_template
= start_struct (RECORD_TYPE, get_identifier (UTAG_MODULE));
@@ -1914,6 +1977,11 @@ build_module_descriptor (void)
c_expand_expr_stmt (decelerator);
finish_function ();
+ /* APPLE LOCAL begin Objective-C++ */
+#ifdef OBJCPLUS
+ pop_lang_context ();
+#endif
+ /* APPLE LOCAL end Objective-C++ */
return XEXP (DECL_RTL (init_function_decl), 0);
}
@@ -2586,18 +2654,18 @@ objc_is_object_ptr (tree type)
tree
lookup_interface (tree ident)
{
- tree chain;
+ /* APPLE LOCAL objc speedup dpatel */
+ tree chain ATTRIBUTE_UNUSED;
#ifdef OBJCPLUS
if (ident && TREE_CODE (ident) == TYPE_DECL)
ident = DECL_NAME (ident);
#endif
- for (chain = interface_chain; chain; chain = TREE_CHAIN (chain))
- {
- if (ident == CLASS_NAME (chain))
- return chain;
- }
- return NULL_TREE;
+ /* APPLE LOCAL begin objc speedup dpatel */
+ return (ident && TREE_CODE (ident) == IDENTIFIER_NODE
+ ? IDENTIFIER_INTERFACE_VALUE (ident)
+ : NULL_TREE);
+ /* APPLE LOCAL end objc speedup dpatel */
}
/* Implement @defs (<classname>) within struct bodies. */
@@ -6342,9 +6410,14 @@ objc_add_method (tree class, tree method, int is_class)
return method;
}
+/* APPLE LOCAL begin objc speedup dpatel */
+/* New parameter, name */
static tree
-add_class (tree class)
+add_class (tree class, tree name)
{
+ /* APPLE LOCAL end objc speedup dpatel */
+ IDENTIFIER_INTERFACE_VALUE (name) = class;
+
/* Put interfaces on list in reverse order. */
TREE_CHAIN (class) = interface_chain;
interface_chain = class;
@@ -6815,7 +6888,9 @@ start_class (enum tree_code code, tree class_name, tree super_name,
{
warning ("cannot find interface declaration for `%s'",
IDENTIFIER_POINTER (class_name));
- add_class (implementation_template = objc_implementation_context);
+ /* APPLE LOCAL objc speedup dpatel */
+ /* Add second parameter class_name */
+ add_class (implementation_template = objc_implementation_context, class_name);
}
/* If a super class has been specified in the implementation,
@@ -6848,8 +6923,10 @@ start_class (enum tree_code code, tree class_name, tree super_name,
warning ("duplicate interface declaration for class `%s'",
#endif
IDENTIFIER_POINTER (class_name));
- else
- add_class (class);
+ else
+ /* APPLE LOCAL objc speedup dpatel */
+ /* Add second parameter, class_name */
+ add_class (class, class_name);
if (protocol_list)
CLASS_PROTOCOL_LIST (class)
@@ -6915,6 +6992,12 @@ continue_class (tree class)
/* code generation */
+ /* APPLE LOCAL begin Objective-C++ */
+#ifdef OBJCPLUS
+ push_lang_context (lang_name_c);
+#endif
+ /* APPLE LOCAL end Objective-C++ */
+
ivar_context = build_private_template (implementation_template);
if (!objc_class_template)
@@ -6937,14 +7020,34 @@ continue_class (tree class)
else
cat_count++;
+ /* APPLE LOCAL begin Objective-C++ */
+#ifdef OBJCPLUS
+ pop_lang_context ();
+#endif /* OBJCPLUS */
+ /* APPLE LOCAL end Objective-C++ */
+
return ivar_context;
}
else if (TREE_CODE (class) == CLASS_INTERFACE_TYPE)
{
+/* APPLE LOCAL begin Objective-C++ */
+#ifdef OBJCPLUS
+ push_lang_context (lang_name_c);
+#endif /* OBJCPLUS */
+/* APPLE LOCAL end Objective-C++ */
if (!CLASS_STATIC_TEMPLATE (class))
{
tree record = start_struct (RECORD_TYPE, CLASS_NAME (class));
+
+ /* APPLE LOCAL begin 3261135 */
+ /* FSF Candidate */
+ /* Set the TREE_USED bit for this struct, so that stab generator can emit
+ stabs for this struct type. */
+ if (flag_debug_only_used_symbols && TYPE_STUB_DECL (record))
+ TREE_USED (TYPE_STUB_DECL (record)) = 1;
+ /* APPLE LOCAL end 3261135 */
+
finish_struct (record, get_class_ivars (class, 0), NULL_TREE);
CLASS_STATIC_TEMPLATE (class) = record;
@@ -6952,6 +7055,11 @@ continue_class (tree class)
TREE_STATIC_TEMPLATE (record) = 1;
}
+ /* APPLE LOCAL begin Objective-C++ */
+#ifdef OBJCPLUS
+ pop_lang_context ();
+#endif /* OBJCPLUS */
+ /* APPLE LOCAL end Objective-C++ */
return NULL_TREE;
}
@@ -9086,5 +9194,7 @@ lookup_objc_ivar (tree id)
return 0;
}
+/* APPLE LOCAL objective-C++ */
+#include "gt-objc-objc-act-h.h"
#include "gt-objc-objc-act.h"
#include "gtype-objc.h"
diff --git a/gcc/objc/objc-act.h b/gcc/objc/objc-act.h
index abbf6562731..8c19b563691 100644
--- a/gcc/objc/objc-act.h
+++ b/gcc/objc/objc-act.h
@@ -126,6 +126,9 @@ tree build_encode_expr (tree);
? (TYPE)->type.context : NULL_TREE)
#define SET_TYPE_PROTOCOL_LIST(TYPE, P) (TYPE_CHECK (TYPE)->type.context = (P))
+/* APPLE LOCAL objc speedup dpatel */
+#define IDENTIFIER_INTERFACE_VALUE(NODE) (((struct lang_identifier *) (NODE))->interface_value)
+
/* Set by `continue_class' and checked by `is_public'. */
#define TREE_STATIC_TEMPLATE(record_type) (TREE_PUBLIC (record_type))
diff --git a/gcc/objc/objc-dmp-tree.c b/gcc/objc/objc-dmp-tree.c
new file mode 100644
index 00000000000..14d9dabfca1
--- /dev/null
+++ b/gcc/objc/objc-dmp-tree.c
@@ -0,0 +1,285 @@
+/* APPLE LOCAL file new tree dump */
+/* Common condensed tree display routines specific for objc and objc++.
+ Copyright (C) 2001 Free Software Foundation, Inc.
+ Contributed by Ira L. Ruben (ira@apple.com)
+
+This file is part of GNU CC.
+
+GNU CC is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2, or (at your option)
+any later version.
+
+GNU CC is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+GNU General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with GNU CC; see the file COPYING. If not, write to
+the Free Software Foundation, 59 Temple Place - Suite 330,
+Boston, MA 02111-1307, USA. */
+
+/* The Objective-C++ and Objective-C tree dump handling is piggybacked
+ on either C++ or C tree dump handling. */
+
+#ifdef OBJCPLUS
+#include "cp-dmp-tree.c"
+#else
+#include "c-dmp-tree.c"
+#endif
+
+#include "objc-act.h"
+
+int objc_dump_tree_p (FILE *, const char *, tree, int);
+lang_dump_tree_p_t objc_prev_lang_dump_tree_p = NULL;
+
+#define DEFTREECODE(SYM, NAME, TYPE, LENGTH) \
+static void print_ ## SYM (FILE *file, const char *annotation, tree node, int indent);
+#include "objc-tree.def"
+#undef DEFTREECODE
+
+/*-------------------------------------------------------------------*/
+
+static void
+print_CLASS_INTERFACE_TYPE (file, annotation, node, indent)
+ FILE *file ATTRIBUTE_UNUSED;
+ const char *annotation ATTRIBUTE_UNUSED;
+ tree node ATTRIBUTE_UNUSED;
+ int indent ATTRIBUTE_UNUSED;
+{
+ tree n;
+
+ if (CLASS_SUPER_NAME (node))
+ fprintf (file, " super-name=%s",
+ IDENTIFIER_POINTER (CLASS_SUPER_NAME (node)));
+ /* The ivars for the class are accessible either via
+ CLASS_IVARS(node), or as fields of the
+ underlying C struct (itself accessible via
+ CLASS_STATIC_TEMPLATE(node). */
+ fprintf (file, " ivars=");
+ fprintf (file, HOST_PTR_PRINTF,
+ HOST_PTR_PRINTF_VALUE (CLASS_IVARS (node)));
+ /* zlaski 2001-Jul-26: not sure what the raw ivars are for... */
+ fprintf (file, " raw_ivars=");
+ fprintf (file, HOST_PTR_PRINTF,
+ HOST_PTR_PRINTF_VALUE (CLASS_RAW_IVARS (node)));
+ /* The "own ivars" list contains just the ivars defined by this
+ class (i.e., not inherited). */
+ fprintf (file, " own_ivars=");
+ fprintf (file, HOST_PTR_PRINTF,
+ HOST_PTR_PRINTF_VALUE (CLASS_OWN_IVARS (node)));
+
+ print_type (file, annotation, node, indent);
+ (void)node_seen (node, TRUE);
+
+ /* print out names of protocols, categories. */
+ for (n = CLASS_PROTOCOL_LIST (node); n; n = TREE_CHAIN (n))
+ print_type (file, NULL, TREE_VALUE (n), indent + INDENT);
+ for (n = CLASS_CATEGORY_LIST (node); n; n = TREE_CHAIN (n))
+ print_type (file, NULL, TREE_VALUE (n), indent + INDENT);
+
+ /* Print the underlying RECORD_TYPE node, with fields. */
+ dump_tree (file, annotation, CLASS_STATIC_TEMPLATE (node),
+ indent + INDENT);
+ /* Print out names of class and instance methods. */
+ for (n = CLASS_CLS_METHODS (node); n; n = TREE_CHAIN (n))
+ dump_tree (file, NULL, n, indent + INDENT);
+ for (n = CLASS_NST_METHODS (node); n; n = TREE_CHAIN (n))
+ dump_tree (file, NULL, n, indent + INDENT);
+}
+
+static void
+print_CLASS_IMPLEMENTATION_TYPE (file, annotation, node, indent)
+ FILE *file ATTRIBUTE_UNUSED;
+ const char *annotation ATTRIBUTE_UNUSED;
+ tree node ATTRIBUTE_UNUSED;
+ int indent ATTRIBUTE_UNUSED;
+{
+ print_CLASS_INTERFACE_TYPE (file, annotation, node, indent);
+}
+
+static void
+print_CATEGORY_INTERFACE_TYPE (file, annotation, node, indent)
+ FILE *file ATTRIBUTE_UNUSED;
+ const char *annotation ATTRIBUTE_UNUSED;
+ tree node ATTRIBUTE_UNUSED;
+ int indent ATTRIBUTE_UNUSED;
+{
+ tree n;
+
+ fprintf (file, " cat-name=%s",
+ IDENTIFIER_POINTER (CLASS_SUPER_NAME (node)));
+ print_type (file, annotation, node, indent);
+ (void)node_seen (node, TRUE);
+
+ for (n = CLASS_PROTOCOL_LIST (node); n; n = TREE_CHAIN (n))
+ dump_tree (file, NULL, TREE_VALUE (n), indent + INDENT);
+ /* Print out names of class and instance methods. */
+ for (n = CLASS_CLS_METHODS (node); n; n = TREE_CHAIN (n))
+ dump_tree (file, NULL, n, indent + INDENT);
+ for (n = CLASS_NST_METHODS (node); n; n = TREE_CHAIN (n))
+ dump_tree (file, NULL, n, indent + INDENT);
+}
+
+static void
+print_CATEGORY_IMPLEMENTATION_TYPE (file, annotation, node, indent)
+ FILE *file ATTRIBUTE_UNUSED;
+ const char *annotation ATTRIBUTE_UNUSED;
+ tree node ATTRIBUTE_UNUSED;
+ int indent ATTRIBUTE_UNUSED;
+{
+ print_CATEGORY_INTERFACE_TYPE (file, annotation, node, indent);
+}
+
+static void
+print_PROTOCOL_INTERFACE_TYPE (file, annotation, node, indent)
+ FILE *file ATTRIBUTE_UNUSED;
+ const char *annotation ATTRIBUTE_UNUSED;
+ tree node ATTRIBUTE_UNUSED;
+ int indent ATTRIBUTE_UNUSED;
+{
+ tree n;
+
+ fprintf (file, " fwd-decl=");
+ fprintf (file, HOST_PTR_PRINTF,
+ HOST_PTR_PRINTF_VALUE (PROTOCOL_FORWARD_DECL (node)));
+ fprintf (file, " defined=%d", PROTOCOL_DEFINED (node));
+
+ print_type (file, annotation, node, indent);
+ (void)node_seen (node, TRUE);
+
+ /* print superprotocols, if any. */
+ for (n = PROTOCOL_LIST (node); n; n = TREE_CHAIN (n))
+ dump_tree (file, NULL, TREE_VALUE (n), indent + INDENT);
+
+ /* Print out names of class and instance methods. */
+ for (n = PROTOCOL_CLS_METHODS (node); n; n = TREE_CHAIN (n))
+ dump_tree (file, NULL, n, indent + INDENT);
+ for (n = PROTOCOL_NST_METHODS (node); n; n = TREE_CHAIN (n))
+ dump_tree (file, NULL, n, indent + INDENT);
+}
+
+static void
+print_KEYWORD_DECL (file, annotation, node, indent)
+ FILE *file ATTRIBUTE_UNUSED;
+ const char *annotation ATTRIBUTE_UNUSED;
+ tree node ATTRIBUTE_UNUSED;
+ int indent ATTRIBUTE_UNUSED;
+{
+ fprintf (file, " key=%s",
+ IDENTIFIER_POINTER (KEYWORD_KEY_NAME (node)));
+ fprintf (file, " arg=%s",
+ IDENTIFIER_POINTER (KEYWORD_ARG_NAME (node)));
+
+ print_type (file, annotation, node, indent);
+ (void)node_seen (node, TRUE);
+}
+
+static void
+print_INSTANCE_METHOD_DECL (file, annotation, node, indent)
+ FILE *file ATTRIBUTE_UNUSED;
+ const char *annotation ATTRIBUTE_UNUSED;
+ tree node ATTRIBUTE_UNUSED;
+ int indent ATTRIBUTE_UNUSED;
+{
+ fprintf (file, " args=");
+ fprintf (file, HOST_PTR_PRINTF,
+ HOST_PTR_PRINTF_VALUE (METHOD_SEL_ARGS (node)));
+ fprintf (file, " addl=");
+ fprintf (file, HOST_PTR_PRINTF,
+ HOST_PTR_PRINTF_VALUE (METHOD_ADD_ARGS (node)));
+ if (METHOD_ENCODING (node))
+ fprintf (file, " encode=%s",
+ IDENTIFIER_POINTER (METHOD_ENCODING (node)));
+
+ print_decl (file, annotation, node, indent);
+
+ /* Print the underlying FUNCTION_DECL node. */
+ if (METHOD_DEFINITION (node))
+ dump_tree (file, annotation, METHOD_DEFINITION (node),
+ indent + INDENT);
+
+ (void)node_seen (node, TRUE);
+}
+
+static void
+print_CLASS_METHOD_DECL (file, annotation, node, indent)
+ FILE *file ATTRIBUTE_UNUSED;
+ const char *annotation ATTRIBUTE_UNUSED;
+ tree node ATTRIBUTE_UNUSED;
+ int indent ATTRIBUTE_UNUSED;
+{
+ print_INSTANCE_METHOD_DECL (file, annotation, node, indent);
+}
+
+static void
+print_CLASS_REFERENCE_EXPR (file, annotation, node, indent)
+ FILE *file ATTRIBUTE_UNUSED;
+ const char *annotation ATTRIBUTE_UNUSED;
+ tree node ATTRIBUTE_UNUSED;
+ int indent ATTRIBUTE_UNUSED;
+{
+ fprintf (file, " ident=");
+ fprintf (file, HOST_PTR_PRINTF,
+ HOST_PTR_PRINTF_VALUE (TREE_OPERAND (node, 0)));
+ (void)node_seen (node, TRUE);
+}
+
+static void
+print_MESSAGE_SEND_EXPR (file, annotation, node, indent)
+ FILE *file ATTRIBUTE_UNUSED;
+ const char *annotation ATTRIBUTE_UNUSED;
+ tree node ATTRIBUTE_UNUSED;
+ int indent ATTRIBUTE_UNUSED;
+{
+ fprintf (file, " receiver=");
+ fprintf (file, HOST_PTR_PRINTF,
+ HOST_PTR_PRINTF_VALUE (TREE_OPERAND (node, 0)));
+ fprintf (file, " sel_name=%s",
+ IDENTIFIER_POINTER (TREE_OPERAND (node, 1)));
+ fprintf (file, " args=");
+ fprintf (file, HOST_PTR_PRINTF,
+ HOST_PTR_PRINTF_VALUE (TREE_OPERAND (node, 2)));
+ (void)node_seen (node, TRUE);
+}
+
+/*-------------------------------------------------------------------*/
+
+int
+objc_dump_tree_p (file, annotation, node, indent)
+ FILE *file;
+ const char *annotation ATTRIBUTE_UNUSED;
+ tree node;
+ int indent;
+{
+ switch (TREE_CODE (node))
+ {
+#define DEFTREECODE(SYM, NAME, TYPE, LENGTH) \
+ case SYM: print_ ## SYM (file, annotation, node, indent); break;
+#include "objc-tree.def"
+#undef DEFTREECODE
+ default:
+ return objc_prev_lang_dump_tree_p (file, annotation, node, indent);
+ }
+
+ return 1;
+}
+
+
+/*-------------------------------------------------------------------*/
+
+#if 0
+
+cd $gcc3/gcc; \
+cc -no-cpp-precomp -c -DIN_GCC -g \
+ -W -Wall -Wwrite-strings -Wstrict-prototypes -Wmissing-prototypes -Wtraditional -pedantic -Wno-long-long \
+ -DHAVE_CONFIG_H \
+ -I$gcc3obj \
+ -I. \
+ -Iobjc \
+ -Iconfig \
+ -I../include \
+ objc/objc-dmp-tree.c -o ~/tmp.o -w
+
+#endif
diff --git a/gcc/objc/objc-idebug.c b/gcc/objc/objc-idebug.c
new file mode 100644
index 00000000000..4bf78cdd18a
--- /dev/null
+++ b/gcc/objc/objc-idebug.c
@@ -0,0 +1,72 @@
+/* APPLE LOCAL file debugging */
+/* ObjC tree & rtl accessors defined as functions for use in a debugger.
+ Copyright (C) 2001 Free Software Foundation, Inc.
+ Contributed by Ira L. Ruben (ira@apple.com)
+
+This file is part of GNU CC.
+
+GNU CC is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2, or (at your option)
+any later version.
+
+GNU CC is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+GNU General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with GNU CC; see the file COPYING. If not, write to
+the Free Software Foundation, 59 Temple Place - Suite 330,
+Boston, MA 02111-1307, USA. */
+
+/* What we do here is to instantiate each macro as a function *BY
+ THE SAME NAME*. Depends on the macro not being expanded when
+ it is surrounded by parens.
+
+ Note that this file includes idebug.c or cp/cp-idebug.c (depending
+ on weather OBJCPLUS is defined) so that only debugging macros for
+ objc-act.h are actually defined here. For objc only this file is
+ included in the link while for C only idebug.c is built and inlcuded
+ in the link. Similarly, for objc++ this is the only included file
+ and cp-idebug.c is not linked. */
+
+#ifdef OBJCPLUS
+#include "cp/cp-idebug.c"
+#else
+#include "c-idebug.c"
+#endif
+
+#ifdef ENABLE_IDEBUG
+
+#include "objc-act.h"
+
+/* Macros from objc/objc-act.h */
+
+fn_1 ( KEYWORD_KEY_NAME, tree, tree )
+fn_1 ( KEYWORD_ARG_NAME, tree, tree )
+fn_1 ( METHOD_SEL_NAME, tree, tree )
+fn_1 ( METHOD_SEL_ARGS, tree, tree )
+fn_1 ( METHOD_ADD_ARGS, tree, tree )
+fn_1 ( METHOD_DEFINITION, tree, tree )
+fn_1 ( METHOD_ENCODING, tree, tree )
+fn_1 ( CLASS_NAME, tree, tree )
+fn_1 ( CLASS_SUPER_NAME, tree, tree )
+fn_1 ( CLASS_IVARS, tree, tree )
+fn_1 ( CLASS_RAW_IVARS, tree, tree )
+fn_1 ( CLASS_NST_METHODS, tree, tree )
+fn_1 ( CLASS_CLS_METHODS, tree, tree )
+fn_1 ( CLASS_OWN_IVARS, tree, tree )
+fn_1 ( CLASS_STATIC_TEMPLATE, tree, tree )
+fn_1 ( CLASS_CATEGORY_LIST, tree, tree )
+fn_1 ( CLASS_PROTOCOL_LIST, tree, tree )
+fn_1 ( PROTOCOL_NAME, tree, tree )
+fn_1 ( PROTOCOL_LIST, tree, tree )
+fn_1 ( PROTOCOL_NST_METHODS, tree, tree )
+fn_1 ( PROTOCOL_CLS_METHODS, tree, tree )
+fn_1 ( PROTOCOL_FORWARD_DECL, tree, tree )
+fn_1 ( PROTOCOL_DEFINED, tree, tree )
+fn_1 ( TREE_STATIC_TEMPLATE, int, tree )
+fn_1 ( TYPE_PROTOCOL_LIST, tree, tree)
+
+#endif /* ENABLE_IDEBUG */
diff --git a/gcc/objc/objc-lang.c b/gcc/objc/objc-lang.c
index 8f5692cad11..621d006a16b 100644
--- a/gcc/objc/objc-lang.c
+++ b/gcc/objc/objc-lang.c
@@ -39,6 +39,10 @@ enum c_language_kind c_language = clk_objc;
#define LANG_HOOKS_INIT objc_init
#undef LANG_HOOKS_FINISH
#define LANG_HOOKS_FINISH c_common_finish
+/* APPLE LOCAL begin Objective-C++ */
+#undef LANG_HOOKS_FINISH_FILE
+#define LANG_HOOKS_FINISH_FILE finish_file
+/* APPLE LOCAL end Objective-C++ */
#undef LANG_HOOKS_INIT_OPTIONS
#define LANG_HOOKS_INIT_OPTIONS c_common_init_options
#undef LANG_HOOKS_HANDLE_OPTION
diff --git a/gcc/objc/objc-root.h b/gcc/objc/objc-root.h
new file mode 100644
index 00000000000..96d86209715
--- /dev/null
+++ b/gcc/objc/objc-root.h
@@ -0,0 +1,4 @@
+/* APPLE LOCAL file Objective-C++ */
+/* Empty file to be the base for gtype-objc.h. */
+
+extern GTY(()) tree objc_dummy;
diff --git a/gcc/objcp/.cvsignore b/gcc/objcp/.cvsignore
new file mode 100644
index 00000000000..69944476744
--- /dev/null
+++ b/gcc/objcp/.cvsignore
@@ -0,0 +1,4 @@
+# APPLE LOCAL entire file
+objcp-parse.h
+objcp-parse.c
+g++int.info*
diff --git a/gcc/objcp/Make-lang.in b/gcc/objcp/Make-lang.in
new file mode 100644
index 00000000000..74b72211b09
--- /dev/null
+++ b/gcc/objcp/Make-lang.in
@@ -0,0 +1,222 @@
+# APPLE LOCAL Objective-C++
+# Top level makefile fragment for GNU Objective-C++
+# Copyright (C) 1997, 1998, 2000 Free Software Foundation, Inc.
+
+#This file is part of GNU CC.
+
+#GNU CC is free software; you can redistribute it and/or modify
+#it under the terms of the GNU General Public License as published by
+#the Free Software Foundation; either version 2, or (at your option)
+#any later version.
+
+#GNU CC is distributed in the hope that it will be useful,
+#but WITHOUT ANY WARRANTY; without even the implied warranty of
+#MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+#GNU General Public License for more details.
+
+#You should have received a copy of the GNU General Public License
+#along with GNU CC; see the file COPYING. If not, write to
+#the Free Software Foundation, 59 Temple Place - Suite 330,
+#Boston, MA 02111-1307, USA.
+
+# This file provides the language dependent support in the main Makefile.
+# Each language makefile fragment must provide the following targets:
+#
+# foo.all.build, foo.all.cross, foo.start.encap, foo.rest.encap,
+# foo.info, foo.dvi,
+# foo.install-normal, foo.install-common, foo.install-info, foo.install-man,
+# foo.uninstall,
+# foo.mostlyclean, foo.clean, foo.distclean, foo.extraclean,
+# foo.maintainer-clean, foo.stage1, foo.stage2, foo.stage3, foo.stage4
+#
+# where `foo' is the name of the language.
+#
+# It should also provide rules for:
+#
+# - making any compiler driver (eg: g++)
+# - the compiler proper (eg: cc1plus)
+# - define the names for selecting the language in LANGUAGES.
+
+#
+# Define the names for selecting Objective-C++ in LANGUAGES.
+OBJC++ objc++: cc1objplus$(exeext)
+OBJECTIVE-C++ objective-c++: cc1objplus$(exeext)
+
+# Tell GNU make to ignore these if they exist.
+.PHONY: objective-c++ objc++ ObjC++
+
+# Use maximal warnings for this front end (actually, this applies to the ObjC files,
+# not the C++ files, which have been compiled elsewhere).
+objc++-warn = $(STRICT_WARN)
+
+# APPLE LOCAL begin order files ilr
+ifeq ($(ORDER_FILES),yes)
+CC1OBJPLUS_ORDER_FLAGS = `if [ -f $(srcdir)/../order-files/cc1objplus.order ]; then \
+ echo -sectorder __TEXT __text $(srcdir)/../order-files/cc1objplus.order -e start ; fi`
+else
+CC1OBJPLUS_ORDER_FLAGS =
+endif
+# APPLE LOCAL end order files ilr
+
+# Language-specific object files for Objective C++.
+# APPLE LOCAL new tree dump
+# APPLE LOCAL debugging
+# APPLE LOCAL separate outputdir
+OBJCP_OBJS = $(CXX_AND_OBJCP_OBJS) $(CXX_C_OBJS) objcp/objcp-lang.o \
+ objcp/objcp-parse.o objcp/objcp-decl.o objcp/objcp-act.o \
+ objcp/objcp-idebug.o objcp/objcp-dmp-tree.o
+
+# APPLE LOCAL order files ilr
+cc1objplus$(exeext): $(OBJCP_OBJS) $(BACKEND) libcpp.a $(LIBDEPS)
+ $(CC) $(ALL_CFLAGS) $(LDFLAGS) -o $@ $(OBJCP_OBJS) $(BACKEND) libcpp.a $(LIBS) \
+ $(CC1OBJPLUS_ORDER_FLAGS)
+
+# Objective C++ language specific files.
+
+# APPLE LOCAL separate outputdir
+objcp/objcp-decl.o : $(srcdir)/objcp/objcp-decl.c $(srcdir)/objcp/objcp-decl.h \
+ $(CONFIG_H) $(TREE_H) $(srcdir)/toplev.h $(srcdir)/ggc.h \
+ $(srcdir)/cp/lex.h $(srcdir)/cp/cp-tree.h $(srcdir)/c-common.h \
+ $(srcdir)/input.h $(srcdir)/flags.h $(srcdir)/output.h \
+ $(srcdir)/objc/objc-act.h $(SYSTEM_H) $(CPPLIB_H)
+ $(CC) $(ALL_CFLAGS) $(ALL_CPPFLAGS) $(INCLUDES) -I$(srcdir)/cp -I$(srcdir)/objc \
+ -I$(srcdir)/objcp -DOBJCPLUS -c $(srcdir)/objcp/objcp-decl.c $(OUTPUT_OPTION)
+
+# APPLE LOCAL separate outputdir
+objcp/objcp-lang.o : $(srcdir)/cp/cp-lang.c \
+ $(CONFIG_H) $(TREE_H) $(srcdir)/toplev.h $(srcdir)/ggc.h \
+ $(srcdir)/cp/lex.h $(srcdir)/cp/cp-tree.h $(srcdir)/c-common.h \
+ $(srcdir)/input.h $(srcdir)/flags.h $(srcdir)/output.h \
+ $(srcdir)/objc/objc-act.h $(SYSTEM_H) $(CPPLIB_H)
+ $(CC) $(ALL_CFLAGS) $(ALL_CPPFLAGS) $(INCLUDES) -I$(srcdir)/cp -I$(srcdir)/objc \
+ -I$(srcdir)/objcp -DOBJCPLUS -c $(srcdir)/cp/cp-lang.c $(OUTPUT_OPTION)
+
+objcp/objcp-parse.o : $(parsedir)/objcp/objcp-parse.c $(CXX_TREE_H) flags.h cp/lex.h \
+ except.h output.h \
+ $(SYSTEM_H) toplev.h $(GGC_H) objc/objc-act.h objcp/objcp-decl.h
+ $(CC) -c $(ALL_CFLAGS) $(ALL_CPPFLAGS) $(INCLUDES) -I$(srcdir)/cp \
+ -I$(srcdir)/objc $(BIG_SWITCHFLAG) \
+ -DOBJCPLUS $(parsedir)/objcp/objcp-parse.c $(OUTPUT_OPTION)
+
+# APPLE LOCAL parsedir
+po-generated: $(parsedir)/objcp/objcp-parse.c
+
+# APPLE LOCAL parsedir
+# APPLE LOCAL Objective-C++
+$(parsedir)/objcp/objcp-parse.c : $(parsedir)/objcp/objcp-parse.y
+ cd $(parsedir)/objcp; \
+ $(BISON) $(BISONFLAGS) -d -v -o p$$$$.c objcp-parse.y ; \
+ mv -f p$$$$.c objcp-parse.c
+
+# APPLE LOCAL parsedir
+$(parsedir)/objcp/objcp-parse.y : $(srcdir)/cp/cp-parse.in
+ echo '/*WARNING: This file is automatically generated!*/' >tmp-objcp-prs.y
+ sed -e "/^ifcp$$/,/^end ifcp$$/d" \
+ -e "/^ifobjcp$$/d" -e "/^end ifobjcp$$/d" \
+ -e "/^...ifobjcp...$$/d" -e "/^...end ifobjcp...$$/d" \
+ $(srcdir)/cp/cp-parse.in >>tmp-objcp-prs.y
+ $(SHELL) $(srcdir)/move-if-change tmp-objcp-prs.y $(parsedir)/objcp/objcp-parse.y
+
+# APPLE LOCAL separate outputdir
+objcp/objcp-act.o : $(srcdir)/objc/objc-act.c $(srcdir)/objcp/objcp-decl.h \
+ $(CONFIG_H) $(TREE_H) $(RTL_H) $(SYSTEM_H) $(EXPR_H) $(TARGET_H) \
+ $(srcdir)/c-tree.h $(srcdir)/c-common.h $(VARRAY_H) \
+ $(srcdir)/toplev.h $(srcdir)/flags.h objc/objc-act.h objcp/objcp-decl.h \
+ $(srcdir)/input.h $(srcdir)/function.h $(srcdir)/output.h $(srcdir)/debug.h \
+ $(srcdir)/langhooks.h $(srcdir)/langhooks-def.h
+ $(CC) $(ALL_CFLAGS) $(ALL_CPPFLAGS) $(INCLUDES) -I$(srcdir)/cp -I$(srcdir)/objc \
+ -I$(srcdir)/objcp -DOBJCPLUS -c $(srcdir)/objc/objc-act.c $(OUTPUT_OPTION)
+
+# APPLE LOCAL debugging
+# Suppress all warnings explicitly for the idebug builds since there can be
+# many when, and if, -traditional-cpp is used.
+# APPLE LOCAL separate outputdir
+objcp/objcp-idebug.o : $(srcdir)/objc/objc-idebug.c $(CONFIG_H) $(TREE_H) $(C_TREE_H) \
+ $(RTL_H) $(srcdir)/objc/objc-act.h flags.h c-idebug.c idebug.c
+ $(CC) $(ALL_CFLAGS) $(ALL_CPPFLAGS) $(INCLUDES) -I$(srcdir)/cp -I$(srcdir)/objc \
+ -I$(srcdir)/objcp -DOBJCPLUS -c -w $(srcdir)/objc/objc-idebug.c $(OUTPUT_OPTION)
+
+# APPLE LOCAL new tree dump
+# APPLE LOCAL separate outputdir
+objcp/objcp-dmp-tree.o: $(srcdir)/objc/objc-dmp-tree.c $(srcdir)/cp/cp-dmp-tree.c \
+ $(srcdir)/c-dmp-tree.c $(CONFIG_H) $(TREE_H) $(SYSTEM_H) $(srcdir)/c-common.h \
+ $(srcdir)/objc/objc-act.h \
+ $(srcdir)/cp/cp-tree.h \
+ $(srcdir)/dmp-tree.c $(srcdir)/dmp-tree.h
+ $(CC) $(ALL_CFLAGS) $(ALL_CPPFLAGS) $(INCLUDES) -I$(srcdir)/cp -I$(srcdir)/objc \
+ -I$(srcdir)/objcp -DOBJCPLUS -c $(srcdir)/objc/objc-dmp-tree.c $(OUTPUT_OPTION)
+
+# APPLE LOCAL separate outputdir
+objcp/objcp-act.o : config.h
+
+gtype-objcp.h : s-gtype ; @true
+
+#
+# Build hooks:
+
+objc++.all.build:
+objc++.all.cross:
+objc++.start.encap:
+objc++.rest.encap:
+
+objc++.info:
+objc++.dvi:
+objc++.generated-manpages:
+
+#
+# Install hooks:
+# cc1objplus is installed elsewhere as part of $(COMPILERS).
+
+objc++.install-normal:
+
+objc++.install-common:
+
+objc++.install-info:
+
+objc++.install-man:
+
+objc++.uninstall:
+#
+# Clean hooks:
+# A lot of the ancillary files are deleted by the main makefile.
+# We just have to delete files specific to us.
+objc++.mostlyclean:
+ -rm -f objcp/*$(objext)
+objc++.clean: objc++.mostlyclean
+ -rm -rf objcp-headers
+objc++.distclean:
+ -rm -f objcp/config.status objcp/Makefile
+ -rm -f $(parsedir)/objcp/objcp-parse.output
+objc++.extraclean:
+# APPLE LOCAL: parsedir
+objc++.maintainer-clean:
+ -rm -f $(parsedir)/objcp/objcp-parse.y
+ -rm -f $(parsedir)/objcp/objcp-parse.c $(parsedir)/objcp/objcp-parse.output
+
+#
+# Stage hooks:
+
+objc++.stage1: stage1-start
+ -mv objcp/*$(objext) stage1/objcp
+ -mv cc1objplus$(exeext) stage1
+objc++.stage2: stage2-start
+ -mv objcp/*$(objext) stage2/objcp
+ -mv cc1objplus$(exeext) stage2
+objc++.stage3: stage3-start
+ -mv objcp/*$(objext) stage3/objcp
+ -mv cc1objplus$(exeext) stage3
+objc++.stage4: stage4-start
+ -mv objcp/*$(objext) stage4/objcp
+ -mv cc1objplus$(exeext) stage4
+
+# These exist for maintenance purposes.
+
+# APPLE LOCAL Objective-C++
+# Update the tags table.
+objcp/TAGS: force
+ cd $(srcdir)/objcp ; \
+ etags --no-globals -l c `echo *.c | sed 's/objcp-parse.c//'` \
+ objcp-parse.y *.h ../*.c ../*.h;
+
+.PHONY: objcp/TAGS
+
diff --git a/gcc/objcp/config-lang.in b/gcc/objcp/config-lang.in
new file mode 100644
index 00000000000..b6c0ac8cb63
--- /dev/null
+++ b/gcc/objcp/config-lang.in
@@ -0,0 +1,43 @@
+# APPLE LOCAL Objective-C++
+# Top level configure fragment for GNU Objective-C++.
+# Copyright (C) 1997, 1998, 2000, 2001 Free Software Foundation, Inc.
+
+#This file is part of GNU CC.
+
+#GNU CC is free software; you can redistribute it and/or modify
+#it under the terms of the GNU General Public License as published by
+#the Free Software Foundation; either version 2, or (at your option)
+#any later version.
+
+#GNU CC is distributed in the hope that it will be useful,
+#but WITHOUT ANY WARRANTY; without even the implied warranty of
+#MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+#GNU General Public License for more details.
+
+#You should have received a copy of the GNU General Public License
+#along with GNU CC; see the file COPYING. If not, write to
+#the Free Software Foundation, 59 Temple Place - Suite 330,
+#Boston, MA 02111-1307, USA.
+
+# Configure looks for the existence of this file to auto-config each language.
+# We define several parameters used by configure:
+#
+# language - name of language as it would appear in $(LANGUAGES)
+# compilers - value to add to $(COMPILERS)
+# stagestuff - files to add to $(STAGESTUFF)
+# diff_excludes - files to ignore when building diffs between two versions.
+
+language="objc++"
+
+compilers="cc1objplus\$(exeext)"
+
+stagestuff=""
+
+diff_excludes="-x objcp-parse.c -x objcp-parse.y "
+
+# By building the Objective-C and C++ front-ends, we will get
+# the object files we need, along with the libraries (libstdc++,
+# libobjc).
+lang_requires="objc c++"
+
+gtfiles="\$(srcdir)/objcp/objcp-root.h \$(srcdir)/objc/objc-act.h \$(srcdir)/cp/cp-tree.h \$(srcdir)/cp/decl.h \$(srcdir)/cp/lex.h \$(srcdir)/cp/call.c \$(srcdir)/cp/decl.c \$(srcdir)/cp/decl2.c \$(srcdir)/cp/pt.c \$(srcdir)/cp/repo.c \$(srcdir)/cp/tree.c \$(srcdir)/c-common.c \$(srcdir)/c-common.h \$(srcdir)/c-pragma.c"
diff --git a/gcc/objcp/lang-specs.h b/gcc/objcp/lang-specs.h
new file mode 100644
index 00000000000..e8672070a0e
--- /dev/null
+++ b/gcc/objcp/lang-specs.h
@@ -0,0 +1,59 @@
+/* APPLE LOCAL Objective-C++ */
+/* Definitions for specs for C++.
+ Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003
+ Free Software Foundation, Inc.
+
+This file is part of GNU CC.
+
+GNU CC is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2, or (at your option)
+any later version.
+
+GNU CC is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+GNU General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with GNU CC; see the file COPYING. If not, write to
+the Free Software Foundation, 59 Temple Place - Suite 330,
+Boston, MA 02111-1307, USA. */
+
+/* This is the contribution to the `default_compilers' array in gcc.c for
+ objective-c++. */
+
+#ifndef OBJCPLUSPLUS_CPP_SPEC
+#define OBJCPLUSPLUS_CPP_SPEC 0
+#endif
+
+ {".mm", "@objective-c++", 0},
+ {".M", "@objective-c++", 0},
+ {"@objective-c++",
+ "%{E|M|MM:cc1objplus -E %{!no-gcc:-D__GNUG__=%v1}\
+ %(cpp_options) %2 %(cpp_debug_options)}\
+ "/* APPLE LOCAL prohibit -arch with -E and -S */"\
+ %{E|S:%{@:%e-E and -S are not allowed with multiple -arch flags}}\
+ %{!E:%{!M:%{!MM:\
+ %{save-temps:cc1objplus -E %{!no-gcc:-D__GNUG__=%v1}\
+ %(cpp_options) %2 %b.mii \n}\
+ cc1objplus %{save-temps:-fpreprocessed %b.mii}\
+ %{!save-temps:%(cpp_unique_options) %{!no-gcc:-D__GNUG__=%v1}}\
+ %(cc1_options) %{gen-decls} %2 %{+e1*}\
+ %{!fsyntax-only:%(invoke_as)}}}}",
+ OBJCPLUSPLUS_CPP_SPEC},
+ {".mii", "@objc++-cpp-output", 0},
+ {"@objc++-cpp-output",
+ "%{!M:%{!MM:%{!E:\
+ cc1objplus -fpreprocessed %i %(cc1_options) %{gen-decls} %2 %{+e*}\
+ %{!fsyntax-only:%(invoke_as)}}}}", 0},
+ {"@objective-c++-header",
+ "%{E|M|MM:cc1objplus -E %{!no-gcc:-D__GNUG__=%v1}\
+ %(cpp_options) %2 %(cpp_debug_options)}\
+ %{!E:%{!M:%{!MM:\
+ %{save-temps:cc1objplus -E %{!no-gcc:-D__GNUG__=%v1}\
+ %(cpp_options) %2 %b.mii \n}\
+ cc1objplus %{save-temps:-fpreprocessed %b.mii}\
+ %{!save-temps:%(cpp_unique_options) %{!no-gcc:-D__GNUG__=%v1}}\
+ %(cc1_options) %{gen-decls} %2 %{+e1*}\
+ %(pch) %(dbg_ss)}}}", 0},
diff --git a/gcc/objcp/objcp-decl.c b/gcc/objcp/objcp-decl.c
new file mode 100644
index 00000000000..8c6848ab87b
--- /dev/null
+++ b/gcc/objcp/objcp-decl.c
@@ -0,0 +1,306 @@
+/* APPLE LOCAL file Objective-C++ */
+/* Process the ObjC-specific declarations and variables for
+ the Objective-C++ compiler.
+ Copyright (C) 1988, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000,
+ 2001 Free Software Foundation, Inc.
+
+This file is part of GCC.
+
+GCC is free software; you can redistribute it and/or modify it under
+the terms of the GNU General Public License as published by the Free
+Software Foundation; either version 2, or (at your option) any later
+version.
+
+GCC is distributed in the hope that it will be useful, but WITHOUT ANY
+WARRANTY; without even the implied warranty of MERCHANTABILITY or
+FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+for more details.
+
+You should have received a copy of the GNU General Public License
+along with GCC; see the file COPYING. If not, write to the Free
+Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+02111-1307, USA. */
+
+/* Process declarations and symbol lookup for C front end.
+ Also constructs types; the standard scalar types at initialization,
+ and structure, union, array and enum types when they are declared. */
+
+/* ??? not all decl nodes are given the most useful possible
+ line numbers. For example, the CONST_DECLs for enum values. */
+
+#include "config.h"
+#include "system.h"
+#include "tree.h"
+#include "rtl.h"
+#include "expr.h"
+#include "cp-tree.h"
+#include "lex.h"
+#include "c-common.h"
+#include "flags.h"
+#include "input.h"
+#include "except.h"
+#include "output.h"
+#include "toplev.h"
+#include "cpplib.h"
+#include "debug.h"
+#include "target.h"
+#include "varray.h"
+
+#include "objc-act.h"
+#include "objcp-decl.h"
+
+/* APPLE LOCAL indexing */
+#include "genindex.h"
+
+static tree objcp_parmlist = NULL_TREE;
+
+/* Hacks to simulate start_struct() and finish_struct(). */
+
+tree
+objcp_start_struct (code, name)
+ enum tree_code code ATTRIBUTE_UNUSED;
+ tree name;
+{
+ int new_scope = 0;
+ tree h, s;
+ /* The idea here is to mimic the actions that the C++ parser takes when
+ constructing 'extern "C" struct {'. */
+ push_lang_context (lang_name_c);
+ if (!name)
+ name = make_anon_name ();
+ h = handle_class_head (record_type, 0, name, 0, 1, &new_scope);
+
+ /* APPLE LOCAL indexing dpatel */
+ flag_suppress_builtin_indexing = 1;
+
+ s = begin_class_definition (TREE_TYPE (h));
+
+ /* APPLE LOCAL indexing dpatel */
+ flag_suppress_builtin_indexing = 0;
+
+ return s;
+}
+
+tree
+objcp_finish_struct (t, fieldlist, attributes)
+ tree t;
+ tree fieldlist, attributes;
+{
+ tree s, field, next_field;
+
+ /* APPLE LOCAL indexing dpatel */
+ flag_suppress_builtin_indexing = 1;
+
+ for (field = fieldlist; field; field = next_field)
+ {
+ next_field = TREE_CHAIN (field); /* insert one field at a time; */
+ TREE_CHAIN (field) = NULL_TREE; /* otherwise, grokfield croaks. */
+ finish_member_declaration (field);
+ }
+ s = finish_class_definition (t, attributes, 1, 0);
+
+ /* APPLE LOCAL indexing dpatel */
+ flag_suppress_builtin_indexing = 0;
+
+ pop_lang_context ();
+ return s;
+}
+
+int
+objcp_start_function (declspecs, declarator, attributes)
+ tree declspecs, declarator, attributes;
+{
+ return start_function (declspecs, declarator, attributes, 0);
+}
+
+void
+objcp_finish_function (nested)
+ int nested ATTRIBUTE_UNUSED;
+{
+ /* The C++ flavor of 'finish_function' does not generate RTL -- one has
+ to call 'expand_body' to do that. */
+ expand_body (finish_function (0));
+}
+
+tree
+objcp_start_decl (declarator, declspecs, initialized, attributes)
+ tree declarator, declspecs;
+ int initialized;
+ tree attributes;
+{
+ return start_decl (declarator, declspecs, initialized,
+ attributes, NULL_TREE);
+}
+
+void
+objcp_finish_decl (decl, init, asmspec)
+ tree decl, init, asmspec;
+{
+ cp_finish_decl (decl, init, asmspec, 0);
+}
+
+tree
+objcp_lookup_name (name)
+ tree name;
+{
+ return lookup_name (name, -1);
+}
+
+/* Hacks to simulate push_parm_decl() and get_parm_info(). */
+
+tree
+objcp_push_parm_decl (parm)
+ tree parm;
+{
+ /* C++ parms are laid out slightly differently from C parms. Adjust
+ for this here. */
+ TREE_VALUE (parm) = TREE_PURPOSE (parm);
+ TREE_PURPOSE (parm) = NULL_TREE;
+
+ if (objcp_parmlist)
+ objcp_parmlist = chainon (objcp_parmlist, parm);
+ else
+ objcp_parmlist = parm;
+
+ return objcp_parmlist;
+}
+
+tree
+objcp_get_parm_info (void_at_end)
+ int void_at_end;
+{
+ tree parm_info = finish_parmlist (objcp_parmlist, !void_at_end);
+
+ /* The C++ notion of a parameter list differs slightly from that of
+ C. Adjust for this. */
+ parm_info = build_tree_list (parm_info, NULL_TREE);
+ objcp_parmlist = NULL_TREE;
+
+ return parm_info;
+}
+
+void
+objcp_store_parm_decls ()
+{
+ /* In C++ land, 'start_function' calls 'store_parm_decls'; hence we
+ do not need to do anything here. */
+}
+
+tree
+objcp_build_function_call (function, args)
+ tree function, args;
+{
+ /* APPLE MERGE this is probably wrong */
+ return build_function_call (function, args);
+}
+
+tree
+objcp_xref_tag (code, name)
+ enum tree_code code;
+ tree name;
+{
+ if (code != RECORD_TYPE)
+ abort (); /* this is sheer laziness... */
+ return xref_tag (record_type, name, 0, 1);
+}
+
+tree
+objcp_grokfield (filename, line, declarator, declspecs, width)
+ const char *filename ATTRIBUTE_UNUSED;
+ int line ATTRIBUTE_UNUSED;
+ tree declarator, declspecs, width;
+{
+ return (width) ? grokbitfield (declarator, declspecs, width)
+ : grokfield (declarator, declspecs, 0, 0, 0);
+}
+
+tree
+objcp_build_component_ref (datum, component)
+ tree datum, component;
+{
+ /* The 'build_component_ref' routine has been removed from the C++
+ front-end, but 'finish_class_member_access_expr' seems to be
+ a worthy substitute. */
+ return finish_class_member_access_expr (datum, component);
+}
+
+int
+objcp_comptypes (type1, type2)
+ tree type1, type2;
+{
+ return comptypes (type1, type2, 0);
+}
+
+tree
+objcp_type_name (type)
+ tree type;
+{
+ if (TYPE_NAME (type) && TREE_CODE (TYPE_NAME (type)) == TYPE_DECL)
+ return DECL_NAME (TYPE_NAME (type));
+ else
+ return TYPE_NAME (type);
+}
+
+tree
+objcp_type_size (type)
+ tree type;
+{
+ tree size = TYPE_SIZE (type);
+ if (size == NULL_TREE)
+ {
+ warning ("Requesting size of incomplete type `%s'",
+ IDENTIFIER_POINTER (objcp_type_name (type)));
+ layout_type (type);
+ size = TYPE_SIZE (type);
+ }
+ return build_int_2 (TREE_INT_CST_LOW (size), 0);
+}
+
+/* C++'s version of 'builtin_function' winds up placing our precious
+ objc_msgSend and friends in namespace std! This will not do.
+ We shall hence duplicate C's 'builtin_function' here instead. */
+
+tree
+objcp_builtin_function (name, type, code, class, libname, attrs)
+ const char *name;
+ tree type;
+ int code;
+ enum built_in_class class;
+ const char *libname ATTRIBUTE_UNUSED;
+ tree attrs;
+{
+ tree decl = NULL;
+ decl = build_decl (FUNCTION_DECL, get_identifier (name), type);
+ DECL_EXTERNAL (decl) = 1;
+ TREE_PUBLIC (decl) = 1;
+ make_decl_rtl (decl, NULL);
+ pushdecl (decl);
+ DECL_BUILT_IN_CLASS (decl) = class;
+ DECL_FUNCTION_CODE (decl) = code;
+ DECL_ANTICIPATED (decl) = 1;
+
+ /* Possibly apply some default attributes to this built-in function. */
+ if (attrs)
+ decl_attributes (&decl, attrs, ATTR_FLAG_BUILT_IN);
+ else
+ decl_attributes (&decl, NULL_TREE, 0);
+
+ return decl;
+}
+
+int
+objcp_lookup_identifier (token, id, check_conflict)
+ tree token;
+ tree *id;
+ int check_conflict;
+{
+ tree objc_id = lookup_objc_ivar (token);
+
+ if (!check_conflict || objc_id && IS_SUPER (objc_id))
+ *id = objc_id;
+ else if (objc_id && *id && IDENTIFIER_BINDING (token))
+ warning ("local declaration of `%s' hides instance variable",
+ IDENTIFIER_POINTER (token));
+
+ return (objc_id != NULL_TREE);
+}
diff --git a/gcc/objcp/objcp-decl.h b/gcc/objcp/objcp-decl.h
new file mode 100644
index 00000000000..945631d1b91
--- /dev/null
+++ b/gcc/objcp/objcp-decl.h
@@ -0,0 +1,100 @@
+/* Process the ObjC-specific declarations and variables for
+ the Objective-C++ compiler.
+ Copyright (C) 1988, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000,
+ 2001 Free Software Foundation, Inc.
+
+This file is part of GCC.
+
+GCC is free software; you can redistribute it and/or modify it under
+the terms of the GNU General Public License as published by the Free
+Software Foundation; either version 2, or (at your option) any later
+version.
+
+GCC is distributed in the hope that it will be useful, but WITHOUT ANY
+WARRANTY; without even the implied warranty of MERCHANTABILITY or
+FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+for more details.
+
+You should have received a copy of the GNU General Public License
+along with GCC; see the file COPYING. If not, write to the Free
+Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+02111-1307, USA. */
+
+#ifndef GCC_OBJCP_DECL_H
+#define GCC_OBJCP_DECL_H
+
+/* APPLE LOCAL entire file */
+
+extern tree objcp_start_struct PARAMS ((enum tree_code, tree));
+extern tree objcp_finish_struct PARAMS ((tree, tree, tree));
+extern int objcp_start_function PARAMS ((tree, tree, tree));
+extern void objcp_finish_function PARAMS ((int));
+extern tree objcp_start_decl PARAMS ((tree, tree, int, tree));
+extern void objcp_finish_decl PARAMS ((tree, tree, tree));
+extern tree objcp_lookup_name PARAMS ((tree));
+extern tree objcp_push_parm_decl PARAMS ((tree));
+extern tree objcp_get_parm_info PARAMS ((int));
+extern void objcp_store_parm_decls PARAMS ((void));
+extern tree objcp_build_function_call PARAMS ((tree, tree));
+extern tree objcp_xref_tag PARAMS ((enum tree_code, tree));
+extern tree objcp_grokfield PARAMS ((const char *, int, tree, tree, tree));
+extern tree objcp_build_component_ref PARAMS ((tree, tree));
+extern int objcp_comptypes PARAMS ((tree, tree));
+extern tree objcp_type_name PARAMS ((tree));
+extern tree objcp_type_size PARAMS ((tree));
+extern tree objcp_builtin_function PARAMS ((const char *, tree, int,
+ enum built_in_class, const char *, tree));
+
+extern int objcp_lookup_identifier PARAMS ((tree, tree *, int));
+
+/* Now "cover up" the corresponding C++ functions if required (NB: the
+ OBJCP_ORIGINAL_FUNCTION macro, shown below, can still be used to
+ invoke the original C++ functions if needed). */
+#ifdef OBJCP_REMAP_FUNCTIONS
+
+#define start_struct(code, name) \
+ objcp_start_struct (code, name)
+#define finish_struct(t, fieldlist, attributes) \
+ objcp_finish_struct (t, fieldlist, attributes)
+#define start_function(declspecs, declarator, attributes) \
+ objcp_start_function (declspecs, declarator, attributes)
+#define finish_function(nested) \
+ objcp_finish_function (nested)
+#define start_decl(declarator, declspecs, initialized, attributes) \
+ objcp_start_decl (declarator, declspecs, initialized, attributes)
+#define finish_decl(decl, init, asmspec) \
+ objcp_finish_decl (decl, init, asmspec)
+#define lookup_name(name) \
+ objcp_lookup_name (name)
+#define push_parm_decl(parm) \
+ objcp_push_parm_decl (parm)
+#define get_parm_info(void_at_end) \
+ objcp_get_parm_info (void_at_end)
+#define store_parm_decls() \
+ objcp_store_parm_decls ()
+#define build_function_call(function, args) \
+ objcp_build_function_call (function, args)
+#define xref_tag(code, name) \
+ objcp_xref_tag (code, name)
+#define grokfield(filename, line, declarator, declspecs, width) \
+ objcp_grokfield (filename, line, declarator, declspecs, width)
+#define build_component_ref(datum, component) \
+ objcp_build_component_ref (datum, component)
+#define comptypes(type1, type2) \
+ objcp_comptypes (type1, type2)
+#define builtin_function(name, type, code, class, libname, attr) \
+ objcp_builtin_function(name, type, code, class, libname, attr)
+
+#undef TYPE_NAME
+#define TYPE_NAME(type) \
+ objcp_type_name (type)
+
+#undef TYPE_SIZE
+#define TYPE_SIZE(type) \
+ objcp_type_size (type)
+
+#define OBJCP_ORIGINAL_FUNCTION(name, args) (name)args
+
+#endif /* OBJCP_REMAP_FUNCTIONS */
+
+#endif /* ! GCC_OBJCP_DECL_H */
diff --git a/gcc/objcp/objcp-root.h b/gcc/objcp/objcp-root.h
new file mode 100644
index 00000000000..f55bc6a26f5
--- /dev/null
+++ b/gcc/objcp/objcp-root.h
@@ -0,0 +1,4 @@
+/* APPLE LOCAL file Objective-C++ */
+/* Empty file to be the base for gtype-objcp.h. */
+
+extern GTY(()) tree objcp_dummy;
diff --git a/gcc/opts.c b/gcc/opts.c
index 3bfa1c42ed0..c7310e1ffed 100644
--- a/gcc/opts.c
+++ b/gcc/opts.c
@@ -134,6 +134,14 @@ static bool maybe_warn_unused_parameter;
debugging information. */
enum debug_info_type write_symbols = NO_DEBUG;
+/* APPLE LOCAL begin Symbol Separation */
+/* Original value of write_symbols. */
+enum debug_info_type orig_write_symbols = NO_DEBUG;
+
+/* Nonzero means, try to look for separate symbol repositories. */
+int flag_grepository = 0;
+/* APPLE LOCAL end Symbol Separation */
+
/* Level of debugging information we are producing. See flags.h for
the definitions of the different possible levels. */
enum debug_info_level debug_info_level = DINFO_LEVEL_NONE;
@@ -434,6 +442,10 @@ handle_option (const char **argv, unsigned int lang_mask)
return result;
}
+/* APPLE LOCAL radar 2866081: Env. variable override ilr */
+static int add_env_options PARAMS ((unsigned int *, const char ***));
+static int override_option PARAMS ((int, int, const char **));
+
/* Decode and handle the vector of command line options. LANG_MASK
contains has a single bit set representing the current
language. */
@@ -442,10 +454,23 @@ handle_options (unsigned int argc, const char **argv, unsigned int lang_mask)
{
unsigned int n, i;
+ /* APPLE LOCAL radar 2866081: Env. variable override ilr */
+ do {
+
for (i = 1; i < argc; i += n)
{
const char *opt = argv[i];
+ /* APPLE LOCAL begin radar 2866081: Env. variable override ilr */
+ if (!override_option (i, argc, argv))
+ {
+ ++i;
+ /* MERGE FIXME: we need to compute 'n'. */
+ n = 0;
+ continue;
+ }
+ /* APPLE LOCAL end radar 2866081: Env. variable override ilr */
+
/* Interpret "-" or a non-switch as a file name. */
if (opt[0] != '-' || opt[1] == '\0')
{
@@ -464,8 +489,518 @@ handle_options (unsigned int argc, const char **argv, unsigned int lang_mask)
error ("unrecognized command line option \"%s\"", opt);
}
}
+
+ /* APPLE LOCAL radar 2866081: Env. variable override ilr */
+ } while (add_env_options (&argc, &argv));
+}
+
+/* APPLE LOCAL begin radar 2866081: Env. variable override ilr */
+/*--------------------------------------------------------------------*/
+
+/* The QA_OVERRIDE_GCC3_OPTIONS environment variable, if it exists,
+ contains a list of options which override their counterparts on
+ the compiler command line. This routine collects the options from
+ that environment variable and creates an array (env_override_options)
+ of n_overrides string pointers to then. Each command line option
+ is passed through override_option() to check to see if it has an
+ override in the env_override_options[] array.
+
+ The general form for QA_OVERRIDE_GCC3_OPTIONS is as follows:
+
+ -opt ... --opt arg s/pattern/replacement/ + -opt --opt arg ...
+
+ In other words a set of override options or option replacements in
+ the forms described below. The '+' means all options that the
+ following options are to be added to the command line if they don't
+ otherwise replace options.
+
+ The syntax of the options in QA_OVERRIDE_GCC3_OPTIONS can be any
+ of the following forms:
+
+ -f[no-]option, -m[no-]option, -W[no-]option
+ Override corresponding (ignoring the 'no-' prefix) options
+ on the command line.
+
+ --option arg
+ Indicates that the -option has an argument and that the
+ argument is to be replaced for that -option if it is
+ present on the command line.
+
+ +
+ Adds the options that follow to the command line. Any of above
+ option forms specified. They are added to the command line if
+ not otherwise used to override an existing command line
+ option.
+
+ s/-option/replacement-option/,
+ s/-option/replacement-option replacement-arg/,
+ s/--option/replacement-option/,
+ s/--option/replacement-option replacement-arg/
+ Replaces the -option and/or its argument. If there is nothing
+ between the second two /'s (which can be any character) the
+ option (and its arg for --option) are deleted. The --option
+ cases indicate that the option and its argument are to
+ be replaced either with an option that has no argument or
+ another (possibly the same option) that itself has an
+ argument.
+
+ Note, there should be only one space between the
+ replacement-option and replacement-arg.
+
+ Normally whenever a command line option is affected by the
+ options in QA_OVERRIDE_GCC3_OPTIONS are displayed confirming
+ what was done (to stderr). For example,
+
+ ### QA_OVERRIDE_GCC3_OPTIONS: -O2 -fno-inline
+ ### QA_OVERRIDE_GCC3_OPTIONS: Optimization set to -O2
+
+ This may be suppressed by placing a '#' as the first character
+ in the QA_OVERRIDE_GCC3_OPTIONS string.
+*/
+
+struct env_overrides {
+ char *option;
+ unsigned short flags;
+};
+#define env_ovr_used 1
+#define env_ovr_has_arg 2
+#define env_ovr_add_arg 4
+#define env_over_no_msg 8
+static struct env_overrides *env_override_options;
+static int n_overrides = 0;
+static int env_override_options_max = 0;
+static int have_added_opts = 0;
+static int add_env_opts = 0;
+static int env_ovr_confirm = 1;
+static char *extract_override_options PARAMS ((void));
+static void override_O_option PARAMS ((void));
+
+static char *
+extract_override_options (void)
+{
+ int has_arg = 0, scnt = 0, added_flag;
+ char *override_O = NULL, s = 0;
+ char *opts = getenv ("QA_OVERRIDE_GCC3_OPTIONS");
+
+ if (opts && *opts)
+ {
+ char c, *p, quote;
+ static char *override_options_line;
+
+ override_options_line = xstrdup (opts);
+
+ if (override_options_line[0] == '#')
+ {
+ env_ovr_confirm = 0;
+ p = override_options_line;
+ }
+ else
+ {
+ env_ovr_confirm = 1;
+ p = override_options_line - 1;
+ }
+
+ if (env_ovr_confirm)
+ fprintf (stderr, "### QA_OVERRIDE_GCC3_OPTIONS: %s\n",
+ override_options_line);
+
+ n_overrides = 0;
+
+ while (1)
+ {
+ while (*++p == ' ') ;
+ if ((c = *p) == '\0')
+ break;
+
+ if (p[0] == '-' && p[1] == 'O')
+ override_O = p;
+ else
+ {
+ if (p[0] == '+')
+ {
+ have_added_opts = env_ovr_add_arg;
+ continue;
+ }
+
+ if (p[0] == 's')
+ {
+ s = p[1];
+ scnt = 0;
+ added_flag = 0;
+ }
+ else
+ {
+ s = scnt = 0;
+ added_flag = have_added_opts;
+ }
+
+ if (n_overrides >= env_override_options_max)
+ {
+ env_override_options_max += 6;
+ env_override_options = (struct env_overrides *)
+ xrealloc (env_override_options,
+ sizeof (struct env_overrides)
+ * env_override_options_max);
+ if (n_overrides == 0) /* match argv[] counting */
+ ++n_overrides;
+ }
+
+ if (!has_arg && p[0] == '-' && p[1] == '-')
+ {
+ env_override_options[n_overrides].flags = env_ovr_has_arg | added_flag;
+ env_override_options[n_overrides].option = p + 1;
+ has_arg = 1;
+ }
+ else
+ {
+ env_override_options[n_overrides].flags = added_flag;
+ env_override_options[n_overrides].option = p--;
+ has_arg = 0;
+ }
+
+ ++n_overrides;
+ }
+
+ quote = 0;
+ while (*++p && (*p != ' ' || quote || s))
+ if (*p == '"' || *p == '\'')
+ quote = (quote && *p == quote) ? 0 : *p;
+ else if (*p == '\\')
+ ++p;
+ else if (*p == s && ++scnt == 3)
+ s = 0;
+
+ if (!*p)
+ break;
+
+ *p = '\0';
+ }
+ }
+
+ if (has_arg)
+ fatal_error ("QA_OVERRIDE_GCC3_OPTIONS invalid - last option should have an argument");
+
+ return override_O;
}
+/* Called to handle -O overrides prior to main argument processing.
+ A -O option can be overridded from the QA_OVERRIDE_GCC3_OPTIONS
+ environment variable. Note that since this is prior to argument
+ processing we call extract_override_options() from here to build
+ the option overrides from QA_OVERRIDE_GCC3_OPTIONS. During
+ main line option processing we then call override_option() to
+ see if a specific option is overridden. */
+
+static void
+override_O_option (void)
+{
+ char *overide_opt = extract_override_options ();
+ int optimize0 = optimize, optimize_size0 = optimize_size;
+
+ if (!overide_opt)
+ return;
+
+ optimize = -1;
+ if (!strcmp (overide_opt, "-O"))
+ {
+ optimize = 1;
+ optimize_size = 0;
+ }
+ else if (overide_opt[0] == '-' && overide_opt[1] == 'O')
+ {
+ /* Handle -Os, -O2, -O3, -O69, ... */
+ char *p = overide_opt + 2;
+
+ if ((p[0] == 's') && (p[1] == 0))
+ {
+ optimize_size = 1;
+
+ /* Optimizing for size forces optimize to be 2. */
+ optimize = 2;
+ }
+ else
+ {
+ const int optimize_val = read_integral_parameter (p, p - 2, -1);
+ if (optimize_val != -1)
+ {
+ optimize = optimize_val;
+ optimize_size = 0;
+ }
+ }
+ }
+
+ if (optimize < 0)
+ fatal_error ("QA_OVERRIDE_GCC3_OPTIONS set with an invalid O option (%s).",
+ overide_opt);
+ if (env_ovr_confirm
+ && (optimize != optimize0 || optimize_size != optimize_size0))
+ fprintf (stderr, "### QA_OVERRIDE_GCC3_OPTIONS: Optimization set to %s\n", overide_opt);
+}
+
+/* Check to see if the specified command line option is overridden
+ by an option in the QA_OVERRIDE_GCC3_OPTIONS environment variable
+ string. If is isn't, return the original command line option. If
+ it is, return the override and display a message that the option
+ was overridden.
+
+ If add_env_opts is set then we only add options that are flagged to
+ be added. This is initiated when add_env_options() is called after
+ processing the command line options.
+*/
+
+static int
+override_option (int i, int argc, const char **argv)
+{
+ int j, len, parg;
+ char *p;
+ const char *opt;
+ char letter_opt1, letter_opt2, s = 0;
+ char *repopt = NULL;
+ char *reparg, *repend;
+ static char rep_option[256], rep_arg[256];
+
+ if (n_overrides == 0)
+ return 1;
+
+ if (add_env_opts)
+ {
+ if ((env_override_options[i].flags & env_ovr_add_arg) == 0
+ || (env_override_options[i].flags & env_ovr_used) != 0
+ || env_override_options[i].option == NULL)
+ return 0;
+ argv[i] = env_override_options[i].option;
+ if (env_override_options[i].flags & env_ovr_has_arg)
+ {
+ argv[i+1] = env_override_options[i+1].option;
+ if (env_ovr_confirm
+ && (env_override_options[i].flags & env_over_no_msg) == 0)
+ fprintf (stderr,
+ "### QA_OVERRIDE_GCC3_OPTIONS: Adding command line option '%s %s'\n",
+ argv[i], argv[i+1]);
+ }
+ else if (env_ovr_confirm
+ && (env_override_options[i].flags & env_over_no_msg) == 0)
+ fprintf (stderr, "### QA_OVERRIDE_GCC3_OPTIONS: Adding command line option '%s'\n",
+ argv[i]);
+ return 1;
+ }
+
+ if (!argv[i])
+ return 0;
+
+ opt = argv[i];
+ letter_opt1 = 0;
+
+ if (opt[0] == '-')
+ {
+ if (opt[1] == 'f' || opt[1] == 'm' || opt[1] == 'W')
+ {
+ letter_opt1 = opt[1];
+ opt += 2;
+ }
+ if (opt[0] == 'n' && opt[1] == 'o' && opt[2] == '-')
+ opt += 3;
+ }
+
+ for (j = 1; j < n_overrides; ++j)
+ {
+ p = env_override_options[j].option;
+ letter_opt2 = 0;
+ s = 0;
+ parg = 0;
+
+ if (p[0] == 's')
+ {
+ s = p[1];
+ p += 2;
+ repopt = strchr (p, s);
+ if (!repopt)
+ return 1;
+ *repopt++ = '\0';
+ if (p[0] == '-' && p[1] == '-')
+ {
+ parg = 1;
+ ++p;
+ }
+ }
+
+ if (p[0] == '-')
+ {
+ if (p[1] == 'f' || p[1] == 'm' || p[1] == 'W')
+ {
+ letter_opt2 = p[1];
+ p += 2;
+ }
+ if (p[0] == 'n' && p[1] == 'o' && p[2] == '-')
+ p += 3;
+ }
+
+ if (strcmp (p, opt) == 0 && letter_opt1 == letter_opt2)
+ {
+ if (i < argc - 1
+ && (env_override_options[j].flags & env_ovr_has_arg))
+ argv[i + 1] = env_override_options[j + 1].option;
+
+ if (s)
+ {
+ repend = strchr (repopt, s);
+ reparg = NULL;
+ if (repend)
+ {
+ reparg = strchr(repopt, ' ');
+ if (reparg)
+ {
+ strncpy (rep_option, repopt, len = reparg - repopt);
+ rep_option[len] = '\0';
+ ++reparg;
+ strncpy (rep_arg, reparg, len = repend - reparg);
+ rep_arg[len] = '\0';
+ }
+ else
+ {
+ strncpy (rep_option, repopt, len = repend - repopt);
+ rep_option[len] = rep_arg[0] = '\0';
+ }
+
+ if (len)
+ {
+ if (parg)
+ {
+ if (reparg) /* s/--opt/rep_option rep_arg/ */
+ {
+ if (strcmp (argv[i], rep_option) != 0
+ || strcmp (argv[i+1], rep_arg) == 0)
+ {
+ if (env_ovr_confirm
+ && (env_override_options[j].flags & env_ovr_used) == 0)
+ fprintf (stderr,
+ "### QA_OVERRIDE_GCC3_OPTIONS: Replacing command line option '%s %s' with '%s %s'\n",
+ argv[i], argv[i + 1], rep_option, rep_arg);
+ argv[i] = rep_option;
+ argv[i + 1] = rep_arg;
+ }
+ }
+ else /* s/--opt/rep_option/ */
+ {
+ if (env_ovr_confirm
+ && (env_override_options[j].flags & env_ovr_used) == 0)
+ fprintf (stderr,
+ "### QA_OVERRIDE_GCC3_OPTIONS: Replacing command line option '%s %s' with '%s'\n",
+ argv[i], argv[i + 1], rep_option);
+ argv[i] = rep_option;
+ argv[i+1] = NULL;
+ }
+ }
+ else if (reparg) /* s/-opt/rep_option rep_arg/ */
+ {
+ if (env_ovr_confirm
+ && (env_override_options[j].flags & env_ovr_used) == 0)
+ fprintf (stderr,
+ "### QA_OVERRIDE_GCC3_OPTIONS: Replacing command line option '%s' with '%s %s'\n",
+ argv[i], rep_option, rep_arg);
+ if (n_overrides+1 >= env_override_options_max)
+ {
+ env_override_options_max += 6;
+ env_override_options = (struct env_overrides *)
+ xrealloc (env_override_options,
+ sizeof (struct env_overrides)
+ * env_override_options_max);
+ if (n_overrides == 0) /* match argv[] counting */
+ ++n_overrides;
+ }
+ env_override_options[n_overrides ].option = rep_option;
+ env_override_options[n_overrides++].flags = env_ovr_has_arg | env_ovr_add_arg | env_over_no_msg;
+ env_override_options[n_overrides ].option = rep_arg;
+ env_override_options[n_overrides++].flags = env_ovr_add_arg | env_over_no_msg;
+ argv[i] = NULL;
+ have_added_opts = 1;
+ }
+ else if (strcmp (argv[i], rep_option) != 0) /* s/-opt/rep_option/ */
+ {
+ if (env_ovr_confirm
+ && (env_override_options[j].flags & env_ovr_used) == 0)
+ fprintf (stderr,
+ "### QA_OVERRIDE_GCC3_OPTIONS: Replacing command line option '%s' with '%s'\n",
+ argv[i], rep_option);
+ argv[i] = rep_option;
+ }
+ }
+ else
+ {
+ if (env_ovr_confirm
+ && (env_override_options[j].flags & env_ovr_used) == 0)
+ fprintf (stderr, "### QA_OVERRIDE_GCC3_OPTIONS: Deleting command line option '%s", argv[i]);
+ if (parg)
+ {
+ if (env_ovr_confirm
+ && (env_override_options[j].flags & env_ovr_used) == 0)
+ fprintf (stderr, " %s", argv[i + 1]);
+ argv[i + 1] = NULL;
+ }
+ if (env_ovr_confirm
+ && (env_override_options[j].flags & env_ovr_used) == 0)
+ fputs ("'\n", stderr);
+ argv[i] = NULL;
+ }
+ }
+ *(repopt-1) = s;
+ env_override_options[j].flags |= env_ovr_used;
+ return argv[i] != NULL;
+ }
+ else if (strcmp (argv[i], env_override_options[j].option) != 0)
+ {
+ if (env_ovr_confirm
+ && (env_override_options[j].flags & env_ovr_used) == 0)
+ fprintf (stderr,
+ "### QA_OVERRIDE_GCC3_OPTIONS: Overriding command line option '%s' with '%s'\n",
+ argv[i], env_override_options[j].option);
+ argv[i] = env_override_options[j].option;
+ env_override_options[j].flags |= env_ovr_used;
+ return 1;
+ }
+ }
+ else if (s)
+ *(repopt-1) = s;
+ }
+
+ return 1;
+}
+
+/* Once all command line options are processed this routine is called
+ to see if QA_OVERRIDE_GCC3_OPTIONS specified any options to be
+ added. If there are we will return 1 to cause another option
+ processing pass. But this time argc and argv will be set to use
+ the env_override_options[] array and then only to select the added
+ options. */
+
+static int
+add_env_options (unsigned int *argc, const char ***argv)
+{
+ static unsigned int save_argc;
+ static const char **save_argv;
+
+ if (have_added_opts)
+ {
+ if (!add_env_opts)
+ {
+ save_argv = *argv;
+ save_argc = *argc;
+ *argc = n_overrides;
+ *argv = xmalloc (n_overrides * sizeof (char *));
+ add_env_opts = 1;
+ return 1;
+ }
+
+ free (*argv);
+ *argc = save_argc;
+ *argv = save_argv;
+ add_env_opts = 0;
+ }
+
+ return 0;
+}
+/* APPLE LOCAL end radar 2866081: Env. variable override ilr */
+
/* Handle FILENAME from the command line. */
void
add_input_filename (const char *filename)
@@ -518,8 +1053,31 @@ decode_options (unsigned int argc, const char **argv)
}
}
}
+ /* APPLE LOCAL begin -fast or -fastf or -fastcp */
+ else if (argv[i][0] == '-' && argv[i][1] == 'f')
+ {
+ const char *p = &argv[i][2];
+ if (!strcmp(p, "ast"))
+ flag_fast = 1;
+ else if (!strcmp(p, "astf"))
+ flag_fastf = 1;
+ else if (!strcmp(p, "astcp"))
+ flag_fastcp = 1;
+ }
+ /* APPLE LOCAL end -fast or -fastf */
}
+ /* APPLE LOCAL begin -fast or -fastf or -fastcp */
+ if (flag_fast || flag_fastf || flag_fastcp )
+ {
+ optimize = 3;
+ optimize_size = 0;
+ }
+ /* APPLE LOCAL end -fast or -fastf or -fastcp */
+
+ /* APPLE LOCAL radar 2866081: Env. variable -O override ilr */
+ override_O_option ();
+
if (!optimize)
{
flag_merge_constants = 0;
@@ -610,6 +1168,9 @@ decode_options (unsigned int argc, const char **argv)
or less automatically remove extra jumps, but would also try to
use more short jumps instead of long jumps. */
flag_reorder_blocks = 0;
+ /* APPLE LOCAL begin hot/cold partitioning */
+ flag_reorder_blocks_and_partition = 0;
+ /* APPLE LOCAL end hot/cold partitioning */
}
/* Initialize whether `char' is signed. */
@@ -666,6 +1227,21 @@ decode_options (unsigned int argc, const char **argv)
if (flag_really_no_inline == 2)
flag_really_no_inline = flag_no_inline;
+
+ /* APPLE LOCAL begin hot/cold partitioning */
+ /* The optimization to partition hot and cold basic blocks into separate
+ sections of the .o and executable files does not work (currently)
+ with exception handling. If flag_exceptions is turned on we need to
+ turn off the partitioning optimization. */
+
+ if (flag_exceptions && flag_reorder_blocks_and_partition)
+ {
+ warning
+ ("-freorder-blocks-and-partition does not work with exceptions");
+ flag_reorder_blocks_and_partition = 0;
+ flag_reorder_blocks = 1;
+ }
+ /* APPLE LOCAL end hot/cold partitioning */
}
/* Handle target- and language-independent options. Return zero to
@@ -851,6 +1427,12 @@ common_handle_option (size_t scode, const char *arg,
flag_pie = value + value;
break;
+ /* APPLE LOCAL begin -floop-transpose */
+ case OPT_floop_transpose:
+ flag_loop_transpose = value;
+ break;
+ /* APPLE LOCAL end -floop-transpose */
+
case OPT_fabi_version_:
flag_abi_version = value;
break;
@@ -1294,6 +1876,12 @@ common_handle_option (size_t scode, const char *arg,
flag_reorder_blocks = value;
break;
+ /* APPLE LOCAL begin hot/cold partitioning */
+ case OPT_freorder_blocks_and_partition:
+ flag_reorder_blocks_and_partition = value;
+ break;
+ /* APPLE LOCAL end hot/cold partitioning */
+
case OPT_freorder_functions:
flag_reorder_functions = value;
break;
@@ -1722,9 +2310,46 @@ static void
set_debug_level (enum debug_info_type type, int extended, const char *arg)
{
static bool type_explicit;
+/* APPLE LOCAL gdb only used symbols ilr */
+ int g_all_len = 0;
use_gnu_debug_info_extensions = extended;
+/* APPLE LOCAL begin gdb only used symbols ilr */
+#ifdef DBX_ONLY_USED_SYMBOLS
+ if (strncmp (arg, "full", 4) == 0 || strncmp (arg, "-full", 5) == 0)
+ {
+ char *p = (char *)arg + (*(char *)arg == '-') + 4;
+ flag_debug_only_used_symbols = 0;
+ if (*p == '-')
+ ++p;
+ g_all_len = p - arg;
+ arg += g_all_len;
+ }
+ if (strncmp (arg, "used", 4) == 0 || strncmp (arg, "-used", 5) == 0)
+ {
+ char *p = (char *)arg + (*(char *)arg == '-') + 4;
+ flag_debug_only_used_symbols = 1;
+ if (*p == '-')
+ ++p;
+ g_all_len = p - arg;
+ arg += g_all_len;
+ }
+#endif
+/* APPLE LOCAL end gdb only used symbols ilr */
+
+/* APPLE LOCAL begin Symbol Separation */
+ if (strncmp (arg, "repository", 10) == 0 || strncmp (arg, "-repository", 11) == 0)
+ {
+ char *p = (char *)arg + (*(char *)arg == '-') + 10;
+ flag_grepository = 1;
+ if (*p == '-')
+ ++p;
+ g_all_len = p - arg;
+ arg += g_all_len;
+ }
+/* APPLE LOCAL end Symbol Separation */
+
if (type == NO_DEBUG)
{
if (write_symbols == NO_DEBUG)
@@ -1738,6 +2363,12 @@ set_debug_level (enum debug_info_type type, int extended, const char *arg)
#elif defined DBX_DEBUGGING_INFO
write_symbols = DBX_DEBUG;
#endif
+/* APPLE LOCAL begin dwarf */
+/* Even though DWARF2_DEBUGGING_INFO is defined, use stabs for
+ debugging symbols with -ggdb. Remove this local patch when we
+ switch to dwarf. */
+ write_symbols = DBX_DEBUG;
+/* APPLE LOCAL end dwarf */
}
if (write_symbols == NO_DEBUG)
@@ -1768,6 +2399,10 @@ set_debug_level (enum debug_info_type type, int extended, const char *arg)
else if (debug_info_level > 3)
error ("debug output level %s is too high", arg);
}
+
+ /* APPLE LOCAL Symbol Separation */
+ /* Save original value */
+ orig_write_symbols = write_symbols;
}
/* Output --help text. */
diff --git a/gcc/output.h b/gcc/output.h
index 3138ed2a99d..4fda6d57b54 100644
--- a/gcc/output.h
+++ b/gcc/output.h
@@ -157,6 +157,11 @@ extern int regno_clobbered_at_setjmp (int);
/* Tell assembler to switch to text section. */
extern void text_section (void);
+/* APPLE LOCAL begin hot/cold partitioning */
+/* Tell assembler to switch to unlikely-to-be-executed text section. */
+extern void unlikely_text_section (void);
+/* APPLE LOCAL end hot/cold partitioning */
+
/* Tell assembler to switch to data section. */
extern void data_section (void);
@@ -167,6 +172,11 @@ extern void readonly_data_section (void);
/* Determine if we're in the text section. */
extern int in_text_section (void);
+/* APPLE LOCAL begin hot/cold partitioning */
+/* Determine if we're in the unlikely-to-be-executed text section. */
+extern int in_unlikely_text_section (void);
+/* APPLE LOCAL end hot/cold partitioning */
+
#ifdef CTORS_SECTION_ASM_OP
extern void ctors_section (void);
#endif
@@ -516,4 +526,8 @@ extern bool default_valid_pointer_mode (enum machine_mode);
extern int default_address_cost (rtx);
+/* APPLE LOCAL begin coalescing */
+extern int darwin_named_section_is (const char* name);
+/* APPLE LOCAL end coalescing */
+
#endif /* ! GCC_OUTPUT_H */
diff --git a/gcc/params.def b/gcc/params.def
index 7bb97b1ab4a..5ef8ebcd439 100644
--- a/gcc/params.def
+++ b/gcc/params.def
@@ -297,8 +297,10 @@ DEFPARAM(PARAM_MAX_CSELIB_MEMORY_LOCATIONS,
# define GGC_MIN_EXPAND_DEFAULT 0
# define GGC_MIN_HEAPSIZE_DEFAULT 0
#else
-# define GGC_MIN_EXPAND_DEFAULT 30
-# define GGC_MIN_HEAPSIZE_DEFAULT 4096
+/* APPLE LOCAL begin try to improve ggc */
+# define GGC_MIN_EXPAND_DEFAULT 100
+# define GGC_MIN_HEAPSIZE_DEFAULT 8192
+/* APPLE LOCAL end try to improve ggc*/
#endif
DEFPARAM(GGC_MIN_EXPAND,
@@ -325,6 +327,16 @@ DEFPARAM(PARAM_MAX_ALIASED_VOPS,
"The maximum number of virtual operands allowed to represent aliases before triggering alias grouping.",
500)
+DEFPARAM(PARAM_MAX_SCHED_REGION_BLOCKS,
+ "max-sched-region-blocks",
+ "The maximum number of blocks in a region to be considered for interblock scheduling",
+ 10)
+
+DEFPARAM(PARAM_MAX_SCHED_REGION_INSNS,
+ "max-sched-region-insns",
+ "The maximum number of insns in a region to be considered for interblock scheduling",
+ 100)
+
/*
Local variables:
mode:c
diff --git a/gcc/passes.c b/gcc/passes.c
index e504fa2943a..db1bacb2431 100644
--- a/gcc/passes.c
+++ b/gcc/passes.c
@@ -523,7 +523,9 @@ rest_of_handle_stack_regs (tree decl, rtx insns)
{
if (cleanup_cfg (CLEANUP_EXPENSIVE | CLEANUP_POST_REGSTACK
| (flag_crossjumping ? CLEANUP_CROSSJUMP : 0))
- && flag_reorder_blocks)
+ /* APPLE LOCAL begin hot/cold partitioning */
+ && (flag_reorder_blocks || flag_reorder_blocks_and_partition))
+ /* APPLE LOCAL end hot/cold partitioning */
{
reorder_basic_blocks ();
cleanup_cfg (CLEANUP_EXPENSIVE | CLEANUP_POST_REGSTACK);
@@ -719,13 +721,15 @@ rest_of_handle_reorder_blocks (tree decl, rtx insns)
if (flag_sched2_use_traces && flag_schedule_insns_after_reload)
tracer ();
- if (flag_reorder_blocks)
+ /* APPLE LOCAL begin hot/cold partitioning */
+ if (flag_reorder_blocks || flag_reorder_blocks_and_partition)
reorder_basic_blocks ();
- if (flag_reorder_blocks
+ if (flag_reorder_blocks || flag_reorder_blocks_and_partition
|| (flag_sched2_use_traces && flag_schedule_insns_after_reload))
changed |= cleanup_cfg (CLEANUP_EXPENSIVE
| (!HAVE_conditional_execution
? CLEANUP_UPDATE_LIFE : 0));
+ /* APPLE LOCAL end hot/cold partitioning */
/* On conditional execution targets we can not update the life cheaply, so
we deffer the updating to after both cleanups. This may lose some cases
@@ -1275,7 +1279,7 @@ rest_of_handle_loop_optimize (tree decl, rtx insns)
reg_scan (insns, max_reg_num (), 1);
}
cleanup_barriers ();
- loop_optimize (insns, dump_file, do_unroll | LOOP_BCT | do_prefetch);
+ loop_optimize (insns, dump_file, do_unroll | do_prefetch);
/* Loop can create trivially dead instructions. */
delete_trivially_dead_insns (insns, max_reg_num ());
@@ -1295,6 +1299,12 @@ rest_of_handle_loop2 (tree decl, rtx insns)
struct loops *loops;
basic_block bb;
+ if (!flag_unswitch_loops
+ && !flag_peel_loops
+ && !flag_unroll_loops
+ && !flag_branch_on_count_reg)
+ return;
+
timevar_push (TV_LOOP);
open_dump_file (DFI_loop2, decl);
if (dump_file)
@@ -1317,6 +1327,11 @@ rest_of_handle_loop2 (tree decl, rtx insns)
(flag_unroll_loops ? UAP_UNROLL : 0) |
(flag_unroll_all_loops ? UAP_UNROLL_ALL : 0));
+#ifdef HAVE_doloop_end
+ if (flag_branch_on_count_reg && HAVE_doloop_end)
+ doloop_optimize_loops (loops);
+#endif /* HAVE_doloop_end */
+
loop_optimizer_finalize (loops, dump_file);
}
@@ -1594,10 +1609,7 @@ rest_of_compilation (tree decl)
if (flag_tracer)
rest_of_handle_tracer (decl, insns);
- if (optimize > 0
- && (flag_unswitch_loops
- || flag_peel_loops
- || flag_unroll_loops))
+ if (optimize > 0)
rest_of_handle_loop2 (decl, insns);
if (flag_web)
@@ -1616,6 +1628,22 @@ rest_of_compilation (tree decl)
if (flag_if_conversion)
rest_of_handle_if_after_combine (decl, insns);
+ /* APPLE LOCAL begin hot/cold partitioning */
+ /* The optimization to partition hot/cold basic blocks into separate
+ sections of the .o file does not work well with exception handling.
+ Don't call it if there are exceptions. */
+
+ if (flag_reorder_blocks_and_partition)
+ {
+ no_new_pseudos = 0;
+ partition_hot_cold_basic_blocks ();
+ allocate_reg_life_data ();
+ update_life_info (NULL, UPDATE_LIFE_GLOBAL_RM_NOTES,
+ PROP_LOG_LINKS | PROP_REG_INFO | PROP_DEATH_NOTES);
+ no_new_pseudos = 1;
+ }
+ /* APPLE LOCAL end hot/cold partitioning */
+
if (optimize > 0 && (flag_regmove || flag_expensive_optimizations))
rest_of_handle_regmove (decl, insns);
diff --git a/gcc/predict.c b/gcc/predict.c
index 0069274d0f2..223f43a5455 100644
--- a/gcc/predict.c
+++ b/gcc/predict.c
@@ -1578,6 +1578,14 @@ choose_function_section (void)
of all instances. For now just never set frequency for these. */
|| DECL_ONE_ONLY (current_function_decl))
return;
+
+ /* APPLE LOCAL hot/cold partitioning */
+ /* If we are doing the partitioning optimization, let the optimization
+ choose the correct section into which to put things. */
+ if (flag_reorder_blocks_and_partition)
+ return;
+ /* APPLE LOCAL hot/cold partitioning */
+
if (cfun->function_frequency == FUNCTION_FREQUENCY_HOT)
DECL_SECTION_NAME (current_function_decl) =
build_string (strlen (HOT_TEXT_SECTION_NAME), HOT_TEXT_SECTION_NAME);
diff --git a/gcc/print-rtl.c b/gcc/print-rtl.c
index b3f72a5269b..3bf400f5575 100644
--- a/gcc/print-rtl.c
+++ b/gcc/print-rtl.c
@@ -291,6 +291,16 @@ print_rtx (rtx in_rtx)
fprintf (outfile, " [ ERROR ]");
break;
+ /* APPLE LOCAL begin hot/cold partitioning */
+ case NOTE_INSN_UNLIKELY_EXECUTED_CODE:
+ {
+ basic_block bb = NOTE_BASIC_BLOCK (in_rtx);
+ if (bb != 0)
+ fprintf (outfile, " [bb %d]", bb->index);
+ break;
+ }
+ /* APPLE LOCAL end hot/cold partitioning */
+
case NOTE_INSN_VAR_LOCATION:
fprintf (outfile, " (");
print_mem_expr (outfile, NOTE_VAR_LOCATION_DECL (in_rtx));
diff --git a/gcc/print-tree.c b/gcc/print-tree.c
index 259466cebb6..e123ef15945 100644
--- a/gcc/print-tree.c
+++ b/gcc/print-tree.c
@@ -275,6 +275,10 @@ print_node (FILE *file, const char *prefix, tree node, int indent)
fputs (" static", file);
if (TREE_DEPRECATED (node))
fputs (" deprecated", file);
+ /* APPLE LOCAL begin unavailable (Radar 2809697) ilr */
+ if (TREE_UNAVAILABLE (node))
+ fputs (" unavailable", file);
+ /* APPLE LOCAL end unavailable ilr */
if (TREE_VISITED (node))
fputs (" visited", file);
if (TREE_LANG_FLAG_0 (node))
@@ -318,6 +322,10 @@ print_node (FILE *file, const char *prefix, tree node, int indent)
if (DECL_NONLOCAL (node))
fputs (" nonlocal", file);
+ /* APPLE LOCAL coalescing */
+ if (DECL_COALESCED (node))
+ fputs (" coalesced", file);
+
if (TREE_CODE (node) == TYPE_DECL && TYPE_DECL_SUPPRESS_DEBUG (node))
fputs (" suppress-debug", file);
diff --git a/gcc/ra-build.c b/gcc/ra-build.c
index 4f0eac0b166..8c2d1a0f448 100644
--- a/gcc/ra-build.c
+++ b/gcc/ra-build.c
@@ -2301,8 +2301,14 @@ remember_web_was_spilled (struct web *web)
reg_class_contents[reg_alternate_class (web->regno)]);
}
else
+/* APPLE LOCAL */
+#ifdef TARGET_POWERPC
+ COPY_HARD_REG_SET (web->usable_regs,
+ reg_class_contents[(int) NON_SPECIAL_REGS]);
+#else
COPY_HARD_REG_SET (web->usable_regs,
reg_class_contents[(int) GENERAL_REGS]);
+#endif
AND_COMPL_HARD_REG_SET (web->usable_regs, never_use_colors);
prune_hardregs_for_mode (&web->usable_regs, PSEUDO_REGNO_MODE (web->regno));
#ifdef CANNOT_CHANGE_MODE_CLASS
diff --git a/gcc/regrename.c b/gcc/regrename.c
index e15bd87f861..a653966fdb2 100644
--- a/gcc/regrename.c
+++ b/gcc/regrename.c
@@ -1267,6 +1267,14 @@ static bool
mode_change_ok (enum machine_mode orig_mode, enum machine_mode new_mode,
unsigned int regno ATTRIBUTE_UNUSED)
{
+ /* APPLE LOCAL begin add mode change case */
+#ifdef TARGET_POWERPC
+ /* This arises from FLOAT_EXTEND which is really a NOP. */
+ if (orig_mode == SFmode && new_mode == DFmode)
+ return true;
+#endif
+ /* APPLE LOCAL end add mode change case */
+
if (GET_MODE_SIZE (orig_mode) < GET_MODE_SIZE (new_mode))
return false;
@@ -1712,6 +1720,15 @@ copyprop_hardreg_forward_1 (basic_block bb, struct value_data *vd)
/* Notice copies. */
if (set && REG_P (SET_DEST (set)) && REG_P (SET_SRC (set)))
copy_value (SET_DEST (set), SET_SRC (set), vd);
+ /* APPLE LOCAL begin record that float extend is a copy */
+#ifdef TARGET_POWERPC
+ /* FLOAT_EXTEND is actually a copy; record that too. */
+ if (set && REG_P (SET_DEST (set))
+ && GET_CODE (SET_SRC (set)) == FLOAT_EXTEND
+ && REG_P (XEXP (SET_SRC (set), 0)))
+ copy_value (SET_DEST (set), XEXP (SET_SRC (set), 0), vd);
+#endif
+ /* APPLE LOCAL end record that float extend is a copy */
if (insn == BB_END (bb))
break;
diff --git a/gcc/reload.c b/gcc/reload.c
index ae211302efa..2b069a27d18 100644
--- a/gcc/reload.c
+++ b/gcc/reload.c
@@ -1300,18 +1300,31 @@ push_reload (rtx in, rtx out, rtx *inloc, rtx *outloc,
and IN or CLASS and OUT. Get the icode and push any required reloads
needed for each of them if so. */
+ /* APPLE LOCAL restoration of inmode/outmode */
#ifdef SECONDARY_INPUT_RELOAD_CLASS
if (in != 0)
- secondary_in_reload
- = push_secondary_reload (1, in, opnum, optional, class, inmode, type,
- &secondary_in_icode);
+ {
+ secondary_in_reload
+ = push_secondary_reload (1, in, opnum, optional, class, inmode, type,
+ &secondary_in_icode);
+#ifdef TARGET_POWERPC
+ if ( secondary_in_reload != -1 && in_subreg_loc )
+ inmode = GET_MODE (*in_subreg_loc);
+#endif
+ }
#endif
#ifdef SECONDARY_OUTPUT_RELOAD_CLASS
if (out != 0 && GET_CODE (out) != SCRATCH)
- secondary_out_reload
- = push_secondary_reload (0, out, opnum, optional, class, outmode,
- type, &secondary_out_icode);
+ {
+ secondary_out_reload
+ = push_secondary_reload (0, out, opnum, optional, class, outmode,
+ type, &secondary_out_icode);
+#ifdef TARGET_POWERPC
+ if ( secondary_out_reload != -1 && out_subreg_loc )
+ outmode = GET_MODE (*out_subreg_loc);
+#endif
+ }
#endif
/* We found no existing reload suitable for re-use.
@@ -1720,7 +1733,13 @@ combine_reloads (void)
if ((rld[i].when_needed == RELOAD_FOR_OUTPUT_ADDRESS
|| rld[i].when_needed == RELOAD_FOR_OUTADDR_ADDRESS)
&& rld[i].opnum == rld[output_reload].opnum)
+ /* APPLE LOCAL begin try destroyed input */
+#ifdef TARGET_POWERPC
+ goto try_destroyed_input;
+#else
return;
+#endif
+ /* APPLE LOCAL end try destroyed input */
/* Check each input reload; can we combine it? */
@@ -1817,6 +1836,11 @@ combine_reloads (void)
that it does not occur in the output (we already know it isn't an
earlyclobber. If this is an asm insn, give up. */
+ /* APPLE LOCAL begin try destroyed input */
+#ifdef TARGET_POWERPC
+ try_destroyed_input:
+#endif
+ /* APPLE LOCAL end try destroyed input */
if (INSN_CODE (this_insn) == -1)
return;
diff --git a/gcc/rtl.c b/gcc/rtl.c
index 9f545d83623..000c34e9b8e 100644
--- a/gcc/rtl.c
+++ b/gcc/rtl.c
@@ -122,7 +122,9 @@ const char * const note_insn_name[NOTE_INSN_MAX - NOTE_INSN_BIAS] =
"NOTE_INSN_EH_REGION_BEG", "NOTE_INSN_EH_REGION_END",
"NOTE_INSN_REPEATED_LINE_NUMBER",
"NOTE_INSN_BASIC_BLOCK", "NOTE_INSN_EXPECTED_VALUE",
- "NOTE_INSN_PREDICTION", "NOTE_INSN_VAR_LOCATION"
+ "NOTE_INSN_PREDICTION",
+ "NOTE_INSN_UNLIKELY_EXECUTED_CODE",
+ "NOTE_INSN_VAR_LOCATION"
};
const char * const reg_note_name[] =
@@ -134,7 +136,7 @@ const char * const reg_note_name[] =
"REG_VALUE_PROFILE", "REG_NOALIAS", "REG_SAVE_AREA", "REG_BR_PRED",
"REG_FRAME_RELATED_EXPR", "REG_EH_CONTEXT", "REG_EH_REGION",
"REG_SAVE_NOTE", "REG_MAYBE_DEAD", "REG_NORETURN",
- "REG_NON_LOCAL_GOTO", "REG_SETJMP", "REG_ALWAYS_RETURN",
+ "REG_NON_LOCAL_GOTO", "REG_CROSSING_JUMP", "REG_SETJMP", "REG_ALWAYS_RETURN",
"REG_VTABLE_REF"
};
diff --git a/gcc/rtl.h b/gcc/rtl.h
index b6807424495..be3a55eec17 100644
--- a/gcc/rtl.h
+++ b/gcc/rtl.h
@@ -193,6 +193,8 @@ struct rtx_def GTY((chain_next ("RTX_NEXT (&%h)"),
1 in a CALL_INSN if it is a sibling call.
1 in a SET that is for a return.
In a CODE_LABEL, part of the two-bit alternate entry field. */
+ /* APPLE LOCAL weak import
+ SYMBOL_REF_WEAK_IMPORT in a SYMBOL_REF. */
unsigned int jump : 1;
/* In a CODE_LABEL, part of the two-bit alternate entry field.
1 in a MEM if it cannot trap. */
@@ -850,6 +852,13 @@ enum reg_note
computed goto. */
REG_NON_LOCAL_GOTO,
+ /* APPLE LOCAL begin hot/cold partitioning */
+ /* Indicates that a jump crosses between hot and cold sections
+ in a (partitioned) assembly or .o file, and therefore should not be
+ reduced to a simpler jump by optimizations. */
+ REG_CROSSING_JUMP,
+ /* APPLE LOCAL end hot/cold partitioning */
+
/* This kind of note is generated at each to `setjmp',
and similar functions that can return twice. */
REG_SETJMP,
@@ -1011,6 +1020,12 @@ enum insn_note
/* Record a prediction. Uses NOTE_PREDICTION. */
NOTE_INSN_PREDICTION,
+ /* APPLE LOCAL begin hot/cold partitioning */
+ /* Record that the current basic block is unlikely to be executed and
+ should be moved to the UNLIKELY_EXECUTED_TEXT_SECTION. */
+ NOTE_INSN_UNLIKELY_EXECUTED_CODE,
+ /* APPLE LOCAL end hot/cold partitioning */
+
/* The location of a variable. */
NOTE_INSN_VAR_LOCATION,
@@ -1390,6 +1405,12 @@ do { \
#define SYMBOL_REF_WEAK(RTX) \
(RTL_FLAG_CHECK1("SYMBOL_REF_WEAK", (RTX), SYMBOL_REF)->return_val)
+/* APPLE LOCAL begin weak import */
+/* 1 means a SYMBOL_REF is weak import. */
+#define SYMBOL_REF_WEAK_IMPORT(RTX) \
+ (RTL_FLAG_CHECK1("SYMBOL_REF_WEAK", (RTX), SYMBOL_REF)->jump)
+/* APPLE LOCAL end weak import */
+
/* The tree (decl or constant) associated with the symbol, or null. */
#define SYMBOL_REF_DECL(RTX) X0TREE ((RTX), 2)
@@ -1639,6 +1660,9 @@ extern rtx simplify_subtraction (rtx);
/* In function.c */
extern rtx assign_stack_local (enum machine_mode, HOST_WIDE_INT, int);
+/* APPLE LOCAL next declaration */
+extern rtx assign_stack_local_with_alias (enum machine_mode,
+ HOST_WIDE_INT, int);
extern rtx assign_stack_temp (enum machine_mode, HOST_WIDE_INT, int);
extern rtx assign_stack_temp_for_type (enum machine_mode,
HOST_WIDE_INT, int, tree);
diff --git a/gcc/sched-rgn.c b/gcc/sched-rgn.c
index 673416fca07..eded4fea151 100644
--- a/gcc/sched-rgn.c
+++ b/gcc/sched-rgn.c
@@ -63,6 +63,7 @@ Software Foundation, 59 Temple Place - Suite 330, Boston, MA
#include "toplev.h"
#include "recog.h"
#include "cfglayout.h"
+#include "params.h"
#include "sched-int.h"
#include "target.h"
@@ -83,9 +84,6 @@ Software Foundation, 59 Temple Place - Suite 330, Boston, MA
#define FED_BY_SPEC_LOAD(insn) (h_i_d[INSN_UID (insn)].fed_by_spec_load)
#define IS_LOAD_INSN(insn) (h_i_d[INSN_UID (insn)].is_load_insn)
-#define MAX_RGN_BLOCKS 10
-#define MAX_RGN_INSNS 100
-
/* nr_inter/spec counts interblock/speculative motion for the function. */
static int nr_inter, nr_spec;
@@ -156,7 +154,7 @@ static int *containing_rgn;
void debug_regions (void);
static void find_single_block_region (void);
static void find_rgns (struct edge_list *);
-static int too_large (int, int *, int *);
+static bool too_large (int, int *, int *);
extern void debug_live (int, int);
@@ -551,19 +549,18 @@ find_single_block_region (void)
}
/* Update number of blocks and the estimate for number of insns
- in the region. Return 1 if the region is "too large" for interblock
- scheduling (compile time considerations), otherwise return 0. */
+ in the region. Return true if the region is "too large" for interblock
+ scheduling (compile time considerations). */
-static int
+static bool
too_large (int block, int *num_bbs, int *num_insns)
{
(*num_bbs)++;
- (*num_insns) += (INSN_LUID (BB_END (BASIC_BLOCK (block))) -
- INSN_LUID (BB_HEAD (BASIC_BLOCK (block))));
- if ((*num_bbs > MAX_RGN_BLOCKS) || (*num_insns > MAX_RGN_INSNS))
- return 1;
- else
- return 0;
+ (*num_insns) += (INSN_LUID (BB_END (BASIC_BLOCK (block)))
+ - INSN_LUID (BB_HEAD (BASIC_BLOCK (block))));
+
+ return ((*num_bbs > PARAM_VALUE (PARAM_MAX_SCHED_REGION_BLOCKS))
+ || (*num_insns > PARAM_VALUE (PARAM_MAX_SCHED_REGION_INSNS)));
}
/* Update_loop_relations(blk, hdr): Check if the loop headed by max_hdr[blk]
diff --git a/gcc/simplify-rtx.c b/gcc/simplify-rtx.c
index 2ade695b980..f880b461f26 100644
--- a/gcc/simplify-rtx.c
+++ b/gcc/simplify-rtx.c
@@ -1572,7 +1572,11 @@ simplify_binary_operation (enum rtx_code code, enum machine_mode mode,
return simplify_gen_unary (NEG, mode, op1, mode);
/* (-1 - a) is ~a. */
- if (trueop0 == constm1_rtx)
+ /* APPLE LOCAL disallow (not (SYM))
+ But not when a is relocatable (this arises temporarily when
+ pulling 386 global addresses out of a loop). */
+ if (trueop0 == constm1_rtx
+ && GET_CODE (op1) != SYMBOL_REF )
return simplify_gen_unary (NOT, mode, op1, mode);
/* Subtracting 0 has no effect unless the mode has signed zeros
diff --git a/gcc/stor-layout.c b/gcc/stor-layout.c
index 95e7988c678..43904839213 100644
--- a/gcc/stor-layout.c
+++ b/gcc/stor-layout.c
@@ -80,6 +80,15 @@ int immediate_size_expand;
/* Show that REFERENCE_TYPES are internal and should be Pmode. Called only
by front end. */
+/* APPLE LOCAL begin Macintosh alignment 2002-5-24 ff */
+/* Keep track of whether we are laying out the first declared member
+ of a C++ class. We need this flag to handle the case of classes
+ with v-tables where the test to see if the offset in the record
+ is zero is not sufficient to determine if we are dealing with the
+ first declared member. */
+int darwin_align_is_first_member_of_class = 0;
+/* APPLE LOCAL end Macintosh alignment 2002-5-24 ff */
+
void
internal_reference_types (void)
{
@@ -459,6 +468,12 @@ layout_decl (tree decl, unsigned int known_align)
|| DECL_SIZE_UNIT (decl) == 0
|| TREE_CODE (DECL_SIZE_UNIT (decl)) == INTEGER_CST))
DECL_ALIGN (decl) = MIN (DECL_ALIGN (decl), BITS_PER_UNIT);
+/* APPLE LOCAL begin Macintosh alignment 2002-2-12 ff */
+#ifdef PEG_ALIGN_FOR_MAC68K
+ else if (TARGET_ALIGN_MAC68K)
+ DECL_ALIGN (decl) = PEG_ALIGN_FOR_MAC68K (DECL_ALIGN (decl));
+#endif
+/* APPLE LOCAL end Macintosh alignment 2002-2-12 ff */
/* Should this be controlled by DECL_USER_ALIGN, too? */
if (maximum_field_alignment != 0)
@@ -473,7 +488,10 @@ layout_decl (tree decl, unsigned int known_align)
= MIN (DECL_ALIGN (decl), (unsigned) BIGGEST_FIELD_ALIGNMENT);
#endif
#ifdef ADJUST_FIELD_ALIGN
- DECL_ALIGN (decl) = ADJUST_FIELD_ALIGN (decl, DECL_ALIGN (decl));
+ /* APPLE LOCAL begin Macintosh alignment 2002-5-24 ff */
+ DECL_ALIGN (decl) = ADJUST_FIELD_ALIGN (decl, DECL_ALIGN (decl),
+ known_align == 0);
+ /* APPLE LOCAL end Macintosh alignment 2002-5-24 ff */
#endif
}
}
@@ -690,6 +708,19 @@ update_alignment_for_field (record_layout_info rli, tree field,
&& DECL_BIT_FIELD_TYPE (field)
&& ! integer_zerop (TYPE_SIZE (type)));
+#ifdef ADJUST_FIELD_ALIGN
+ if (! user_align)
+ /* APPLE LOCAL begin Macintosh alignment 2002-5-24 ff */
+ /* The third argument to ADJUST_FIELD_ALIGN indicates whether
+ we are dealing with the first field of the structure. */
+ desired_align =
+ ADJUST_FIELD_ALIGN (field, desired_align,
+ (darwin_align_is_first_member_of_class
+ || (integer_zerop (rli->offset)
+ && integer_zerop (rli->bitpos))));
+ /* APPLE LOCAL end Macintosh alignment 2002-5-24 ff */
+#endif
+
/* Record must have at least as much alignment as any field.
Otherwise, the alignment of the field within the record is
meaningless. */
@@ -726,13 +757,24 @@ update_alignment_for_field (record_layout_info rli, tree field,
#ifdef ADJUST_FIELD_ALIGN
if (! TYPE_USER_ALIGN (type))
- type_align = ADJUST_FIELD_ALIGN (field, type_align);
+ /* APPLE LOCAL begin Macintosh alignment */
+ type_align = ADJUST_FIELD_ALIGN (field, type_align,
+ (darwin_align_is_first_member_of_class
+ || (integer_zerop (rli->offset)
+ && integer_zerop (rli->bitpos))));
+ /* APPLE LOCAL end Macintosh alignment */
#endif
if (maximum_field_alignment != 0)
type_align = MIN (type_align, maximum_field_alignment);
else if (DECL_PACKED (field))
type_align = MIN (type_align, BITS_PER_UNIT);
+/* APPLE LOCAL begin Macintosh alignment 2002-2-12 ff */
+#ifdef PEG_ALIGN_FOR_MAC68K
+ else if (TARGET_ALIGN_MAC68K)
+ type_align = PEG_ALIGN_FOR_MAC68K (type_align);
+#endif
+/* APPLE LOCAL end Macintosh alignment 2002-2-12 ff */
/* The alignment of the record is increased to the maximum
of the current alignment, the alignment indicated on the
@@ -919,6 +961,11 @@ place_field (record_layout_info rli, tree field)
&& DECL_BIT_FIELD (field)
&& ! DECL_PACKED (field)
&& maximum_field_alignment == 0
+/* APPLE LOCAL begin Macintosh alignment 2002-2-12 ff */
+#ifdef PEG_ALIGN_FOR_MAC68K
+ && ! TARGET_ALIGN_MAC68K
+#endif
+/* APPLE LOCAL end Macintosh alignment 2002-2-12 ff */
&& ! integer_zerop (DECL_SIZE (field))
&& host_integerp (DECL_SIZE (field), 1)
&& host_integerp (rli->offset, 1)
@@ -932,7 +979,12 @@ place_field (record_layout_info rli, tree field)
#ifdef ADJUST_FIELD_ALIGN
if (! TYPE_USER_ALIGN (type))
- type_align = ADJUST_FIELD_ALIGN (field, type_align);
+ /* APPLE LOCAL begin Macintosh alignment */
+ type_align = ADJUST_FIELD_ALIGN (field, type_align,
+ (darwin_align_is_first_member_of_class
+ || (integer_zerop (rli->offset)
+ && integer_zerop (rli->bitpos))));
+ /* APPLE LOCAL end Macintosh alignment */
#endif
/* A bit field may not span more units of alignment of its type
@@ -964,7 +1016,12 @@ place_field (record_layout_info rli, tree field)
#ifdef ADJUST_FIELD_ALIGN
if (! TYPE_USER_ALIGN (type))
- type_align = ADJUST_FIELD_ALIGN (field, type_align);
+ /* APPLE LOCAL begin Macintosh alignment */
+ type_align = ADJUST_FIELD_ALIGN (field, type_align,
+ (darwin_align_is_first_member_of_class
+ || (integer_zerop (rli->offset)
+ && integer_zerop (rli->bitpos))));
+ /* APPLE LOCAL end Macintosh alignment */
#endif
if (maximum_field_alignment != 0)
@@ -973,6 +1030,12 @@ place_field (record_layout_info rli, tree field)
statement, so this code is unreachable currently. */
else if (DECL_PACKED (field))
type_align = MIN (type_align, BITS_PER_UNIT);
+/* APPLE LOCAL begin Macintosh alignment 2002-2-12 ff */
+#ifdef PEG_ALIGN_FOR_MAC68K
+ else if (TARGET_ALIGN_MAC68K)
+ type_align = PEG_ALIGN_FOR_MAC68K (type_align);
+#endif
+/* APPLE LOCAL end Macintosh alignment 2002-2-12 ff */
/* A bit field may not span the unit of alignment of its type.
Advance to next boundary if necessary. */
@@ -1327,6 +1390,16 @@ compute_record_mode (tree type)
RECORD_TYPE. This does not apply to unions. */
if (TREE_CODE (type) == RECORD_TYPE && mode != VOIDmode)
TYPE_MODE (type) = mode;
+ /* APPLE LOCAL 8-byte-struct hack */
+#if defined RS6000_VARARGS_AREA
+ /* Make 8-byte structs BLKmode instead of DImode, which fixes both
+ struct-return methods and attempts to use floats in kernel code.
+ This should probably become a generic macro similar to
+ MEMBER_TYPE_FORCES_BLK above. */
+ else if (mode_for_size_tree (TYPE_SIZE (type), MODE_INT, 1) == DImode
+ && flag_pic)
+ ;
+#endif
else
TYPE_MODE (type) = mode_for_size_tree (TYPE_SIZE (type), MODE_INT, 1);
diff --git a/gcc/stringpool.c b/gcc/stringpool.c
index 0cf3be14f88..d7b25e1492c 100644
--- a/gcc/stringpool.c
+++ b/gcc/stringpool.c
@@ -122,6 +122,7 @@ get_identifier_with_length (const char *text, size_t length)
return HT_IDENT_TO_GCC_IDENT (ht_node);
}
+
/* If an identifier with the name TEXT (a null-terminated string) has
previously been referred to, return that node; otherwise return
NULL_TREE. */
diff --git a/gcc/target-def.h b/gcc/target-def.h
index 89af47e12ee..5e5deac9375 100644
--- a/gcc/target-def.h
+++ b/gcc/target-def.h
@@ -305,6 +305,7 @@ Foundation, 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
#define TARGET_FUNCTION_ATTRIBUTE_INLINABLE_P hook_bool_tree_false
#define TARGET_MS_BITFIELD_LAYOUT_P hook_bool_tree_false
#define TARGET_RTX_COSTS hook_bool_rtx_int_int_intp_false
+#define TARGET_MANGLE_FUNDAMENTAL_TYPE hook_constcharptr_tree_null
#ifndef TARGET_INIT_LIBFUNCS
#define TARGET_INIT_LIBFUNCS hook_void_void
@@ -318,6 +319,11 @@ Foundation, 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
#define TARGET_ENCODE_SECTION_INFO default_encode_section_info
#endif
+/* APPLE LOCAL begin AltiVec */
+#define TARGET_EXPAND_MACRO_P hook_bool_constcpp_tokenp_false
+#define TARGET_CAST_EXPR_AS_VECTOR_INIT false
+/* APPLE LOCAL end AltiVec */
+
#define TARGET_FIXED_CONDITION_CODE_REGS hook_bool_uintp_uintp_false
#define TARGET_CC_MODES_COMPATIBLE default_cc_modes_compatible
@@ -376,6 +382,7 @@ Foundation, 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
TARGET_MS_BITFIELD_LAYOUT_P, \
TARGET_INIT_BUILTINS, \
TARGET_EXPAND_BUILTIN, \
+ TARGET_MANGLE_FUNDAMENTAL_TYPE, \
TARGET_INIT_LIBFUNCS, \
TARGET_SECTION_TYPE_FLAGS, \
TARGET_CANNOT_MODIFY_JUMPS_P, \
@@ -410,6 +417,10 @@ Foundation, 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
TARGET_TERMINATE_DW2_EH_FRAME_INFO, \
TARGET_ASM_FILE_START_APP_OFF, \
TARGET_ASM_FILE_START_FILE_DIRECTIVE, \
+ /* APPLE LOCAL begin AltiVec */ \
+ TARGET_EXPAND_MACRO_P, \
+ TARGET_CAST_EXPR_AS_VECTOR_INIT, \
+ /* APPLE LOCAL end AltiVec */ \
TARGET_CALLS, \
}
diff --git a/gcc/target.h b/gcc/target.h
index 2387e4dd38a..ee45a5b5756 100644
--- a/gcc/target.h
+++ b/gcc/target.h
@@ -308,6 +308,11 @@ struct gcc_target
rtx (* expand_builtin) (tree exp, rtx target, rtx subtarget,
enum machine_mode mode, int ignore);
+ /* For a vendor-specific fundamental TYPE, return a pointer to
+ a statically-allocated string containing the C++ mangling for
+ TYPE. In all other cases, return NULL. */
+ const char * (* mangle_fundamental_type) (tree type);
+
/* Make any adjustments to libfunc names needed for this target. */
void (* init_libfuncs) (void);
@@ -455,6 +460,20 @@ struct gcc_target
at the beginning of assembly output. */
bool file_start_file_directive;
+ /* APPLE LOCAL begin AltiVec */
+ /* Return true if we should expand a disabled (conditional) macro. */
+ bool (* expand_macro_p) (const struct cpp_token *);
+
+ /* True if it is permissible to use cast expressions as
+ vector initializers, e.g.:
+
+ (vector unsigned int)(3, 4, 5, 6)
+ (vector float)(2.5)
+
+ This is required for the Motorola AltiVec syntax on the PowerPC. */
+ bool cast_expr_as_vector_init;
+ /* APPLE LOCAL end AltiVec */
+
/* Functions relating to calls - argument passing, returns, etc. */
struct calls {
bool (*promote_function_args) (tree fntype);
diff --git a/gcc/testsuite/UNTESTABLE b/gcc/testsuite/UNTESTABLE
new file mode 100644
index 00000000000..aa6053a4372
--- /dev/null
+++ b/gcc/testsuite/UNTESTABLE
@@ -0,0 +1,57 @@
+APPLE LOCAL file testsuite
+
+This file lists the markers for local changes that are by their nature
+not testable, such as source code tweaks that don't directly affect
+compiler behavior. Every other local change must have at least one
+test case.
+
+Note that if a local change fixes a bug that is exposed by an existing
+test, then by definition the local change should go into FSF GCC
+instead of being listed here.
+
+APPLE LOCAL MW compatibility
+APPLE LOCAL Mach time
+APPLE LOCAL OS pragma hook
+APPLE LOCAL RTX_COST for multiply
+APPLE LOCAL Stripped encodings ('!T_' and '!t_') should match.
+APPLE LOCAL branch cost
+APPLE LOCAL code size reduction / performance enhancement
+APPLE LOCAL combine hoisted consts
+APPLE LOCAL compare >= 0, not > 0.
+APPLE LOCAL darwin host
+APPLE LOCAL darwin mmap bug workaround
+APPLE LOCAL darwin_set_section_for_var_p
+APPLE LOCAL debugging
+APPLE LOCAL default to ppro
+APPLE LOCAL do not extern fp save/restore
+APPLE LOCAL don't define SAVE_FP_PREFIX and friends
+APPLE LOCAL fat builds readability
+APPLE LOCAL finish file hook
+APPLE LOCAL fix prototypes
+APPLE LOCAL fix redundant add?
+APPLE LOCAL flag_objc
+APPLE LOCAL include guard for darwin.h
+APPLE LOCAL interrupt signal handler (radar 2941633)
+APPLE LOCAL keep tables in sync comment
+APPLE LOCAL make easy_vector_constant globally visible (rs6000-protos.h)
+APPLE LOCAL manual
+APPLE LOCAL more orphaned code
+APPLE LOCAL move is_class_name to stub-objc.c
+APPLE LOCAL move lookup_interface to stub-objc.c
+APPLE LOCAL move lookup_objc_ivar to stub-objc.c
+APPLE LOCAL multiply cost pulled into function
+APPLE LOCAL objc finish file
+APPLE LOCAL order files
+APPLE LOCAL parsedir
+APPLE LOCAL prototypes
+APPLE LOCAL prune man page
+APPLE LOCAL reduce code size
+APPLE LOCAL remove a stub tweak
+APPLE LOCAL remove machopic_output_possible_stub_label
+APPLE LOCAL rename for HFS
+APPLE LOCAL separate outputdir
+APPLE LOCAL setrlimit
+APPLE LOCAL time formatting
+APPLE LOCAL try to improve ggc
+APPLE LOCAL work around a makeinfo complaint
+APPLE LOCAL cp_binding_level
diff --git a/gcc/testsuite/ada/acats/support/f340a000.a b/gcc/testsuite/ada/acats/support/f340a000.a
deleted file mode 100644
index a3daf96b551..00000000000
--- a/gcc/testsuite/ada/acats/support/f340a000.a
+++ /dev/null
@@ -1,149 +0,0 @@
--- F340A000.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- FOUNDATION DESCRIPTION:
--- This file simulates a generic linked list abstraction for use in tests
--- covering tagged types and type extensions.
---
--- TEST FILES:
--- This foundation consists of the following files:
---
--- => F340A000.A
--- F340A001.A
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 12 Jun 96 SAIC ACVC 2.1: Modified prologue. Added pragma
--- Elaborate_Body.
---
---!
-
-generic -- Singly-linked list abstraction.
- type Parent_Type is tagged private; -- Actual is parent
-package F340A000 is -- tagged type.
-
- pragma Elaborate_Body;
-
-
- -- Declarations for visible linked list nodes:
-
- type Node_Type;
-
- type Node_Ptr is access Node_Type;
-
- type Node_Type is new Parent_Type with record -- Record extension
- Next : Node_Ptr := null; -- of parent type.
- end record;
-
-
- -- Inherits primitive operations of actual type corresponding
- -- to Parent_Type.
-
- -- Add node at head of list.
- procedure Add (Item : in Node_Ptr;
- Head : in out Node_Ptr);
-
- -- Remove node from head of list and return it.
- procedure Remove (Head : in out Node_Ptr;
- Item : out Node_Ptr);
-
-
-
- -- Declarations for private linked list nodes:
-
- type Priv_Node_Type is new Parent_Type with private; -- Private extension
- -- of parent type.
-
- -- Inherits primitive operations of actual parameter corresponding
- -- to Parent_Type.
-
-
- type Priv_Node_Ptr is access Priv_Node_Type;
-
-
- -- Add node at head of list.
- procedure Add (Item : in Priv_Node_Ptr;
- Head : in out Priv_Node_Ptr);
-
- -- Remove node from head of list and return it.
- procedure Remove (Head : in out Priv_Node_Ptr;
- Item : out Priv_Node_Ptr);
-
-
-private
-
- type Priv_Node_Type is new Parent_Type with record
- Next : Priv_Node_Ptr := null;
- end record;
-
-end F340A000;
-
-
- --==================================================================--
-
-
-package body F340A000 is -- Singly-linked list abstraction.
-
- procedure Add (Item : in Node_Ptr;
- Head : in out Node_Ptr) is
- begin
- if Item /= null then
- Item.Next := Head;
- Head := Item;
- end if;
- end Add;
-
-
- procedure Remove (Head : in out Node_Ptr;
- Item : out Node_Ptr) is
- begin
- Item := Head;
- if Head /= null then
- Head := Head.Next;
- end if;
- end Remove;
-
-
- procedure Add (Item : in Priv_Node_Ptr;
- Head : in out Priv_Node_Ptr) is
- begin
- if Item /= null then
- Item.Next := Head;
- Head := Item;
- end if;
- end Add;
-
-
- procedure Remove (Head : in out Priv_Node_Ptr;
- Item : out Priv_Node_Ptr) is
- begin
- Item := Head;
- if Head /= null then
- Head := Head.Next;
- end if;
- end Remove;
-
-
-end F340A000;
diff --git a/gcc/testsuite/ada/acats/support/f340a001.a b/gcc/testsuite/ada/acats/support/f340a001.a
deleted file mode 100644
index 3fe027e59f2..00000000000
--- a/gcc/testsuite/ada/acats/support/f340a001.a
+++ /dev/null
@@ -1,75 +0,0 @@
--- F340A001.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- FOUNDATION DESCRIPTION:
--- This file declares a tagged type and primitive subprogram for use in
--- tests covering tagged types and type extensions.
---
--- TEST FILES:
--- The following files comprise this foundation:
---
--- F340A000.A
--- => F340A001.A
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
---
---!
-
-package F340A001 is -- Book definitions.
-
-
- type Text_Ptr is access String;
-
- type Book_Type is tagged record -- Root tagged type.
- Title : Text_Ptr;
- Author : Text_Ptr;
- end record;
-
-
- procedure Create_Book (Title : in Text_Ptr; -- Primitive operation
- Author : in Text_Ptr; -- of root tagged type.
- Book : out Book_Type);
-
-
-end F340A001;
-
-
- --==================================================================--
-
-
-package body F340A001 is -- Book definitions.
-
-
- procedure Create_Book (Title : in Text_Ptr;
- Author : in Text_Ptr;
- Book : out Book_Type) is
- begin
- Book.Title := Title;
- Book.Author := Author;
- end Create_Book;
-
-
-end F340A001;
diff --git a/gcc/testsuite/ada/acats/support/f341a00.a b/gcc/testsuite/ada/acats/support/f341a00.a
deleted file mode 100644
index b2e389f737b..00000000000
--- a/gcc/testsuite/ada/acats/support/f341a00.a
+++ /dev/null
@@ -1,216 +0,0 @@
--- F341A00.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- FOUNDATION DESCRIPTION:
--- This foundation provides a simple class hierarchy (a root type and two
--- levels of derivation from it) to use in testing the basic OO features
--- related to tagged types.
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
---
---!
-
-package F341A00_0 is -- package Bank
-
- type Dollar_Amount is new Float;
-
- type Account is tagged
- record
- Current_Balance: Dollar_Amount;
- end record;
-
- -- Primitive operations.
-
- procedure Deposit (A : in out Account;
- X : in Dollar_Amount);
- procedure Withdrawal (A : in out Account;
- X : in Dollar_Amount);
- function Balance (A : in Account) return Dollar_Amount;
- procedure Service_Charge (A : in out Account);
- procedure Add_Interest (A : in out Account);
- procedure Open (A : in out Account);
-
-end F341A00_0;
-
-
- --=================================================================--
-
-
-package body F341A00_0 is
-
- -- Primitive operations for type Account.
-
- procedure Deposit (A : in out Account;
- X : in Dollar_Amount) is
- begin
- A.Current_Balance := A.Current_Balance + X;
- end Deposit;
-
- --
-
- procedure Withdrawal (A : in out Account;
- X : in Dollar_Amount) is
- begin
- A.Current_Balance := A.Current_Balance - X;
- end Withdrawal;
-
- --
-
- function Balance (A : in Account) return Dollar_Amount is
- begin
- return (A.Current_Balance);
- end Balance;
-
- --
-
- procedure Service_Charge (A : in out Account) is
- begin
- A.Current_Balance := A.Current_Balance - 5.00;
- end Service_Charge;
-
- --
-
- procedure Add_Interest (A : in out Account) is
- -- No interest accumulated on this type of account.
- Interest_On_Account : Dollar_Amount := 0.00;
- begin
- A.Current_Balance := A.Current_Balance + Interest_On_Account;
- end Add_Interest;
-
- --
-
- procedure Open (A : in out Account) is
- Initial_Deposit : Dollar_Amount := 10.00;
- begin
- A.Current_Balance := Initial_Deposit;
- end Open;
-
-end F341A00_0;
-
-
- --=================================================================--
-
-
-with F341A00_0;
-
-package F341A00_1 is -- package Checking
-
- package Bank renames F341A00_0;
-
- type Account is new Bank.Account with
- record
- Overdraft_Fee : Bank.Dollar_Amount;
- end record;
-
-
- -- Inherited primitive operations.
- -- procedure Deposit (A : in out Account; X : in Bank.Dollar_Amount);
- -- procedure Withdrawal (A : in out Account; X : in Bank.Dollar_Amount);
- -- function Balance (A : in Account) return Bank.Dollar_Amount;
- -- procedure Service_Charge(A : in out Account);
- -- procedure Add_Interest (A : in out Account);
-
- -- Overridden primitive operation.
- procedure Open (A : in out Account);
-
-end F341A00_1;
-
-
- --=================================================================--
-
-
-package body F341A00_1 is
-
- -- Overridden primitive operation.
-
- procedure Open (A : in out Account) is
- Check_Guarantee : Bank.Dollar_Amount := 10.00;
- Initial_Deposit : Bank.Dollar_Amount := 100.00;
- begin
- A.Current_Balance := Initial_Deposit;
- A.Overdraft_Fee := Check_Guarantee;
- end Open;
-
-end F341A00_1;
-
-
- --=================================================================--
-
-
-with F341A00_0; -- package Bank
-with F341A00_1; -- package Checking
-
-package F341A00_2 is -- package Interest_Checking
-
- package Bank renames F341A00_0;
- package Checking renames F341A00_1;
-
- subtype Interest_Rate is Bank.Dollar_Amount digits 4;
-
- Current_Rate : Interest_Rate := 0.030;
-
- type Account is new Checking.Account with
- record
- Rate : Interest_Rate;
- end record;
-
- -- "Twice" inherited primitive operations (Bank.Account, Checking.Account)
- -- procedure Deposit (A : in out Account; X : in Bank.Dollar_Amount);
- -- procedure Withdrawal (A : in out Account; X : in Bank.Dollar_Amount);
- -- function Balance (A : in Account) return Bank.Dollar_Amount;
- -- procedure Service_Charge(A : in out Account);
-
- -- Overridden primitive operations.
- procedure Add_Interest (A : in out Account);
- procedure Open (A : in out Account);
-
-end F341A00_2;
-
-
- --=================================================================--
-
-
-package body F341A00_2 is
-
- -- Overridden primitive operations.
-
- procedure Add_Interest (A : in out Account) is
- use type Bank.Dollar_Amount;
- Interest_On_Account : Bank.Dollar_Amount
- := Bank.Dollar_Amount(A.Current_Balance * A.Rate);
- begin
- A.Current_Balance := A.Current_Balance + Interest_On_Account;
- end Add_Interest;
-
- procedure Open (A : in out Account) is
- Initial_Deposit : Bank.Dollar_Amount := 1000.00;
- begin
- Checking.Open (Checking.Account (A));
- A.Current_Balance := Initial_Deposit;
- A.Rate := Current_Rate;
- end Open;
-
-end F341A00_2;
diff --git a/gcc/testsuite/ada/acats/support/f390a00.a b/gcc/testsuite/ada/acats/support/f390a00.a
deleted file mode 100644
index 0230812e61f..00000000000
--- a/gcc/testsuite/ada/acats/support/f390a00.a
+++ /dev/null
@@ -1,94 +0,0 @@
--- F390A00.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- FOUNDATION DESCRIPTION:
--- This file declares the root type and primitive subprograms of an
--- alert system abstraction, to be used for tests covering tagged
--- types and type extensions.
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 04 Jun 96 SAIC ACVC 2.1: Added pragma Elaborate for Ada.Calendar.
---
---!
-
-with Ada.Calendar;
-pragma Elaborate (Ada.Calendar);
-
-package F390A00 is -- Alert system abstraction.
-
-
- -- Declarations used by component Display_On and procedure Display.
-
- type Device_Enum is (Null_Device, Teletype, Console, Big_Screen);
- type Display_Counters is array (Device_Enum) of Natural;
-
- Display_Count_For : Display_Counters := (others => 0);
-
-
- -- Declarations used by component Arrival_Time.
-
- Default_Time : constant Ada.Calendar.Time :=
- Ada.Calendar.Time_Of (1901, 1, 1);
- Alert_Time : constant Ada.Calendar.Time :=
- Ada.Calendar.Time_Of (1991, 6, 15);
-
-
-
- type Alert_Type is tagged record -- Root tagged type.
- Arrival_Time : Ada.Calendar.Time := Default_Time;
- Display_On : Device_Enum := Null_Device;
- end record;
-
-
- procedure Display (A : in Alert_Type); -- To be inherited by
- -- all derivatives.
-
- procedure Handle (A : in out Alert_Type); -- To be overridden by
- -- all derivatives.
-
-end F390A00;
-
-
- --==================================================================--
-
-
-package body F390A00 is -- Alert system abstraction.
-
-
- procedure Display (A : in Alert_Type) is
- begin
- Display_Count_For (A.Display_On) := Display_Count_For (A.Display_On) + 1;
- end Display;
-
-
- procedure Handle (A : in out Alert_Type) is
- begin
- A.Arrival_Time := Alert_Time;
- Display (A);
- end Handle;
-
-
-end F390A00;
diff --git a/gcc/testsuite/ada/acats/support/f392a00.a b/gcc/testsuite/ada/acats/support/f392a00.a
deleted file mode 100644
index 2d4f7a55aec..00000000000
--- a/gcc/testsuite/ada/acats/support/f392a00.a
+++ /dev/null
@@ -1,200 +0,0 @@
--- F392A00.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- FOUNDATION DESCRIPTION:
--- This foundation provides a basis for tests needing a hierarchy of
--- types to check object-oriented features.
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
---
---!
-
-package F392A00 is -- package Accounts
-
- --
- -- Types and subtypes.
- --
-
- type Dollar_Amount is new Float;
- type Interest_Rate is delta 0.001 range 0.000 .. 1.000;
- type Account_Types is (Bank, Savings, Preferred, Total);
- type Account_Counter is array (Account_Types) of Integer;
- type Account_Rep is (President, Manager, New_Account_Manager, Teller);
-
- --
- -- Constants.
- --
-
- Opening_Balance : constant Dollar_Amount := 100.00;
- Current_Rate : constant Interest_Rate := 0.030;
- Preferred_Minimum_Balance : constant Dollar_Amount := 1000.00;
-
- --
- -- Global Variables
- --
-
- Bank_Reserve : Dollar_Amount := 0.00;
- Daily_Representative : Account_Rep := New_Account_Manager;
- Number_Of_Accounts : Account_Counter := (Bank => 0,
- Savings => 0,
- Preferred => 0,
- Total => 0);
- --
- -- Account types and their primitive operations.
- --
-
- -- Root type.
-
- type Bank_Account is tagged
- record
- Balance : Dollar_Amount;
- end record;
-
- -- Primitive operations of Bank_Account.
-
- procedure Increment_Bank_Reserve (Acct : in Bank_Account);
- procedure Assign_Representative (Acct : in Bank_Account);
- procedure Increment_Counters (Acct : in Bank_Account);
- procedure Open (Acct : in out Bank_Account);
-
- --
-
- type Savings_Account is new Bank_Account with
- record
- Rate : Interest_Rate;
- end record;
-
- -- Procedure Increment_Bank_Reserve inherited from parent (Bank_Account).
-
- -- Primitive operations (Overridden).
- procedure Assign_Representative (Acct : in Savings_Account);
- procedure Increment_Counters (Acct : in Savings_Account);
- procedure Open (Acct : in out Savings_Account);
-
- --
-
- type Preferred_Account is new Savings_Account with
- record
- Minimum_Balance : Dollar_Amount;
- end record;
-
- -- Procedure Increment_Bank_Reserve inherited twice.
- -- Procedure Assign_Representative inherited from parent (Savings_Account).
-
- -- Primitive operations (Overridden).
- procedure Increment_Counters (Acct : in Preferred_Account);
- procedure Open (Acct : in out Preferred_Account);
-
- -- Function used to verify Open operation for Preferred_Account objects.
- function Verify_Open (Acct : in Preferred_Account) return Boolean;
-
-
-end F392A00;
-
-
- --=================================================================--
-
-
-package body F392A00 is
-
- --
- -- Primitive operations for Bank_Account.
- --
-
- procedure Increment_Bank_Reserve (Acct : in Bank_Account) is
- begin
- Bank_Reserve := Bank_Reserve + Acct.Balance;
- end Increment_Bank_Reserve;
-
- procedure Assign_Representative (Acct : in Bank_Account) is
- begin
- Daily_Representative := Teller;
- end Assign_Representative;
-
- procedure Increment_Counters (Acct : in Bank_Account) is
- begin
- Number_Of_Accounts (Bank) := Number_Of_Accounts (Bank) + 1;
- Number_Of_Accounts (Total) := Number_Of_Accounts (Total) + 1;
- end Increment_Counters;
-
- procedure Open (Acct : in out Bank_Account) is
- begin
- Acct.Balance := Opening_Balance;
- end Open;
-
-
- --
- -- Overridden operations for Savings_Account type.
- --
-
- procedure Assign_Representative (Acct : in Savings_Account) is
- begin
- Daily_Representative := Manager;
- end Assign_Representative;
-
- procedure Increment_Counters (Acct : in Savings_Account) is
- begin
- Number_Of_Accounts (Savings) := Number_Of_Accounts (Savings) + 1;
- Number_Of_Accounts (Total) := Number_Of_Accounts (Total) + 1;
- end Increment_Counters;
-
- procedure Open (Acct : in out Savings_Account) is
- begin
- Open (Bank_Account(Acct));
- Acct.Rate := Current_Rate;
- Acct.Balance := 2.0 * Opening_Balance;
- end Open;
-
-
- --
- -- Overridden operation for Preferred_Account type.
- --
-
- procedure Increment_Counters (Acct : in Preferred_Account) is
- begin
- Number_Of_Accounts (Preferred) := Number_Of_Accounts (Preferred) + 1;
- Number_Of_Accounts (Total) := Number_Of_Accounts (Total) + 1;
- end Increment_Counters;
-
- procedure Open (Acct : in out Preferred_Account) is
- begin
- Open (Savings_Account(Acct));
- Acct.Minimum_Balance := Preferred_Minimum_Balance;
- Acct.Balance := Acct.Minimum_Balance;
- end Open;
-
- --
- -- Function used to verify Open operation for Preferred_Account objects.
- --
-
- function Verify_Open (Acct : in Preferred_Account) return Boolean is
- begin
- return (Acct.Balance = Preferred_Minimum_Balance and
- Acct.Rate = Current_Rate and
- Acct.Minimum_Balance = Preferred_Minimum_Balance);
- end Verify_Open;
-
-end F392A00;
diff --git a/gcc/testsuite/ada/acats/support/f392c00.a b/gcc/testsuite/ada/acats/support/f392c00.a
deleted file mode 100644
index 8a470e7d4de..00000000000
--- a/gcc/testsuite/ada/acats/support/f392c00.a
+++ /dev/null
@@ -1,267 +0,0 @@
--- F392C00.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- FOUNDATION DESCRIPTION:
--- This foundation provides a basis for tagged type and dispatching
--- tests. Each test describes the utilizations.
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 24 OCT 95 SAIC Updated for ACVC 2.0.1
---
---!
-
-package F392C00_1 is -- Switches
-
- type Toggle is tagged private; ---------------------------------- Toggle
-
- function Create return Toggle;
- procedure Flip ( It : in out Toggle );
- function On ( It : Toggle'Class ) return Boolean;
- function Off ( It : Toggle'Class ) return Boolean;
-
- type Dimmer is new Toggle with private; ------------------------- Dimmer
-
- type Luminance is range 0..100;
-
- function Create return Dimmer;
- procedure Flip ( It : in out Dimmer );
- procedure Brighten( It : in out Dimmer;
- By : in Luminance := 10 );
- procedure Dim ( It : in out Dimmer;
- By : in Luminance := 10 );
- function Intensity( It : Dimmer ) return Luminance;
-
- type Auto_Dimmer is new Dimmer with private; --------------- Auto_Dimmer
-
- function Create return Auto_Dimmer;
- procedure Flip ( It: in out Auto_Dimmer );
- procedure Set_Auto ( It: in out Auto_Dimmer );
- procedure Clear_Auto( It: in out Auto_Dimmer );
- -- procedure Set_Manual( It: in out Auto_Dimmer ) renames Clear_Auto;
- procedure Set_Cutin ( It: in out Auto_Dimmer; Lumens: in Luminance );
- procedure Set_Cutout( It: in out Auto_Dimmer; Lumens: in Luminance );
-
- function Auto ( It: Auto_Dimmer ) return Boolean;
- function Cutout_Threshold( It: Auto_Dimmer ) return Luminance;
- function Cutin_Threshold ( It: Auto_Dimmer ) return Luminance;
-
- function TC_CW_TI( Key : Character ) return Toggle'Class;
-
- function TC_Non_Disp( It: Toggle ) return Boolean;
- function TC_Non_Disp( It: Dimmer ) return Boolean;
- function TC_Non_Disp( It: Auto_Dimmer ) return Boolean;
-
-private
-
- type Toggle is tagged record
- On : Boolean := False;
- end record;
-
- type Dimmer is new Toggle with record
- Intensity : Luminance := 100;
- end record;
-
- type Auto_Dimmer is new Dimmer with record
- Cutout_Threshold : Luminance := 60;
- Cutin_Threshold : Luminance := 40;
- Auto_Engaged : Boolean := False;
- end record;
-
-end F392C00_1;
-
-with TCTouch;
-package body F392C00_1 is
-
- function Create return Toggle is
- begin
- TCTouch.Touch( '1' ); ------------------------------------------------ 1
- return Toggle'( On => True );
- end Create;
-
- function Create return Dimmer is
- begin
- TCTouch.Touch( '2' ); ------------------------------------------------ 2
- return Dimmer'( On => True, Intensity => 75 );
- end Create;
-
- function Create return Auto_Dimmer is
- begin
- TCTouch.Touch( '3' ); ------------------------------------------------ 3
- return Auto_Dimmer'( On => True, Intensity => 25,
- Cutout_Threshold | Cutin_Threshold => 50,
- Auto_Engaged => True );
- end Create;
-
- procedure Flip ( It : in out Toggle ) is
- begin
- TCTouch.Touch( 'A' ); ------------------------------------------------ A
- It.On := not It.On;
- end Flip;
-
- function On( It : Toggle'Class ) return Boolean is
- begin
- TCTouch.Touch( 'B' ); ------------------------------------------------ B
- return It.On;
- end On;
-
- function Off( It : Toggle'Class ) return Boolean is
- begin
- TCTouch.Touch( 'C' ); ------------------------------------------------ C
- return not It.On;
- end Off;
-
- procedure Brighten( It : in out Dimmer;
- By : in Luminance := 10 ) is
- begin
- TCTouch.Touch( 'D' ); ------------------------------------------------ D
- if (It.Intensity+By) <= Luminance'Last then
- It.Intensity := It.Intensity+By;
- else
- It.Intensity := Luminance'Last;
- end if;
- end Brighten;
-
- procedure Dim ( It : in out Dimmer;
- By : in Luminance := 10 ) is
- begin
- TCTouch.Touch( 'E' ); ------------------------------------------------ E
- if (It.Intensity-By) >= Luminance'First then
- It.Intensity := It.Intensity-By;
- else
- It.Intensity := Luminance'First;
- end if;
- end Dim;
-
- function Intensity( It : Dimmer ) return Luminance is
- begin
- TCTouch.Touch( 'F' ); ------------------------------------------------ F
- if On(It) then
- return It.Intensity;
- else
- return Luminance'First;
- end if;
- end Intensity;
-
- procedure Flip ( It : in out Dimmer ) is
- begin
- TCTouch.Touch( 'G' ); ------------------------------------------------ G
- if On( It ) and (It.Intensity < 50) then
- It.Intensity := Luminance'Last - It.Intensity;
- else
- Flip( Toggle( It ) );
- end if;
- end Flip;
-
- procedure Set_Auto ( It: in out Auto_Dimmer ) is
- begin
- TCTouch.Touch( 'H' ); ------------------------------------------------ H
- It.Auto_Engaged := True;
- end Set_Auto;
-
- procedure Clear_Auto( It: in out Auto_Dimmer ) is
- begin
- TCTouch.Touch( 'I' ); ------------------------------------------------ I
- It.Auto_Engaged := False;
- end Clear_Auto;
-
- function Auto ( It: Auto_Dimmer ) return Boolean is
- begin
- TCTouch.Touch( 'J' ); ------------------------------------------------ J
- return It.Auto_Engaged;
- end Auto;
-
- procedure Flip ( It: in out Auto_Dimmer ) is
- begin
- TCTouch.Touch( 'K' ); ------------------------------------------------ K
- if It.Auto_Engaged then
- if Off(It) then
- Flip( Dimmer( It ) );
- else
- It.Auto_Engaged := False;
- end if;
- else
- Flip( Dimmer( It ) );
- end if;
- end Flip;
-
- procedure Set_Cutin ( It : in out Auto_Dimmer;
- Lumens : in Luminance) is
- begin
- TCTouch.Touch( 'L' ); ------------------------------------------------ L
- It.Cutin_Threshold := Lumens;
- end Set_Cutin;
-
- procedure Set_Cutout( It : in out Auto_Dimmer;
- Lumens : in Luminance) is
- begin
- TCTouch.Touch( 'M' ); ------------------------------------------------ M
- It.Cutout_Threshold := Lumens;
- end Set_Cutout;
-
- function Cutout_Threshold( It : Auto_Dimmer ) return Luminance is
- begin
- TCTouch.Touch( 'N' ); ------------------------------------------------ N
- return It.Cutout_Threshold;
- end Cutout_Threshold;
-
- function Cutin_Threshold ( It : Auto_Dimmer ) return Luminance is
- begin
- TCTouch.Touch( 'O' ); ------------------------------------------------ O
- return It.Cutin_Threshold;
- end Cutin_Threshold;
-
- function TC_CW_TI( Key : Character ) return Toggle'Class is
- begin
- TCTouch.Touch( 'W' ); ------------------------------------------------ W
- case Key is
- when 'T' | 't' => return Toggle'( On => True );
- when 'D' | 'd' => return Dimmer'( On => True, Intensity => 75 );
- when 'A' | 'a' => return Auto_Dimmer'( On => True, Intensity => 25,
- Cutout_Threshold | Cutin_Threshold => 50,
- Auto_Engaged => True );
- when others => null;
- end case;
- end TC_CW_TI;
-
- function TC_Non_Disp( It: Toggle ) return Boolean is
- begin
- TCTouch.Touch( 'X' ); ------------------------------------------------ X
- return It.On;
- end TC_Non_Disp;
-
- function TC_Non_Disp( It: Dimmer ) return Boolean is
- begin
- TCTouch.Touch( 'Y' ); ------------------------------------------------ Y
- return It.On;
- end TC_Non_Disp;
-
- function TC_Non_Disp( It: Auto_Dimmer ) return Boolean is
- begin
- TCTouch.Touch( 'Z' ); ------------------------------------------------ Z
- return It.On;
- end TC_Non_Disp;
-
-end F392C00_1;
diff --git a/gcc/testsuite/ada/acats/support/f392d00.a b/gcc/testsuite/ada/acats/support/f392d00.a
deleted file mode 100644
index 24f742739c8..00000000000
--- a/gcc/testsuite/ada/acats/support/f392d00.a
+++ /dev/null
@@ -1,103 +0,0 @@
--- F392D00.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- FOUNDATION DESCRIPTION:
--- This foundation declares parent tagged types and subprograms for use
--- in tests covering dispatching operations.
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
---
---!
-
-package F392D00 is
-
- type Depth_Of_Field is range 5 .. 100;
- type Shutter_Speed is (One, Two_Fifty, Four_Hundred, Thousand);
-
- type Remote_Camera is tagged record
- DOF : Depth_Of_Field := 10;
- Shutter: Shutter_Speed := One;
- end record;
-
- -- ...Other declarations.
-
- procedure Focus (C : in out Remote_Camera;
- Depth : in Depth_Of_Field);
-
- procedure Self_Test (C: in out Remote_Camera'Class);
-
- -- ...Other operations.
-
-private
-
- procedure Set_Shutter_Speed (C : in out Remote_Camera;
- Speed : in Shutter_Speed);
-
- -- For the basic remote camera, shutter speed might be set as a function of
- -- focus perhaps, thus it is declared as a private operation (usable
- -- only internally within the abstraction).
-
-
-end F392D00;
-
-
- --==================================================================--
-
-
-package body F392D00 is
-
- procedure Focus (C : in out Remote_Camera;
- Depth : in Depth_Of_Field) is
- begin
- -- Artificial for testing purposes.
- C.DOF := 46;
- end Focus;
-
- -----------------------------------------------------------
- procedure Set_Shutter_Speed (C : in out Remote_Camera;
- Speed : in Shutter_Speed) is
- begin
- -- Artificial for testing purposes.
- C.Shutter := Thousand;
- end Set_Shutter_Speed;
-
- -----------------------------------------------------------
- procedure Self_Test (C: in out Remote_Camera'Class) is
- TC_Dummy_Depth : constant Depth_Of_Field := 23;
- TC_Dummy_Speed : constant Shutter_Speed := Four_Hundred;
- begin
-
- -- Test focus at various depths:
- Focus(C, TC_Dummy_Depth);
- -- ...Additional calls to Focus.
-
- -- Test various shutter speeds:
- Set_Shutter_Speed(C, TC_Dummy_Speed);
- -- ...Additional calls to Set_Shutter_Speed.
-
- end Self_Test;
-
-end F392D00;
diff --git a/gcc/testsuite/ada/acats/support/f393a00.a b/gcc/testsuite/ada/acats/support/f393a00.a
deleted file mode 100644
index e85c3f49cd0..00000000000
--- a/gcc/testsuite/ada/acats/support/f393a00.a
+++ /dev/null
@@ -1,245 +0,0 @@
--- F393A00.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- FOUNDATION DESCRIPTION:
--- This foundation provides a simple background for a class family
--- based on an abstract type. It is to be used to test the
--- dispatching of various forms of subprogram defined/inherited and
--- overridden with the abstract type.
---
--- type procedures functions
--- ---- ---------- ---------
--- Object Initialize, Swap(abstract) Create(abstract)
--- Object'Class Initialized
--- Windmill is new Object Swap, Stop, Add_Spin Create, Spin
--- Pump is new Windmill Set_Rate Create, Rate
--- Mill is new Windmill Swap, Stop Create
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
---
---!
-
-package F393A00_0 is
- procedure TC_Touch ( A_Tag : Character );
- procedure TC_Validate( Expected: String; Message: String );
-end F393A00_0;
-
-with Report;
-package body F393A00_0 is
- Expectation : String(1..20);
- Finger : Natural := 0;
-
- procedure TC_Touch ( A_Tag : Character ) is
- begin
- Finger := Finger+1;
- Expectation(Finger) := A_Tag;
- end TC_Touch;
-
- procedure TC_Validate( Expected: String; Message: String ) is
- begin
- if Expectation(1..Finger) /= Expected then
- Report.Failed( Message & " Expecting: " & Expected
- & " Got: " & Expectation(1..Finger) );
- end if;
- Finger := 0;
- end TC_Validate;
-end F393A00_0;
-
-----------------------------------------------------------------------
-
-package F393A00_1 is
- type Object is abstract tagged private;
- procedure Initialize( An_Object: in out Object );
- function Initialized( An_Object: Object'Class ) return Boolean;
- procedure Swap( A,B: in out Object ) is abstract;
- function Create return Object is abstract;
-private
- type Object is abstract tagged record
- Initialized : Boolean := False;
- end record;
-end F393A00_1;
-
-with F393A00_0;
-package body F393A00_1 is
- procedure Initialize( An_Object: in out Object ) is
- begin
- An_Object.Initialized := True;
- F393A00_0.TC_Touch('a');
- end Initialize;
-
- function Initialized( An_Object: Object'Class ) return Boolean is
- begin
- F393A00_0.TC_Touch('b');
- return An_Object.Initialized;
- end Initialized;
-end F393A00_1;
-
-----------------------------------------------------------------------
-
-with F393A00_1;
-package F393A00_2 is
-
- type Rotational_Measurement is range -1_000 .. 1_000;
- type Windmill is new F393A00_1.Object with private;
-
- procedure Swap( A,B: in out Windmill );
-
- function Create return Windmill;
-
- procedure Add_Spin( To_Mill : in out Windmill;
- RPMs : in Rotational_Measurement );
-
- procedure Stop( Mill : in out Windmill );
-
- function Spin( Mill : Windmill ) return Rotational_Measurement;
-
-private
- type Windmill is new F393A00_1.Object with
- record
- Spin : Rotational_Measurement := 0;
- end record;
-end F393A00_2;
-
-with F393A00_0;
-package body F393A00_2 is
-
- procedure Swap( A,B: in out Windmill ) is
- T : constant Windmill := B;
- begin
- F393A00_0.TC_Touch('c');
- B := A;
- A := T;
- end Swap;
-
- function Create return Windmill is
- A_Mill : Windmill;
- begin
- F393A00_0.TC_Touch('d');
- return A_Mill;
- end Create;
-
- procedure Add_Spin( To_Mill : in out Windmill;
- RPMs : in Rotational_Measurement ) is
- begin
- F393A00_0.TC_Touch('e');
- To_Mill.Spin := To_Mill.Spin + RPMs;
- end Add_Spin;
-
- procedure Stop( Mill : in out Windmill ) is
- begin
- F393A00_0.TC_Touch('f');
- Mill.Spin := 0;
- end Stop;
-
- function Spin( Mill : Windmill ) return Rotational_Measurement is
- begin
- F393A00_0.TC_Touch('g');
- return Mill.Spin;
- end Spin;
-
-end F393A00_2;
-
-----------------------------------------------------------------------
-
-with F393A00_2;
-package F393A00_3 is
- type Pump is new F393A00_2.Windmill with private;
- function Create return Pump;
-
- type Gallons_Per_Revolution is digits 3;
- procedure Set_Rate( A_Pump: in out Pump; To_Rate: Gallons_Per_Revolution);
- function Rate( Of_Pump: Pump ) return Gallons_Per_Revolution;
-private
- type Pump is new F393A00_2.Windmill with
- record
- GPRPM : Gallons_Per_Revolution := 0.0; -- Gallons/RPM
- end record;
-end F393A00_3;
-
-with F393A00_0;
-package body F393A00_3 is
- function Create return Pump is
- Sump : Pump;
- begin
- F393A00_0.TC_Touch('h');
- return Sump;
- end Create;
-
- procedure Set_Rate( A_Pump: in out Pump; To_Rate: Gallons_Per_Revolution)
- is
- begin
- F393A00_0.TC_Touch('i');
- A_Pump.GPRPM := To_Rate;
- end Set_Rate;
-
- function Rate( Of_Pump: Pump ) return Gallons_Per_Revolution is
- begin
- F393A00_0.TC_Touch('j');
- return Of_Pump.GPRPM;
- end Rate;
-end F393A00_3;
-
-----------------------------------------------------------------------
-
-with F393A00_2;
-with F393A00_3;
-package F393A00_4 is
- type Mill is new F393A00_2.Windmill with private;
-
- procedure Swap( A,B: in out Mill );
- function Create return Mill;
- procedure Stop( It: in out Mill );
- private
- type Mill is new F393A00_2.Windmill with
- record
- Pump: F393A00_3.Pump := F393A00_3.Create;
- end record;
-end F393A00_4;
-
-with F393A00_0;
-package body F393A00_4 is
- procedure Swap( A,B: in out Mill ) is
- T: constant Mill := A;
- begin
- F393A00_0.TC_Touch('k');
- A := B;
- B := T;
- end Swap;
-
- function Create return Mill is
- A_Mill : Mill;
- begin
- F393A00_0.TC_Touch('l');
- return A_Mill;
- end Create;
-
- procedure Stop( It: in out Mill ) is
- begin
- F393A00_0.TC_Touch('m');
- F393A00_3.Stop( It.Pump );
- F393A00_2.Stop( F393A00_2.Windmill( It ) );
- end Stop;
-end F393A00_4;
diff --git a/gcc/testsuite/ada/acats/support/f393b00.a b/gcc/testsuite/ada/acats/support/f393b00.a
deleted file mode 100644
index afabdd72fb5..00000000000
--- a/gcc/testsuite/ada/acats/support/f393b00.a
+++ /dev/null
@@ -1,101 +0,0 @@
--- F393B00.A
- -- Alert_Foundation
- --
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
- --
- -- FOUNDATION DESCRIPTION:
- -- This package declares three abstract types for use in C660 series
- -- tests, Alert, Special_Alert, and Private_Alert.
- -- It models (in miniature) an application situation in which an
- -- abstraction is defined in terms of structure (record and operations
- -- on the record) but not in terms of content (record is null). It
- -- also models a situation in which an abstraction includes some
- -- specific, implementation dependent, information.
- --
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
---
- --!
-
- package F393B00 is
- type Alert is abstract tagged null record; -- abstract type
- -- see procedure Handle below
-
- procedure Handle (A : in out Alert) is abstract;
- -- abstract procedure,
- -- explicitly declared
-
-
- type Private_Alert is abstract tagged private;
-
- procedure Handle (PA : in out Private_Alert) is abstract;
- -- ensures that Private_Alert
- -- is visibly abstract
-
-
- type Status_Kind is (Practice, Real, Dont_Care);
- type Urgency_Kind is (Low, Medium, High);
-
- type Practice_Alert is new Alert with record
- Status : Status_Kind := Dont_Care;
- Urgency : Urgency_Kind := Low;
- end record;
-
- procedure Handle (PA : in out Practice_Alert);
- -- overrides inherited Handle
-
-
-
- type Device is (Teletype, Console, Big_Screen);
-
- type Special_Alert (Age : Integer) is
- abstract new Practice_Alert with record
- Display : Device;
- end record;
-
- procedure Handle (SA : in out Special_Alert) is abstract;
- -- overrides inherited Handle
-
- private
- subtype Implementation_Detail is Integer range 1..10;
-
- type Private_Alert is abstract tagged record
- Private_Field : Implementation_Detail := 1;
- end record;
-
-
- end F393B00;
-
- --=======================================================================--
-
- package body F393B00 is
-
- procedure Handle (PA : in out Practice_Alert) is
- begin
- PA.Status := Real;
- PA.Urgency := Medium;
- end Handle;
-
- end F393B00;
-
diff --git a/gcc/testsuite/ada/acats/support/f3a2a00.a b/gcc/testsuite/ada/acats/support/f3a2a00.a
deleted file mode 100644
index c839082312e..00000000000
--- a/gcc/testsuite/ada/acats/support/f3a2a00.a
+++ /dev/null
@@ -1,81 +0,0 @@
--- F3A2A00.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- FOUNDATION DESCRIPTION:
--- This foundation declares support types and subprograms for testing
--- run-time accessibility checks.
---
--- CHANGE HISTORY:
--- 01 May 95 SAIC Initial prerelease version.
---
---!
-
-package F3A2A00 is
-
- type Tagged_Type is tagged record
- C: Integer := 0;
- end record;
-
- type Array_Type is array (1 .. 10) of Tagged_Type;
-
- type AccTag_L0 is access all Tagged_Type;
- type AccTagClass_L0 is access all Tagged_Type'Class;
-
- type AccArr_L0 is access all Array_Type;
-
- X_L0 : Tagged_Type;
-
-
- type TC_Result_Kind is (OK, P_E, O_E);
-
- procedure TC_Display_Results (Actual : in TC_Result_Kind;
- Expected: in TC_Result_Kind;
- Message : in String);
-end F3A2A00;
-
-
- --==================================================================--
-
-
-with Report;
-package body F3A2A00 is
-
- procedure TC_Display_Results (Actual : in TC_Result_Kind;
- Expected: in TC_Result_Kind;
- Message : in String) is
- begin
- if Actual /= Expected then
- case Actual is
- when OK =>
- Report.Failed ("No exception raised: " & Message);
- when P_E =>
- Report.Failed ("Program_Error raised: " & Message);
- when O_E =>
- Report.Failed ("Unexpected exception raised: " & Message);
- end case;
- end if;
- end TC_Display_Results;
-
-end F3A2A00;
diff --git a/gcc/testsuite/ada/acats/support/f460a00.a b/gcc/testsuite/ada/acats/support/f460a00.a
deleted file mode 100644
index 382f5c516c8..00000000000
--- a/gcc/testsuite/ada/acats/support/f460a00.a
+++ /dev/null
@@ -1,90 +0,0 @@
--- F460A00.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- FOUNDATION DESCRIPTION:
--- This foundation declares support types and subprograms for testing
--- run-time accessibility checks.
---
--- CHANGE HISTORY:
--- 11 May 95 SAIC Initial prerelease version.
--- 24 Apr 96 SAIC Modified Array_Type.
---
---!
-
-package F460A00 is
-
- type Tagged_Type is tagged record
- C : Integer := 0;
- end record;
-
- type Derived_Tagged_Type is new Tagged_Type with record
- D : String (1 .. 4) := "void";
- end record;
-
- type Composite_Type (D: access Tagged_Type) is limited record
- C : Boolean;
- end record;
-
- type Array_Type is array (1 .. 10) of Tagged_Type;
-
- type AccTag_L0 is access constant Tagged_Type;
- type AccTagClass_L0 is access all Tagged_Type'Class;
-
- type AccArr_L0 is access all Array_Type;
-
- X_DerivedTag : aliased Derived_Tagged_Type;
- PTagClass_L0 : AccTagClass_L0 := X_DerivedTag'Access;
-
- type TC_Result_Kind is (OK, UN_Init, PE_Exception, Others_Exception);
-
- procedure TC_Check_Results (Actual : in TC_Result_Kind;
- Expected: in TC_Result_Kind;
- Message : in String);
-end F460A00;
-
-
- --==================================================================--
-
-
-with Report;
-package body F460A00 is
-
- procedure TC_Check_Results (Actual : in TC_Result_Kind;
- Expected: in TC_Result_Kind;
- Message : in String) is
- begin
- if Actual /= Expected then
- case Actual is
- when OK | UN_Init =>
- Report.Failed ("No exception raised: " & Message);
- when PE_Exception =>
- Report.Failed ("Program_Error raised: " & Message);
- when Others_Exception =>
- Report.Failed ("Unexpected exception raised: " & Message);
- end case;
- end if;
- end TC_Check_Results;
-
-end F460A00;
diff --git a/gcc/testsuite/ada/acats/support/f730a000.a b/gcc/testsuite/ada/acats/support/f730a000.a
deleted file mode 100644
index 137f33306cb..00000000000
--- a/gcc/testsuite/ada/acats/support/f730a000.a
+++ /dev/null
@@ -1,107 +0,0 @@
--- F730A000.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- FOUNDATION DESCRIPTION:
--- This file simulates a generic linked list abstraction for use in tests
--- covering tagged types and type extensions.
---
--- TEST FILES:
--- This foundation consists of the following files:
---
--- => F730A000.A
--- F730A001.A
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 03 Aug 96 SAIC ACVC 2.1: Modified prologue. Added pragma
--- Elaborate_Body. Removed extraneous record
--- extension.
---
---!
-
-generic -- Singly-linked list abstraction.
- type Parent_Type is tagged private; -- Actual is parent
-package F730A000 is -- tagged type.
-
- pragma Elaborate_Body;
-
-
- -- Declarations for private linked list nodes:
-
- type Priv_Node_Type is new Parent_Type with private; -- Private extension
- -- of parent type.
-
- -- Inherits primitive operations of actual parameter corresponding
- -- to Parent_Type.
-
-
- type Priv_Node_Ptr is access Priv_Node_Type;
-
-
- -- Add node at head of list.
- procedure Add (Item : in Priv_Node_Ptr;
- Head : in out Priv_Node_Ptr);
-
- -- Remove node from head of list and return it.
- procedure Remove (Head : in out Priv_Node_Ptr;
- Item : out Priv_Node_Ptr);
-
-
-private
-
- type Priv_Node_Type is new Parent_Type with record
- Next : Priv_Node_Ptr := null;
- end record;
-
-end F730A000;
-
-
- --==================================================================--
-
-
-package body F730A000 is -- Singly-linked list abstraction.
-
-
- procedure Add (Item : in Priv_Node_Ptr;
- Head : in out Priv_Node_Ptr) is
- begin
- if Item /= null then
- Item.Next := Head;
- Head := Item;
- end if;
- end Add;
-
-
- procedure Remove (Head : in out Priv_Node_Ptr;
- Item : out Priv_Node_Ptr) is
- begin
- Item := Head;
- if Head /= null then
- Head := Head.Next;
- end if;
- end Remove;
-
-
-end F730A000;
diff --git a/gcc/testsuite/ada/acats/support/f730a001.a b/gcc/testsuite/ada/acats/support/f730a001.a
deleted file mode 100644
index 18153b7ebba..00000000000
--- a/gcc/testsuite/ada/acats/support/f730a001.a
+++ /dev/null
@@ -1,76 +0,0 @@
--- F730A001.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- FOUNDATION DESCRIPTION:
--- This file declares a tagged type and primitive subprogram for use in
--- tests covering tagged types and type extensions.
---
--- TEST FILES:
--- The following files comprise this foundation:
---
--- F730A000.A
--- => F730A001.A
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
---
---!
-
-
-package F730A001 is -- Book definitions.
-
-
- type Text_Ptr is access String;
-
- type Book_Type is tagged record -- Root tagged type.
- Title : Text_Ptr;
- Author : Text_Ptr;
- end record;
-
-
- procedure Create_Book (Title : in Text_Ptr; -- Primitive operation
- Author : in Text_Ptr; -- of root tagged type.
- Book : out Book_Type);
-
-
-end F730A001;
-
-
- --==================================================================--
-
-
-package body F730A001 is -- Book definitions.
-
-
- procedure Create_Book (Title : in Text_Ptr;
- Author : in Text_Ptr;
- Book : out Book_Type) is
- begin
- Book.Title := Title;
- Book.Author := Author;
- end Create_Book;
-
-
-end F730A001;
diff --git a/gcc/testsuite/ada/acats/support/f731a00.a b/gcc/testsuite/ada/acats/support/f731a00.a
deleted file mode 100644
index 5e29fbd96af..00000000000
--- a/gcc/testsuite/ada/acats/support/f731a00.a
+++ /dev/null
@@ -1,66 +0,0 @@
--- F731A00.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- FOUNDATION DESCRIPTION:
--- This foundation declares parent tagged types and subprograms for use
--- in tests covering operations of private types and private extensions.
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
---
---!
-
-package F731A00 is
-
- type Parent is tagged private;
-
- function Vis_Op (P: Parent) return Boolean;
-
-private
-
- type Parent is tagged record
- Component : Integer := 1;
- end record;
-
- function Pri_Op (P: Parent) return Boolean;
-
-end F731A00;
-
-
- --==================================================================--
-
-
-package body F731A00 is
- function Vis_Op (P: Parent) return Boolean is
- begin
- return True;
- end Vis_Op;
-
- function Pri_Op (P: Parent) return Boolean is
- begin
- return False;
- end Pri_Op;
-
-end F731A00;
diff --git a/gcc/testsuite/ada/acats/support/f940a00.a b/gcc/testsuite/ada/acats/support/f940a00.a
deleted file mode 100644
index ddc614f1b4d..00000000000
--- a/gcc/testsuite/ada/acats/support/f940a00.a
+++ /dev/null
@@ -1,97 +0,0 @@
--- F940A00.A
---
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- FOUNDATION DESCRIPTION:
--- This foundation contains test control code for tests covering
--- the protected record.
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
---
---!
-
-package F940A00 is
- -- Interlock_Foundation
-
- protected type Interlock_Type is
- entry Post;
- entry Consume;
- private
- Int_Count : Integer := 0;
- end Interlock_Type;
-
- protected Counter is -- used to count the number of
- procedure Increment; -- resources that have been granted
- procedure Decrement; -- to tasks
- function Number return integer;
- private
- Count : Integer := 0;
- end Counter;
-
-end F940A00;
- -- Interlock_Foundation
-
---===================================--
-
-package body F940A00 is
- -- Interlock_Foundation
-
- protected body Interlock_Type is
-
- entry Post when true is
- begin
- Int_Count := Int_Count + 1;
- end Post;
-
- entry Consume when Int_Count > 0 is
- begin
- Int_Count := Int_Count - 1;
- end Consume;
-
- end Interlock_Type;
-
-
- protected body Counter is
-
- procedure Increment is
- begin
- Count := Count + 1;
- end Increment;
-
- procedure Decrement is
- begin
- Count := Count - 1;
- end Decrement;
-
- function Number return Integer is
- begin
- return Count;
- end Number;
-
- end Counter;
-
-end F940A00;
- -- Interlock_Foundation
diff --git a/gcc/testsuite/ada/acats/support/f954a00.a b/gcc/testsuite/ada/acats/support/f954a00.a
deleted file mode 100644
index 615aa986030..00000000000
--- a/gcc/testsuite/ada/acats/support/f954a00.a
+++ /dev/null
@@ -1,134 +0,0 @@
--- F954A00.A
---
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- This file contains foundation code for tests covering the requeue
--- statement.
---
--- TEST DESCRIPTION:
--- See prologues of specific tests.
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
---
---!
-
-package F954A00 is -- Printer device abstraction.
-
-
- -- Model a printer device driver as a protected type. A printer remains
- -- unavailable while data is printing. The printer generates an interrupt
- -- when printing is complete, after which the printer is again made
- -- available.
-
-
- type Printers_Info is tagged record
- Some_Info : Integer;
- end record;
-
- --==============================================--
-
- protected type Printers is -- Device driver for printer.
-
- procedure Start_Printing (File_Name : String); -- Begin printing on
- -- printer.
-
- procedure Handle_Interrupt; -- Handle interrupt from
- -- printer.
-
- entry Done_Printing; -- Wait until printer is
- -- done.
-
- function Available return Boolean; -- Return value of Ready.
- function Is_Done return Boolean; -- Return value of Done.
-
- private
-
- Ready : Boolean := True; -- Entry barrier.
- Done : Boolean := True; -- Testing flag.
-
- end Printers;
-
- --==============================================--
-
- Number_Of_Printers : constant := 2;
-
- type Printer_ID is range 1 .. Number_Of_Printers;
-
- type Printer_Array is array (Printer_ID) of Printers;
- type Info_Array is array (Printer_ID) of Printers_Info;
-
- Printer : Printer_Array;
- Printer_Info : constant Info_Array := ( (Some_Info => 1),
- (Some_Info => 2) );
-
-end F954A00;
-
-
- --==================================================================--
-
-
-package body F954A00 is -- Printer server abstraction.
-
-
- protected body Printers is
-
- procedure Start_Printing (File_Name : String) is
- begin
- Ready := False; -- Block other requests
- Done := False; -- for this printer
- -- Send data to the printer... -- and begin printing.
- end Start_Printing;
-
-
- -- Set the "not ready" one-shot
- entry Done_Printing when Ready is -- Callers wait here
- begin -- until printing is
- Done := True; -- done (signaled by a
- end Done_Printing; -- printer interrupt).
-
-
- procedure Handle_Interrupt is -- Called when the
- begin -- printer interrupts,
- Ready := True; -- indicating that
- end Handle_Interrupt; -- printing is done.
-
-
- function Available return Boolean is -- Artifice for test
- begin -- purposes: checks
- return (Ready); -- whether printer is
- end Available; -- still printing.
-
-
- function Is_Done return Boolean is -- Artifice for test
- begin -- purposes: checks
- return (Done); -- whether Done_Printing
- end Is_Done; -- entry was executed.
-
- end Printers;
-
-
-end F954A00;
diff --git a/gcc/testsuite/ada/acats/support/fa11a00.a b/gcc/testsuite/ada/acats/support/fa11a00.a
deleted file mode 100644
index b57a6b7f569..00000000000
--- a/gcc/testsuite/ada/acats/support/fa11a00.a
+++ /dev/null
@@ -1,73 +0,0 @@
--- FA11A00.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- FOUNDATION DESCRIPTION:
--- This foundation declares a tagged type and primitive subprograms in
--- a parent package.
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
---
---!
-
-package FA11A00 is -- Widget_Pkg
--- This package represents processing of widgets in a window system. It
--- contains a tagged type that can be extended by its children.
-
- type Widget_Length is range 1 .. 100;
-
- type Widget is tagged -- Parent tagged type
- record
- Width, Height : Widget_Length;
- -- More components to be added by extension
- end record;
-
- -- To be inherited by its children derivatives.
- procedure Set_Width (The_Widget : in out Widget;
- W : in Widget_Length);
-
- -- To be inherited by its children derivatives.
- procedure Set_Height (The_Widget : in out Widget;
- H : in Widget_Length);
-
-end FA11A00; -- Widget_Pkg
-
---=======================================================================--
-
-package body FA11A00 is -- Widget_Pkg
-
- procedure Set_Width (The_Widget : in out Widget;
- W : in Widget_Length) is
- begin
- The_Widget.Width := W;
- end Set_Width;
- -------------------------------------------------------
- procedure Set_Height (The_Widget : in out Widget;
- H : in Widget_Length) is
- begin
- The_Widget.Height := H;
- end Set_Height;
-
-end FA11A00; -- Widget_Pkg
diff --git a/gcc/testsuite/ada/acats/support/fa11b00.a b/gcc/testsuite/ada/acats/support/fa11b00.a
deleted file mode 100644
index 161be8e1722..00000000000
--- a/gcc/testsuite/ada/acats/support/fa11b00.a
+++ /dev/null
@@ -1,110 +0,0 @@
--- FA11B00.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- FOUNDATION DESCRIPTION:
--- This foundation declares parent types and operations that can
--- be inherited by its children.
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
---
---!
-
-package FA11B00 is -- Application_One_Widget
--- This foundation simulates code that might be obtained as an already
--- implemented set of objects and services, perhaps from a source code
--- vendor. It represents processing of widgets in a window system.
--- These widgets all have the same characteristics, but they are application
--- specific, so we do not allow assignment of an App_1_Widget to App_2_Widget.
-
--- The dimension measurement is in pixels (dots on the screen).
- type Pixels is range 0 .. 10_000;
- type Widget_Id is new Integer;
- type Widget_Color_Enum is (Amber, Green, White, None);
- subtype Widget_Label_Str is string (1 .. 15);
-
- type Widget_Location is
- record
- X_Location, Y_Location : Pixels;
- end record;
-
- type Widget_Size is
- record
- X_Length, Y_Length : Pixels;
- end record;
-
- -- NOTE : not a tagged record.
- type App1_Widget (Maximum_Size : Pixels := Pixels'Last)
- is record -- Parent type
- Size : Widget_Size := (Maximum_Size, Maximum_Size);
- ID : Widget_Id := 1;
- Location : Widget_Location := (0,0);
- Color : Widget_Color_Enum := None;
- Label : Widget_Label_Str := " ";
- end record;
-
- -- Primitive operation of type Widget.
- -- To be inherited by its children derivatives.
- procedure App1_Widget_Specific_Oper (The_Widget : in out App1_Widget;
- I : in Widget_Id;
- C : in Widget_Color_Enum;
- L : in Widget_Label_Str);
-
-end FA11B00; -- Application_One_Widget
-
---=======================================================================--
-
-package body FA11B00 is -- Application_One_Widget
-
- procedure Set_Color (The_Widget : in out App1_Widget;
- C : in Widget_Color_Enum) is
- begin
- The_Widget.Color := C;
- end Set_Color;
- -------------------------------------------------------------
- procedure Set_Label (The_Widget : in out App1_Widget;
- L : in Widget_Label_Str) is
- begin
- The_Widget.Label := L;
- end Set_Label;
- -------------------------------------------------------------
- procedure Set_Id (The_Widget : in out App1_Widget;
- I : in Widget_Id) is
- begin
- The_Widget.Id := I;
- end Set_Id;
- -------------------------------------------------------------
- procedure App1_Widget_Specific_Oper
- (The_Widget : in out App1_Widget;
- I : in Widget_Id;
- C : in Widget_Color_Enum;
- L : in Widget_Label_Str) is
- begin
- Set_Color (The_Widget, C);
- Set_Label (The_Widget, L);
- Set_Id (The_Widget, I);
- end App1_Widget_Specific_Oper;
-
-end FA11B00; -- Application_One_Widget
diff --git a/gcc/testsuite/ada/acats/support/fa11c00.a b/gcc/testsuite/ada/acats/support/fa11c00.a
deleted file mode 100644
index 4b153b25eba..00000000000
--- a/gcc/testsuite/ada/acats/support/fa11c00.a
+++ /dev/null
@@ -1,112 +0,0 @@
--- FA11C00.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- FOUNDATION DESCRIPTION:
--- This foundation declares parent types and operations that can
--- be inherited by its children.
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
---
---!
-
-package FA11C00_0 is -- Package Animal
-
- type Kilogram_Weight_Type is new Natural;
- subtype Species_Name_Type is String (1 .. 20);
-
- type Animal is tagged
- record
- Common_Name : Species_Name_Type;
- Weight : Kilogram_Weight_Type;
- end record;
-
- function Image (A : Animal) return String;
-
-end FA11C00_0; -- Package Animal
-
- --=================================================================--
-
-package body FA11C00_0 is -- Package body Animal
-
- function Image (A : Animal) return String is
- begin
- return ("Animal Species: " & A.Common_Name);
- end Image;
-
-end FA11C00_0; -- Package body Animal
-
- --=================================================================--
-
-package FA11C00_0.FA11C00_1 is -- Package Animal.Mammal
-
- type Hair_Color_Type is (Black, Brown, Blonde, Grey, White, Red);
-
- type Mammal is new Animal with
- record
- Hair_Color : Hair_Color_Type;
- end record;
-
- function Image (M : Mammal) return String;
-
-end FA11C00_0.FA11C00_1; -- Package Animal.Mammal
-
- --=================================================================--
-
-package body FA11C00_0.FA11C00_1 is -- Package body Animal.Mammal
-
- function Image (M : Mammal) return String is
- begin
- return ("Mammal Species: " & M.Common_Name);
- end Image;
-
-end FA11C00_0.FA11C00_1; -- Package body Animal.Mammal
-
- --=================================================================--
-
-package FA11C00_0.FA11C00_1.FA11C00_2 is -- Package Animal.Mammal.Primate
-
- type Habitat_Type is (Arboreal, Terrestrial);
-
- type Primate is new Mammal with
- record
- Habitat : Habitat_Type;
- end record;
-
- function Image (P : Primate) return String;
-
-end FA11C00_0.FA11C00_1.FA11C00_2; -- Package Animal.Mammal.Primate
-
- --=================================================================--
-
- -- Package body Animal.Mammal.Primate
-package body FA11C00_0.FA11C00_1.FA11C00_2 is
-
- function Image (P : Primate) return String is
- begin
- return ("Primate Species: " & P.Common_Name);
- end Image;
-
-end FA11C00_0.FA11C00_1.FA11C00_2; -- Package body Animal.Mammal.Primate
diff --git a/gcc/testsuite/ada/acats/support/fa11d00.a b/gcc/testsuite/ada/acats/support/fa11d00.a
deleted file mode 100644
index 9efe33be73c..00000000000
--- a/gcc/testsuite/ada/acats/support/fa11d00.a
+++ /dev/null
@@ -1,78 +0,0 @@
--- FA11D00.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- FOUNDATION DESCRIPTION:
--- This foundation declares parent types and operations that can
--- be inherited by its children.
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 21 Dec 94 SAIC Modified type Int_Type
---
---!
-
-package FA11D00 is -- Complex_Definition_Pkg
-
- -- Simulate a complex number support package. Complex numbers
- -- are treated as coordinates in the Cartesian plane.
-
- type Int_Type is range -200 .. 100;
-
- type Complex_Type is record
- Real : Int_Type;
- Imag : Int_Type;
- end record;
-
- Zero : constant Complex_Type := (Real => 0, Imag => 0);
- One : constant Complex_Type := (Real => 1, Imag => 0);
- Check_Value : constant Complex_Type := (Real => 17, Imag => 23);
-
- Add_Error : exception;
- Subtract_Error : exception;
- Divide_Error : exception;
- Multiply_Error : exception;
-
- TC_Handled_In_Caller,
- TC_Handled_In_Child_Pkg_Proc,
- TC_Handled_In_Child_Pkg_Func,
- TC_Handled_In_Grandchild_Pkg_Proc,
- TC_Handled_In_Grandchild_Pkg_Func,
- TC_Handled_In_Child_Sub,
- TC_Propagated_To_Caller : boolean := False;
-
- function Complex (Real, Imag : Int_Type)
- return Complex_Type;
-
-end FA11D00; -- Complex_Definition_Pkg
-
---=======================================================================--
-
-package body FA11D00 is -- Complex_Definition_Pkg
- function Complex (Real, Imag : Int_Type) return Complex_Type is
- begin
- return (Real, Imag);
- end Complex;
-
-end FA11D00; -- Complex_Definition_Pkg
diff --git a/gcc/testsuite/ada/acats/support/fa13a00.a b/gcc/testsuite/ada/acats/support/fa13a00.a
deleted file mode 100644
index be6ecde56ed..00000000000
--- a/gcc/testsuite/ada/acats/support/fa13a00.a
+++ /dev/null
@@ -1,171 +0,0 @@
--- FA13A00.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- FOUNDATION DESCRIPTION:
--- This foundation code is used to check visibility of separate
--- subunit of child packages.
--- Declares a package containing type definitions; package will be
--- with'ed by the root of the elevator abstraction.
---
--- Declare an elevator abstraction in a parent root package which manages
--- basic operations. This package has a private part. Declare a
--- private child package which calculates the floors for going up or
--- down. Declare a public child package which provides the actual
--- operations.
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
---
---!
-
--- Simulates a fragment of an elevator operation application.
-
-package FA13A00_0 is -- Building Manager
-
- type Electrical_Power is (Off, V120, V240);
- Power : Electrical_Power := V120;
-
- -- other type definitions and procedure declarations in real application.
-
-end FA13A00_0;
-
--- No bodies provided for FA13A00_0.
-
- --==================================================================--
-
-package FA13A00_1 is -- Basic Elevator Operations
-
- type Call_Waiting_Type is private;
- type Floor is (Basement, Floor1, Floor2, Floor3, Penthouse);
- type Floor_No is range Floor'Pos(Floor'First) .. Floor'Pos(Floor'Last);
- Current_Floor : Floor := Floor1;
-
- TC_Operation : boolean := true;
-
- procedure Call (F : in Floor; C : in out Call_Waiting_Type);
- procedure Clear_Calls (C : in out Call_Waiting_Type);
-
-private
- type Call_Waiting_Type is array (Floor) of boolean;
- Call_Waiting : Call_Waiting_Type := (others => false);
-
-end FA13A00_1;
-
-
- --==================================================================--
-
-package body FA13A00_1 is
-
- -- Call the elevator.
-
- procedure Call (F : in Floor; C : in out Call_Waiting_Type) is
- begin
- C (F) := true;
- end Call;
-
- --------------------------------------------
-
- -- Clear all calls of the elevator.
-
- procedure Clear_Calls (C : in out Call_Waiting_Type) is
- begin
- C := (others => false);
- end Clear_Calls;
-
-end FA13A00_1;
-
- --==================================================================--
-
--- Private child package of an elevator application. This package calculates
--- how many floors to go up or down.
-
-private package FA13A00_1.FA13A00_2 is -- Floor Calculation
-
- -- Other type definitions in real application.
-
- procedure Up (HowMany : in Floor_No);
-
- procedure Down (HowMany : in Floor_No);
-
-end FA13A00_1.FA13A00_2;
-
- --==================================================================--
-
-package body FA13A00_1.FA13A00_2 is
-
- -- Go up from the current floor.
-
- procedure Up (HowMany : in Floor_No) is
- begin
- Current_Floor := Floor'val (Floor'pos (Current_Floor) + HowMany);
- end Up;
-
- --------------------------------------------
-
- -- Go down from the current floor.
-
- procedure Down (HowMany : in Floor_No) is
- begin
- Current_Floor := Floor'val (Floor'pos (Current_Floor) - HowMany);
- end Down;
-
-end FA13A00_1.FA13A00_2;
-
- --==================================================================--
-
--- Public child package of an elevator application. This package provides
--- the actual operation of the elevator.
-
-package FA13A00_1.FA13A00_3 is -- Move Elevator
-
- -- Other type definitions in real application.
-
- procedure Move_Elevator (F : in Floor;
- C : in out Call_Waiting_Type);
-
-end FA13A00_1.FA13A00_3;
-
- --==================================================================--
-
-with FA13A00_1.FA13A00_2; -- Floor Calculation
-
-package body FA13A00_1.FA13A00_3 is
-
- -- Going up or down depends on the current floor.
-
- procedure Move_Elevator (F : in Floor;
- C : in out Call_Waiting_Type) is
- begin
- if F > Current_Floor then
- FA13A00_1.FA13A00_2.Up (Floor'Pos (F) - Floor'Pos (Current_Floor));
- FA13A00_1.Call (F, C);
- elsif F < Current_Floor then
- FA13A00_1.FA13A00_2.Down (Floor'Pos (Current_Floor) - Floor'Pos (F));
- FA13A00_1.Call (F, C);
- end if;
-
- end Move_Elevator;
-
-end FA13A00_1.FA13A00_3;
diff --git a/gcc/testsuite/ada/acats/support/fa13b00.a b/gcc/testsuite/ada/acats/support/fa13b00.a
deleted file mode 100644
index da555540fbd..00000000000
--- a/gcc/testsuite/ada/acats/support/fa13b00.a
+++ /dev/null
@@ -1,106 +0,0 @@
--- FA13B00.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- FOUNDATION DESCRIPTION:
--- This foundation code is used to check visibility of separate
--- subunit of child packages.
--- Declares a package containing type definitions and a private
--- part; package will be with'ed by the parent's body of the subunits.
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
---
---!
-
-package FA13B00_0 is
-
- -- Type definitions.
-
- type Visible_Integer is range 1 .. 10;
-
- type Private_Record is private;
-
- type Visible_Tagged is tagged
- record
- PR : Private_Record;
- end record;
-
- type Private_Tagged is tagged private;
-
- Visible_Num : Visible_Integer := 7;
-
- -- Subprogram definitions.
-
- function Assign_Visible_Tagged (I : Visible_Integer)
- return Visible_Tagged;
-
- function Assign_Private_Tagged (I : Visible_Integer)
- return Private_Tagged;
-
-private
-
- -- Type definitions.
-
- type Private_Integer is range 11 .. 20;
-
- type Private_Record is
- record
- VI : Visible_Integer;
- end record;
-
- type Private_Tagged is tagged
- record
- VI : Visible_Integer;
- end record;
-
- -- Object definitions.
-
- Private_Num : Visible_Integer := 6;
-
-end FA13B00_0;
-
- --==================================================================--
-
-package body FA13B00_0 is
-
- function Assign_Visible_Tagged(I : Visible_Integer)
- return Visible_Tagged is
- VT : Visible_Tagged := (PR => (VI => I));
- begin
- return VT;
- end Assign_Visible_Tagged;
-
- -------------------------------------------------------
-
- function Assign_Private_Tagged (I : Visible_Integer)
- return Private_Tagged is
- PT : Private_Tagged := (VI => I);
- begin
- return PT;
- end Assign_Private_Tagged;
-
- -------------------------------------------------------
-
-end FA13B00_0;
diff --git a/gcc/testsuite/ada/acats/support/fa21a00.a b/gcc/testsuite/ada/acats/support/fa21a00.a
deleted file mode 100644
index 7af0da1d1cd..00000000000
--- a/gcc/testsuite/ada/acats/support/fa21a00.a
+++ /dev/null
@@ -1,127 +0,0 @@
--- FA21A00.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- FOUNDATION DESCRIPTION:
--- This foundation declares various supporting types, objects, and
--- subprograms for use in tests checking preelaborability.
---
--- CHANGE HISTORY:
--- 20 Mar 95 SAIC Initial prerelease version.
---
---!
-
-with Ada.Finalization; -- Preelaborated library unit.
-package FA21A00 is
-
- pragma Preelaborate (FA21A00);
-
-
- type My_Int is new Integer range 0 .. 100;
- function Func return My_Int; -- Non-static function.
-
- subtype Idx is Natural range 1 .. 5;
-
- Three : constant My_Int := 3;
- Ten : My_Int := 10; -- Non-static.
-
- type RecWithDisc (D: My_Int) is record
- Twice: My_Int := D*2;
- end record;
-
- type RecCallDefault is record
- C : My_Int := Func;
- D : My_Int := 0;
- end record;
-
- type RecPrimDefault is record
- C : My_Int := Ten;
- end record;
-
- type Tag is tagged record
- C : My_Int;
- end record;
-
- type AccTag is access all Tag;
-
- Tag1: aliased Tag; -- OK.
-
- type My_Controlled is new Ada.Finalization.Controlled with record
- C : My_Int;
- end record;
-
- type ContComp is tagged record
- C: My_Controlled;
- end record;
-
- task type Tsk (D: My_Int);
-
- protected type Prot is
- entry E;
- end Prot;
-
- type Priv is tagged private;
-
- type PrivComp is array (1 .. 5) of Priv;
-
- type Pri_Ext is new Tag with private;
-
- type PriExtComp is array (1 .. 5) of Pri_Ext;
-
-private
-
- type Priv is tagged record
- B: Boolean;
- end record;
-
- type Pri_Ext is new Tag with record
- N: String (1 .. 5);
- end record;
-
-end FA21A00;
-
-
- --===================================================================--
-
-
-package body FA21A00 is
-
- task body Tsk is
- begin
- null;
- end Tsk;
-
- protected body Prot is
- entry E when False is
- begin
- null;
- end E;
- end Prot;
-
- function Func return My_Int is
- begin
- return 0;
- end Func;
-
-end FA21A00;
diff --git a/gcc/testsuite/ada/acats/support/fb20a00.a b/gcc/testsuite/ada/acats/support/fb20a00.a
deleted file mode 100644
index 46184c954fa..00000000000
--- a/gcc/testsuite/ada/acats/support/fb20a00.a
+++ /dev/null
@@ -1,101 +0,0 @@
--- FB20A00.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- FOUNDATION DESCRIPTION:
--- This test performs a search for the first instance of a specified
--- substring within a specified string, returning boolean result.
--- (Case insensitive analysis) Both the string and the substring are
--- made upper case. Successive slices are taken from the input string
--- and compared with the substring. If a match is found, the search is
--- terminated immediately. The search continues until the last index
--- position from which a substring-length slice can be constructed is
--- passed.
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
---
---!
-
-package FB20A00 is
-
- function Find ( Str : in String ;
- Sub : in String ) return Boolean;
-
-end FB20A00;
-
- --=================================================================--
-
-package body FB20A00 is
-
- function Find ( Str : in String ;
- Sub : in String ) return Boolean is
-
- New_Str : String (Str'First .. Str'Last);
- New_Sub : String (Sub'First .. Sub'Last);
-
- Pos : Integer := Str'First ; -- Character index.
-
-
- function Upper_Case (Str : in String) return String is
- subtype Upper is Character range 'A' .. 'Z' ;
- subtype Lower is Character range 'a' .. 'z' ;
- Ret : String (Str'First .. Str'Last) ;
- Pos : Integer;
- begin
- for I in Str'Range loop
- if ( Str (I) in Lower ) then
- Pos := Upper'Pos (Upper'First) +
- ( Lower'Pos (Str(I)) - Lower'Pos(Lower'First) ) ;
- Ret (I) := Upper'Val (Pos) ;
- else
- Ret (I) := Str (I);
- end if ;
- end loop ;
- return (Ret) ;
- end Upper_Case;
-
- begin
-
-
- New_Str := Upper_Case (Str); -- Convert Str and Sub to upper
- New_Sub := Upper_Case (Sub); -- case for comparison.
-
- while ( Pos <= New_Str'Last-New_Sub'Length+1 ) -- Search until no more
- and then -- sub-string-length
- ( New_Str ( Pos .. Pos+New_Sub'Length-1 ) /= New_Sub ) -- slices
- -- remain.
- loop
- Pos := Pos + 1 ;
- end loop ;
-
- if ( Pos > New_Str'Last-New_Sub'Length+1 ) then -- Substring not found.
- return (False);
- else
- return (True);
- end if ;
-
- end Find;
-
-end FB20A00;
diff --git a/gcc/testsuite/ada/acats/support/fb40a00.a b/gcc/testsuite/ada/acats/support/fb40a00.a
deleted file mode 100644
index adffc69a301..00000000000
--- a/gcc/testsuite/ada/acats/support/fb40a00.a
+++ /dev/null
@@ -1,81 +0,0 @@
--- FB40A00.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- FOUNDATION DESCRIPTION:
--- This foundation package contains global variables, types, a user
--- defined exception, and two subprograms used to increment the
--- global variables.
--- See prologues of specific tests for specific information.
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
---
---!
-
-
-package FB40A00 is -- package Text_Parser
-
- -- Global Variables
-
- AlphaNumeric_Count,
- Non_AlphaNumeric_Count : Natural := 0;
-
-
- -- Types
-
- type String_Pointer_Type is access String;
-
-
- -- Exceptions
-
- Completed_Text_Processing : exception;
-
- -- Subprograms
-
- procedure Increment_AlphaNumeric_Count;
- procedure Increment_Non_AlphaNumeric_Count;
-
-end FB40A00;
-
-
- --=================================================================--
-
-
-package body FB40A00 is
-
-
- procedure Increment_AlphaNumeric_Count is
- begin
- AlphaNumeric_Count := AlphaNumeric_Count + 1;
- end Increment_AlphaNumeric_Count;
-
-
- procedure Increment_Non_AlphaNumeric_Count is
- begin
- Non_AlphaNumeric_Count := Non_AlphaNumeric_Count + 1;
- end Increment_Non_AlphaNumeric_Count;
-
-
-end FB40A00;
diff --git a/gcc/testsuite/ada/acats/support/fc50a00.a b/gcc/testsuite/ada/acats/support/fc50a00.a
deleted file mode 100644
index 4c37328135d..00000000000
--- a/gcc/testsuite/ada/acats/support/fc50a00.a
+++ /dev/null
@@ -1,92 +0,0 @@
--- FC50A00.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- FOUNDATION DESCRIPTION:
--- This foundation declares various tagged types which will be passed as
--- actuals to generic formal tagged private types. It also declares
--- various objects of these types, which will be used for testing.
--- The types defined are both discriminated and nondiscriminated.
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
---
---!
-
-package FC50A00 is
-
---
--- Nonlimited tagged types:
---
-
- type Count_Type is tagged record -- Nondiscriminated
- Count : Integer := 0; -- type.
- end record;
-
-
- subtype Str_Len is Natural range 0 .. 100;
- subtype Stu_ID is String (1 .. 5);
- subtype Dept_ID is String (1 .. 4);
- subtype Emp_ID is String (1 .. 9);
- type Status is (Student, Faculty, Staff);
- subtype Reserved is Positive range 1 .. 50;
-
-
- type Person_Type (Stat : Status; -- Discriminated
- NameLen, AddrLen : Str_Len) is -- type.
- tagged record
- Name : String (1 .. NameLen);
- Address : String (1 .. AddrLen);
- case Stat is
- when Student =>
- Student_ID : Stu_ID;
- when Faculty =>
- Department : Dept_ID;
- when Staff =>
- Employee_ID : Emp_ID;
- end case;
- end record;
-
-
- type VIPerson_Type is new Person_Type with record -- Extension of
- Parking_Space : Reserved; -- discriminated type.
- end record;
-
-
- -- Testing entities: ------------------------------------------------
-
- TC_Count_Item : constant Count_Type := (Count => 111);
- TC_Default_Count : constant Count_Type := (Count => 0);
-
- TC_Person_Item : constant Person_Type :=
- (Faculty, 18, 17, "Eccles, John Scott", "Popham House, Lee", "0931");
- TC_Default_Person : constant Person_Type :=
- (Student, 0, 0, "", "", "00000");
-
- TC_VIPerson_Item : constant VIPerson_Type := (TC_Person_Item with 1);
-
- ---------------------------------------------------------------------
-
-
-end FC50A00;
diff --git a/gcc/testsuite/ada/acats/support/fc51a00.a b/gcc/testsuite/ada/acats/support/fc51a00.a
deleted file mode 100644
index 9b584d7f8fc..00000000000
--- a/gcc/testsuite/ada/acats/support/fc51a00.a
+++ /dev/null
@@ -1,99 +0,0 @@
--- FC51A00.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- FOUNDATION DESCRIPTION:
--- This foundation defines a fraction type abstraction. Fractions are
--- implemented as records with two scalar components: a numerator
--- of type integer and a denominator of type positive. Fractions are
--- created via an overloaded "/" operator.
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
---
---!
-
-package FC51A00 is -- Fraction type abstraction.
-
- type Fraction_Type is private;
-
- -- Create a fraction object by integer division.
- function "/" (Left, Right : Integer) return Fraction_Type;
-
- -- Change the sign of a fraction.
- function "-" (Frac : Fraction_Type) return Fraction_Type;
-
- -- Return value of numerator as integer.
- function Numerator (Frac : Fraction_Type) return Integer;
-
- -- Return value of denominator as integer.
- function Denominator (Frac : Fraction_Type) return Integer;
-
- -- ... Other operations on fraction types.
-
-private
-
- type Fraction_Type is record
- Numerator : Integer;
- Denominator : Positive;
- end record;
-
-end FC51A00;
-
-
- --==================================================================--
-
-
-package body FC51A00 is
-
- function "/" (Left, Right : Integer) return Fraction_Type is
- Result : Fraction_Type;
- begin
- Result.Numerator := Left;
- Result.Denominator := Right;
- return Result;
- end "/";
-
-
- function "-" (Frac : Fraction_Type) return Fraction_Type is
- Result : Fraction_Type := Frac;
- begin
- Result.Numerator := -(Result.Numerator);
- return Result;
- end "-";
-
-
- function Numerator (Frac : Fraction_Type) return Integer is
- begin
- return (Frac.Numerator);
- end Numerator;
-
-
- function Denominator (Frac : Fraction_Type) return Integer is
- begin
- return (Frac.Denominator);
- end Denominator;
-
-
-end FC51A00;
diff --git a/gcc/testsuite/ada/acats/support/fc51b00.a b/gcc/testsuite/ada/acats/support/fc51b00.a
deleted file mode 100644
index 1d2b57e3231..00000000000
--- a/gcc/testsuite/ada/acats/support/fc51b00.a
+++ /dev/null
@@ -1,62 +0,0 @@
--- FC51B00.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- FOUNDATION DESCRIPTION:
--- This foundation declares a set of tagged and untagged indefinite
--- subtypes.
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
---
---!
-
-package FC51B00 is -- Type definitions.
-
- subtype Size is Natural range 1 .. 4;
-
- type Matrix is array -- Unconstrained array
- (Size range <>, Size range <>) of Integer; -- type.
-
- type Square (Side : Size) is record -- Unconstrained record
- Mat : Matrix (1 .. Side, 1 .. Side); -- with undefaulted
- end record; -- discriminants.
-
- type Square_Pair (Dimension : Size) is tagged record -- Unconstrained tagged
- Left : Square (Dimension); -- type.
- Right : Square (Dimension);
- end record;
-
- type Vector is tagged record -- Constrained tagged
- Mat : Matrix (1 .. 3, 1 .. 1); -- type (used to get
- end record; -- class-wide type).
-
- generic -- Template for a generic formal package.
- type Vectors (<>) is new Vector with private; -- Type with unknown
- package Signature is end; -- discriminants.
-
-end FC51B00;
-
-
--- No body for FC51B00;
diff --git a/gcc/testsuite/ada/acats/support/fc51c00.a b/gcc/testsuite/ada/acats/support/fc51c00.a
deleted file mode 100644
index 33364c95237..00000000000
--- a/gcc/testsuite/ada/acats/support/fc51c00.a
+++ /dev/null
@@ -1,112 +0,0 @@
--- FC51C00.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- FOUNDATION DESCRIPTION:
--- This foundation declares a hierarchy of tagged types, which includes
--- both abstract and non-abstract types, and which have both abstract
--- and non-abstract primitive subprograms.
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 03 Nov 95 SAIC ACVC 2.0.1 fixes: Deleted primitive operation Proc
--- of Concrete_Root.
--- 11 Aug 96 SAIC ACVC 2.1: Changed procedure bodies to update
--- actual parameters.
---
---!
-
-package FC51C00 is
-
---
--- Non-abstract ultimate ancestor type:
---
-
- type Concrete_Root is tagged null record;
-
- function Func (P: Concrete_Root) return Concrete_Root; -- Abstract when
- -- inherited.
-
-
---
--- Abstract descendant of non-abstract ultimate ancestor:
---
-
- type Abstract_Child is abstract new Concrete_Root with null record;
-
- -- Inherits:
- -- function Func (P: Abstract_Child) return Abstract_Child is abstract;
-
- procedure Proc (P: in out Abstract_Child) is abstract; -- Abstract.
- procedure New_Proc (P : out Abstract_Child) is abstract; -- Abstract.
-
-
-
---
--- Non-abstract descendant of abstract descendant:
---
-
- type Concrete_GrandChild is new Abstract_Child with null record;
-
- function Func (P: Concrete_GrandChild) return Concrete_GrandChild;
-
- procedure Proc (P: in out Concrete_GrandChild);
- procedure New_Proc (P : out Concrete_GrandChild);
-
-
-end FC51C00;
-
-
- --===================================================================--
-
-
-package body FC51C00 is
-
- Value : Concrete_GrandChild;
-
-
- function Func (P: Concrete_Root) return Concrete_Root is
- begin
- return P;
- end Func;
-
-
- function Func (P: Concrete_GrandChild) return Concrete_GrandChild is
- begin
- return P;
- end Func;
-
-
- procedure Proc (P: in out Concrete_GrandChild) is
- begin
- P := Value;
- end Proc;
-
-
- procedure New_Proc (P : out Concrete_GrandChild) is
- begin
- P := Value;
- end New_Proc;
-
-end FC51C00;
diff --git a/gcc/testsuite/ada/acats/support/fc51d00.a b/gcc/testsuite/ada/acats/support/fc51d00.a
deleted file mode 100644
index 4d31bb1341a..00000000000
--- a/gcc/testsuite/ada/acats/support/fc51d00.a
+++ /dev/null
@@ -1,82 +0,0 @@
--- FC51D00.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- FOUNDATION DESCRIPTION:
--- This foundation defines a generic list abstraction. List elements can
--- be of any (nonlimited) type. Lists are implemented as arrays of
--- pointers and are only two elements in length.
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
---
---!
-
-generic
- type Element_Type (<>) is private;
-package FC51D00 is -- This package simulates a generic list abstraction.
-
- -- The definition of List_Type below is purely artificial; its validity
- -- in the context of the abstraction is irrelevant to the feature being
- -- tested.
-
- type Element_Ptr is access Element_Type;
-
- subtype List_Size is Natural range 1 .. 2;
- type List_Type is array (List_Size) of Element_Ptr;
-
- function View_Element (I : List_Size; L : List_Type) return Element_Type;
-
- procedure Write_Element (I : in List_Size;
- L : in out List_Type;
- E : in Element_Type);
-
- -- ... Other list operations for Element_Type.
-
-end FC51D00;
-
-
- --==================================================================--
-
-
-package body FC51D00 is
-
- -- The implementations of the operations below are purely artificial; the
- -- validity of their implementations in the context of the abstraction is
- -- irrelevant to the feature being tested.
-
- function View_Element (I : List_Size; L : List_Type) return Element_Type is
- begin
- return L(I).all;
- end View_Element;
-
-
- procedure Write_Element (I : in List_Size;
- L : in out List_Type;
- E : in Element_Type) is
- begin
- L(I) := new Element_Type'(E);
- end Write_Element;
-
-end FC51D00;
diff --git a/gcc/testsuite/ada/acats/support/fc54a00.a b/gcc/testsuite/ada/acats/support/fc54a00.a
deleted file mode 100644
index 16bf742defa..00000000000
--- a/gcc/testsuite/ada/acats/support/fc54a00.a
+++ /dev/null
@@ -1,132 +0,0 @@
--- FC54A00.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- FOUNDATION DESCRIPTION:
--- This foundation declares various types which will serve as designated
--- types for tests involving generic formal access types (including
--- access-to-subprogram types).
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
---
---!
-
-package FC54A00 is
-
-
- -- Discrete (integer) types:
-
- Bits : constant := 8; -- Named number.
-
- type Numerals is range -256 .. 255;
- type New_Numerals is new Numerals range -128 .. 127;
- subtype Positives is Numerals range 0 .. 255;
- subtype Same_Numerals is Numerals;
- subtype Numerals_Static is Numerals range -2**Bits .. 2**Bits - 1;
-
- Min : Numerals := Numerals'First; -- Variable.
- Max : Integer := 255; -- Variable.
-
- subtype Numerals_Nonstatic is Numerals range Min .. 255;
- subtype Positive_Nonstatic is Positives range 0 .. Positives(Max);
- subtype Pos_Dupl_Nonstatic is Positives range 0 .. Positives(Max);
- subtype Pos_Attr_Nonstatic is Positives range Positive_Nonstatic'Range;
-
-
-
- -- Floating point types:
-
- type Float_Type is digits 3;
- type New_Float is new Float_Type;
- subtype Float_100 is Float_Type range 0.0 .. 100.0;
- subtype Same_Float is Float_Type;
-
- Hundred : constant := 100.0; -- Named number.
-
- type Float_With_Range is digits 3 range 0.0 .. 100.0;
- subtype Float_Same_Range is Float_With_Range range 0.0 .. Hundred;
-
-
-
- -- Tagged record types:
-
- subtype Lengths is Natural range 0 .. 50;
-
- type Parent is abstract tagged null record;
-
- type Tag (Len: Lengths) is new Parent with record
- Msg : String (1 .. Len);
- end record;
-
- type New_Tag is new Tag with record
- Sent : Boolean;
- end record;
-
- subtype Same_Tag is Tag;
-
- Twenty : constant := 20; -- Named number.
-
- subtype Tag20 is Tag (Len => 20);
- subtype Tag25 is Tag (25);
- subtype Tag_Twenty is Tag (Twenty);
-
- My_Len : Lengths := Twenty; -- Variable.
- subtype Sub_Length is Lengths range 1 .. My_Len;
-
- subtype Tag20_Nonstatic is Tag (Len => Sub_Length'Last);
- subtype Tag20_Dupl_Nonstatic is Tag (Sub_Length'Last);
- subtype Tag20_Same_Nonstatic is Tag20_Nonstatic;
- subtype Tag20_Var_Nonstatic is Tag (Len => My_Len);
-
-
-
- -- Access types (designated type is tagged):
-
- type Tagged_Ptr is access Tag;
- type Tag_Class_Ptr is access Tag'Class;
-
- subtype Msg_Ptr_Static is Tagged_Ptr(Twenty);
-
-
-
- -- Array types:
-
- type New_String is new String;
- subtype Same_String is String;
-
- Ten : constant := 10; -- Named number.
-
- subtype Msg_Static is String(1 .. Ten);
- type Msg10 is new String(1 .. 10);
- subtype Msg20 is String(1 .. 20);
-
- Size : Positive := 10;
-
- subtype Msg_Nonstatic is String(1 .. Size);
- subtype Msg_Dupl_Nonstatic is String(1 .. Size);
- subtype Msg_Same_Nonstatic is Msg_Nonstatic;
-
-
-end FC54A00;
diff --git a/gcc/testsuite/ada/acats/support/fc70a00.a b/gcc/testsuite/ada/acats/support/fc70a00.a
deleted file mode 100644
index e903a13ade3..00000000000
--- a/gcc/testsuite/ada/acats/support/fc70a00.a
+++ /dev/null
@@ -1,117 +0,0 @@
--- FC70A00.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- FOUNDATION DESCRIPTION:
--- This file simulates a generic complex integer support package, to be
--- used for tests covering generic formal packages.
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
---
---!
-
-generic -- Complex integer abstraction.
- type Int_Type is range <>;
-package FC70A00 is
-
- -- Simulate a generic complex integer support package. Complex integers
- -- are treated as coordinates in the Cartesian plane.
-
-
- type Complex_Type is private;
-
- Zero : constant Complex_Type; -- (0,0).
- One : constant Complex_Type; -- (1,0).
-
-
- function "-" (Right : Complex_Type) -- Invert a complex
- return Complex_Type; -- integer.
-
- function "+" (Left, Right : Complex_Type) -- Add two complex
- return Complex_Type; -- integers.
-
- function "*" (Left, Right : Complex_Type) -- Multiply two complex
- return Complex_Type; -- integers.
-
- function Reciprocal (Right : Complex_Type) -- Return the reciprocal
- return Complex_Type; -- of a complex integer.
-
- function Complex (Real, Imag : Int_Type) -- Create a complex
- return Complex_Type; -- integer.
-
-private
-
- type Complex_Type is record
- Real : Int_Type;
- Imag : Int_Type;
- end record;
-
- Zero : constant Complex_Type := (Real => 0, Imag => 0);
- One : constant Complex_Type := (Real => 1, Imag => 0);
-
-end FC70A00;
-
-
- --==================================================================--
-
-
-package body FC70A00 is -- Complex integer abstraction.
-
- function Complex (Real, Imag : Int_Type) return Complex_Type is
- begin
- return ( (Real, Imag) );
- end Complex;
-
- --==============================================--
-
- function "-" (Right : Complex_Type) return Complex_Type is
- begin
- return ( (-Right.Real, -Right.Imag) );
- end "-";
-
- --==============================================--
-
- function "+" (Left, Right : Complex_Type) return Complex_Type is
- begin
- return ( (Left.Real + Right.Real, Left.Imag + Right.Imag) );
- end "+";
-
- --==============================================--
-
- function "*" (Left, Right : Complex_Type) return Complex_Type is
- begin
- return ( (Real => (Left.Real * Right.Real) - (Left.Imag * Right.Imag),
- Imag => (Left.Imag * Right.Real) + (Left.Real * Right.Imag)) );
- end "*";
-
- --==============================================--
-
- function Reciprocal (Right : Complex_Type) return Complex_Type is
- Denominator : Int_Type := Right.Real**2 + Right.Imag**2;
- begin -- NOTE: Results are truncated.
- return ( (Right.Real/Denominator, -Right.Imag/Denominator) );
- end Reciprocal;
-
-end FC70A00;
diff --git a/gcc/testsuite/ada/acats/support/fc70b00.a b/gcc/testsuite/ada/acats/support/fc70b00.a
deleted file mode 100644
index 46b106e0b25..00000000000
--- a/gcc/testsuite/ada/acats/support/fc70b00.a
+++ /dev/null
@@ -1,133 +0,0 @@
--- FC70B00.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- FOUNDATION DESCRIPTION:
--- This foundation defines a generic list abstraction. List elements can
--- be of any (nonlimited) type. Lists are implemented as singly linked
--- lists. Access to list elements is sequential. For each list, pointers
--- are maintained to the first and last elements in the list, as well as
--- the next element to be accessed.
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
---
---!
-
-generic -- List abstraction.
- type Element_Type is private; -- List elems can be of any nonlimited type.
-package FC70B00 is
-
- type List_Type is limited private;
-
- -- Return true if current element is last in the list.
- function End_Of_List (L : List_Type) return Boolean;
-
- -- Read current element value; do NOT advance "current" pointer.
- procedure View_Element (L : in List_Type; E : out Element_Type);
-
- -- Read from current element and advance "current" pointer.
- procedure Read_Element (L : in out List_Type; E : out Element_Type);
-
- -- Write to current element and advance "current" pointer.
- procedure Write_Element (L : in out List_Type; E : in Element_Type);
-
- -- Add element to end of list.
- procedure Add_Element (L : in out List_Type; E : in Element_Type);
-
- -- Set "current" pointer to first list element.
- procedure Reset (L : in out List_Type);
-
-private
-
- type Node_Type;
- type Node_Pointer is access Node_Type;
-
- type Node_Type is record
- Item : Element_Type;
- Next : Node_Pointer;
- end record;
-
- type List_Type is record
- First : Node_Pointer;
- Current : Node_Pointer;
- Last : Node_Pointer;
- end record;
-
-end FC70B00;
-
-
- --==================================================================--
-
-
-package body FC70B00 is
-
- function End_Of_List (L : List_Type) return Boolean is
- begin
- return (L.Current = null);
- end End_Of_List;
-
-
- procedure View_Element (L : in List_Type; E : out Element_Type) is
- begin
- -- ... Error-checking code omitted for brevity.
- E := L.Current.Item; -- Retrieve current element.
- end View_Element;
-
-
- procedure Read_Element (L : in out List_Type; E : out Element_Type) is
- begin
- -- ... Error-checking code omitted for brevity.
- E := L.Current.Item; -- Retrieve current element.
- L.Current := L.Current.Next; -- Advance "current" pointer.
- end Read_Element;
-
-
- procedure Write_Element (L : in out List_Type; E : in Element_Type) is
- begin
- -- ... Error-checking code omitted for brevity.
- L.Current.Item := E; -- Write to current element.
- L.Current := L.Current.Next; -- Advance "current" pointer.
- end Write_Element;
-
-
- procedure Add_Element (L : in out List_Type; E : in Element_Type) is
- New_Node : Node_Pointer := new Node_Type'(E, null);
- begin
- if L.First = null then -- No elements in list, so add new
- L.First := New_Node; -- element at beginning of list.
- else
- L.Last.Next := New_Node; -- Add new element at end of list.
- end if;
- L.Last := New_Node; -- Set last-in-list pointer.
- end Add_Element;
-
-
- procedure Reset (L : in out List_Type) is
- begin
- L.Current := L.First; -- Set "current" pointer to first
- end Reset; -- list element.
-
-
-end FC70B00;
diff --git a/gcc/testsuite/ada/acats/support/fc70c00.a b/gcc/testsuite/ada/acats/support/fc70c00.a
deleted file mode 100644
index 140b2401065..00000000000
--- a/gcc/testsuite/ada/acats/support/fc70c00.a
+++ /dev/null
@@ -1,100 +0,0 @@
--- FC70C00.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- FOUNDATION DESCRIPTION:
--- This foundation defines a generic list abstraction in two packages.
--- The first package declares the types, the second declares the
--- operations. List elements can be of any (nonlimited) type. Lists are
--- implemented as singly linked lists. Access to list elements is
--- sequential. For each list, pointers are maintained to the first and
--- last elements in the list, as well as the next element to be accessed.
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
---
---!
-
-generic
- type Element_Type is private; -- List elems may be of any nonlimited type.
-package FC70C00_0 is -- List abstraction.
-
- type Node_Type;
- type Node_Pointer is access Node_Type;
-
- type Node_Type is record
- Item : Element_Type;
- Next : Node_Pointer;
- end record;
-
- type List_Type is record
- First : Node_Pointer;
- Current : Node_Pointer;
- Last : Node_Pointer;
- end record;
-
-end FC70C00_0;
-
-
- --==================================================================--
-
-
--- No body for FC70C00_0;
-
-
- --==================================================================--
-
-
-with FC70C00_0; -- List abstraction.
-generic
- with package List_Mgr is new FC70C00_0 (<>);
-package FC70C00_1 is -- Basic list operations.
-
- -- Return true if current element is last in the list.
- function End_Of_List (L : List_Mgr.List_Type) return Boolean;
-
- -- Set "current" pointer to first list element.
- procedure Reset (L : in out List_Mgr.List_Type);
-
-end FC70C00_1;
-
-
- --==================================================================--
-
-
-package body FC70C00_1 is
-
- function End_Of_List (L : List_Mgr.List_Type) return Boolean is
- use List_Mgr; -- Renders "=" directly visible.
- begin
- return (L.Current = null);
- end End_Of_List;
-
-
- procedure Reset (L : in out List_Mgr.List_Type) is
- begin
- L.Current := L.First; -- Set "current" pointer to first
- end Reset; -- list element.
-
-end FC70C00_1;
diff --git a/gcc/testsuite/ada/acats/support/fd72a00.a b/gcc/testsuite/ada/acats/support/fd72a00.a
deleted file mode 100644
index fe662ca2601..00000000000
--- a/gcc/testsuite/ada/acats/support/fd72a00.a
+++ /dev/null
@@ -1,84 +0,0 @@
--- FD72A00.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- FOUNDATION DESCRIPTION:
--- This foundation provides a basis for testing package
--- System.Address_To_Access_Conversions
---
--- TEST FILES:
--- The following files comprise this foundation:
---
--- FD72A00.A
---
--- CHANGE HISTORY:
--- 08 FEB 96 SAIC Initial version
---
---!
-
-with Impdef;
-with System.Storage_Elements;
-package FD72A00 is
- use System;
-
- subtype Number is System.Storage_Elements.Integer_Address;
-
- package Num_IO renames Impdef.Address_Value_IO;
-
- -- the following conversions To/From Hex are to prevent optimizers from
- -- optimizing out the otherwise senseless identity conversions, and
- -- given the unknown nature of the type Number, the Identity operations
- -- provided in Report will not suffice to this cause.
-
- function Address_To_Hex( Adder: System.Address ) return String;
-
- function Hex_To_Address( Hex: access String ) return System.Address;
-
-end FD72A00;
-
-package body FD72A00 is
-
- function Address_To_Hex( Adder: System.Address ) return String is
- S : String(1..64)
- := "uninitializedDEFuninitializedDEFuninitializedDEFuninitializedDEF";
- DeBlank : Positive := S'First;
- begin
- Num_IO.Put( S, Number( System.Storage_Elements.To_Integer( Adder ) ),
- Base => 16 );
- while S(DeBlank) = ' ' loop
- DeBlank := DeBlank +1;
- end loop;
- return S(DeBlank..S'Last);
- end Address_To_Hex;
-
- function Hex_To_Address( Hex: access String ) return System.Address is
- The_Number : Number;
- Tail : Natural;
- begin
- Num_IO.Get( Hex.all, The_Number, Tail );
- return System.Storage_Elements.To_Address(
- System.Storage_Elements.Integer_Address( The_Number ) );
- end Hex_To_Address;
-
-end FD72A00;
diff --git a/gcc/testsuite/ada/acats/support/fdb0a00.a b/gcc/testsuite/ada/acats/support/fdb0a00.a
deleted file mode 100644
index 4888c24aa9b..00000000000
--- a/gcc/testsuite/ada/acats/support/fdb0a00.a
+++ /dev/null
@@ -1,144 +0,0 @@
--- FDB0A00.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- FOUNDATION DESCRIPTION:
--- This foundation provides the basis for testing package
--- System.Storage_Pools. It provides simple implementations of
--- Allocate and Deallocate that have the side effect of calling
--- TCTouch.Touch when they are called.
---
--- CHANGE HISTORY:
--- 02 JUN 95 SAIC Initial version
--- 05 APR 96 SAIC Fixed header for 2.1
--- 02 JUL 98 EDS Swapped Pool.Avail change with overflow check
---!
-
----------------------------------------------------------------- FDB0A00
-
-with Report;
-with System.Storage_Pools;
-with System.Storage_Elements;
-package FDB0A00 is
-
- type Stack_Heap( Water_Line: System.Storage_Elements.Storage_Count )
- is new System.Storage_Pools.Root_Storage_Pool with private;
-
- procedure Allocate(
- Pool : in out Stack_Heap;
- Storage_Address : out System.Address;
- Size_In_Storage_Elements : in System.Storage_Elements.Storage_Count;
- Alignment : in System.Storage_Elements.Storage_Count);
-
- procedure Deallocate(
- Pool : in out Stack_Heap;
- Storage_Address : in System.Address;
- Size_In_Storage_Elements : in System.Storage_Elements.Storage_Count;
- Alignment : in System.Storage_Elements.Storage_Count);
-
- function Storage_Size( Pool: in Stack_Heap )
- return System.Storage_Elements.Storage_Count;
-
- function TC_Largest_Request return System.Storage_Elements.Storage_Count;
-
- Pool_Overflow : exception;
-
-private
-
- type Data_Array is array(System.Storage_Elements.Storage_Count range <>)
- of System.Storage_Elements.Storage_Element;
-
- type Stack_Heap( Water_Line: System.Storage_Elements.Storage_Count )
- is new System.Storage_Pools.Root_Storage_Pool with record
- Data : Data_Array(1..Water_Line);
- Avail : System.Storage_Elements.Storage_Count := 1;
- end record;
-
-end FDB0A00;
-
--- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
-
-with TCTouch;
-package body FDB0A00 is
-
- Largest_Request_On_Record : System.Storage_Elements.Storage_Count := 0;
-
- procedure Allocate(
- Pool : in out Stack_Heap;
- Storage_Address : out System.Address;
- Size_In_Storage_Elements : in System.Storage_Elements.Storage_Count;
- Alignment : in System.Storage_Elements.Storage_Count) is
- use type System.Storage_Elements.Storage_Offset;
- begin
- TCTouch.Touch('A'); --------------------------------------------------- A
-
- -- set the pointer to the next correctly aligned available address
- Pool.Avail := Pool.Avail
- + (Alignment - (Pool.Data(Pool.Avail)'Address mod Alignment));
-
- -- check for overflow
- if Pool.Avail + Size_In_Storage_Elements > Pool.Water_Line then
- raise Pool_Overflow;
- end if;
-
- -- set the resulting address to that address
- Storage_Address := Pool.Data(Pool.Avail)'Address;
-
- -- update the housekeeping
- Pool.Avail := Pool.Avail + Size_In_Storage_Elements;
- Largest_Request_On_Record
- := System.Storage_Elements.Storage_Count'Max(Largest_Request_On_Record,
- Size_In_Storage_Elements);
- exception
- when Constraint_Error => raise Pool_Overflow; -- in case I missed an edge
- end Allocate;
-
- procedure Deallocate(
- Pool : in out Stack_Heap;
- Storage_Address : in System.Address;
- Size_In_Storage_Elements : in System.Storage_Elements.Storage_Count;
- Alignment : in System.Storage_Elements.Storage_Count) is
- begin
- TCTouch.Touch('D'); --------------------------------------------------- D
-
- -- for the purposes of validation, the simplest possible implementation
- -- of Deallocate is shown below:
-
- null;
-
- end Deallocate;
-
- function Storage_Size( Pool: in Stack_Heap )
- return System.Storage_Elements.Storage_Count is
- begin
- TCTouch.Touch('S'); --------------------------------------------------- S
- return Pool.Water_Line;
- end Storage_Size;
-
- function TC_Largest_Request return System.Storage_Elements.Storage_Count is
- begin
- return Largest_Request_On_Record;
- end TC_Largest_Request;
-
-end FDB0A00;
diff --git a/gcc/testsuite/ada/acats/support/fdd2a00.a b/gcc/testsuite/ada/acats/support/fdd2a00.a
deleted file mode 100644
index 43a11101d61..00000000000
--- a/gcc/testsuite/ada/acats/support/fdd2a00.a
+++ /dev/null
@@ -1,149 +0,0 @@
--- FDD2A00.A
---
--- Grant of Unlimited Rights
---
--- The Ada Conformity Assessment Authority (ACAA) holds unlimited
--- rights in the software and documentation contained herein. Unlimited
--- rights are the same as those granted by the U.S. Government for older
--- parts of the Ada Conformity Assessment Test Suite, and are defined
--- in DFAR 252.227-7013(a)(19). By making this public release, the ACAA
--- intends to confer upon all recipients unlimited rights equal to those
--- held by the ACAA. These rights include rights to use, duplicate,
--- release or disclose the released technical data and computer software
--- in whole or in part, in any manner and for any purpose whatsoever, and
--- to have or permit others to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---
---
--- FOUNDATION DESCRIPTION:
--- This foundation provides the basis for testing user-defined stream
--- attributes. It provides operations which count calls to stream
--- attributes.
---
--- CHANGE HISTORY:
--- 30 JUL 2001 PHL Initial version.
--- 5 DEC 2001 RLB Reformatted for ACATS.
---
-
-with Ada.Streams;
-use Ada.Streams;
-package FDD2A00 is
-
- type Kinds is (Read, Write, Input, Output);
- type Counts is array (Kinds) of Natural;
-
-
- type My_Stream (Size : Stream_Element_Count) is new Root_Stream_Type with
- record
- First : Stream_Element_Offset := 1;
- Last : Stream_Element_Offset := 0;
- Contents : Stream_Element_Array (1 .. Size);
- end record;
-
- procedure Clear (Stream : in out My_Stream);
-
- procedure Read (Stream : in out My_Stream;
- Item : out Stream_Element_Array;
- Last : out Stream_Element_Offset);
-
- procedure Write (Stream : in out My_Stream; Item : in Stream_Element_Array);
-
-
- generic
- type T (<>) is limited private;
- with procedure Actual_Write
- (Stream : access Root_Stream_Type'Class; Item : T);
- with function Actual_Input
- (Stream : access Root_Stream_Type'Class) return T;
- with procedure Actual_Read (Stream : access Root_Stream_Type'Class;
- Item : out T);
- with procedure Actual_Output
- (Stream : access Root_Stream_Type'Class; Item : T);
- package Counting_Stream_Ops is
-
- procedure Write (Stream : access Root_Stream_Type'Class; Item : T);
- function Input (Stream : access Root_Stream_Type'Class) return T;
- procedure Read (Stream : access Root_Stream_Type'Class; Item : out T);
- procedure Output (Stream : access Root_Stream_Type'Class; Item : T);
-
- function Get_Counts return Counts;
-
- end Counting_Stream_Ops;
-
-end FDD2A00;
-package body FDD2A00 is
-
- procedure Clear (Stream : in out My_Stream) is
- begin
- Stream.First := 1;
- Stream.Last := 0;
- end Clear;
-
- procedure Read (Stream : in out My_Stream;
- Item : out Stream_Element_Array;
- Last : out Stream_Element_Offset) is
- begin
- if Item'Length >= Stream.Last - Stream.First + 1 then
- Item (Item'First .. Item'First + Stream.Last - Stream.First) :=
- Stream.Contents (Stream.First .. Stream.Last);
- Last := Item'First + Stream.Last - Stream.First;
- Stream.First := Stream.Last + 1;
- else
- Item := Stream.Contents (Stream.First ..
- Stream.First + Item'Length - 1);
- Last := Item'Last;
- Stream.First := Stream.First + Item'Length;
- end if;
- end Read;
-
- procedure Write (Stream : in out My_Stream;
- Item : in Stream_Element_Array) is
- begin
- Stream.Contents (Stream.Last + 1 .. Stream.Last + Item'Length) := Item;
- Stream.Last := Stream.Last + Item'Length;
- end Write;
-
-
- package body Counting_Stream_Ops is
- Cnts : Counts := (others => 0);
-
- procedure Write (Stream : access Root_Stream_Type'Class; Item : T) is
- begin
- Cnts (Write) := Cnts (Write) + 1;
- Actual_Write (Stream, Item);
- end Write;
-
- function Input (Stream : access Root_Stream_Type'Class) return T is
- begin
- Cnts (Input) := Cnts (Input) + 1;
- return Actual_Input (Stream);
- end Input;
-
- procedure Read (Stream : access Root_Stream_Type'Class; Item : out T) is
- begin
- Cnts (Read) := Cnts (Read) + 1;
- Actual_Read (Stream, Item);
- end Read;
-
- procedure Output (Stream : access Root_Stream_Type'Class; Item : T) is
- begin
- Cnts (Output) := Cnts (Output) + 1;
- Actual_Output (Stream, Item);
- end Output;
-
- function Get_Counts return Counts is
- begin
- return Cnts;
- end Get_Counts;
-
- end Counting_Stream_Ops;
-
-end FDD2A00;
diff --git a/gcc/testsuite/ada/acats/support/fxa5a00.a b/gcc/testsuite/ada/acats/support/fxa5a00.a
deleted file mode 100644
index 6b2fcef7d7e..00000000000
--- a/gcc/testsuite/ada/acats/support/fxa5a00.a
+++ /dev/null
@@ -1,121 +0,0 @@
--- FXA5A00.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- FOUNDATION DESCRIPTION:
--- This foundation package contains constants and a function used in
--- the evaluation of the Generic Elementary Functions.
---
--- CHANGE HISTORY:
--- 06 Mar 95 SAIC Initial prerelease version.
--- 03 Apr 95 SAIC Corrected error in context clause.
--- 12 Jun 95 SAIC Added procedure Dont_Optimize. Added New_Float
--- type, and overload of function
--- Result_Within_Range.
---
---!
-
-with Ada.Numerics;
-with Report;
-
-package FXA5A00 is
-
- -- Constants.
-
- Epsilon : constant Float := Float'Model_Epsilon;
- Small : constant Float := Float'Model_Small;
- Large : constant Float := Float'Safe_Last;
- Minus_Large : constant Float := Float'Safe_First;
-
- Half_Pi : constant Float := Ada.Numerics.Pi / 2.0;
- Two_Pi : constant Float := Ada.Numerics.Pi * 2.0;
-
- Floating_Delta : constant Float := 0.05;
- One_Plus_Delta : constant Float := 1.0 + Floating_Delta;
- One_Minus_Delta : constant Float := 1.0 - Floating_Delta;
- Minus_One_Plus_Delta : constant Float := -1.0 + Floating_Delta;
- Minus_One_Minus_Delta : constant Float := -1.0 - Floating_Delta;
-
-
- type New_Float is new Float digits 6;
-
- function Result_Within_Range (Result : Float;
- Expected_Result : Float;
- Relative_Error : Float) return Boolean;
-
- function Result_Within_Range (Result : New_Float;
- Expected_Result : Float;
- Relative_Error : Float) return Boolean;
-
- -- This procedure is designed to defeat optimization attempts by an
- -- implementation in cases where an exception is specifically raised
- -- in a test to test a prescribed exception result condition.
- -- The parameter Num is a unique identifier for location purposes within
- -- the test.
-
- generic
- type Eval_Type is digits <>;
- procedure Dont_Optimize (Check_Result : Eval_Type;
- Num : Integer);
-
-end FXA5A00;
-
----
-
-package body FXA5A00 is
-
-
- function Result_Within_Range (Result : Float;
- Expected_Result : Float;
- Relative_Error : Float) return Boolean is
- begin
- return (Result <= Expected_Result + Relative_Error) and
- (Result >= Expected_Result - Relative_Error);
- end Result_Within_Range;
-
-
- function Result_Within_Range (Result : New_Float;
- Expected_Result : Float;
- Relative_Error : Float) return Boolean is
- begin
- return (Float(Result) <= Expected_Result + Relative_Error) and
- (Float(Result) >= Expected_Result - Relative_Error);
- end Result_Within_Range;
-
-
- procedure Dont_Optimize (Check_Result : Eval_Type;
- Num : Integer) is
- begin
- -- Note that the use of Minus_Large here is simply as a "dummy" value,
- -- designed to indicate use of the Check_Result parameter, and has no
- -- pass/fail significance to any test using this procedure.
- --
- if Float(Check_Result) = Minus_Large then
- Report.Comment("Attempted Defeat of Optimization ONLY -- Not " &
- "a cause for test failure! " &
- "Result = Minus_Large, Case:" & Integer'Image(Num));
- end if;
- end Dont_Optimize;
-
-end FXA5A00;
diff --git a/gcc/testsuite/ada/acats/support/fxaca00.a b/gcc/testsuite/ada/acats/support/fxaca00.a
deleted file mode 100644
index d8aa5e5929e..00000000000
--- a/gcc/testsuite/ada/acats/support/fxaca00.a
+++ /dev/null
@@ -1,144 +0,0 @@
--- FXACA00.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- FOUNDATION DESCRIPTION:
--- This foundation consists of type definitions and object declarations
--- used by tests of Stream_IO functionality.
--- Objects of both record types specified below (discriminated records
--- with defaults, and discriminated records w/o defaults that have the
--- discriminant included in a representation clause for the type) should
--- have their discriminants included in the stream when using 'Write
--- Likewise, discriminants should be extracted from the stream when
--- using 'Read.
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 02 May 96 SAIC Incorporated reviewer comments for ACVC 2.1.
---
---!
-
-with ImpDef;
-
-package FXACA00 is
-
- type Origin_Type is (Foreign, Domestic);
-
- for Origin_Type'Size use 1; -- Forces objects of the type to be
- -- representable in 1 bit, used in rep clause
- -- below for Sales_Record_Type.
-
- type Product_Type (Manufacture : Origin_Type := Domestic) is
- record
- Item : String (1..8);
- ID : Natural range 1..100;
- case Manufacture is
- when Foreign =>
- Importer : String (1..10);
- when Domestic =>
- Distributor : String (1..10);
- end case;
- end record;
-
-
- type Sales_Record_Type (Buyer : Origin_Type) is -- No default provided
- record -- for the discriminant.
- Name : String (1..6);
- Sale_Item : Boolean := False;
- case Buyer is
- when Foreign =>
- Quantity_Discount : Boolean;
- when Domestic =>
- Cash_Discount : Boolean;
- end case;
- end record;
-
-
- String_Bits : constant := ImpDef.Char_Bits * 6 - 1;
-
- -- This discriminated record type has a representation clause that
- -- includes the discriminant of the object of this type.
-
- for Sales_Record_Type use
- record
- Name at 0 range 0..String_Bits;
- Sale_Item at ImpDef.Next_Storage_Slot range 0..0;
- Buyer at ImpDef.Next_Storage_Slot range 1..1;
- Quantity_Discount at ImpDef.Next_Storage_Slot range 2..2;
- Cash_Discount at ImpDef.Next_Storage_Slot range 3..3;
- end record;
-
-
- type Timespan_Type is (Week, Month, Year);
-
- type Sales_Statistics_Type is
- array (Timespan_Type) of natural range 0 .. 500;
-
-
- -- Object Declarations
-
-
- Product_01 : Product_Type := (Domestic, "Product1", 1, "Distrib 01");
- Product_02 : Product_Type (Manufacture => Foreign) := (Foreign,
- "Product2",
- 2,
- "Importer02");
- Product_03 : Product_Type (Foreign) := (Manufacture => Foreign,
- Item => "Product3",
- ID => 3,
- Importer => "Importer03");
- --
-
- Sale_Count_01 : Integer := 2;
- Sale_Count_02 : Integer := 0;
- Sale_Count_03 : Integer := 3;
-
- --
-
- Sale_Rec_01 : Sales_Record_Type (Domestic) :=
- (Domestic, "Buyer1", False, True);
- Sale_Rec_02 : Sales_Record_Type (Domestic) :=
- (Domestic, "Buyer2", True, False);
-
- Sale_Rec_03 : Sales_Record_Type (Buyer => Foreign) :=
- (Buyer => Foreign, Name => "Buyer3", Sale_Item => True,
- Quantity_Discount => True);
-
- Sale_Rec_04 : Sales_Record_Type (Foreign) :=
- (Foreign, "Buyer4", True, False);
- Sale_Rec_05 : Sales_Record_Type (Buyer => Foreign) := (Foreign,
- "Buyer5",
- False,
- False);
- --
-
-
- Product_01_Stats : Sales_Statistics_Type := (2,4,8);
- Product_02_Stats : Sales_Statistics_Type := (Week => 0,
- Month => 5,
- Year => 10);
- Product_03_Stats : Sales_Statistics_Type := (3, 6, others => 12);
-
-
-end FXACA00;
diff --git a/gcc/testsuite/ada/acats/support/fxacb00.a b/gcc/testsuite/ada/acats/support/fxacb00.a
deleted file mode 100644
index 22b50efb0bb..00000000000
--- a/gcc/testsuite/ada/acats/support/fxacb00.a
+++ /dev/null
@@ -1,107 +0,0 @@
--- FXACB00.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- FOUNDATION DESCRIPTION:
--- This foundation consists of type definitions and object declarations
--- used by tests of Stream_IO functionality.
--- These types include an unconstrained array type, and a discriminated
--- record without a default discriminant, specifically chosen for use in
--- demonstrating the capabilities of 'Output and 'Input.
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
---
---!
-
-package FXACB00 is
-
- type Customer_Type is (Residence, Apartment, Commercial);
- type Electric_Usage_Type is range 0..100000;
- type Months_In_Service_Type is range 1..12;
- type Quarterly_Period_Type is (Spring, Summer, Autumn, Winter);
- subtype Month_In_Quarter_Type is Positive range 1..3;
- type Service_History_Type is
- array (Quarterly_Period_Type range <>, Month_In_Quarter_Type range <>)
- of Electric_Usage_Type;
-
-
- type Service_Type (Customer : Customer_Type) is
- record
- Name : String (1..21);
- Account_ID : Natural range 0..100;
- case Customer is
- when Residence | Apartment =>
- Low_Income_Credit : Boolean := False;
- when Commercial =>
- Baseline_Allowance : Natural range 0..1000;
- Quantity_Discount : Boolean := False;
- end case;
- end record;
-
-
- -- Object Declarations
-
-
- Customer1 : Service_Type (Residence) :=
- (Residence, "1221 Morningstar Lane", 44, False);
- Customer2 : Service_Type (Apartment) := (Customer => Apartment,
- Account_ID => 67,
- Name => "15 South Front St. #8",
- Low_Income_Credit => True);
- Customer3 : Service_Type (Commercial) := (Commercial,
- "12442 Central Avenue ",
- 100,
- Baseline_Allowance => 938,
- Quantity_Discount => True);
-
- --
-
- C1_Months : Months_In_Service_Type := 10;
- C2_Months : Months_In_Service_Type := 2;
- C3_Months : Months_In_Service_Type := 12;
-
- --
-
- C1_Service_History :
- Service_History_Type (Quarterly_Period_Type, Month_In_Quarter_Type) :=
- (Spring => (1 => 35, 2 => 39, 3 => 32),
- Summer => (1 => 34, 2 => 33, 3 => 39),
- Autumn => (1 => 45, 2 => 40, 3 => 38),
- Winter => (1 => 53, 2 => 0, 3 => 0));
-
- C2_Service_History :
- Service_History_Type (Quarterly_Period_Type range Spring..Summer,
- Month_In_Quarter_Type) :=
- (Spring => (23, 22, 0), Summer => (0, 0, 0));
-
- C3_Service_History :
- Service_History_Type (Quarterly_Period_Type, Month_In_Quarter_Type) :=
- (others => (others => 200));
-
- --
-
- Total_Customers_In_Service : constant Natural := 3;
-
-end FXACB00;
diff --git a/gcc/testsuite/ada/acats/support/fxacc00.a b/gcc/testsuite/ada/acats/support/fxacc00.a
deleted file mode 100644
index 64d63bed9fd..00000000000
--- a/gcc/testsuite/ada/acats/support/fxacc00.a
+++ /dev/null
@@ -1,115 +0,0 @@
--- FXACC00.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- FOUNDATION DESCRIPTION:
--- This foundation consists of a tagged type definition and several
--- record extensions. Objects of each type have also been declared
--- and given initial values.
---
--- Visual Description of Type Extensions:
---
--- type Ticket_Request
--- |
--- _______________|_________________
--- | |
--- | |
--- type Subscriber_Request type VIP_Request
--- |
--- |
--- type Last_Minute_Request
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
---
---!
-
-with Ada.Calendar;
-
-package FXACC00 is
-
- type Location_Type is (Backstage, Orchestra, Center, Back, Balcony);
- type Quantity_Type is range 1 .. 100;
- subtype Season_Ticket_Type is Positive range 1 .. 1750;
- type VIP_Status_Type is (Mayor, City_Council, Visitor);
- type Donation_Type is (To_Charity, To_Theatre, Personal);
-
- Show_Of_Appreciation : constant Boolean := True;
-
- type Ticket_Request is tagged
- record
- Location : Location_Type;
- Number_Of_Tickets : Quantity_Type;
- end record;
-
-
- type Subscriber_Request is new Ticket_Request with
- record
- Subscription_Number : Season_Ticket_Type;
- end record;
-
-
- type VIP_Request is new Ticket_Request with
- record
- Rank : VIP_Status_Type;
- end record;
-
-
- type Last_Minute_Request (Special_Consideration : Boolean)
- is new VIP_Request with
- record
- Time_of_Request : Ada.Calendar.Time;
- case Special_Consideration is
- when True => Donation : Donation_Type;
- when False => null;
- end case;
- end record;
-
-
- -- Object Declarations.
-
-
- Box_Office_Request : Ticket_Request :=
- (Location => Back,
- Number_Of_Tickets => 2);
-
- Summer_Subscription : Subscriber_Request :=
- (Ticket_Request'(Box_Office_Request)
- with Subscription_Number => 567);
-
- Mayoral_Ticket_Request : VIP_Request :=
- (Location => Backstage,
- Number_Of_Tickets => 6,
- Rank => Mayor);
-
- Late_Request : Last_Minute_Request (Show_Of_Appreciation) :=
- (Special_Consideration => Show_Of_Appreciation,
- Location => Orchestra,
- Number_Of_Tickets => 2,
- Rank => City_Council,
- Time_Of_Request => Ada.Calendar.Clock,
- Donation => To_Charity);
-
-
-end FXACC00;
diff --git a/gcc/testsuite/ada/acats/support/fxc6a00.a b/gcc/testsuite/ada/acats/support/fxc6a00.a
deleted file mode 100644
index 1e51d2ab391..00000000000
--- a/gcc/testsuite/ada/acats/support/fxc6a00.a
+++ /dev/null
@@ -1,162 +0,0 @@
--- FXC6A00.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- FOUNDATION DESCRIPTION:
--- This foundation declares various volatile and non-volatile types. Some
--- are by-reference types, and some allow pass-by-copy.
---
--- CHANGE HISTORY:
--- 23 Jan 96 SAIC Initial version for ACVC 2.1.
--- 02 DEC 97 EDS Removed Pragma Volatile applied to composite types.
--- 27 AUG 99 RLB Repaired so Nonvolatile_Tagged really is
--- Nonvolatile.
---!
-
-package FXC6A00 is
-
- type Roman is ('I', 'V', 'X', 'L', 'C', 'D', 'M'); -- By-copy type.
-
- type Acc_Roman is access all Roman;
-
-
- type Tagged_Type is tagged record -- By-reference type.
- C: Natural;
- end record;
-
-
- type Volatile_Tagged is new Tagged_Type with record -- Volatile by-reference
- R1: Roman; -- type.
- end record;
- pragma Volatile (Volatile_Tagged);
-
- type Acc_Volatile_Tagged is access all Volatile_Tagged;
-
- -- By-reference type.
- type NonVolatile_Tagged is new Tagged_Type with record
- R2: aliased Roman;
- end record;
-
-
- task type Task_Type is -- By-reference type.
- entry Calculate (C: in out Natural);
- end Task_Type;
-
- type Acc_Task_Type is access all Task_Type;
-
-
- protected type Protected_Type is -- By-reference type.
- procedure Op;
- private
- Count : Natural := 0;
- end Protected_Type;
-
-
- protected type Volatile_Protected is -- Volatile by-reference
- procedure Handler; -- type.
- pragma Interrupt_Handler (Handler);
-
- function Handled return Boolean;
- private
- Was_Handled : Boolean := False;
- end Volatile_Protected;
- pragma Volatile (Volatile_Protected);
-
- type Acc_Vol_Protected is access all Volatile_Protected;
-
-
- type Record_Type is record -- Allows pass-by-copy.
- C: String(1 .. 2);
- end record;
-
-
- type Volatile_Record is limited record -- Volatile by-reference
- C: String(1 .. 2); -- type.
- end record;
- pragma Volatile (Volatile_Record);
-
-
- type Composite_Type is record -- By-reference type.
- C: Tagged_Type;
- D: aliased Volatile_Tagged; -- Volatile component.
- end record;
-
-
- type Private_Type is private; -- By-reference type.
-
-
- type Array_Type is array (1..3) of Tagged_Type; -- By-reference type.
- pragma Volatile_Components (Array_Type);
-
- type Acc_Array_Type is access all Array_Type;
-
-
- type Lim_Private_Type is limited private; -- By-copy type.
-
-private
-
- type Private_Type is new Tagged_Type with record
- D: Character;
- end record;
-
-
- type Lim_Private_Type is new Integer;
-
-end FXC6A00;
-
-
- --==================================================================--
-
-
-package body FXC6A00 is
-
- task body Task_Type is
- begin
- accept Calculate (C: in out Natural) do
- C := C * 10;
- end Calculate;
- end Task_Type;
-
-
- protected body Protected_Type is
- procedure Op is
- begin
- Count := Count + 1;
- end Op;
- end Protected_Type;
-
-
- protected body Volatile_Protected is
- procedure Handler is
- begin
- Was_Handled := True;
- end Handler;
-
- function Handled return Boolean is
- begin
- return Was_Handled;
- end Handled;
- end Volatile_Protected;
-
-end FXC6A00;
diff --git a/gcc/testsuite/ada/acats/support/fxe2a00.a b/gcc/testsuite/ada/acats/support/fxe2a00.a
deleted file mode 100644
index ed943155ec9..00000000000
--- a/gcc/testsuite/ada/acats/support/fxe2a00.a
+++ /dev/null
@@ -1,90 +0,0 @@
--- FXE2A00.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- FOUNDATION DESCRIPTION:
--- This foundation provides a Declared Pure package, a Shared Passive
--- package, a Remote Types package and a normal, unrestricted package.
---
--- It is used by tests checking the interrelationship between the
--- categorized packages
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
---
---!
-
-
---====================================================================
-
--- This is a DECLARED PURE package
---
-package FXE2A00_0 is
-
- pragma pure (FXE2A00_0);
-
- type Type_From_0 is (Red, Orange, Yellow);
-
-
-end FXE2A00_0;
-
-
---====================================================================
-
--- This is a SHARED_PASSIVE package
---
-package FXE2A00_1 is
-
-
- pragma shared_passive (FXE2A00_1);
-
- type Type_From_1 is (Blue, Indigo, Violet);
-
-end FXE2A00_1;
-
-
---====================================================================
-
--- This is a REMOTE TYPES package
---
-package FXE2A00_2 is
-
- pragma Remote_Types (FXE2A00_2);
-
- type Type_From_2 is (Red, Orange, Yellow, Green, Blue, Indigo, Violet);
-
-end FXE2A00_2;
-
-
---====================================================================
-
--- This is a NORMAL unrestricted package which has no categorization
---
-package FXE2A00_4 is
-
- type Type_From_4 is (Black, White);
-
-end FXE2A00_4;
-
---====================================================================
diff --git a/gcc/testsuite/ada/acats/support/fxf2a00.a b/gcc/testsuite/ada/acats/support/fxf2a00.a
deleted file mode 100644
index 2471f5c5950..00000000000
--- a/gcc/testsuite/ada/acats/support/fxf2a00.a
+++ /dev/null
@@ -1,96 +0,0 @@
--- FXF2A00.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- FOUNDATION DESCRIPTION:
--- This foundation declares supporting objects, types and a generic
--- function for testing decimal fixed point operations.
---
--- The generic function contains a loop which steps through two arrays:
--- one of binary operations and one of operands. For each iteration, the
--- current operation is performed on the current operand and a variable
--- "Result" e.g.:
---
--- Result := Operation(2)(Operand(3), Result);
---
--- The result of each operation is cumulated in Result and returned to
--- the caller when the loop completes.
---
--- CHANGE HISTORY:
--- 12 Mar 96 SAIC Prerelease version for ACVC 2.1.
---
---!
-
-package FXF2A00 is
-
- Loop_Count : constant := 30000; -- # test iterations.
- Optr_Count : constant := 6; -- # operations in op sequence.
- Opnd_Count : constant := 5; -- # different operands.
-
- type Loop_Range is range 1 .. Loop_Count; -- range 1 .. 30000.
- type Optr_Range is mod Optr_Count; -- range 0 .. 5.
- type Opnd_Range is mod Opnd_Count; -- range 0 .. 4.
-
-
- generic
-
- type Decimal_Fixed is delta <> digits <>;
-
- type Operator_Ptr is access
- function (L, R : Decimal_Fixed) return Decimal_Fixed;
-
- type Operator_Table is array (Optr_Range) of Operator_Ptr;
- type Operand_Table is array (Opnd_Range) of Decimal_Fixed;
-
- function Operations_Loop (Initial : Decimal_Fixed;
- Operator: Operator_Table;
- Operand : Operand_Table) return Decimal_Fixed;
-
-end FXF2A00;
-
-
- --==================================================================--
-
-
-package body FXF2A00 is
-
- function Operations_Loop (Initial : Decimal_Fixed;
- Operator: Operator_Table;
- Operand : Operand_Table) return Decimal_Fixed is
-
- Result : Decimal_Fixed := Initial; -- Cumulator.
- Optr_Index : Optr_Range := 0; -- Index into operations table.
- Opnd_Index : Opnd_Range := 0; -- Index into operand table.
-
- begin
- for Count in Loop_Range loop
- Result := Operator(Optr_Index) (Result, Operand(Opnd_Index));
- Optr_Index := Optr_Index + 1; -- Modular addition.
- Opnd_Index := Opnd_Index + 1; -- Modular addition.
- end loop;
-
- return Result;
- end Operations_Loop;
-
-end FXF2A00;
diff --git a/gcc/testsuite/ada/acats/support/fxf3a00.a b/gcc/testsuite/ada/acats/support/fxf3a00.a
deleted file mode 100644
index 645010ecfcc..00000000000
--- a/gcc/testsuite/ada/acats/support/fxf3a00.a
+++ /dev/null
@@ -1,330 +0,0 @@
--- FXF3A00.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- FOUNDATION DESCRIPTION:
--- This foundation contains decimal data values, valid and invalid
--- Picture strings, and Edited Output result strings that will be used
--- in tests of Appendix F.3.
--- Note: In this foundation package, the effect of "Table Driven Data"
--- is achieved using a series of arrays to hold the various data items.
--- Since the data items (Picture strings, Edited Output) are often of
--- different lengths, the arrays are defined to contain pointers to
--- string values, thereby allowing the "tables" to hold string data of
--- different sizes.
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 15 Feb 95 SAIC Picture string, decimal data, and edited_output
--- modifications.
--- 23 Feb 95 SAIC Picture string modification.
--- 10 Mar 95 SAIC Added explanatory comments.
--- 15 Nov 95 SAIC Corrected picture string for ACVC 2.0.1.
--- 06 Oct 96 SAIC Corrected invalid picture strings.
--- 13 Feb 97 PWB.CTA Deleted invalid picture string.
--- 17 Feb 97 PWB.CTA Added leading blank to two picture strings
---!
-
-with Ada.Text_IO.Editing;
-
-package FXF3A00 is
-
- Number_Of_NDP_Items : constant := 12; -- No Decimal Places.
- Number_Of_2DP_Items : constant := 20; -- Two Decimal Places.
- Number_Of_Valid_Strings : constant := 40;
- Number_Of_FF_Strings : constant := 4; -- French Francs
- Number_Of_DM_Strings : constant := 5; -- Deutchemarks
- Number_Of_CHF_Strings : constant := 1; -- Swiss Francs
- Number_Of_Foreign_Strings : constant := Number_Of_FF_Strings +
- Number_Of_DM_Strings +
- Number_Of_CHF_Strings;
- Number_Of_Invalid_Strings : constant := 25;
- Number_Of_Erroneous_Conditions : constant := 3;
- Number_Of_Edited_Output_Strings : constant := 32;
-
- -- The following string is to be used as a picture string with length
- -- beyond the maximum (Max_Picture_Length) that is supported by the
- -- implementation.
-
- A_Picture_String_Too_Long : constant
- String (1..Ada.Text_IO.Editing.Max_Picture_Length + 1) := (others => '9');
-
-
- type Str_Ptr is access String;
-
- type Decimal_Type_NDP is delta 1.0 digits 16; -- no decimal places
- type Decimal_Type_2DP is delta 0.01 digits 16; -- two decimal places
-
- type Data_Array_Type_1 is array (Integer range <>) of Decimal_Type_NDP;
- type Data_Array_Type_2 is array (Integer range <>) of Decimal_Type_2DP;
-
-
- type Picture_String_Array_Type is
- array (Integer range <>) of Str_Ptr;
-
- type Edited_Output_Results_Array_Type is
- array (Integer range <>) of Str_Ptr;
-
-
-
- Data_With_NDP : Data_Array_Type_1 (1..Number_Of_NDP_Items) :=
- ( 1 => 1234.0,
- 2 => 51234.0,
- 3 => -1234.0,
- 4 => 1234.0,
- 5 => 1.0,
- 6 => 0.0,
- 7 => -10.0,
- 8 => -1.0,
- 9 => 1234.0,
- 10 => 1.0,
- 11 => 36.0,
- 12 => 0.0
- );
-
-
- Data_With_2DP : Data_Array_Type_2 (1..Number_Of_2DP_Items) :=
- ( 1 => 123456.78,
- 2 => 123456.78,
- 3 => 0.0,
- 4 => 0.20,
- 5 => 123456.00,
- 6 => -123456.78,
- 7 => 123456.78,
- 8 => -12.34,
- 9 => 1.23,
- 10 => 12.34,
-
- -- Items 11-20 are used with picture strings in evaluating use of
- -- foreign currency symbols.
-
- 11 => 123456.78,
- 12 => 123456.78,
- 13 => 32.10,
- 14 => -5432.10,
- 15 => -1234.57,
- 16 => 123456.78,
- 17 => 12.34,
- 18 => 12.34,
- 19 => 1.23,
- 20 => 12345.67
- );
-
-
-
- Valid_Strings : Picture_String_Array_Type
- (1..Number_Of_Valid_Strings) :=
-
- -- Items 1-10 are used in conjunction with Data_With_2DP values
- -- to produce edited output strings, as well as in tests of
- -- function Valid.
-
- ( 1 => new String'("-###**_***_**9.99"),
- 2 => new String'("-$**_***_**9.99"),
- 3 => new String'("-$$$$$$.$$"),
- 4 => new String'("-$$$$$$.$$"),
- 5 => new String'("+BBBZZ_ZZZ_ZZZ.ZZ"),
- 6 => new String'("--_---_---_--9"),
- 7 => new String'("-$_$$$_$$$_$$9.99"),
- 8 => new String'("<$$_$$$9.99>"),
- 9 => new String'("$_$$9.99"),
- 10 => new String'("$$9.99"),
-
- -- Items 11-22 are used in conjunction with Data_With_NDP values
- -- to produce edited output strings.
-
- 11 => new String'("ZZZZ9"),
- 12 => new String'("ZZZZ9"),
- 13 => new String'("<#Z_ZZ9>"),
- 14 => new String'("<#Z_ZZ9>"),
- 15 => new String'("ZZZ.ZZ"),
- 16 => new String'("ZZZ.ZZ"),
- 17 => new String'("<###99>"),
- 18 => new String'("ZZZZZ-"),
- 19 => new String'("$$$$9"),
- 20 => new String'("$$$$$"),
- 21 => new String'("<###99>"),
- 22 => new String'("$$$$9"),
-
- -- Items 23-40 are used in validation of the Valid, To_Picture, and
- -- Pic_String subprograms of package Text_IO.Editing, and are not
- -- used to generate edited output.
-
- 23 => new String'("zZzZzZzZzZzZzZzZzZ"),
- 24 => new String'("999999999999999999"),
- 25 => new String'("******************"),
- 26 => new String'("$$$$$$$$$$$$$$$$$$"),
- 27 => new String'("9999/9999B9999_999909999"),
- 28 => new String'("+999999999999999999"),
- 29 => new String'("-999999999999999999"),
- 30 => new String'("999999999999999999+"),
- 31 => new String'("999999999999999999-"),
- 32 => new String'("<<<_<<<_<<<_<<<_<<<_<<9>"),
- 33 => new String'("++++++++++++++++++++"),
- 34 => new String'("--------------------"),
- 35 => new String'("zZzZzZzZzZzZzZzZzZ.zZ"),
- 36 => new String'("******************.99"),
- 37 => new String'("$$$$$$$$$$$$$$$$$$.99"),
-
- -- The following string has length 30, which is the minimum value
- -- that must be supported for Max_Picture_Length.
-
- 38 => new String'("9_999_999_999_999_999_999BB.99"),
- 39 => new String'("<<<_<<<_<<<_<<<.99>"),
- 40 => new String'("ZZZZZZZZZZZZZZZZZ+")
- );
-
-
-
- Foreign_Strings : Picture_String_Array_Type
- (1..Number_Of_Foreign_Strings) :=
-
- -- These strings are going to be used in conjunction with non-default
- -- values for Currency string, Radix mark, and Separator in calls to
- -- Image and Put, as well as in tests of function Valid.
-
- ( 1 => new String'("-###**_***_**9.99"), -- FF
- 2 => new String'("-$**_***_**9.99"), -- FF
- 3 => new String'("<###z_ZZ9.99>"), -- FF
- 4 => new String'("<###Z_ZZ9.99>"), -- FF
- 5 => new String'("<<<<_<<<.<<###>"), -- DM
- 6 => new String'("-$_$$$_$$$_$$9.99"), -- DM
- 7 => new String'("$z99.99"), -- DM
- 8 => new String'("$$$9.99"), -- DM
- 9 => new String'("$_$$9.99"), -- DM
- 10 => new String'("###_###_##9.99") -- CHF
- );
-
-
-
- Invalid_Strings : Picture_String_Array_Type
- (1..Number_Of_Invalid_Strings) :=
- --
- -- The RM references to the right of these invalid picture strings
- -- indicates which of the composition constraints of picture strings
- -- is violated by the particular string (and all following strings
- -- until another reference is presented). However, certain strings
- -- violate multiple of the constraints.
- --
- ( 1 => new String'("<<<"),
- 2 => new String'("<<>>"),
- 3 => new String'("<<<9_B0/$DB"),
- 4 => new String'("+BB"),
- 5 => new String'("<-"),
- 6 => new String'("<CR"),
- 7 => new String'("<db"),
- 8 => new String'("<<BBBcr"),
- 9 => new String'("<<__DB"),
- 10 => new String'("<<<++++_++-"),
- 11 => new String'("-999.99>"),
- 12 => new String'("+++9.99+"),
- 13 => new String'("++++>>"),
- 14 => new String'("->"),
- 15 => new String'("++9-"),
- 16 => new String'("---999999->"),
- 17 => new String'("+++-"),
- 18 => new String'("+++_+++_+.--"),
- 19 => new String'("--B.BB+>"),
- 20 => new String'("$$#$"),
- 21 => new String'("#B$$$$"),
- 22 => new String'("**Z"),
- 23 => new String'("ZZZzzz*"),
- 24 => new String'("9.99DB(2)"),
- 25 => new String'(A_Picture_String_Too_Long)
- );
-
-
- Edited_Output : Edited_Output_Results_Array_Type
- (1..Number_Of_Edited_Output_Strings) :=
-
- -- The following 10 edited output strings result from the first 10
- -- valid strings when used with the first 10 Data_With_2DP numeric
- -- values.
- ( 1 => new String'(" $***123,456.78"),
- 2 => new String'(" $***123,456.78"),
- 3 => new String'(" "),
- 4 => new String'(" $.20"),
- 5 => new String'("+ 123,456.00"),
- 6 => new String'(" -123,457"),
- 7 => new String'(" $123,456.78"),
- 8 => new String'("( $12.34)"),
- 9 => new String'(" $1.23"),
- 10 => new String'("$12.34"),
-
- -- The following 10 edited output strings correspond to the 10 foreign
- -- currency picture strings (the currency string is supplied at the
- -- time of the call to Editing.Image or Editing.Put), when used in
- -- conjunction with Data_With_2DP items 11-20
-
- 11 => new String'(" FF***123.456,78"),
- 12 => new String'(" FF***123.456,78"),
- 13 => new String'(" FF 32,10 "),
- 14 => new String'("( FF5.432,10)"),
- 15 => new String'(" (1,234.57DM )"),
- 16 => new String'(" DM123,456.78"),
- 17 => new String'("DM 12.34"),
- 18 => new String'(" DM12.34"),
- 19 => new String'(" DM1.23"),
- 20 => new String'(" CHF12,345.67"),
-
- -- The following 12 edited output strings correspond to the 12
- -- Data_With_NDP items formatted using Valid_String items 11-22.
- -- This combination shows decimal data with no decimal places
- -- formatted using picture strings.
-
- 21 => new String'(" 1234"),
- 22 => new String'("51234"),
- 23 => new String'("($1,234)"),
- 24 => new String'(" $1,234 "),
- 25 => new String'(" 1.00"),
- 26 => new String'(" "),
- 27 => new String'("( $10)"),
- 28 => new String'(" 1-"),
- 29 => new String'("$1234"),
- 30 => new String'(" $1"),
- 31 => new String'(" $36 "),
- 32 => new String'(" $0")
- );
-
-
-
- -- The following data is used to create exception situations in tests of
- -- the Edited Output capabilities of package Ada.Text_IO.Editing. The data
- -- are not themselves erroneous, but will produce exceptions based on the
- -- data/picture string combination used.
-
- Erroneous_Data : Data_Array_Type_2 (1..Number_Of_Erroneous_Conditions) :=
- ( 1 => 12.34,
- 2 => -12.34,
- 3 => 51234.0
- );
-
- Erroneous_Strings : Picture_String_Array_Type
- (1..Number_Of_Erroneous_Conditions) :=
- ( 1 => new String'("9.99"),
- 2 => new String'("99.99"),
- 3 => new String'("$$$$9")
- );
-
-end FXF3A00;
diff --git a/gcc/testsuite/ada/acats/support/impdef.a b/gcc/testsuite/ada/acats/support/impdef.a
deleted file mode 100644
index 1cd0d466caa..00000000000
--- a/gcc/testsuite/ada/acats/support/impdef.a
+++ /dev/null
@@ -1,371 +0,0 @@
--- IMPDEF.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- DESCRIPTION:
--- This package provides tailorable entities for a particular
--- implementation. Each entity may be modified to suit the needs
--- of the implementation. Default values are provided to act as
--- a guide.
---
--- The entities in this package are those which are used in at least
--- one core test. Entities which are used exclusively in tests for
--- annexes C-H are located in annex-specific child units of this package.
---
--- CHANGE HISTORY:
--- 12 DEC 93 SAIC Initial PreRelease version
--- 02 DEC 94 SAIC Second PreRelease version
--- 16 May 95 SAIC Added constants specific to tests of the random
--- number generator.
--- 16 May 95 SAIC Added Max_RPC_Call_Time constant.
--- 17 Jul 95 SAIC Added Non_State_String constant.
--- 21 Aug 95 SAIC Created from existing IMPSPEC.ADA and IMPBODY.ADA
--- files.
--- 30 Oct 95 SAIC Added external name string constants.
--- 24 Jan 96 SAIC Added alignment constants.
--- 29 Jan 96 SAIC Moved entities not used in core tests into annex-
--- specific child packages. Adjusted commentary.
--- Renamed Validating_System_Programming_Annex to
--- Validating_Annex_C. Added similar Validating_Annex_?
--- constants for the other non-core annexes (D-H).
--- 01 Mar 96 SAIC Added external name string constants.
--- 21 Mar 96 SAIC Added external name string constants.
--- 02 May 96 SAIC Removed constants for draft test CXA5014, which was
--- removed from the tentative ACVC 2.1 suite.
--- Added constants for use with FXACA00.
--- 06 Jun 96 SAIC Added constants for wide character test files.
--- 11 Dec 96 SAIC Updated constants for wide character test files.
--- 13 Dec 96 SAIC Added Address_Value_IO
--- 13 Sep 99 RLB Added more external name string constants.
--- 16 Sep 99 RLB Corrected definition of Non_State_String constant.
---
---!
-
-with Report;
-with Ada.Text_IO;
-with System.Storage_Elements;
-
-package ImpDef is
-
---=====-=====-=====-=====-=====-=====-=====-=====-=====-=====-=====-=====--
-
- -- The following boolean constants indicate whether this validation will
- -- include any of annexes C-H. The values of these booleans affect the
- -- behavior of the test result reporting software.
- --
- -- True means the associated annex IS included in the validation.
- -- False means the associated annex is NOT included.
-
- Validating_Annex_C : constant Boolean := True;
- -- ^^^^^ --- MODIFY HERE AS NEEDED
-
- Validating_Annex_D : constant Boolean := True;
- -- ^^^^^ --- MODIFY HERE AS NEEDED
-
- Validating_Annex_E : constant Boolean := True;
- -- ^^^^^ --- MODIFY HERE AS NEEDED
-
- Validating_Annex_F : constant Boolean := True;
- -- ^^^^^ --- MODIFY HERE AS NEEDED
-
- Validating_Annex_G : constant Boolean := True;
- -- ^^^^^ --- MODIFY HERE AS NEEDED
-
- Validating_Annex_H : constant Boolean := True;
- -- ^^^^^ --- MODIFY HERE AS NEEDED
-
---=====-=====-=====-=====-=====-=====-=====-=====-=====-=====-=====-=====--
-
- -- This is the minimum time required to allow another task to get
- -- control. It is expected that the task is on the Ready queue.
- -- A duration of 0.0 would normally be sufficient but some number
- -- greater than that is expected.
-
- Minimum_Task_Switch : constant Duration := 0.001;
- -- ^^^ --- MODIFY HERE AS NEEDED
-
---=====-=====-=====-=====-=====-=====-=====-=====-=====-=====-=====-=====--
-
- -- This is the time required to activate another task and allow it
- -- to run to its first accept statement. We are considering a simple task
- -- with very few Ada statements before the accept. An implementation is
- -- free to specify a delay of several seconds, or even minutes if need be.
- -- The main effect of specifying a longer delay than necessary will be an
- -- extension of the time needed to run the associated tests.
-
- Switch_To_New_Task : constant Duration := 0.001;
- -- ^^^ -- MODIFY HERE AS NEEDED
-
---=====-=====-=====-=====-=====-=====-=====-=====-=====-=====-=====-=====--
-
- -- This is the time which will clear the queues of other tasks
- -- waiting to run. It is expected that this will be about five
- -- times greater than Switch_To_New_Task.
-
- Clear_Ready_Queue : constant Duration := 1.1;
- -- ^^^ --- MODIFY HERE AS NEEDED
-
---=====-=====-=====-=====-=====-=====-=====-=====-=====-=====-=====-=====--
-
- -- Some implementations will boot with the time set to 1901/1/1/0.0
- -- When a delay of Delay_For_Time_Past is given, the implementation
- -- guarantees that a subsequent call to Ada.Calendar.Time_Of(1901,1,1)
- -- will yield a time that has already passed (for example, when used in
- -- a delay_until statement).
-
- Delay_For_Time_Past : constant Duration := 0.001;
- -- ^^^ --- MODIFY HERE AS NEEDED
-
---=====-=====-=====-=====-=====-=====-=====-=====-=====-=====-=====-=====--
-
- -- Minimum time interval between calls to the time dependent Reset
- -- procedures in Float_Random and Discrete_Random packages that is
- -- guaranteed to initiate different sequences. See RM A.5.2(45).
-
- Time_Dependent_Reset : constant Duration := 0.001;
- -- ^^^ --- MODIFY HERE AS NEEDED
-
---=====-=====-=====-=====-=====-=====-=====-=====-=====-=====-=====-=====--
-
- -- Test CXA5013 will loop, trying to generate the required sequence
- -- of random numbers. If the RNG is faulty, the required sequence
- -- will never be generated. Delay_Per_Random_Test is a time-out value
- -- which allows the test to run for a period of time after which the
- -- test is failed if the required sequence has not been produced.
- -- This value should be the time allowed for the test to run before it
- -- times out. It should be long enough to allow multiple (independent)
- -- runs of the testing code, each generating up to 1000 random
- -- numbers.
-
- Delay_Per_Random_Test : constant Duration := 0.001;
- -- ^^^ --- MODIFY HERE AS NEEDED
-
---=====-=====-=====-=====-=====-=====-=====-=====-=====-=====-=====-=====--
-
- -- The time required to execute this procedure must be greater than the
- -- time slice unit on implementations which use time slicing. For
- -- implementations which do not use time slicing the body can be null.
-
- procedure Exceed_Time_Slice;
-
---=====-=====-=====-=====-=====-=====-=====-=====-=====-=====-=====-=====--
-
- -- This constant must not depict a random number generator state value.
- -- Using this string in a call to function Value from either the
- -- Discrete_Random or Float_Random packages will result in
- -- Constraint_Error or Program_Error (expected result in test CXA5012).
- -- If there is no such string, set it to "**NONE**".
-
- Non_State_String : constant String := "By No Means A State";
- -- MODIFY HERE AS NEEDED --- ^^^^^^^^^^^^^^^^^^^
-
---=====-=====-=====-=====-=====-=====-=====-=====-=====-=====-=====-=====--
-
- -- This string constant must be a legal external tag value as used by
- -- CD10001 for the type Some_Tagged_Type in the representation
- -- specification for the value of 'External_Tag.
-
- External_Tag_Value : constant String := "implementation_defined";
- -- MODIFY HERE AS NEEDED --- ^^^^^^^^^^^^^^^^^^^^^^
-
---=====-=====-=====-=====-=====-=====-=====-=====-=====-=====-=====-=====--
-
- -- The following address constant must be a valid address to locate
- -- the C program CD30005_1. It is shown here as a named number;
- -- the implementation may choose to type the constant as appropriate.
-
- function Cd30005_Proc (X : Integer) return Integer;
- pragma Import (C, Cd30005_Proc, "_cd30005_1");
-
- pragma Linker_Options ("ACATS4GNATDIR/support/cd300051.o");
-
- CD30005_1_Foreign_Address : constant System.Address:= Cd30005_Proc'Address;
-
- -- CD30005_1_Foreign_Address : constant System.Address:=
- -- System.Storage_Elements.To_Address ( 16#0000_0000# )
- -- --MODIFY HERE AS REQUIRED --- ^^^^^^^^^^^^^
-
---=====-=====-=====-=====-=====-=====-=====-=====-=====-=====-=====-=====--
-
- -- The following string constant must be the external name resulting
- -- from the C compilation of CD30005_1. The string will be used as an
- -- argument to pragma Import.
-
- CD30005_1_External_Name : constant String := "_cd30005_1";
- -- MODIFY HERE AS NEEDED --- ^^^^^^^^^
-
---=====-=====-=====-=====-=====-=====-=====-=====-=====-=====-=====-=====--
-
- -- The following constants should represent the largest default alignment
- -- value and the largest alignment value supported by the linker.
- -- See RM 13.3(35).
-
- Max_Default_Alignment : constant := Standard'Maximum_Alignment;
- -- ^ --- MODIFY HERE AS NEEDED
-
- Max_Linker_Alignment : constant := Standard'Maximum_Alignment;
- -- ^ --- MODIFY HERE AS NEEDED
-
---=====-=====-=====-=====-=====-=====-=====-=====-=====-=====-=====-=====--
-
- -- The following string constants must be the external names resulting
- -- from the C compilation of CXB30040.C, CXB30060.C, CXB30130.C, and
- -- CXB30131.C. The strings will be used as arguments to pragma Import.
-
- CXB30040_External_Name : constant String := "CXB30040";
- -- MODIFY HERE AS NEEDED --- ^^^^^^^^
-
- CXB30060_External_Name : constant String := "CXB30060";
- -- MODIFY HERE AS NEEDED --- ^^^^^^^^
-
- CXB30130_External_Name : constant String := "CXB30130";
- -- MODIFY HERE AS NEEDED --- ^^^^^^^^
-
- CXB30131_External_Name : constant String := "CXB30131";
- -- MODIFY HERE AS NEEDED --- ^^^^^^^^
-
---=====-=====-=====-=====-=====-=====-=====-=====-=====-=====-=====-=====--
-
- -- The following string constants must be the external names resulting
- -- from the COBOL compilation of CXB40090.CBL, CXB40091.CBL, and
- -- CXB40092.CBL. The strings will be used as arguments to pragma Import.
-
- CXB40090_External_Name : constant String := "CXB40090";
- -- MODIFY HERE AS NEEDED --- ^^^^^^^^
-
- CXB40091_External_Name : constant String := "CXB40091";
- -- MODIFY HERE AS NEEDED --- ^^^^^^^^
-
- CXB40092_External_Name : constant String := "CXB40092";
- -- MODIFY HERE AS NEEDED --- ^^^^^^^^
-
---=====-=====-=====-=====-=====-=====-=====-=====-=====-=====-=====-=====--
-
- -- The following string constants must be the external names resulting
- -- from the Fortran compilation of CXB50040.FTN, CXB50041.FTN,
- -- CXB50050.FTN, and CXB50051.FTN.
- --
- -- The strings will be used as arguments to pragma Import.
- --
- -- Note that the use of these four string constants will be split between
- -- two tests, CXB5004 and CXB5005.
-
- CXB50040_External_Name : constant String := "CXB50040";
- -- MODIFY HERE AS NEEDED --- ^^^^^^^^
-
- CXB50041_External_Name : constant String := "CXB50041";
- -- MODIFY HERE AS NEEDED --- ^^^^^^^^
-
- CXB50050_External_Name : constant String := "CXB50050";
- -- MODIFY HERE AS NEEDED --- ^^^^^^^^
-
- CXB50051_External_Name : constant String := "CXB50051";
- -- MODIFY HERE AS NEEDED --- ^^^^^^^^
-
---=====-=====-=====-=====-=====-=====-=====-=====-=====-=====-=====-=====--
-
- -- The following constants have been defined for use with the
- -- representation clause in FXACA00 of type Sales_Record_Type.
- --
- -- Char_Bits should be an integer at least as large as the number
- -- of bits needed to hold a character in an array.
- -- A value of 6 * Char_Bits will be used in a representation clause
- -- to reserve space for a six character string.
- --
- -- Next_Storage_Slot should indicate the next storage unit in the record
- -- representation clause that does not overlap the storage designated for
- -- the six character string.
-
- Char_Bits : constant := 8;
- -- MODIFY HERE AS NEEDED ---^
-
- Next_Storage_Slot : constant := 6;
- -- MODIFY HERE AS NEEDED ---^
-
---=====-=====-=====-=====-=====-=====-=====-=====-=====-=====-=====-=====--
-
- -- The following string constant must be the path name for the .AW
- -- files that will be processed by the Wide Character processor to
- -- create the C250001 and C250002 tests. The Wide Character processor
- -- will expect to find the files to process at this location.
-
- Test_Path_Root : constant String :=
- "ACATS4GNATDIR/tests/c2/";
- -- ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ --- MODIFY HERE AS NEEDED
-
- -- The following two strings must not be modified unless the .AW file
- -- names have been changed. The Wide Character processor will use
- -- these strings to find the .AW files used in creating the C250001
- -- and C250002 tests.
-
- Wide_Character_Test : constant String := Test_Path_Root & "c250001";
- Upper_Latin_Test : constant String := Test_Path_Root & "c250002";
-
---=====-=====-=====-=====-=====-=====-=====-=====-=====-=====-=====-=====--
-
- -- The following instance of Integer_IO or Modular_IO must be supplied
- -- in order for test CD72A02 to compile correctly.
- -- Depending on the choice of base type used for the type
- -- System.Storage_Elements.Integer_Address; one of the two instances will
- -- be correct. Comment out the incorrect instance.
-
- -- package Address_Value_IO is
- -- new Ada.Text_IO.Integer_IO(System.Storage_Elements.Integer_Address);
-
- package Address_Value_IO is
- new Ada.Text_IO.Modular_IO(System.Storage_Elements.Integer_Address);
-
---=====-=====-=====-=====-=====-=====-=====-=====-=====-=====-=====-=====--
-
- One_Second : constant Duration := 0.001;
-
-end ImpDef;
-
-
- --==================================================================--
-
-
-package body ImpDef is
-
- -- NOTE: These are example bodies. It is expected that implementors
- -- will write their own versions of these routines.
-
---=====-=====-=====-=====-=====-=====-=====-=====-=====-=====-=====-=====--
-
- -- The time required to execute this procedure must be greater than the
- -- time slice unit on implementations which use time slicing. For
- -- implementations which do not use time slicing the body can be null.
-
- Procedure Exceed_Time_Slice is
- T : Integer := 0;
- Loop_Max : constant Integer := 4_000;
- begin
- for I in 1..Loop_Max loop
- T := Report.Ident_Int (1) * Report.Ident_Int (2);
- end loop;
- end Exceed_Time_Slice;
-
---=====-=====-=====-=====-=====-=====-=====-=====-=====-=====-=====-=====--
-
-end ImpDef;
diff --git a/gcc/testsuite/ada/acats/support/impdefd.a b/gcc/testsuite/ada/acats/support/impdefd.a
deleted file mode 100644
index 85f6b7924a0..00000000000
--- a/gcc/testsuite/ada/acats/support/impdefd.a
+++ /dev/null
@@ -1,69 +0,0 @@
--- IMPDEFD.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- DESCRIPTION:
--- This package provides tailorable entities for a particular
--- implementation. Each entity may be modified to suit the needs
--- of the implementation. Default values are provided to act as
--- a guide.
---
--- The entities in this package are those which are used exclusively
--- in tests for Annex D (Real-Time Systems).
---
--- APPLICABILITY CRITERIA:
--- This package is only required for implementations validating the
--- Real-Time Systems Annex.
---
--- CHANGE HISTORY:
--- 29 Jan 96 SAIC Initial version for ACVC 2.1.
--- 27 Aug 98 EDS Removed Processor_Type value Time_Slice
---!
-
-package ImpDef.Annex_D is
-
---=====-=====-=====-=====-=====-=====-=====-=====-=====-=====-=====-=====--
-
- -- This constant is the maximum storage size that can be specified
- -- for a task. A single task that has this size must be able to
- -- run. Ideally, this value is large enough that two tasks of this
- -- size cannot run at the same time. If the value is too small then
- -- test CXDC001 may take longer to run. See the test for further
- -- information.
-
- Maximum_Task_Storage_Size : constant := 16_000_000;
- -- ^^^^^^^^^^ --- MODIFY HERE AS NEEDED
-
---=====-=====-=====-=====-=====-=====-=====-=====-=====-=====-=====-=====--
-
- -- Indicates the type of processor on which the tests are running.
-
- type Processor_Type is (Uni_Processor, Multi_Processor);
-
- Processor : constant Processor_Type := Uni_Processor;
- -- ^^^^^^^^^^^ --- MODIFY HERE AS NEEDED
-
---=====-=====-=====-=====-=====-=====-=====-=====-=====-=====-=====-=====--
-
-end ImpDef.Annex_D;
diff --git a/gcc/testsuite/ada/acats/support/impdefe.a b/gcc/testsuite/ada/acats/support/impdefe.a
deleted file mode 100644
index ae9f651b9bc..00000000000
--- a/gcc/testsuite/ada/acats/support/impdefe.a
+++ /dev/null
@@ -1,58 +0,0 @@
--- IMPDEFE.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- DESCRIPTION:
--- This package provides tailorable entities for a particular
--- implementation. Each entity may be modified to suit the needs
--- of the implementation. Default values are provided to act as
--- a guide.
---
--- The entities in this package are those which are used exclusively
--- in tests for Annex E (Distributed Systems).
---
--- APPLICABILITY CRITERIA:
--- This package is only required for implementations validating the
--- Distributed Systems Annex.
---
--- CHANGE HISTORY:
--- 29 Jan 96 SAIC Initial version for ACVC 2.1.
---
---!
-
-package ImpDef.Annex_E is
-
---=====-=====-=====-=====-=====-=====-=====-=====-=====-=====-=====-=====--
-
- -- The Max_RPC_Call_Time value is the longest time a test needs to wait for
- -- an RPC to complete. Included in this time is the time for the called
- -- procedure to make a task entry call where the task is ready to accept
- -- the call.
-
- Max_RPC_Call_Time : constant Duration := 2.0;
- -- ^^^ --- MODIFY HERE AS NEEDED
-
---=====-=====-=====-=====-=====-=====-=====-=====-=====-=====-=====-=====--
-
-end ImpDef.Annex_E;
diff --git a/gcc/testsuite/ada/acats/support/impdefg.a b/gcc/testsuite/ada/acats/support/impdefg.a
deleted file mode 100644
index 459ba9c9462..00000000000
--- a/gcc/testsuite/ada/acats/support/impdefg.a
+++ /dev/null
@@ -1,83 +0,0 @@
--- IMPDEFG.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- DESCRIPTION:
--- This package provides tailorable entities for a particular
--- implementation. Each entity may be modified to suit the needs
--- of the implementation. Default values are provided to act as
--- a guide.
---
--- The entities in this package are those which are used exclusively
--- in tests for Annex G (Numerics).
---
--- APPLICABILITY CRITERIA:
--- This package is only required for implementations validating the
--- Numerics Annex.
---
--- CHANGE HISTORY:
--- 29 Jan 96 SAIC Initial version for ACVC 2.1.
---
---!
-
-package ImpDef.Annex_G is
-
---=====-=====-=====-=====-=====-=====-=====-=====-=====-=====-=====-=====--
-
- -- This function must return a "negative zero" value for implementations
- -- for which Float'Signed_Zeros is True.
-
- function Negative_Zero return Float;
-
---=====-=====-=====-=====-=====-=====-=====-=====-=====-=====-=====-=====--
-
-end ImpDef.Annex_G;
-
-
- --==================================================================--
-
-
-package body ImpDef.Annex_G is
-
-
---=====-=====-=====-=====-=====-=====-=====-=====-=====-=====-=====-=====--
-
- -- This function must return a negative zero value for implementations
- -- for which Float'Signed_Zeros is True.
- -- We generate the smallest normalized negative number, and divide by a
- -- few powers of two to obtain a number whose absolute value equals zero
- -- but whose sign is negative.
-
- function Negative_Zero return Float is
- negz : float := -1.0 *
- float (float'Machine_Radix)
- ** ( Float'Machine_Emin - Float'Machine_Mantissa);
- begin
- return negz / 8.0;
- end Negative_Zero;
-
---=====-=====-=====-=====-=====-=====-=====-=====-=====-=====-=====-=====--
-
-end ImpDef.Annex_G;
-
diff --git a/gcc/testsuite/ada/acats/support/impdefh.a b/gcc/testsuite/ada/acats/support/impdefh.a
deleted file mode 100644
index e6cfda71798..00000000000
--- a/gcc/testsuite/ada/acats/support/impdefh.a
+++ /dev/null
@@ -1,102 +0,0 @@
--- IMPDEFH.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- DESCRIPTION:
--- This package is used to define those values that are implementation
--- defined for use with validating the Safety and Security special needs
--- annex, Annex-H.
---
--- APPLICABILITY CRITERIA:
--- This package is only required for implementations validating the
--- Safety and Security Annex.
---
--- CHANGE HISTORY:
--- 13 FEB 96 SAIC Initial version
--- 25 NOV 96 SAIC Revised for release 2.1
---
---!
-
-package Impdef.Annex_H is
-
- type Scalar_To_Normalize is
- ( Id0, Id1, Id2, Id3, Id4, Id5, Id6, Id7, Id8, Id9,
- Id10, Id11, Id12, Id13, Id14, Id15, Id16, Id17, Id18, Id19,
- Id20, Id21, Id22, Id23, Id24, Id25, Id26, Id27, Id28, Id29,
- Id30, Id31, Id32, Id33, Id34, Id35, Id36, Id37, Id38, Id39,
- Id40, Id41, Id42, Id43, Id44, Id45, Id46, Id47, Id48, Id49,
- Id50, Id51, Id52, Id53, Id54, Id55, Id56, Id57, Id58, Id59,
- Id60, Id61, Id62, Id63, Id64, Id65, Id66, Id67, Id68, Id69,
- Id70, Id71, Id72, Id73, Id74, Id75, Id76, Id77, Id78, Id79,
- Id80, Id81, Id82, Id83, Id84, Id85, Id86, Id87, Id88, Id89,
- Id90, Id91, Id92, Id93, Id94, Id95, Id96, Id97, Id98, Id99,
- IdA0, IdA1, IdA2, IdA3, IdA4, IdA5, IdA6, IdA7, IdA8, IdA9,
- IdB0, IdB1, IdB2, IdB3, IdB4, IdB5, IdB6 );
-
- -- NO MODIFICATION NEEDED TO TYPE SCALAR_TO_NORMALIZE. DO NOT MODIFY.
-
- type Small_Number is range 1..100;
-
- -- NO MODIFICATION NEEDED TO TYPE SMALL_NUMBER. DO NOT MODIFY.
-
---=====================================================================
- -- When the value documented in H.1(5) as the predictable initial value
- -- for an uninitialized object of the type Scalar_To_Normalize
- -- (an enumeration type containing 127 identifiers) is to be in the range
- -- Id0..IdB6, set the following constant to True; otherwise leave it set
- -- to False.
-
- Default_For_Scalar_To_Normalize_Is_In_Range : constant Boolean := False;
- -- MODIFY HERE AS NEEDED --- ^^^^^
-
---=====================================================================
- -- If the above constant Default_For_Scalar_To_Normalize_Is_In_Range is
- -- set True, the following constant must be set to the value documented
- -- in H.1(5) as the predictable initial value for the type
- -- Scalar_To_Normalize.
-
- Default_For_Scalar_To_Normalize : constant Scalar_To_Normalize := Id0;
- -- MODIFY HERE AS NEEDED --- ^^^
-
---=====================================================================
- -- When the value documented in H.1(5) as the predictable initial value
- -- for an uninitialized object of the type Small_Number
- -- (an integer type containing 100 values) is to be in the range
- -- 1..100, set the following constant to True; otherwise leave it set
- -- to False.
-
- Default_For_Small_Number_Is_In_Range : constant Boolean := False;
- -- MODIFY HERE AS NEEDED --- ^^^^^
-
---=====================================================================
- -- If the above constant Default_For_Small_Number_Is_In_Range is
- -- set True, the following constant must be set to the value documented
- -- in H.1(5) as the predictable initial value for the type Small_Number.
-
- Default_For_Small_Number : constant Small_Number := 100;
- -- MODIFY HERE AS NEEDED --- ^^^
-
---=====================================================================
-
-end Impdef.Annex_H;
diff --git a/gcc/testsuite/ada/acats/support/widechr.a b/gcc/testsuite/ada/acats/support/widechr.a
deleted file mode 100644
index 2eac588b890..00000000000
--- a/gcc/testsuite/ada/acats/support/widechr.a
+++ /dev/null
@@ -1,294 +0,0 @@
--- WIDECHR.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- DESCRIPTION:
---
--- This program reads C250001.AW and C250002.AW; translates a special
--- character sequence into characters and wide characters with positions
--- above ASCII.DEL. The resulting tests are written as C250001.A and
--- C250002.A respectively. This program may need to
--- be modified if the Wide_Character representation recognized by
--- your compiler differs from the Wide_Character
--- representation generated by the package Ada.Wide_Text_IO.
--- Modify this program as needed to translate that file.
---
--- A wide character is represented by an 8 character sequence:
---
--- ["abcd"]
---
--- where the character code represented is specified by four hexadecimal
--- digits, abcd, with letters in upper case. For example the wide
--- character with the code 16#AB13# is represented by the eight
--- character sequence:
---
--- ["AB13"]
---
--- ASSUMPTIONS:
---
--- The path for these files is specified in ImpDef.
---
--- SPECIAL REQUIREMENTS:
---
--- Compile, bind and execute this program. It will process the ".AW"
--- tests, "translating" them to ".A" tests.
---
--- CHANGE HISTORY:
--- 11 DEC 96 SAIC ACVC 2.1 Release
---
--- 11 DEC 96 Keith Constructed initial release version
---!
-
-with Ada.Text_IO;
-with Ada.Wide_Text_IO;
-with Ada.Strings.Fixed;
-with Impdef;
-
-procedure WideChr is
-
- -- Debug
- --
- -- To have the program generate trace/debugging information, de-comment
- -- the call to Put_Line
-
- procedure Debug( S: String ) is
- begin
- null; -- Ada.Text_IO.Put_Line(S);
- end Debug;
-
- package TIO renames Ada.Text_IO;
- package WIO renames Ada.Wide_Text_IO;
- package SF renames Ada.Strings.Fixed;
-
- In_File : TIO.File_Type;
-
- -- This program is actually dual-purpose. It translates the ["xxxx"]
- -- notation to Wide_Character, as well as a similar notation ["xx"] into
- -- Character. The intent of the latter being the ability to represent
- -- literals in the Latin-1 character set that have position numbers
- -- greater than ASCII.DEL. The variable Output_Mode drives the algorithms
- -- to generate Wide_Character output (Wide) or Character output (Narrow).
-
- type Output_Modes is ( Wide, Narrow );
- Output_Mode : Output_Modes := Wide;
-
- Wide_Out : WIO.File_Type;
- Narrow_Out : TIO.File_Type;
-
- In_Line : String(1..132); -- SB: $MAX_LINE_LENGTH
-
- -- Index variables
- --
- -- the following index variables: In_Length, Front, Open_Bracket and
- -- Close_Bracket are used by the scanning software to keep track of
- -- what's where.
- --
- -- In_Length stores the value returned by Ada.Text_IO.Get_Line indicating
- -- the position of the last "useful" character in the string In_Line.
- --
- -- Front retains the index of the first non-translating character in
- -- In_Line, it is used to indicate the starting index of the portion of
- -- the string to save without special interpretation. In the example
- -- below, where there are two consecutive characters to translate, we see
- -- that Front will assume three different values processing the string,
- -- these are indicated by the digits '1', '2' & '3' in the comment
- -- attached to the declaration. The processing software will dump
- -- In_Line(Front..Open_Bracket-1) to the output stream. Note that in
- -- the second case, this results in a null string, and in the third case,
- -- where Open_Bracket does not obtain a third value, the slice
- -- In_Line(Front..In_Length) is used instead.
- --
- -- Open_Bracket and Close_Bracket are used to retain the starting index
- -- of the character pairs [" and "] respectively. For the purposes of
- -- this software the character pairs are what are considered to be the
- -- "brackets" enclosing the hexadecimal values to be translated.
- -- Looking at the example below you will see where these index variables
- -- will "point" in the first and second case.
-
- In_Length : Natural := 0; ---> Some_["0A12"]["0B13"]_Thing
- Front : Natural := 0; -- 1 2 3
- Open_Bracket : Natural := 0; -- 1 2
- Close_Bracket : Natural := 0; -- 1 2
-
- -- Xlation
- --
- -- This translation table gives an easy way to translate the "decimal"
- -- value of a hex digit (as represented by a Latin-1 character)
-
- type Xlate is array(Character range '0'..'F') of Natural;
- Xlation : constant Xlate :=
- ('0' => 0, '1' => 1, '2' => 2, '3' => 3, '4' => 4,
- '5' => 5, '6' => 6, '7' => 7, '8' => 8, '9' => 9,
- 'A' => 10, 'B' => 11, 'C' => 12, 'D' => 13, 'E' => 14,
- 'F' => 15,
- others => 0);
-
- -- To_Ch
- --
- -- This function takes a string which is assumed to be trimmed to just a
- -- hexadecimal representation of a Latin-1 character. The result of the
- -- function is the Latin-1 character at the position designated by the
- -- incoming hexadecimal value. (hexadecimal in human readable form)
-
- function To_Ch( S:String ) return Character is
- Numerical : Natural := 0;
- begin
- Debug("To Wide: " & S);
- for I in S'Range loop
- Numerical := Numerical * 16 + Xlation(S(I));
- end loop;
- return Character'Val(Numerical);
- exception
- when Constraint_Error => return '_';
- end To_Ch;
-
- -- To_Wide
- --
- -- This function takes a string which is assumed to be trimmed to just a
- -- hexadecimal representation of a Wide_character. The result of the
- -- function is the Wide_character at the position designated by the
- -- incoming hexadecimal value. (hexadecimal in human readable form)
-
- function To_Wide( S:String ) return Wide_character is
- Numerical : Natural := 0;
- begin
- Debug("To Wide: " & S);
- for I in S'Range loop
- Numerical := Numerical * 16 + Xlation(S(I));
- end loop;
- return Wide_Character'Val(Numerical);
- exception
- when Constraint_Error => return '_';
- end To_Wide;
-
- -- Make_Wide
- --
- -- this function converts a String to a Wide_String
-
- function Make_Wide( S: String ) return Wide_String is
- W: Wide_String(S'Range);
- begin
- for I in S'Range loop
- W(I) := Wide_Character'Val( Character'Pos(S(I)) );
- end loop;
- return W;
- end Make_Wide;
-
- -- Close_Files
- --
- -- Depending on which input we've processed, close the output file
-
- procedure Close_Files is
- begin
- TIO.Close(In_File);
- if Output_Mode = Wide then
- WIO.Close(Wide_Out);
- else
- TIO.Close(Narrow_Out);
- end if;
- end Close_Files;
-
- -- Process
- --
- -- for all lines in the input file
- -- scan the file for occurrences of [" and "]
- -- for found occurrence, attempt translation of the characters found
- -- between the brackets. As a safeguard, unrecognizable character
- -- sequences will be replaced with the underscore character. This
- -- handles the cases in the tests where the test documentation includes
- -- examples that are non-conformant: i.e. ["abcd"] or ["XXXX"]
-
- procedure Process( Input_File_Name: String ) is
- begin
- TIO.Open(In_File,TIO.In_File,Input_File_Name & ".aw" );
-
- if Output_Mode = Wide then
- WIO.Create(Wide_Out,WIO.Out_File, Input_File_Name & ".a" );
- else
- TIO.Create(Narrow_Out,TIO.Out_File, Input_File_Name & ".a" );
- end if;
-
- File: while not TIO.End_Of_File( In_File ) loop
- In_Line := (others => ' ');
- TIO.Get_Line(In_File,In_Line,In_Length);
- Debug(In_Line(1..In_Length));
-
- Front := 1;
-
- Line: loop
- -- scan for next occurrence of ["abcd"]
- Open_Bracket := SF.Index( In_Line(Front..In_Length), "[""" );
- Close_Bracket := SF.Index( In_Line(Front..In_Length), """]" );
- Debug( "[=" & Natural'Image(Open_Bracket) );
- Debug( "]=" & Natural'Image(Close_Bracket) );
-
- if Open_Bracket = 0 or Close_Bracket = 0 then
- -- done with the line, output remaining characters and exit
- Debug("Done with line");
- if Output_Mode = Wide then
- WIO.Put_Line(Wide_Out, Make_Wide(In_Line(Front..In_Length)) );
- else
- TIO.Put_Line(Narrow_Out, In_Line(Front..In_Length) );
- end if;
- exit Line;
- else
- -- output the "normal" stuff up to the bracket
- if Output_Mode = Wide then
- WIO.Put(Wide_Out, Make_Wide(In_Line(Front..Open_Bracket-1)) );
- else
- TIO.Put(Narrow_Out, In_Line(Front..Open_Bracket-1) );
- end if;
-
- -- point beyond the closing bracket
- Front := Close_Bracket +2;
-
- -- output the translated hexadecimal character
- if Output_Mode = Wide then
- WIO.Put(Wide_Out,
- To_Wide( In_Line(Open_Bracket+2..Close_Bracket-1) ));
- else
- TIO.Put(Narrow_Out,
- To_Ch( In_Line(Open_Bracket+2..Close_Bracket-1)) );
- end if;
- end if;
- end loop Line;
-
- end loop File;
-
- Close_Files;
- exception
- when others =>
- Ada.Text_IO.Put_Line("Error in processing " & Input_File_Name);
- raise;
- end Process;
-
-begin
-
- Output_Mode := Wide;
- Process( Impdef.Wide_Character_Test );
-
- Output_Mode := Narrow;
- Process( Impdef.Upper_Latin_Test );
-
-end WideChr;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c330001.a b/gcc/testsuite/ada/acats/tests/c3/c330001.a
deleted file mode 100644
index 218896d679d..00000000000
--- a/gcc/testsuite/ada/acats/tests/c3/c330001.a
+++ /dev/null
@@ -1,354 +0,0 @@
--- C330001.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that a variable object of an indefinite type is properly
--- initialized/constrained by an initial value assignment that is
--- a) an aggregate, b) a function, or c) an object. Check that objects
--- of the above types do not need explicit constraints if they have
--- initial values.
---
--- TEST DESCRIPTION:
--- An indefinite subtype is either:
--- a) An unconstrained array subtype.
--- b) A subtype with unknown discriminants.
--- c) A subtype with unconstrained discriminants without defaults.
---
--- Declare several indefinite types in a parent package specification.
--- In the private part, complete one type with a discriminant without
--- default (indefinite) and the other with a default discriminant
--- (definite). Declare objects of both indefinite and definite subtypes
--- in children (private and public) with initialization expressions. The
--- test verifies all values of the objects. It also verifies that
--- Constraint_Error is raised if an attempt is made to change the
--- discriminants of the objects of the indefinite subtypes.
---
---
--- CHANGE HISTORY:
--- 15 Jan 95 SAIC Initial version for ACVC 2.1
--- 25 Jul 96 SAIC Modified test description. Deleted use C330001_0.
--- 20 Nov 98 RLB Added Elaborate pragmas to avoid problems
--- with an unconventional, but legal, elaboration
--- order.
---!
-
-package C330001_0 is
-
- subtype Sub_Type is Integer range 1 .. 20;
-
- type Tag_W_Disc (D : Sub_Type) is tagged record
- C1 : String (1 .. D);
- end record;
-
- -- Indefinite type declarations.
-
- type FullViewDefinite_Unknown_Disc (<>) is private;
-
- type Indefinite_No_Disc is array (Positive range <>) of Integer;
-
- type Indefinite_Tag_W_Disc (D : Sub_Type) is tagged
- record
- C1 : Boolean := False;
- end record;
-
- type Indefinite_New_W_Disc (ND : Sub_Type) is new
- Indefinite_Tag_W_Disc (ND) with record
- C2 : Integer := 9;
- end record;
-
- type Indefinite_W_Inherit_Disc_1 is new Tag_W_Disc with
- record
- S : Sub_Type := 18;
- end record;
-
- type Indefinite_W_Inherit_Disc_2 is
- new Tag_W_Disc with private;
-
- function Indef_Func_1 return FullViewDefinite_Unknown_Disc;
-
- function Indef_Func_2 (P : Sub_Type) return Indefinite_W_Inherit_Disc_2;
-
-private
-
- type FullViewDefinite_Unknown_Disc (D : Sub_Type := 2) is
- record
- S : String (1 .. D) := "Hi";
- end record;
-
- type Indefinite_W_Inherit_Disc_2 is new Tag_W_Disc with
- record
- S : Sub_Type;
- end record;
-
-end C330001_0;
-
- --==================================================================--
-
-package body C330001_0 is
-
- function Indef_Func_1 return FullViewDefinite_Unknown_Disc is
- Var_1 : FullViewDefinite_Unknown_Disc; -- No need for explicit
- -- constraints, use initial
- begin -- values.
- return Var_1;
- end Indef_Func_1;
-
- ------------------------------------------------------------------
- function Indef_Func_2 (P : Sub_Type) return Indefinite_W_Inherit_Disc_2 is
- Var_2 : Indefinite_W_Inherit_Disc_2 := (D => 5, C1 => "Hello", S => P);
- begin
- return Var_2;
- end Indef_Func_2;
-
-end C330001_0;
-
- --==================================================================--
-
-with C330001_0;
-pragma Elaborate(C330001_0); -- Insure that the functions can be called.
-private
-package C330001_0.C330001_1 is
-
- PrivateChild_Obj : Tag_W_Disc := (D => 4, C1 => "ACVC");
-
- PrivateChild_Obj_01 : Indefinite_W_Inherit_Disc_1
- := Indefinite_W_Inherit_Disc_1'(PrivateChild_Obj with S => 15);
-
- -- Since full view of Indefinite_W_Inherit_Disc_2 is indefinite in
- -- the parent package, Indefinite_W_Inherit_Disc_2 needs an initialization
- -- expression.
-
- PrivateChild_Obj_02 : Indefinite_W_Inherit_Disc_2 := Indef_Func_2 (19);
-
- -- Since full view of FullViewDefinite_Unknown_Disc is definite in the
- -- parent package, no initialization expression needed for
- -- PrivateChild_Obj_03.
-
- PrivateChild_Obj_03 : FullViewDefinite_Unknown_Disc;
-
- PrivateChild_Obj_04 : Indefinite_No_Disc := (12, 15);
-
-end C330001_0.C330001_1;
-
- --==================================================================--
-
-with C330001_0;
-pragma Elaborate(C330001_0); -- Insure that the functions can be called.
-package C330001_0.C330001_2 is
-
- PublicChild_Obj_01 : FullViewDefinite_Unknown_Disc := Indef_Func_1;
-
- PublicChild_Obj_02 : Indefinite_W_Inherit_Disc_2 := Indef_Func_2 (4);
-
- PublicChild_Obj_03 : Indefinite_No_Disc := (38, 72, 21, 59);
-
- PublicChild_Obj_04 : Indefinite_Tag_W_Disc := (D => 7, C1 => True);
-
- PublicChild_Obj_05 : Indefinite_Tag_W_Disc := PublicChild_Obj_04;
-
- PublicChild_Obj_06 : Indefinite_New_W_Disc (6);
-
- procedure Assign_Private_Obj_3;
-
- function Raised_CE_PublicChild_Obj return Boolean;
-
- function Raised_CE_PrivateChild_Obj return Boolean;
-
- -- The following functions check the private types defined in the parent
- -- and the private child package from within the client program.
-
- function Verify_Public_Obj_1 return Boolean;
-
- function Verify_Public_Obj_2 return Boolean;
-
- function Verify_Private_Obj_1 return Boolean;
-
- function Verify_Private_Obj_2 return Boolean;
-
- function Verify_Private_Obj_3 return Boolean;
-
-end C330001_0.C330001_2;
-
- --==================================================================--
-
-with Report;
-with C330001_0.C330001_1;
-package body C330001_0.C330001_2 is
-
- procedure Assign_Private_Obj_3 is
- begin
- C330001_0.C330001_1.PrivateChild_Obj_03 := (5, "Aloha");
- end Assign_Private_Obj_3;
-
- ------------------------------------------------------------------
- function Raised_CE_PublicChild_Obj return Boolean is
- begin
- PublicChild_Obj_03 := (16, 13); -- C_E, can't change constraints
- -- of PublicChild_Obj_03.
-
- Report.Failed ("Constraint_Error not raised - Public child");
-
- -- Next line prevents dead assignment.
-
- Report.Comment ("PublicChild_Obj_03'First is" & Integer'Image
- (PublicChild_Obj_03'First) );
- return False;
-
- exception
- when Constraint_Error =>
- return True; -- Exception is expected.
- when others =>
- return False;
- end Raised_CE_PublicChild_Obj;
-
- ------------------------------------------------------------------
- function Raised_CE_PrivateChild_Obj return Boolean is
- begin
- C330001_0.C330001_1.PrivateChild_Obj_04 := (21, 87, 18);
- -- C_E, can't change constraints
- -- of PrivateChild_Obj_04.
-
- Report.Failed ("Constraint_Error not raised - Private child");
-
- -- Next line prevents dead assignment.
-
- Report.Comment ("PrivateChild_Obj_04'Last is" & Integer'Image
- (C330001_0.C330001_1.PrivateChild_Obj_04'Last) );
- return False;
-
- exception
- when Constraint_Error =>
- return True; -- Exception is expected.
- when others =>
- return False;
- end Raised_CE_PrivateChild_Obj;
-
- ------------------------------------------------------------------
- function Verify_Public_Obj_1 return Boolean is
- begin
- return (PublicChild_Obj_01.D = 2 and PublicChild_Obj_01.S = "Hi");
-
- end Verify_Public_Obj_1;
-
- ------------------------------------------------------------------
- function Verify_Public_Obj_2 return Boolean is
- begin
- return (PublicChild_Obj_02.D = 5 and
- PublicChild_Obj_02.C1 = "Hello" and
- PublicChild_Obj_02.S = 4);
-
- end Verify_Public_Obj_2;
-
- ------------------------------------------------------------------
- function Verify_Private_Obj_1 return Boolean is
- begin
- return (C330001_0.C330001_1.PrivateChild_Obj_01.D = 4 and
- C330001_0.C330001_1.PrivateChild_Obj_01.C1 = "ACVC" and
- C330001_0.C330001_1.PrivateChild_Obj_01.S = 15);
-
- end Verify_Private_Obj_1;
-
- ------------------------------------------------------------------
- function Verify_Private_Obj_2 return Boolean is
- begin
- return (C330001_0.C330001_1.PrivateChild_Obj_02.D = 5 and
- C330001_0.C330001_1.PrivateChild_Obj_02.C1 = "Hello" and
- C330001_0.C330001_1.PrivateChild_Obj_02.S = 19);
-
- end Verify_Private_Obj_2;
-
- ------------------------------------------------------------------
- function Verify_Private_Obj_3 return Boolean is
- begin
- return (C330001_0.C330001_1.PrivateChild_Obj_03.D = 5 and
- C330001_0.C330001_1.PrivateChild_Obj_03.S = "Aloha");
-
- end Verify_Private_Obj_3;
-
-end C330001_0.C330001_2;
-
- --==================================================================--
-
-with C330001_0.C330001_2;
-with Report;
-
-use C330001_0.C330001_2;
-
-procedure C330001 is
-begin
- Report.Test ("C330001", "Check that a variable object of an indefinite " &
- "type is properly initialized/constrained by an initial " &
- "value assignment that is a) an aggregate, b) a function, " &
- "or c) an object. Check that objects of the above types " &
- "do not need explicit constraints if they have initial " &
- "values");
-
- -- Verify values of public child objects.
-
- if not (Verify_Public_Obj_1 and Verify_Public_Obj_2) then
- Report.Failed ("Wrong values for PublicChild_Obj_01 or " &
- "PublicChild_Obj_02");
- end if;
-
- if PublicChild_Obj_03'First /= 1 or
- PublicChild_Obj_03'Last /= 4 then
- Report.Failed ("Wrong values for PublicChild_Obj_03");
- end if;
-
- if PublicChild_Obj_05.D /= 7 or
- not PublicChild_Obj_05.C1 then
- Report.Failed ("Wrong values for PublicChild_Obj_05");
- end if;
-
- if PublicChild_Obj_06.ND /= 6 or
- PublicChild_Obj_06.C2 /= 9 or
- PublicChild_Obj_06.C1 then
- Report.Failed ("Wrong values for PublicChild_Obj_06");
- end if;
-
- -- Definite object can have its discriminant changed by assignment to
- -- the entire object.
-
- Assign_Private_Obj_3;
-
- -- Verify values of private child objects.
-
- if not Verify_Private_Obj_1 or not
- Verify_Private_Obj_2 or not
- Verify_Private_Obj_3 then
- Report.Failed ("Wrong values for PrivateChild_Obj_01 or " &
- "PrivateChild_Obj_02 or PrivateChild_Obj_03");
- end if;
-
- -- Attempt to change the discriminants of the objects of the indefinite
- -- subtypes: Constraint_Error.
-
- if not Raised_CE_PublicChild_Obj or not Raised_CE_PrivateChild_Obj then
- Report.Failed ("Constraint_Error not raised");
- end if;
-
- Report.Result;
-
-end C330001;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c330002.a b/gcc/testsuite/ada/acats/tests/c3/c330002.a
deleted file mode 100644
index 1403d5557b1..00000000000
--- a/gcc/testsuite/ada/acats/tests/c3/c330002.a
+++ /dev/null
@@ -1,326 +0,0 @@
--- C330002.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that if a subtype indication of a variable object defines an
--- indefinite subtype, then there is an initialization expression.
--- Check that the object remains so constrained throughout its lifetime.
--- Check for cases of tagged record, arrays and generic formal type.
---
--- TEST DESCRIPTION:
--- An indefinite subtype is either:
--- a) An unconstrained array subtype.
--- b) A subtype with unknown discriminants (this includes class-wide
--- types).
--- c) A subtype with unconstrained discriminants without defaults.
---
--- Declare tagged types with unconstrained discriminants without
--- defaults. Declare an unconstrained array. Declare a generic formal
--- type with an unknown discriminant and a formal object of this type.
--- In the generic package, declare an object of the formal type using
--- the formal object as its initial value. In the main program,
--- declare objects of tagged types. Instantiate the generic package.
--- The test checks that Constraint_Error is raised if an attempt is
--- made to change bounds as well as discriminants of the objects of the
--- indefinite subtypes.
---
---
--- CHANGE HISTORY:
--- 01 Nov 95 SAIC Initial prerelease version.
--- 27 Jul 96 SAIC Modified test description & Report.Test. Added
--- code to prevent dead variable optimization.
---
---!
-
-package C330002_0 is
-
- subtype Small_Num is Integer range 1 .. 20;
-
- -- Types with unconstrained discriminants without defaults.
-
- type Tag_Type (Disc : Small_Num) is tagged
- record
- S : String (1 .. Disc);
- end record;
-
- function Tag_Value return Tag_Type;
-
- procedure Assign_Tag (A : out Tag_Type);
-
- procedure Avoid_Optimization_and_Fail (P : Tag_Type; Msg : String);
-
- ---------------------------------------------------------------------
- -- An unconstrained array type.
-
- type Array_Type is array (Positive range <>) of Integer;
-
- function Array_Value return Array_Type;
-
- procedure Assign_Array (A : out Array_Type);
-
- ---------------------------------------------------------------------
- generic
- -- Type with an unknown discriminant.
- type Formal_Type (<>) is private;
- FT_Obj : Formal_Type;
- package Gen is
- Gen_Obj : Formal_Type := FT_Obj;
- end Gen;
-
-end C330002_0;
-
- --==================================================================--
-
-with Report;
-package body C330002_0 is
-
- procedure Assign_Tag (A : out Tag_Type) is
- begin
- A := (3, "Bye");
- end Assign_Tag;
-
- ----------------------------------------------------------------------
- procedure Avoid_Optimization_and_Fail (P : Tag_Type; Msg : String) is
- Default : Tag_Type := (1, "!"); -- Unique value.
- begin
- if P = Default then -- Both If branches can't do the same thing.
- Report.Failed (Msg & ": Constraint_Error not raised");
- else -- Subtests should always select this path.
- Report.Failed ("Constraint_Error not raised " & Msg);
- end if;
- end Avoid_Optimization_and_Fail;
-
- ----------------------------------------------------------------------
- function Tag_Value return Tag_Type is
- TO : Tag_Type := (4 , "ACVC");
- begin
- return TO;
- end Tag_Value;
-
- ----------------------------------------------------------------------
- function Array_Value return Array_Type is
- IA : Array_Type := (20, 31);
- begin
- return IA;
- end Array_Value;
-
- ----------------------------------------------------------------------
- procedure Assign_Array (A : out Array_Type) is
- begin
- A := (84, 36);
- end Assign_Array;
-
-end C330002_0;
-
- --==================================================================--
-
-with Report;
-with C330002_0;
-use C330002_0;
-
-procedure C330002 is
-
-begin
- Report.Test ("C330002", "Check that if a subtype indication of a " &
- "variable object defines an indefinite subtype, then " &
- "there is an initialization expression. Check that " &
- "the object remains so constrained throughout its " &
- "lifetime. Check that Constraint_Error is raised " &
- "if an attempt is made to change bounds as well as " &
- "discriminants of the objects of the indefinite " &
- "subtypes. Check for cases of tagged record and generic " &
- "formal types");
-
- TagObj_Block:
- declare
- TObj_ByAgg : Tag_Type := (5, "Hello"); -- Initial assignment is
- -- aggregate.
- TObj_ByObj : Tag_Type := TObj_ByAgg; -- Initial assignment is
- -- an object.
- TObj_ByFunc : Tag_Type := Tag_Value; -- Initial assignment is
- -- function return value.
- Ren_Obj : Tag_Type renames TObj_ByAgg;
-
- begin
-
- begin
- if (TObj_ByAgg.Disc /= 5) or (TObj_ByAgg.S /= "Hello") then
- Report.Failed ("Wrong initial values for TObj_ByAgg");
- end if;
-
- TObj_ByAgg := (2, "Hi"); -- C_E, can't change the
- -- value of the discriminant.
-
- Avoid_Optimization_and_Fail (TObj_ByAgg, "Subtest 1");
-
- exception
- when Constraint_Error => null; -- Exception is expected.
- when others =>
- Report.Failed ("Unexpected exception - Subtest 1");
- end;
-
-
- begin
- Assign_Tag (Ren_Obj); -- C_E, can't change the
- -- value of the discriminant.
-
- Avoid_Optimization_and_Fail (Ren_Obj, "Subtest 2");
-
- exception
- when Constraint_Error => null; -- Exception is expected.
- when others =>
- Report.Failed ("Unexpected exception - Subtest 2");
- end;
-
-
- begin
- if (TObj_ByObj.Disc /= 5) or (TObj_ByObj.S /= "Hello") then
- Report.Failed ("Wrong initial values for TObj_ByObj");
- end if;
-
- TObj_ByObj := (3, "Bye"); -- C_E, can't change the
- -- value of the discriminant.
-
- Avoid_Optimization_and_Fail (TObj_ByObj, "Subtest 3");
-
- exception
- when Constraint_Error => null; -- Exception is expected.
- when others =>
- Report.Failed ("Unexpected exception - Subtest 3");
- end;
-
-
- begin
- if (TObj_ByFunc.Disc /= 4) or (TObj_ByFunc.S /= "ACVC") then
- Report.Failed ("Wrong initial values for TObj_ByFunc");
- end if;
-
- TObj_ByFunc := (5, "Aloha"); -- C_E, can't change the
- -- value of the discriminant.
-
- Avoid_Optimization_and_Fail (TObj_ByFunc, "Subtest 4");
-
- exception
- when Constraint_Error => null; -- Exception is expected.
- when others =>
- Report.Failed ("Unexpected exception - Subtest 4");
- end;
-
- end TagObj_Block;
-
-
- ArrObj_Block:
- declare
- Arr_Const : constant Array_Type
- := (9, 7, 6, 8);
- Arr_ByAgg : Array_Type -- Initial assignment is
- := (10, 11, 12); -- aggregate.
- Arr_ByFunc : Array_Type -- Initial assignment is
- := Array_Value; -- function return value.
- Arr_ByObj : Array_Type -- Initial assignment is
- := Arr_ByAgg; -- object.
-
- Arr_Obj : array (Positive range <>) of Integer
- := (1, 2, 3, 4, 5);
- begin
-
- begin
- if (Arr_Const'First /= 1) or (Arr_Const'Last /= 4) then
- Report.Failed ("Wrong bounds for Arr_Const");
- end if;
-
- if (Arr_ByAgg'First /= 1) or (Arr_ByAgg'Last /= 3) then
- Report.Failed ("Wrong bounds for Arr_ByAgg");
- end if;
-
- if (Arr_ByFunc'First /= 1) or (Arr_ByFunc'Last /= 2) then
- Report.Failed ("Wrong bounds for Arr_ByFunc");
- end if;
-
- if (Arr_ByObj'First /= 1) or (Arr_ByObj'Last /= 3) then
- Report.Failed ("Wrong bounds for Arr_ByObj");
- end if;
-
- Assign_Array (Arr_ByObj); -- C_E, Arr_ByObj bounds are
- -- 1..3.
-
- Report.Failed ("Constraint_Error not raised - Subtest 5");
-
- exception
- when Constraint_Error => null; -- Exception is expected.
- when others =>
- Report.Failed ("Unexpected exception - Subtest 5");
- end;
-
-
- begin
- if (Arr_Obj'First /= 1) or (Arr_Obj'Last /= 5) then
- Report.Failed ("Wrong bounds for Arr_Obj");
- end if;
-
- for I in 0 .. 5 loop
- Arr_Obj (I + 1) := I + 5; -- C_E, Arr_Obj bounds are
- end loop; -- 1..5.
-
- Report.Failed ("Constraint_Error not raised - Subtest 6");
-
- exception
- when Constraint_Error => null; -- Exception is expected.
- when others =>
- Report.Failed ("Unexpected exception - Subtest 6");
- end;
-
- end ArrObj_Block;
-
-
- GenericObj_Block:
- declare
- type Rec (Disc : Small_Num) is
- record
- S : Small_Num := Disc;
- end record;
-
- Rec_Obj : Rec := (2, 2);
- package IGen is new Gen (Rec, Rec_Obj);
-
- begin
- IGen.Gen_Obj := (3, 3); -- C_E, can't change the
- -- value of the discriminant.
-
- Report.Failed ("Constraint_Error not raised - Subtest 7");
-
- -- Next line prevents dead assignment.
- Report.Comment ("Disc is" & Integer'Image (IGen.Gen_Obj.Disc));
-
- exception
- when Constraint_Error => null; -- Exception is expected.
- when others =>
- Report.Failed ("Unexpected exception - Subtest 7");
-
- end GenericObj_Block;
-
- Report.Result;
-
-end C330002;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c332001.a b/gcc/testsuite/ada/acats/tests/c3/c332001.a
deleted file mode 100644
index 21d65737304..00000000000
--- a/gcc/testsuite/ada/acats/tests/c3/c332001.a
+++ /dev/null
@@ -1,226 +0,0 @@
--- C332001.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that the static expression given for a number declaration may be
--- of any numeric type. Check that the type of a named number is
--- universal_integer or universal_real regardless of the type of the
--- static expression that provides its value.
---
--- TEST DESCRIPTION:
--- This test defines a large cross section of mixed type named numbers.
--- Well, obviously the named numbers don't have types (other than
--- universal_integer and universal_real) associated with them.
--- This test uses typed static values in the definition of several named
--- numbers, and then mixes the named numbers to ensure that their typed
--- origins do not interfere with the use of their values.
---
---
--- CHANGE HISTORY:
--- 10 OCT 95 SAIC Initial version
--- 11 APR 96 SAIC Fixed a few arithmetic errors for 2.1
--- 24 NOV 98 RLB Removed decimal types to insure that this
--- test is applicable to all implementations.
---
---!
-
------------------------------------------------------------------ C332001_0
-
-package C332001_0 is
-
- type Enumeration_Type is ( Ah, Gnome, Er, Ay, Shun );
-
- type Integer_Type is range 0..1023;
-
- type Modular_Type is mod 256;
-
- type Floating_Type is digits 4;
-
- type Fixed_Type is delta 0.125 range -10.0 .. 10.0;
-
- type Mod_Array is array(Modular_Type) of Floating_Type;
-
- type Int_Array is array(Integer_Type) of Fixed_Type;
-
- type Record_Type is record
- Pinkie : Integer_Type;
- Ring : Modular_Type;
- Middle : Floating_Type;
- Index : Fixed_Type;
- end record;
-
- Mod_Array_Object : Mod_Array;
- Int_Array_Object : Int_Array;
-
- Record_Object : Record_Type;
-
- -- numeric_literals
-
- Nothing_New_Integer : constant := 1;
- Nothing_New_Real : constant := 1.0;
-
- -- static constants
-
- Integ : constant Integer_Type := 2;
- Modul : constant Modular_Type := 2;
- Float : constant Floating_Type := 2.0; -- bad practice, good test
- Fixed : constant Fixed_Type := 2.0;
-
- Named_Integer : constant := Integ; -- 2
- Named_Modular : constant := Modul; -- 2
- Named_Float : constant := Float; -- 2.0
- Named_Fixed : constant := Fixed; -- 2.0
-
- -- function calls
- -- parenthetical expressions
-
- Fn_Integer : constant := Integer_Type'Min(Integ * 2, 8); -- 4
- Fn_Modular : constant := Modular_Type'Max(Modul + 2, Modular_Type'First);--4
- Fn_Float : constant := (Float ** 2); -- 4.0
- Fn_Fixed : constant := - Fixed; -- -2.0
- -- attributes
-
- ITF : constant := Integer_Type'First; -- 0
- MTL : constant := Modular_Type'Last; -- 255
- MTM : constant := Modular_Type'Modulus; -- 256
- ENP : constant := Enumeration_Type'Pos(Ay); -- 3
- MTP : constant := Modular_Type'Pred(Modul); -- 1
- FTS : constant := Fixed_Type'Size; -- # impdef
- ITS : constant := Integer_Type'Succ(Integ); -- 3
-
- -- array attributes 'First, 'Last, 'Length
-
- MAFirst : constant := Mod_Array_Object'First; -- 0
- IALast : constant := Int_Array_Object'Last; -- 1023
- MAL : constant := Mod_Array_Object'Length; -- 255
- IAL : constant := Int_Array_Object'Length; -- 1024
-
- -- type conversions
- --
- -- F\T Int Mod Flt Fix
- -- Int . X O X
- -- Mod O . X O
- -- Flt X O . X
- -- Fix O X O .
-
- Int2Mod : constant := Modular_Type (Integ); -- 2
- Int2Fix : constant := Fixed_Type (Integ); -- 2.0
- Mod2Flt : constant := Floating_Type (Modul); -- 2.0
- Flt2Int : constant := Integer_Type(Float); -- 2
- Flt2Fix : constant := Fixed_Type (Float); -- 2.0
- Fix2Mod : constant := Modular_Type (Fixed); -- 2
-
- procedure Check_Values;
-
- -- TRANSITION CHECKS
- --
- -- The following were illegal in Ada83; they are now legal in Ada95
- --
-
- Int_Base_First : constant := Integer'Base'First; -- # impdef
- Int_First : constant := Integer'First; -- # impdef
- Int_Last : constant := Integer'Last; -- # impdef
- Int_Val : constant := Integer'Val(17); -- 17
-
- -- END OF TRANSITION CHECKS
-
-end C332001_0;
-
--- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
-
-with Report;
-package body C332001_0 is
-
- procedure Assert( Truth : Boolean; Message: String ) is
- begin
- if not Truth then
- Report.Failed("Assertion " & Message & " not true" );
- end if;
- end Assert;
-
- procedure Check_Values is
- begin
-
- Assert( Nothing_New_Integer * Named_Integer = Named_Modular,
- "Nothing_New_Integer * Named_Integer = Named_Modular" ); -- 1*2 = 2
- Assert( Nothing_New_Real * Named_Float = Named_Fixed,
- "Nothing_New_Real * Named_Float = Named_Fixed" );-- 1.0*2.0 = 2.0
-
- Assert( Fn_Integer = Int2Mod + Flt2Int,
- "Fn_Integer = Int2Mod + Flt2Int" ); -- 4 = 2+2
- Assert( Fn_Modular = Flt2Int * 2,
- "Fn_Modular = Flt2Int * 2" ); -- 4 = 2*2
- Assert( Fn_Float = Mod2Flt ** Fix2Mod,
- "Fn_Float = Mod2Flt ** Fix2Mod" ); -- 4.0 = 2.0**2
- Assert( Fn_Fixed = (- Mod2Flt),
- "Fn_Fixed = (- Mod2Flt)" ); -- -2.0 = (-2.0)
-
- Assert( ITF = Modular_Type'First,
- "ITF = Modular_Type'First" ); -- 0 = 0
- Assert( MTL < Integer_Type'Last,
- "MTL < Integer_Type'Last" ); -- 255 < 1023
- Assert( MTM < Integer_Type'Last,
- "MTM < Integer_Type'Last" ); -- 256 < 1023
- Assert( ENP > MTP,
- "ENP > MTP" ); -- 3 > 1
- Assert( (FTS < MTL) or (FTS >= MTL), -- given FTS is impdef...
- "(FTS < MTL) or (FTS >= MTL)" ); -- True
- Assert( FTS > ITS,
- "FTS > ITS" ); -- impdef > 3
-
- Assert( MAFirst = Int_Array_Object'First,
- "MAFirst = Int_Array_Object'First" ); -- 0 = 0
- Assert( IALast > MAFirst,
- "IALast > MAFirst" ); -- 1023 > 0
- Assert( MAL < IAL,
- "MAL < IAL" ); -- 255 < 1024
-
- Assert( Mod2Flt = Flt2Fix,
- "Mod2Flt = Flt2Fix" ); -- 2.0 = 2.0
-
- end Check_Values;
-
-end C332001_0;
-
-------------------------------------------------------------------- C332001
-
-with Report;
-with C332001_0;
-procedure C332001 is
-
-begin -- Main test procedure.
-
- Report.Test ("C332001", "Check that the static expression given for a " &
- "number declaration may be of any numeric type. " &
- "Check that the type of the named number is " &
- "universal_integer of universal_real regardless " &
- "of the type of the static expression that " &
- "provides its value" );
-
- C332001_0.Check_Values;
-
- Report.Result;
-
-end C332001;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c340001.a b/gcc/testsuite/ada/acats/tests/c3/c340001.a
deleted file mode 100644
index dce98bdb05b..00000000000
--- a/gcc/testsuite/ada/acats/tests/c3/c340001.a
+++ /dev/null
@@ -1,470 +0,0 @@
--- C340001.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that user-defined equality operators are inherited by a
--- derived type except when the derived type is a nonlimited record
--- extension. In the latter case, ensure that the primitive
--- equality operation of the record extension compares any extended
--- components according to the predefined equality operators of the
--- component types. Also check that the parent portion of the extended
--- type is compared using the user-defined equality operation of the
--- parent type.
---
--- TEST DESCRIPTION:
--- Declares a nonlimited tagged record and a limited tagged record
--- type, each in a separate package. A user-defined "=" operation is
--- defined for each type. Each type is extended with one new record
--- component added.
---
--- Objects are declared for each parent and extended types and are
--- assigned values. For the limited type, modifier operations defined
--- in the package are used to assign values.
---
--- To verify the use of the user-defined "=", values are assigned so
--- that predefined equality will return the opposite result if called.
--- Similarly, values are assigned to the extended type objects so that
--- one comparison will verify that the inherited components from the
--- parent are compared using the user-defined equality operation.
---
--- A second comparison sets the values of the inherited components to
--- be the same so that equality based on the extended component may be
--- verified. For the nonlimited type, the test for equality should
--- fail, as the "=" defined for this type should include testing
--- equality of the extended component. For the limited type, "=" of the
--- parent should be inherited as-is, so the test for equality should
--- succeed even though the records differ in the extended component.
---
--- A third package declares a discriminated tagged record. Equality
--- is user-defined and ignores the discriminant value. A type
--- extension is declared which also contains a discriminant. Since
--- an inherited discriminant may not be referenced other than in a
--- "new" discriminant, the type extension is also discriminated. The
--- discriminant is used as the constraint for the parent type.
---
--- A variant part is declared in the type extension based on the new
--- discriminant. Comparisons are made to confirm that the user-defined
--- equality operator is used to compare values of the type extension.
--- Two record objects are given values so that user-defined equality
--- for the parent portion of the record succeeds, but the variant
--- parts in the type extended object differ. These objects are checked
--- to ensure that they are not equal.
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 19 Dec 94 SAIC Removed RM references from objective text.
---
---!
-
-with Ada.Calendar;
-package C340001_0 is
-
- type DB_Record is tagged record
- Key : Natural range 1 .. 9999;
- Data : String (1..10);
- end record;
-
- function "=" (L, R : in DB_Record) return Boolean;
-
- type Dated_Record is new DB_Record with record
- Retrieval_Time : Ada.Calendar.Time;
- end record;
-
-end C340001_0;
-
-package body C340001_0 is
-
- function "=" (L, R : in DB_Record) return Boolean is
- -- Key is ignored in determining equality of records
- begin
- return L.Data = R.Data;
- end "=";
-
-end C340001_0;
-
-package C340001_1 is
-
- type List_Contents is array (1..10) of Integer;
- type List is tagged limited record
- Length : Natural range 0..10 := 0;
- Contents : List_Contents := (others => 0);
- end record;
-
- procedure Add_To (L : in out List; New_Value : in Integer);
- procedure Remove_From (L : in out List);
-
- function "=" (L, R : in List) return Boolean;
-
- subtype Revision_Mark is Character range 'A' .. 'Z';
- type Revisable_List is new List with record
- Revision : Revision_Mark := 'A';
- end record;
-
- procedure Revise (L : in out Revisable_List);
-
-end C340001_1;
-
-package body C340001_1 is
-
- -- Note: This is not a complete abstraction of a list. Exceptions
- -- are not defined and boundary checks are not made.
-
- procedure Add_To (L : in out List; New_Value : in Integer) is
- begin
- L.Length := L.Length + 1;
- L.Contents (L.Length) := New_Value;
- end Add_To;
-
- procedure Remove_From (L : in out List) is
- -- The list length is decremented. "Old" values are left in the
- -- array. They are overwritten when a new value is added.
- begin
- L.Length := L.Length - 1;
- end Remove_From;
-
- function "=" (L, R : in List) return Boolean is
- -- Two lists are equal if they are the same length and
- -- the component values within that length are the same.
- -- Values stored past the end of the list are ignored.
- begin
- return L.Length = R.Length
- and then L.Contents (1..L.Length) = R.Contents (1..R.Length);
- end "=";
-
- procedure Revise (L : in out Revisable_List) is
- begin
- L.Revision := Character'Succ (L.Revision);
- end Revise;
-
-end C340001_1;
-
-package C340001_2 is
-
- type Media is (Paper, Electronic);
-
- type Transaction (Medium : Media) is tagged record
- ID : Natural range 1000 .. 9999;
- end record;
-
- function "=" (L, R : in Transaction) return Boolean;
-
- type Authorization (Kind : Media) is new Transaction (Medium => Kind)
- with record
- case Kind is
- when Paper =>
- Signature_On_File : Boolean;
- when Electronic =>
- Paper_Backup : Boolean; -- to retain opposing value
- end case;
- end record;
-
-end C340001_2;
-
-package body C340001_2 is
-
- function "=" (L, R : in Transaction) return Boolean is
- -- There may be electronic and paper copies of the same transaction.
- -- The ID uniquely identifies a transaction. The medium (stored in
- -- the discriminant) is ignored.
- begin
- return L.ID = R.ID;
- end "=";
-
-end C340001_2;
-
-
-with C340001_0; -- nonlimited tagged record declarations
-with C340001_1; -- limited tagged record declarations
-with C340001_2; -- tagged variant declarations
-with Ada.Calendar;
-with Report;
-procedure C340001 is
-
- DB_Rec1 : C340001_0.DB_Record := (Key => 1,
- Data => "aaaaaaaaaa");
- DB_Rec2 : C340001_0.DB_Record := (Key => 55,
- Data => "aaaaaaaaaa");
- -- DB_Rec1 = DB_Rec2 using user-defined equality
- -- DB_Rec1 /= DB_Rec2 using predefined equality
-
- Some_Time : Ada.Calendar.Time :=
- Ada.Calendar.Time_Of (Month => 9, Day => 16, Year => 1993);
-
- Another_Time : Ada.Calendar.Time :=
- Ada.Calendar.Time_Of (Month => 9, Day => 19, Year => 1993);
-
- Dated_Rec1 : C340001_0.Dated_Record := (Key => 2,
- Data => "aaaaaaaaaa",
- Retrieval_Time => Some_Time);
- Dated_Rec2 : C340001_0.Dated_Record := (Key => 77,
- Data => "aaaaaaaaaa",
- Retrieval_Time => Some_Time);
- Dated_Rec3 : C340001_0.Dated_Record := (Key => 77,
- Data => "aaaaaaaaaa",
- Retrieval_Time => Another_Time);
- -- Dated_Rec1 = Dated_Rec2 if DB_Record."=" used for parent portion
- -- Dated_Rec2 /= Dated_Rec3 if extended component is compared
- -- using Ada.Calendar.Time."="
-
- List1 : C340001_1.List;
- List2 : C340001_1.List;
-
- RList1 : C340001_1.Revisable_List;
- RList2 : C340001_1.Revisable_List;
- RList3 : C340001_1.Revisable_List;
-
- Current : C340001_2.Transaction (C340001_2.Paper) :=
- (C340001_2.Paper, 2001);
- Last : C340001_2.Transaction (C340001_2.Electronic) :=
- (C340001_2.Electronic, 2001);
- -- Current = Last using user-defined equality
- -- Current /= Last using predefined equality
-
- Approval1 : C340001_2.Authorization (C340001_2.Paper)
- := (Kind => C340001_2.Paper,
- ID => 1040,
- Signature_On_File => True);
- Approval2 : C340001_2.Authorization (C340001_2.Paper)
- := (Kind => C340001_2.Paper,
- ID => 2167,
- Signature_On_File => False);
- Approval3 : C340001_2.Authorization (C340001_2.Electronic)
- := (Kind => C340001_2.Electronic,
- ID => 2167,
- Paper_Backup => False);
- -- Approval1 /= Approval2 if user-defined equality extended with
- -- component equality.
- -- Approval2 /= Approval3 if differing variant parts checked
-
- -- Direct visibility to operator symbols
- use type C340001_0.DB_Record;
- use type C340001_0.Dated_Record;
-
- use type C340001_1.List;
- use type C340001_1.Revisable_List;
-
- use type C340001_2.Transaction;
- use type C340001_2.Authorization;
-
-begin
-
- Report.Test ("C340001", "Inheritance of user-defined ""=""");
-
- -- Approval1 /= Approval2 if user-defined equality extended with
- -- component equality.
- -- Approval2 /= Approval3 if differing variant parts checked
-
- ---------------------------------------------------------------------
- -- Check that "=" and "/=" for the parent type call the user-defined
- -- operation
- ---------------------------------------------------------------------
-
- if not (DB_Rec1 = DB_Rec2) then
- Report.Failed ("Nonlimited tagged record: " &
- "User-defined equality did not override predefined " &
- "equality");
- end if;
-
- if DB_Rec1 /= DB_Rec2 then
- Report.Failed ("Nonlimited tagged record: " &
- "User-defined equality did not override predefined " &
- "inequality as well");
- end if;
-
- ---------------------------------------------------------------------
- -- Check that "=" and "/=" for the type extension use the user-defined
- -- equality operations from the parent to compare the inherited
- -- components
- ---------------------------------------------------------------------
-
- if not (Dated_Rec1 = Dated_Rec2) then
- Report.Failed ("Nonlimited tagged record: " &
- "User-defined equality was not used to compare " &
- "components inherited from parent");
- end if;
-
- if Dated_Rec1 /= Dated_Rec2 then
- Report.Failed ("Nonlimited tagged record: " &
- "User-defined inequality was not used to compare " &
- "components inherited from parent");
- end if;
-
- ---------------------------------------------------------------------
- -- Check that equality and inequality for the type extension incorporate
- -- the predefined equality operators for the extended component type
- ---------------------------------------------------------------------
- if Dated_Rec2 = Dated_Rec3 then
- Report.Failed ("Nonlimited tagged record: " &
- "Record equality was not extended with component " &
- "equality");
- end if;
-
- if not (Dated_Rec2 /= Dated_Rec3) then
- Report.Failed ("Nonlimited tagged record: " &
- "Record inequality was not extended with component " &
- "equality");
- end if;
-
- ---------------------------------------------------------------------
- C340001_1.Add_To (List1, 1);
- C340001_1.Add_To (List1, 2);
- C340001_1.Add_To (List1, 3);
- C340001_1.Remove_From (List1);
-
- C340001_1.Add_To (List2, 1);
- C340001_1.Add_To (List2, 2);
-
- -- List1 contents are (2, (1, 2, 3, 0, 0, 0, 0, 0, 0, 0))
- -- List2 contents are (2, (1, 2, 0, 0, 0, 0, 0, 0, 0, 0))
-
- -- List1 = List2 using user-defined equality
- -- List1 /= List2 using predefined equality
-
- ---------------------------------------------------------------------
- -- Check that "=" and "/=" for the parent type call the user-defined
- -- operation
- ---------------------------------------------------------------------
- if not (List1 = List2) then
- Report.Failed ("Limited tagged record : " &
- "User-defined equality incorrectly implemented " );
- end if;
-
- if List1 /= List2 then
- Report.Failed ("Limited tagged record : " &
- "User-defined equality incorrectly implemented " );
- end if;
-
- ---------------------------------------------------------------------
- -- RList1 and RList2 are made equal but "different" by adding
- -- a nonzero value to RList1 then removing it. Removal updates
- -- the list Length only, not its contents. The two lists will be
- -- equal according to the defined list abstraction, but the records
- -- will contain differing component values.
-
- C340001_1.Add_To (RList1, 1);
- C340001_1.Add_To (RList1, 2);
- C340001_1.Add_To (RList1, 3);
- C340001_1.Remove_From (RList1);
-
- C340001_1.Add_To (RList2, 1);
- C340001_1.Add_To (RList2, 2);
-
- C340001_1.Add_To (RList3, 1);
- C340001_1.Add_To (RList3, 2);
-
- C340001_1.Revise (RList3);
-
- -- RList1 contents are (2, (1, 2, 3, 0, 0, 0, 0, 0, 0, 0), 'A')
- -- RList2 contents are (2, (1, 2, 0, 0, 0, 0, 0, 0, 0, 0), 'A')
- -- RList3 contents are (2, (1, 2, 0, 0, 0, 0, 0, 0, 0, 0), 'B')
-
- -- RList1 = RList2 if List."=" inherited
- -- RList2 /= RList3 if List."=" inherited and extended with Character "="
-
- ---------------------------------------------------------------------
- -- Check that "=" and "/=" are the user-defined operations inherited
- -- from the parent type.
- ---------------------------------------------------------------------
- if not (RList1 = RList2) then
- Report.Failed ("Limited tagged record : " &
- "User-defined equality was not inherited");
- end if;
-
- if RList1 /= RList2 then
- Report.Failed ("Limited tagged record : " &
- "User-defined inequality was not inherited");
- end if;
- ---------------------------------------------------------------------
- -- Check that "=" and "/=" for the type extension are NOT extended
- -- with the predefined equality operators for the extended component.
- -- A limited type extension should inherit the parent equality operation
- -- as is.
- ---------------------------------------------------------------------
- if not (RList2 = RList3) then
- Report.Failed ("Limited tagged record : " &
- "Inherited equality operation was extended with " &
- "component equality");
- end if;
-
- if RList2 /= RList3 then
- Report.Failed ("Limited tagged record : " &
- "Inherited inequality operation was extended with " &
- "component equality");
- end if;
-
- ---------------------------------------------------------------------
- -- Check that "=" and "/=" for the parent type call the user-defined
- -- operation
- ---------------------------------------------------------------------
- if not (Current = Last) then
- Report.Failed ("Variant record : " &
- "User-defined equality did not override predefined " &
- "equality");
- end if;
-
- if Current /= Last then
- Report.Failed ("Variant record : " &
- "User-defined inequality did not override predefined " &
- "inequality");
- end if;
-
- ---------------------------------------------------------------------
- -- Check that user-defined equality was incorporated and extended
- -- with equality of extended components.
- ---------------------------------------------------------------------
- if not (Approval1 /= Approval2) then
- Report.Failed ("Variant record : " &
- "Inequality was not extended with component " &
- "inequality");
- end if;
-
- if Approval1 = Approval2 then
- Report.Failed ("Variant record : " &
- "Equality was not extended with component " &
- "equality");
- end if;
-
- ---------------------------------------------------------------------
- -- Check that equality and inequality for the type extension
- -- succeed despite the presence of differing variant parts.
- ---------------------------------------------------------------------
- if Approval2 = Approval3 then
- Report.Failed ("Variant record : " &
- "Equality succeeded even though variant parts " &
- "in type extension differ");
- end if;
-
- if not (Approval2 /= Approval3) then
- Report.Failed ("Variant record : " &
- "Inequality failed even though variant parts " &
- "in type extension differ");
- end if;
-
- ---------------------------------------------------------------------
- Report.Result;
- ---------------------------------------------------------------------
-
-end C340001;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c340a01.a b/gcc/testsuite/ada/acats/tests/c3/c340a01.a
deleted file mode 100644
index 108a30b5ff6..00000000000
--- a/gcc/testsuite/ada/acats/tests/c3/c340a01.a
+++ /dev/null
@@ -1,165 +0,0 @@
--- C340A01.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that a tagged type declared in a package specification
--- may be passed as a generic formal (tagged) private type to a generic
--- package declaration. Check that the formal type may be extended with
--- a record extension in the generic package.
---
--- Check that, in the instance, the record extension inherits the
--- user-defined primitive subprograms of the tagged actual.
---
--- TEST DESCRIPTION:
--- Declare a tagged type and an associated primitive subprogram in a
--- package specification (foundation code). Declare a generic package
--- which takes a tagged type as a formal parameter, and then extends
--- it with a record extension (foundation code).
---
--- Instantiate the generic package with the tagged type from the first
--- package (the "generic" extension should now have inherited
--- the primitive subprogram of the tagged type from the first
--- package).
---
--- In the main program, call the primitive subprogram inherited by the
--- "generic" extension, and verify the correctness of the components.
---
--- TEST FILES:
--- This test consists of the following files:
---
--- F340A000.A
--- F340A001.A
--- => C340A01.A
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 12 Jun 96 SAIC ACVC 2.1: Modified prologue. Removed extraneous
--- comments.
---
---!
-
-with F340A001; -- Book definitions.
-package C340A01_0 is -- Raw data to be used in creating book elements.
-
-
- Book_Count : constant := 3;
-
- subtype Number_Of_Books is Integer range 1 .. Book_Count;
-
- type Data_List is array (Number_Of_Books) of F340A001.Text_Ptr;
-
- Title_List : Data_List := (new String'("Wuthering Heights"),
- new String'("Heart of Darkness"),
- new String'("Ulysses"));
-
- Author_List : Data_List := (new String'("Bronte, Emily"),
- new String'("Conrad, Joseph"),
- new String'("Joyce, James"));
-
-end C340A01_0;
-
-
- --==================================================================--
-
-
--- Library-level instantiation. Actual parameter is tagged record.
-
-with F340A001; -- Book definitions.
-with F340A000; -- Singly-linked list abstraction.
-package C340A01_1 is new F340A000 (Parent_Type => F340A001.Book_Type);
-
-
- --==================================================================--
-
-
-with Report;
-
-with F340A001; -- Book definitions.
-with C340A01_0; -- Raw book data.
-with C340A01_1; -- Instance.
-
-use F340A001; -- Primitive operations of Book_Type directly visible.
-use C340A01_1; -- Operations inherited by Node_Type directly visible.
-
-procedure C340A01 is
-
-
- List_Of_Books : Node_Ptr := null; -- Head of linked list of books.
-
-
- --========================================================--
-
-
- procedure Create_List (Title, Author : in C340A01_0.Data_List;
- Head : in out Node_Ptr) is
-
- Book : Node_Type; -- Object of extended type.
- Book_Ptr : Node_Ptr;
-
- begin
- for I in C340A01_0.Number_Of_Books loop
- Create_Book (Title (I), Author (I), Book); -- Call inherited
- -- operation.
- Book_Ptr := new Node_Type'(Book);
- Add (Book_Ptr, Head);
- end loop;
- end Create_List;
-
-
- --========================================================--
-
-
- function Bad_List_Contents return Boolean is
- begin
- return (List_Of_Books.Title.all /= "Ulysses" or
- List_Of_Books.Author.all /= "Joyce, James" or
- List_Of_Books.Next.Title.all /= "Heart of Darkness" or
- List_Of_Books.Next.Author.all /= "Conrad, Joseph" or
- List_Of_Books.Next.Next.Title.all /= "Wuthering Heights" or
- List_Of_Books.Next.Next.Author.all /= "Bronte, Emily");
- end Bad_List_Contents;
-
-
- --========================================================--
-
-
-begin -- Main program.
-
- Report.Test ("C340A01", "Inheritance of primitive operations: record " &
- "extension of formal tagged private type; actual is " &
- "an ultimate ancestor type");
-
- -- Create linked list using inherited operation:
- Create_List (C340A01_0.Title_List, C340A01_0.Author_List, List_Of_Books);
-
- -- Verify results:
- if Bad_List_Contents then
- Report.Failed ("Wrong values after call to inherited operation");
- end if;
-
- Report.Result;
-
-end C340A01;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c340a02.a b/gcc/testsuite/ada/acats/tests/c3/c340a02.a
deleted file mode 100644
index 2dd8f175c09..00000000000
--- a/gcc/testsuite/ada/acats/tests/c3/c340a02.a
+++ /dev/null
@@ -1,221 +0,0 @@
--- C340A02.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that a record extension (declared in a package specification) of
--- a tagged type (declared in a different package specification) may be
--- passed as a generic formal (tagged) private type to a generic package
--- declaration. Check that the formal type may be further extended with a
--- record extension in the generic package.
---
--- Check that, in the instance, the record extension inherits the
--- user-defined primitive subprograms of the tagged actual, including
--- those inherited by the actual from its parent.
---
--- TEST DESCRIPTION:
--- Declare a tagged type and an associated primitive subprogram in a
--- package specification (foundation code). Declare a record extension
--- of the tagged type and an associated primitive subprogram in a second
--- package specification. Declare a generic package which takes a tagged
--- type as a formal parameter, and then extends it with a record
--- extension (foundation code).
---
--- Instantiate the generic package with the record extension from the
--- second package (the "generic" extension should now have inherited
--- the primitive subprograms of the record extension from the second
--- package).
---
--- In the main program, call the primitive subprograms inherited by the
--- "generic" extension. There are two: (1) Create_Book, declared for
--- the root tagged type in the first package (inherited by the record
--- extension of the second package, and then in turn by the "generic"
--- extension), and (2) Update_Pages, declared for the record extension
--- in the second package. Verify the correctness of the components.
---
--- TEST FILES:
--- This test consists of the following files:
---
--- F340A000.A
--- F340A001.A
--- => C340A02.A
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 12 Jun 96 SAIC ACVC 2.1: Modified prologue. Removed extraneous
--- comments.
---
---!
-
-with F340A001; -- Book definitions.
-package C340A02_0 is -- Extended book abstraction.
-
-
- type Detailed_Book_Type is new F340A001.Book_Type with record
- Pages : Natural; -- Record ext.
- end record; -- of root tagged
- -- type.
-
- -- Inherits Create_Book from Book_Type.
-
- procedure Update_Pages (Book : in out Detailed_Book_Type; -- Primitive op.
- Pages : in Natural); -- of extension.
-
-
-end C340A02_0;
-
-
- --==================================================================--
-
-
-package body C340A02_0 is
-
-
- procedure Update_Pages (Book : in out Detailed_Book_Type;
- Pages : in Natural) is
- begin
- Book.Pages := Pages;
- end Update_Pages;
-
-
-end C340A02_0;
-
-
- --==================================================================--
-
-
-with F340A001; -- Book definitions.
-package C340A02_1 is -- Raw data to be used in creating book elements.
-
-
- Book_Count : constant := 3;
-
- subtype Number_Of_Books is Integer range 1 .. Book_Count;
-
- type Data_List is array (Number_Of_Books) of F340A001.Text_Ptr;
- type Page_Counts is array (Number_Of_Books) of Natural;
-
- Title_List : Data_List := (new String'("Wuthering Heights"),
- new String'("Heart of Darkness"),
- new String'("Ulysses"));
-
- Author_List : Data_List := (new String'("Bronte, Emily"),
- new String'("Conrad, Joseph"),
- new String'("Joyce, James"));
-
- Page_List : Page_Counts := (237, 215, 456);
-
-end C340A02_1;
-
-
- --==================================================================--
-
-
--- Library-level instantiation. Actual parameter is record extension.
-
-with C340A02_0; -- Extended book abstraction.
-with F340A000; -- Singly-linked list abstraction.
-package C340A02_2 is new F340A000
- (Parent_Type => C340A02_0.Detailed_Book_Type);
-
-
- --==================================================================--
-
-
-with Report;
-
-with C340A02_0; -- Extended book abstraction.
-with C340A02_1; -- Raw book data.
-with C340A02_2; -- Instance.
-
-use C340A02_0; -- Primitive operations of Detailed_Book_Type directly visible.
-use C340A02_2; -- Operations inherited by Node_Type directly visible.
-
-procedure C340A02 is
-
-
- List_Of_Books : Node_Ptr := null; -- Head of linked list of books.
-
-
- --========================================================--
-
-
- procedure Create_List (Title, Author : in C340A02_1.Data_List;
- Pages : in C340A02_1.Page_Counts;
- Head : in out Node_Ptr) is
-
- Book : Node_Type; -- Object of extended type.
- Book_Ptr : Node_Ptr;
-
- begin
- for I in C340A02_1.Number_Of_Books loop
- Create_Book (Title (I), Author (I), Book); -- Call twice-inherited
- -- operation.
- Update_Pages (Book, Pages (I)); -- Call inherited op.
- Book_Ptr := new Node_Type'(Book);
- Add (Book_Ptr, Head);
- end loop;
- end Create_List;
-
-
- --========================================================--
-
-
- function Bad_List_Contents return Boolean is
- begin
- return (List_Of_Books.Title.all /= "Ulysses" or
- List_Of_Books.Author.all /= "Joyce, James" or
- List_Of_Books.Pages /= 456 or
- List_Of_Books.Next.Title.all /= "Heart of Darkness" or
- List_Of_Books.Next.Author.all /= "Conrad, Joseph" or
- List_Of_Books.Next.Pages /= 215 or
- List_Of_Books.Next.Next.Title.all /= "Wuthering Heights" or
- List_Of_Books.Next.Next.Author.all /= "Bronte, Emily" or
- List_Of_Books.Next.Next.Pages /= 237);
-
- end Bad_List_Contents;
-
-
- --========================================================--
-
-
-begin -- Main program.
-
- Report.Test ("C340A02", "Inheritance of primitive operations: record " &
- "extension of formal tagged private type; actual is " &
- "a record extension");
-
- -- Create linked list using inherited operation:
- Create_List (C340A02_1.Title_List, C340A02_1.Author_List,
- C340A02_1.Page_List, List_Of_Books);
-
- -- Verify results:
- if Bad_List_Contents then
- Report.Failed ("Wrong values after call to inherited operations");
- end if;
-
- Report.Result;
-
-end C340A02;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c341a01.a b/gcc/testsuite/ada/acats/tests/c3/c341a01.a
deleted file mode 100644
index 34a1eeeaac6..00000000000
--- a/gcc/testsuite/ada/acats/tests/c3/c341a01.a
+++ /dev/null
@@ -1,117 +0,0 @@
--- C341A01.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that formal parameters of a class-wide type can be passed
--- values of any specific type within the class.
---
--- TEST DESCRIPTION:
--- Define an object of a root tagged type and of various types derived
--- from the root. Define objects of the root class, and initialize them
--- by parameter association of objects of the specific types (root and
--- extended types) within the class.
---
--- The particular root and extended types used in this abstraction are
--- defined in foundation code (F341A00.A), and are graphically displayed
--- as follows:
---
--- package Bank
--- type Account
--- |
--- |
--- |
--- package Checking
--- type Account
--- |
--- |
--- |
--- package Interest_Checking
--- type Account
---
---
--- TEST FILES:
--- This test depends on the following foundation code:
---
--- F341A00.A
---
--- The following files comprise this test:
---
--- => C341A01.A
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
---
---!
-
-with F341A00_0; -- package Bank
-with F341A00_1; -- package Checking
-with F341A00_2; -- package Interest_Checking
-with Report;
-
-procedure C341A01 is
-
- package Bank renames F341A00_0;
- use type Bank.Dollar_Amount;
- package Checking renames F341A00_1;
- package Interest_Checking renames F341A00_2;
-
- Max_Accts : constant := 3;
- Bank_Balance : Bank.Dollar_Amount := 0.00;
-
- -- Initialize objects of specific tagged types.
- B_Acct : Bank.Account := (Current_Balance => 10.00);
- C_Acct : Checking.Account := (100.00, 10.00);
- IC_Acct : Interest_Checking.Account := (1000.00, 10.00, 0.030);
-
- -- Define and initialize (by parameter association) objects of class-wide
- -- type originating from the root type (Bank.Account).
-
- -- Define an account auditing procedure with a class-wide
- -- variable that can hold a value of any object within the class.
- procedure Audit (Next_Account : Bank.Account'Class) is
- begin
- Bank_Balance := Bank_Balance + Next_Account.Current_Balance;
- end Audit;
-
-
-begin -- C341A01
-
- Report.Test ("C341A01", "Check that objects of a class-wide type can " &
- "be initialized, by direct assignment, to a " &
- "value of any specific type within the class" );
-
- -- Perform nightly audit of total funds on deposit in bank.
- Audit (B_Acct);
- Audit (C_Acct);
- Audit (IC_Acct);
-
- if Bank_Balance /= 1110.00 then
- Report.Failed ("Class-wide object processing failed");
- end if;
-
- Report.Result;
-
-end C341A01;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c341a02.a b/gcc/testsuite/ada/acats/tests/c3/c341a02.a
deleted file mode 100644
index 4fa9842bf60..00000000000
--- a/gcc/testsuite/ada/acats/tests/c3/c341a02.a
+++ /dev/null
@@ -1,145 +0,0 @@
--- C341A02.A
- --
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
- --
- -- OBJECTIVE:
- -- Check that class-wide objects can be reassigned with objects from
- -- the same specific type used to initialize them.
- --
- -- TEST DESCRIPTION:
- -- Define new objects of specific types from within a class. Reassign
- -- previously declared class-wide objects with the new specific type
- -- objects. Check that new assignments were performed.
- --
- -- The particular root and extended types used in this abstraction are
- -- defined in foundation code (F341A00.A), and are graphically displayed
- -- as follows:
- --
- -- package Bank
- -- type Account
- -- |
- -- |
- -- |
- -- package Checking
- -- type Account
- -- |
- -- |
- -- |
- -- package Interest_Checking
- -- type Account
- --
- -- TEST FILES:
- -- This test depends on the following foundation code:
- --
- -- F341A00.A
- --
- -- The following files comprise this test:
- --
- -- => C341A02.A
- --
- --
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
---
- --!
-
- with F341A00_0; -- package Bank
- with F341A00_1; -- package Checking
- with F341A00_2; -- package Interest_Checking
- with Report;
-
- procedure C341A02 is
-
- package Bank renames F341A00_0;
- package Checking renames F341A00_1;
- package Interest_Checking renames F341A00_2;
-
- Max_Accts : constant := 3;
- Bank_Balance : Bank.Dollar_Amount := 0.00;
-
- -- Define and initialize objects of specific types.
- B_Acct : aliased Bank.Account := (Current_Balance => 10.00);
- C_Acct : aliased Checking.Account := (100.00, 10.00);
- IC_Acct : aliased Interest_Checking.Account := (1000.00, 10.00, 0.030);
- New_B_Acct : aliased Bank.Account := (Current_Balance => 20.00);
- New_C_Acct : aliased Checking.Account := (200.00, 20.00);
- New_IC_Acct : aliased Interest_Checking.Account := (2000.00, 20.00, 0.060);
-
-
- -- Define and initialize (by direct assignment) objects of a class-wide
- -- type originating from the root type (Bank.Account).
-
- type ATM_Card is access all Bank.Account'Class;
-
- Accounts : array (1 .. Max_Accts) of ATM_Card :=
- (1 => B_Acct'Access, 2 => C_Acct'Access, 3 => IC_Acct'Access);
-
- New_Accounts : array (1 .. Max_Accts) of ATM_Card :=
- (1 => New_B_Acct'Access,
- 2 => New_C_Acct'Access,
- 3 => New_IC_Acct'Access);
-
- -- Define an account auditing procedure with a class-wide
- -- variable that can hold a value of any object within the class,
- -- and once initialized, can hold other values of the same specific type.
-
- procedure Audit (Num : in integer;
- Amt : out Bank.Dollar_Amount) is
- Account_Being_Audited : Bank.Account'Class := Accounts(Num).all;
- use type Bank.Dollar_Amount;
- begin
- Amt := Account_Being_Audited.Current_Balance;
- -- Reassign class-wide variable to another object of the type used to
- -- initialize it.
- Account_Being_Audited := New_Accounts(Num).all;
- Amt := Amt + Account_Being_Audited.Current_Balance; -- Reading OUT
- end Audit; -- parameter.
-
-
- begin
-
- Report.Test ("C341A02", "Check that class-wide objects can be " &
- "reassigned with objects from the same " &
- "specific type used to initialize them" );
- Night_Audit:
- declare
- use type Bank.Dollar_Amount;
- Acct_Value : Bank.Dollar_Amount := 0.00;
- begin
- -- Perform nightly audit of total funds on deposit in bank.
- for i in 1 .. Max_Accts loop
- Audit (i, Acct_Value);
- Bank_Balance := Bank_Balance + Acct_Value;
- end loop;
-
- if Bank_Balance /= 3330.00 then
- Report.Failed ("Class-wide object processing failed");
- end if;
-
- end Night_Audit;
-
- Report.Result;
-
- end C341A02;
-
diff --git a/gcc/testsuite/ada/acats/tests/c3/c341a03.a b/gcc/testsuite/ada/acats/tests/c3/c341a03.a
deleted file mode 100644
index 0911e636d57..00000000000
--- a/gcc/testsuite/ada/acats/tests/c3/c341a03.a
+++ /dev/null
@@ -1,140 +0,0 @@
--- C341A03.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that an object of one class-wide type can initialize a
--- class-wide object of a different type when the operation is embedded
--- in a generic unit.
---
--- TEST DESCRIPTION:
--- Declare specific-type objects of an extended type. Declare an array
--- of access values designating class-wide objects, initialized to point
--- to the objects of the specific type. Define a generic subprogram
--- having a generic formal derived type parameter. Within the generic,
--- declare a class-wide variable of the formal parameter type. Verify
--- that the variable can be initialized with the value of an object
--- of another class-wide type within the class.
---
--- The particular root and extended types used in this abstraction are
--- defined in foundation code (F341A00.A), and are graphically displayed
--- as follows:
---
--- package Bank
--- type Account
--- |
--- |
--- |
--- package Checking
--- type Account
--- |
--- |
--- |
--- package Interest_Checking
--- type Account
---
--- TEST FILES:
--- This test depends on the following foundation code:
---
--- F341A00.A
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 16 Dec 94 SAIC Changed level of 'Class for ATM_Card
---
---!
-
-with F341A00_0; -- package Bank
-generic
- type Account_Type is new F341A00_0.Account with private; -- new Bank.Account
-function C341A03_0 (The_Account : Account_Type'Class) -- function Audit
- return F341A00_0.Dollar_Amount;
-
-function C341A03_0 (The_Account : Account_Type'Class)
- return F341A00_0.Dollar_Amount is
- Acct : Account_Type'Class := The_Account; -- Init. of class-wide with
-begin -- another class-wide object.
- return Acct.Current_Balance;
-end C341A03_0;
-
-
- --=================================================================--
-
-
-with F341A00_0; -- package Bank
-with F341A00_1; -- package Checking
-with C341A03_0; -- generic function Audit
-with Report;
-
-procedure C341A03 is
-
- package Bank renames F341A00_0;
- package Checking renames F341A00_1;
-
- Current_Checking_Accounts : constant := 3;
-
- Checking_Acct1 : aliased Checking.Account := (Current_Balance => 10.00,
- Overdraft_Fee => 5.00);
- Checking_Acct2 : aliased Checking.Account := (Current_Balance => 20.00,
- Overdraft_Fee => 5.00);
- Checking_Acct3 : aliased Checking.Account := (Current_Balance => 30.00,
- Overdraft_Fee => 5.00);
-
- type ATM_Card is access all Checking.Account'Class;
-
- -- Declare array of accesses to class-wide objects.
- Account_Array : array (1 .. Current_Checking_Accounts) of
- ATM_Card := (Checking_Acct1'Access,
- Checking_Acct2'Access,
- Checking_Acct3'Access);
-begin -- C341A03
-
- Report.Test ("C341A03", "Check that an object of one class-wide type " &
- "can initialize a class-wide object of a " &
- "different type when the operation is embedded " &
- "in a generic unit" );
-
- Audit_Checking_Accounts:
- declare
- Balance_In_Checking_Accounts : Bank.Dollar_Amount := 0.00;
- -- Instantiate with a specific extended type.
- function Checking_Audit is new C341A03_0 (Checking.Account);
- use type Bank.Dollar_Amount;
- begin
-
- for I in 1 .. Current_Checking_Accounts loop
- Balance_In_Checking_Accounts := Balance_In_Checking_Accounts +
- Checking_Audit (Account_Array (I).all);
- end loop;
-
- if Balance_In_Checking_Accounts /= 60.00 then
- Report.Failed ("Incorrect initialization of class-wide object");
- end if;
-
- end Audit_Checking_Accounts;
-
- Report.Result;
-
-end C341A03;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c341a04.a b/gcc/testsuite/ada/acats/tests/c3/c341a04.a
deleted file mode 100644
index d7392568e48..00000000000
--- a/gcc/testsuite/ada/acats/tests/c3/c341a04.a
+++ /dev/null
@@ -1,141 +0,0 @@
--- C341A04.A
- --
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
- --
- -- OBJECTIVE:
- -- Check that class-wide objects can be initialized using allocation.
- --
- -- TEST DESCRIPTION:
- -- Declare access types that refer to class-wide types, one with basis
- -- of the root type, another with basis of a type extended from the root.
- -- Declare objects of these access types, and allocate class-wide
- -- objects, initialized to values of specific types within the particular
- -- classes.
- --
- -- The particular root and extended types used in this abstraction are
- -- defined in foundation code (F341A00.A), and are graphically displayed
- -- as follows:
- --
- -- package Bank
- -- type Account
- -- |
- -- |
- -- |
- -- package Checking
- -- type Account
- -- |
- -- |
- -- |
- -- package Interest_Checking
- -- type Account
- --
- -- TEST FILES:
- -- This test depends on the following foundation code:
- --
- -- F341A00.A
- --
- -- The following files comprise this test:
- --
- -- => C341A04.A
- --
- --
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
---
- --!
-
- with F341A00_0; -- package Bank
- with F341A00_1; -- package Checking
- with F341A00_2; -- package Interest_Checking
- with Report;
-
- procedure C341A04 is
-
- package Bank renames F341A00_0;
- package Checking renames F341A00_1;
- package Interest_Checking renames F341A00_2;
-
- use type Bank.Dollar_Amount;
-
- Max_Accts : constant := 3;
- Bank_Balance : Bank.Dollar_Amount := 0.00;
-
- -- Define access types referring to class of types rooted at
- -- Bank.Account (root).
-
- type Bank_Account_Pointer is access Bank.Account'Class;
-
- --
- -- Define class-wide objects, initializing them through allocation.
- --
-
- -- Initialized to specific type that is basis of class.
- Bank_Acct : Bank_Account_Pointer :=
- new Bank.Account'(Current_Balance => 10.00);
-
- -- Initialized to specific type that has been extended from the basis
- -- of the class.
- Checking_Acct : Bank_Account_Pointer :=
- new Checking.Account'(Current_Balance => 100.00,
- Overdraft_Fee => 10.00);
-
- -- Initialized to specific type that has been twice extended from the
- -- basis of the class.
- IC_Acct : Bank_Account_Pointer :=
- new Interest_Checking.Account'(Current_Balance => 1000.00,
- Overdraft_Fee => 10.00,
- Rate => 0.030);
-
- -- Declare and initialize array of pointers to objects of
- -- Bank.Account'Class.
-
- Accounts : array (1 .. Max_Accts) of Bank_Account_Pointer :=
- (Bank_Acct, Checking_Acct, IC_Acct);
-
-
- -- Audit will process any account object within Bank.Account'Class.
-
- function Audit (Ptr : Bank_Account_Pointer) return Bank.Dollar_Amount is
- begin
- return (Ptr.Current_Balance);
- end Audit;
-
-
- begin -- C341A04
-
- Report.Test ("C341A04", "Check that class-wide objects were " &
- "successfully initialized using allocation" );
-
- for i in 1 .. Max_Accts loop
- Bank_Balance := Bank_Balance + Audit (Accounts(i));
- end loop;
-
- if Bank_Balance /= 1110.00 then
- Report.Failed ("Failed class-wide object allocation");
- end if;
-
- Report.Result;
-
- end C341A04;
-
diff --git a/gcc/testsuite/ada/acats/tests/c3/c352001.a b/gcc/testsuite/ada/acats/tests/c3/c352001.a
deleted file mode 100644
index 04b094f1ff3..00000000000
--- a/gcc/testsuite/ada/acats/tests/c3/c352001.a
+++ /dev/null
@@ -1,270 +0,0 @@
---
--- C352001.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that the predefined Character type comprises 256 positions.
--- Check that the names of the non-graphic characters are usable with
--- the attributes (Wide_)Image and (Wide_)Value, and that these
--- attributes produce the correct result.
---
--- TEST DESCRIPTION:
--- Build two tables of nongraphic characters from positions of Row 00
--- (0000-001F and 007F-009F) of the ISO 10646 Basic Multilingual Plane.
--- Fill the first table with compiler created strings. Fill the second
--- table with strings defined by the language. Compare the two tables.
--- Check 256 positions of the predefined character type. Use attributes
--- (Wide_)Image and (Wide_)Value to check the values of the non-graphic
--- characters and the last 2 characters.
---
---
--- CHANGE HISTORY:
--- 20 Jun 95 SAIC Initial prerelease version.
--- 27 Jan 96 SAIC Revised for 2.1. Hid values, added "del" case.
---
---!
-
-with Ada.Characters.Handling;
-with Report;
-procedure C352001 is
-
- Lower_Bound : Integer := 0;
- Middle_Bound : Integer := 31;
- Upper_Bound : Integer := 159;
- Half_Bound : Integer := 127;
- Max_Bound : Integer := 255;
-
- type Dyn_String is access String;
- type Value_Result is array (Character) of Dyn_String;
-
- Table_Of_Character : Value_Result;
- TC_Table : Value_Result;
-
- function CVII(K : Natural) return Character is
- begin
- return Character'Val( Report.Ident_Int(K) );
- end CVII;
-
- function "=" (L, R : String) return Boolean is
- UCL : String (L'First .. L'Last);
- UCR : String (R'First .. R'last);
- begin
- UCL := Ada.Characters.Handling.To_Upper (L);
- UCR := Ada.Characters.Handling.To_Upper (R);
- if UCL'Last /= UCR'Last then
- return False;
- else
- for I in UCL'First .. UCR'Last loop
- if UCL (I) /= UCR (I) then
- return False;
- end if;
- end loop;
- return True;
- end if;
- end "=";
-
-begin
-
- Report.Test ("C352001", "Check that, the predefined Character type " &
- "comprises 256 positions. Check that the names of the " &
- "non-graphic characters are usable with the attributes " &
- "(Wide_)Image and (Wide_)Value, and that these attributes " &
- "produce the correct result");
-
- -- Fill table with strings (positions of Row 00 (0000-001F) of the ISO
- -- 10646 Basic Multilingual Plane created by the compiler.
-
- for I in CVII(Lower_Bound) .. CVII(Middle_Bound) loop
- Table_Of_Character (I) := new String'(Character'Image(I));
- end loop;
-
- -- Fill table with strings (positions of Row 00 (007F-009F) of the ISO
- -- 10646 Basic Multilingual Plane created by the compiler.
-
- for I in CVII(Half_Bound) .. CVII(Upper_Bound) loop
- Table_Of_Character (I) := new String'(Character'Image(I));
- end loop;
-
- -- Fill table with strings (positions of Row 00 (0000-001F) of the ISO
- -- 10646 Basic Multilingual Plane defined by the language.
-
- TC_Table (CVII(0)) := new String'("nul");
- TC_Table (CVII(1)) := new String'("soh");
- TC_Table (CVII(2)) := new String'("stx");
- TC_Table (CVII(3)) := new String'("etx");
- TC_Table (CVII(4)) := new String'("eot");
- TC_Table (CVII(5)) := new String'("enq");
- TC_Table (CVII(6)) := new String'("ack");
- TC_Table (CVII(7)) := new String'("bel");
- TC_Table (CVII(8)) := new String'("bs");
- TC_Table (CVII(9)) := new String'("ht");
- TC_Table (CVII(10)) := new String'("lf");
- TC_Table (CVII(11)) := new String'("vt");
- TC_Table (CVII(12)) := new String'("ff");
- TC_Table (CVII(13)) := new String'("cr");
- TC_Table (CVII(14)) := new String'("so");
- TC_Table (CVII(15)) := new String'("si");
- TC_Table (CVII(16)) := new String'("dle");
- TC_Table (CVII(17)) := new String'("dc1");
- TC_Table (CVII(18)) := new String'("dc2");
- TC_Table (CVII(19)) := new String'("dc3");
- TC_Table (CVII(20)) := new String'("dc4");
- TC_Table (CVII(21)) := new String'("nak");
- TC_Table (CVII(22)) := new String'("syn");
- TC_Table (CVII(23)) := new String'("etb");
- TC_Table (CVII(24)) := new String'("can");
- TC_Table (CVII(25)) := new String'("em");
- TC_Table (CVII(26)) := new String'("sub");
- TC_Table (CVII(27)) := new String'("esc");
- TC_Table (CVII(28)) := new String'("fs");
- TC_Table (CVII(29)) := new String'("gs");
- TC_Table (CVII(30)) := new String'("rs");
- TC_Table (CVII(31)) := new String'("us");
- TC_Table (CVII(127)) := new String'("del");
-
- -- Fill table with strings (positions of Row 00 (007F-009F) of the ISO
- -- 10646 Basic Multilingual Plane defined by the language.
-
- TC_Table (CVII(128)) := new String'("reserved_128");
- TC_Table (CVII(129)) := new String'("reserved_129");
- TC_Table (CVII(130)) := new String'("bph");
- TC_Table (CVII(131)) := new String'("nbh");
- TC_Table (CVII(132)) := new String'("reserved_132");
- TC_Table (CVII(133)) := new String'("nel");
- TC_Table (CVII(134)) := new String'("ssa");
- TC_Table (CVII(135)) := new String'("esa");
- TC_Table (CVII(136)) := new String'("hts");
- TC_Table (CVII(137)) := new String'("htj");
- TC_Table (CVII(138)) := new String'("vts");
- TC_Table (CVII(139)) := new String'("pld");
- TC_Table (CVII(140)) := new String'("plu");
- TC_Table (CVII(141)) := new String'("ri");
- TC_Table (CVII(142)) := new String'("ss2");
- TC_Table (CVII(143)) := new String'("ss3");
- TC_Table (CVII(144)) := new String'("dcs");
- TC_Table (CVII(145)) := new String'("pu1");
- TC_Table (CVII(146)) := new String'("pu2");
- TC_Table (CVII(147)) := new String'("sts");
- TC_Table (CVII(148)) := new String'("cch");
- TC_Table (CVII(149)) := new String'("mw");
- TC_Table (CVII(150)) := new String'("spa");
- TC_Table (CVII(151)) := new String'("epa");
- TC_Table (CVII(152)) := new String'("sos");
- TC_Table (CVII(153)) := new String'("reserved_153");
- TC_Table (CVII(154)) := new String'("sci");
- TC_Table (CVII(155)) := new String'("csi");
- TC_Table (CVII(156)) := new String'("st");
- TC_Table (CVII(157)) := new String'("osc");
- TC_Table (CVII(158)) := new String'("pm");
- TC_Table (CVII(159)) := new String'("apc");
-
-
- -- Compare the first half of two tables.
- for I in CVII(Lower_Bound) .. CVII(Middle_Bound) loop
- if TC_Table(I).all /= Table_Of_Character(I).all then
- Report.Failed("Value of character#" & Integer'Image(Character'Pos(I)) &
- " is not the same in the first half of the table");
- end if;
- end loop;
-
-
- -- Compare the second half of two tables.
- for I in CVII(Half_Bound) .. CVII(Upper_Bound) loop
- if TC_Table(I).all /= Table_Of_Character(I).all then
- Report.Failed("Value of character#" & Integer'Image(Character'Pos(I)) &
- " is not the same in the second half of the table");
- end if;
- end loop;
-
-
- -- Check the first character.
- if Character'Image( Character'First ) /= "NUL" then
- Report.Failed("Value of character#" &
- Integer'Image(Character'Pos (Character'First)) &
- " is not NUL");
- end if;
-
-
- -- Check that the names of the non-graphic characters are usable with
- -- Image and Value attributes.
- if Character'Value( Character'Image( CVII(153) )) /=
- CVII( 153 ) then
- Report.Failed ("Value of character#" &
- Integer'Image( Character'Pos(CVII(153)) ) &
- " is not reserved_153");
- end if;
-
-
- for I in CVII(Lower_Bound) .. CVII(Max_Bound) loop
- if Character'Value(
- Report.Ident_Str(
- Character'Image(CVII(Character'Pos(I)))))
- /= CVII( Character'Pos(I)) then
- Report.Failed ("Value of character#" &
- Integer'Image( Character'Pos(I) ) &
- " is not the same as the predefined character type");
- end if;
- end loop;
-
-
- -- Check Wide_Character attributes.
- for I in Wide_Character'Val(Lower_Bound) .. Wide_Character'Val(Max_Bound)
- loop
- if Wide_Character'Wide_Value(
- Report.Ident_Wide_Str(
- Wide_Character'Wide_Image(
- Wide_Character'Val(Wide_Character'Pos(I)))))
- /= Wide_Character'Val(Wide_Character'Pos(I))
- then
- Report.Failed ("Value of the predefined Wide_Character type " &
- "is not correct");
- end if;
- end loop;
-
-
- if Wide_Character'Value( Wide_Character'Image(Wide_Character'Val(132)) )
- /= Wide_Character'Val( Report.Ident_Int(132) ) then
- Report.Failed ("Wide_Character at 132 is not reserved_132");
- end if;
-
-
- if Wide_Character'Image( Wide_Character'First ) /= "NUL" then
- Report.Failed ("Wide_Character'First is not NUL");
- end if;
-
-
- if Wide_Character'Image
- (Wide_Character'Pred (Wide_Character'Last) ) /= "FFFE" then
- Report.Failed ("Wide_Character at 65534 is not FFFE");
- end if;
-
-
- if Wide_Character'Image(Wide_Character'Last) /= "FFFF" then
- Report.Failed ("Wide_Character'Last is not FFFF");
- end if;
-
- Report.Result;
-
-end C352001;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c354002.a b/gcc/testsuite/ada/acats/tests/c3/c354002.a
deleted file mode 100644
index 3129182b704..00000000000
--- a/gcc/testsuite/ada/acats/tests/c3/c354002.a
+++ /dev/null
@@ -1,335 +0,0 @@
---
--- C354002.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that the attributes of modular types yield
--- correct values/results. The attributes checked are:
---
--- First, Last, Range, Base, Min, Max, Succ, Pred,
--- Image, Width, Value, Pos, and Val
---
--- TEST DESCRIPTION:
--- This test defines several modular types. One type defined at
--- each of System.Max_Binary_Modulus, System.Max_Nonbinary_Modulus,
--- a power of two half that of System.Max_Binary_Modulus, one less
--- than that power of two; one more than that power of two, two
--- less than a (large) power of two. For each of these types,
--- determine the correct operation of the following attributes:
---
--- First, Last, Range, Base, Min, Max, Succ, Pred, Image, Width,
--- Value, Pos, Val, and Modulus
---
--- The attributes Wide_Image and Wide_Value are deferred to C354003.
---
---
---
--- CHANGE HISTORY:
--- 08 SEP 94 SAIC Initial version
--- 17 NOV 94 SAIC Revised version
--- 13 DEC 94 SAIC split off Wide_String attributes into C354003
--- 06 JAN 95 SAIC Promoted to next release
--- 19 APR 95 SAIC Revised in accord with reviewer comments
--- 27 JAN 96 SAIC Eliminated 32/64 bit potential conflict for 2.1
---
---!
-
-with Report;
-with System;
-with TCTouch;
-procedure C354002 is
-
- function ID(Local_Value: Integer) return Integer renames Report.Ident_Int;
- function ID(Local_Value: String) return String renames Report.Ident_Str;
-
- Power_2_Bits : constant := System.Storage_Unit;
- Half_Max_Binary_Value : constant := System.Max_Binary_Modulus / 2;
-
- type Max_Binary is mod System.Max_Binary_Modulus;
- type Max_NonBinary is mod System.Max_Nonbinary_Modulus;
- type Half_Max_Binary is mod Half_Max_Binary_Value;
-
- type Medium is mod 2048;
- type Medium_Plus is mod 2042;
- type Medium_Minus is mod 2111;
-
- type Small is mod 2;
- type Finger is mod 5;
-
- MBL : constant := Max_NonBinary'Last;
- MNBM : constant := Max_NonBinary'Modulus;
-
- Ones_Complement_Permission : constant Boolean := MBL = MNBM;
-
- type Finger_Id is (Thumb, Index, Middle, Ring, Pinkie);
-
- subtype Midrange is Medium_Minus range 222 .. 1111;
-
--- a few numbers for testing purposes
- Max_Binary_Mod_Over_3 : constant := Max_Binary'Modulus / 3;
- Max_NonBinary_Mod_Over_4 : constant := Max_NonBinary'Modulus / 4;
- System_Max_Bin_Mod_Pred : constant := System.Max_Binary_Modulus - 1;
- System_Max_NonBin_Mod_Pred : constant := System.Max_Nonbinary_Modulus - 1;
- Half_Max_Bin_Value_Pred : constant := Half_Max_Binary_Value - 1;
-
- AMB, BMB : Max_Binary;
- AHMB, BHMB : Half_Max_Binary;
- AM, BM : Medium;
- AMP, BMP : Medium_Plus;
- AMM, BMM : Medium_Minus;
- AS, BS : Small;
- AF, BF : Finger;
-
- TC_Pass_Case : Boolean := True;
-
- procedure Value_Fault( S: String ) is
- -- check 'Value for failure modes
- begin
- -- the evaluation of the 'Value expression should raise C_E
- TCTouch.Assert_Not( Midrange'Value(S) = 0, "Value_Fault" );
- if Midrange'Value(S) not in Midrange'Base then
- Report.Failed("'Value(" & S & ") raised no exception");
- end if;
- exception
- when Constraint_Error => null; -- expected case
- when others =>
- Report.Failed("'Value(" & S & ") raised wrong exception");
- end Value_Fault;
-
-begin -- Main test procedure.
-
- Report.Test ("C354002", "Check attributes of modular types" );
-
--- Base
- TCTouch.Assert( Midrange'Base'First = 0, "Midrange'Base'First" );
- TCTouch.Assert( Midrange'Base'Last = Medium_Minus'Last,
- "Midrange'Base'Last" );
-
--- First
- TCTouch.Assert( Max_Binary'First = 0, "Max_Binary'First" );
- TCTouch.Assert( Max_NonBinary'First = 0, "Max_NonBinary'First" );
- TCTouch.Assert( Half_Max_Binary'First = 0, "Half_Max_Binary'First" );
-
- TCTouch.Assert( Medium'First = Medium(ID(0)), "Medium'First" );
- TCTouch.Assert( Medium_Plus'First = Medium_Plus(ID(0)),
- "Medium_Plus'First" );
- TCTouch.Assert( Medium_Minus'First = Medium_Minus(ID(0)),
- "Medium_Minus'First" );
-
- TCTouch.Assert( Small'First = Small(ID(0)), "Small'First" );
- TCTouch.Assert( Finger'First = Finger(ID(0)), "Finger'First" );
- TCTouch.Assert( Midrange'First = Midrange(ID(222)),
- "Midrange'First" );
-
--- Image
- TCTouch.Assert( Half_Max_Binary'Image(255) = " 255",
- "Half_Max_Binary'Image" );
- TCTouch.Assert( Medium'Image(0) = ID(" 0"), "Medium'Image" );
- TCTouch.Assert( Medium_Plus'Image(Medium_Plus'Last) = " 2041",
- "Medium_Plus'Image" );
- TCTouch.Assert( Medium_Minus'Image(Medium_Minus(ID(1024))) = " 1024",
- "Medium_Minus'Image" );
- TCTouch.Assert( Small'Image(Small(ID(1))) = " 1", "Small'Image" );
- TCTouch.Assert( Midrange'Image(Midrange(ID(333))) = " 333",
- "Midrange'Image" );
-
--- Last
- TCTouch.Assert( Max_Binary'Last = System_Max_Bin_Mod_Pred,
- "Max_Binary'Last");
- if Ones_Complement_Permission then
- TCTouch.Assert( Max_NonBinary'Last >= System_Max_NonBin_Mod_Pred,
- "Max_NonBinary'Last (ones comp)");
- else
- TCTouch.Assert( Max_NonBinary'Last = System_Max_NonBin_Mod_Pred,
- "Max_NonBinary'Last");
- end if;
- TCTouch.Assert( Half_Max_Binary'Last = Half_Max_Bin_Value_Pred,
- "Half_Max_Binary'Last");
-
- TCTouch.Assert( Medium'Last = Medium(ID(2047)), "Medium'Last");
- TCTouch.Assert( Medium_Plus'Last = Medium_Plus(ID(2041)),
- "Medium_Plus'Last");
- TCTouch.Assert( Medium_Minus'Last = Medium_Minus(ID(2110)),
- "Medium_Minus'Last");
- TCTouch.Assert( Small'Last = Small(ID(1)), "Small'Last");
- TCTouch.Assert( Finger'Last = Finger(ID(4)), "Finger'Last");
- TCTouch.Assert( Midrange'Last = Midrange(ID(1111)), "Midrange'Last");
-
--- Max
- TCTouch.Assert( Max_Binary'Max(Power_2_Bits, Max_Binary'Last)
- = Max_Binary'Last, "Max_Binary'Max");
- TCTouch.Assert( Max_NonBinary'Max(100,2000) = 2000, "Max_NonBinary'Max");
- TCTouch.Assert( Half_Max_Binary'Max(123,456) = 456,
- "Half_Max_Binary'Max");
-
- TCTouch.Assert( Medium'Max(0,2040) = 2040, "Medium'Max");
- TCTouch.Assert( Medium_Plus'Max(0,1) = 1, "Medium_Plus'Max");
- TCTouch.Assert( Medium_Minus'Max(2001,1995) = 2001, "Medium_Minus'Max");
- TCTouch.Assert( Small'Max(1,0) = 1, "Small'Max");
- TCTouch.Assert( Finger'Max(Finger'Last+1,4) = 4, "Finger'Max");
- TCTouch.Assert( Midrange'Max(Midrange'First+1,222) = Midrange'First+1,
- "Midrange'Max");
-
--- Min
- TCTouch.Assert( Max_Binary'Min(Power_2_Bits, Max_Binary'Last)
- = Power_2_Bits, "Max_Binary'Min");
- TCTouch.Assert( Max_NonBinary'Min(100,2000) = 100, "Max_NonBinary'Min");
- TCTouch.Assert( Half_Max_Binary'Min(123,456) = 123,
- "Half_Max_Binary'Min");
-
- TCTouch.Assert( Medium'Min(0,Medium(ID(2040))) = 0, "Medium'Min");
- TCTouch.Assert( Medium_Plus'Min(0,1) = 0, "Medium_Plus'Min");
- TCTouch.Assert( Medium_Minus'Min(2001,1995) = 1995, "Medium_Minus'Min");
- TCTouch.Assert( Small'Min(1,0) = 0, "Small'Min");
- TCTouch.Assert( Finger'Min(Finger'Last+1,4) /= 4, "Finger'Min");
- TCTouch.Assert( Midrange'Min(Midrange'First+1,222) = 222,
- "Midrange'Min");
--- Modulus
- TCTouch.Assert( Max_Binary'Modulus = System.Max_Binary_Modulus,
- "Max_Binary'Modulus");
- TCTouch.Assert( Max_NonBinary'Modulus = System.Max_Nonbinary_Modulus,
- "Max_NonBinary'Modulus");
- TCTouch.Assert( Half_Max_Binary'Modulus = Half_Max_Binary_Value,
- "Half_Max_Binary'Modulus");
-
- TCTouch.Assert( Medium'Modulus = 2048, "Medium'Modulus");
- TCTouch.Assert( Medium_Plus'Modulus = 2042, "Medium_Plus'Modulus");
- TCTouch.Assert( Medium_Minus'Modulus = 2111, "Medium_Minus'Modulus");
- TCTouch.Assert( Small'Modulus = 2, "Small'Modulus");
- TCTouch.Assert( Finger'Modulus = 5, "Finger'Modulus");
- TCTouch.Assert( Midrange'Modulus = ID(2111), "Midrange'Modulus");
-
--- Pos
- declare
- Int : Natural := 222;
- begin
- for I in Midrange loop
- TC_Pass_Case := TC_Pass_Case and Midrange'Pos(I) = Int;
-
- Int := Int +1;
- end loop;
- end;
-
- TCTouch.Assert( TC_Pass_Case, "Midrange'Pos");
-
--- Pred
- TCTouch.Assert( Max_Binary'Pred(0) = System_Max_Bin_Mod_Pred,
- "Max_Binary'Pred(0)");
- if Ones_Complement_Permission then
- TCTouch.Assert( Max_NonBinary'Pred(0) >= System_Max_NonBin_Mod_Pred,
- "Max_NonBinary'Pred(0) (ones comp)");
- else
- TCTouch.Assert( Max_NonBinary'Pred(0) = System_Max_NonBin_Mod_Pred,
- "Max_NonBinary'Pred(0)");
- end if;
- TCTouch.Assert( Half_Max_Binary'Pred(0) = Half_Max_Bin_Value_Pred,
- "Half_Max_Binary'Pred(0)");
-
- TCTouch.Assert( Medium'Pred(Medium(ID(0))) = 2047, "Medium'Pred(0)");
- TCTouch.Assert( Medium_Plus'Pred(0) = 2041, "Medium_Plus'Pred(0)");
- TCTouch.Assert( Medium_Minus'Pred(0) = 2110, "Medium_Minus'Pred(0)");
- TCTouch.Assert( Small'Pred(0) = 1, "Small'Pred(0)");
- TCTouch.Assert( Finger'Pred(Finger(ID(0))) = 4, "Finger'Pred(0)");
- TCTouch.Assert( Midrange'Pred(222) = 221, "Midrange'Pred('First)");
-
--- Range
- for I in Midrange'Range loop
- if I not in Midrange then
- Report.Failed("Midrange loop test");
- end if;
- end loop;
- for I in Medium'Range loop
- if I not in Medium then
- Report.Failed("Medium loop test");
- end if;
- end loop;
- for I in Medium_Minus'Range loop
- if I not in 0..2110 then
- Report.Failed("Medium loop test");
- end if;
- end loop;
-
--- Succ
- TCTouch.Assert( Max_Binary'Succ(System_Max_Bin_Mod_Pred) = 0,
- "Max_Binary'Succ('Last)");
- if Ones_Complement_Permission then
- TCTouch.Assert( (Max_NonBinary'Succ(System_Max_NonBin_Mod_Pred) = 0)
- or (Max_NonBinary'Succ(System_Max_NonBin_Mod_Pred)
- = Max_NonBinary'Last),
- "Max_NonBinary'Succ('Last) (ones comp)");
- else
- TCTouch.Assert( Max_NonBinary'Succ(System_Max_NonBin_Mod_Pred) = 0,
- "Max_NonBinary'Succ('Last)");
- end if;
- TCTouch.Assert( Half_Max_Binary'Succ(Half_Max_Bin_Value_Pred) = 0,
- "Half_Max_Binary'Succ('Last)");
-
- TCTouch.Assert( Medium'Succ(2047) = 0, "Medium'Succ('Last)");
- TCTouch.Assert( Medium_Plus'Succ(2041) = 0, "Medium_Plus'Succ('Last)");
- TCTouch.Assert( Medium_Minus'Succ(2110) = 0, "Medium_Minus'Succ('Last)");
- TCTouch.Assert( Small'Succ(1) = 0, "Small'Succ('Last)");
- TCTouch.Assert( Finger'Succ(4) = 0, "Finger'Succ('Last)");
- TCTouch.Assert( Midrange'Succ(Midrange(ID(1111))) = 1112,
- "Midrange'Succ('Last)");
-
--- Val
- for I in Natural range ID(222)..ID(1111) loop
- TCTouch.Assert( Midrange'Val(I) = Medium_Minus(I), "Midrange'Val");
- end loop;
-
--- Value
-
- TCTouch.Assert( Half_Max_Binary'Value("255") = 255,
- "Half_Max_Binary'Value" );
-
- TCTouch.Assert( Medium'Value(" 1e2") = 100, "Medium'Value(""1e2"")" );
- TCTouch.Assert( Medium'Value(" 0 ") = 0, "Medium'Value" );
- TCTouch.Assert( Medium_Plus'Value(ID("2041")) = 2041,
- "Medium_Plus'Value" );
- TCTouch.Assert( Medium_Minus'Value(ID("+10_24")) = 1024,
- "Medium_Minus'Value" );
-
- TCTouch.Assert( Small'Value("+1") = 1, "Small'Value" );
- TCTouch.Assert( Midrange'Value(ID("333")) = 333, "Midrange'Value" );
- TCTouch.Assert( Midrange'Value("1E3") = 1000,
- "Midrange'Value(""1E3"")" );
-
- Value_Fault( "bad input" );
- Value_Fault( "-333" );
- Value_Fault( "9999" );
- Value_Fault( ".1" );
- Value_Fault( "1e-1" );
-
--- Width
- TCTouch.Assert( Medium'Width = 5, "Medium'Width");
- TCTouch.Assert( Medium_Plus'Width = 5, "Medium_Plus'Width");
- TCTouch.Assert( Medium_Minus'Width = 5, "Medium_Minus'Width");
- TCTouch.Assert( Small'Width = 2, "Small'Width");
- TCTouch.Assert( Finger'Width = 2, "Finger'Width");
- TCTouch.Assert( Midrange'Width = 5, "Midrange'Width");
-
- Report.Result;
-
-end C354002;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c354003.a b/gcc/testsuite/ada/acats/tests/c3/c354003.a
deleted file mode 100644
index 1f607a7e691..00000000000
--- a/gcc/testsuite/ada/acats/tests/c3/c354003.a
+++ /dev/null
@@ -1,211 +0,0 @@
--- C354003.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that the Wide_String attributes of modular types yield
--- correct values/results. The attributes checked are:
---
--- Wide_Image
--- Wide_Value
---
--- TEST DESCRIPTION:
--- This test is split from C354002. It tests only the attributes:
---
--- Wide_Image, Wide_Value
---
--- This test defines several modular types. One type defined at
--- each of System.Max_Binary_Modulus, System.Max_Nonbinary_Modulus,
--- a power of two half that of System.Max_Binary_Modulus, one less
--- than that power of two; one more than that power of two, two
--- less than a (large) power of two. For each of these types,
--- determine the correct operation of the Wide_String attributes.
---
---
--- CHANGE HISTORY:
--- 13 DEC 94 SAIC Initial version
--- 06 JAN 94 SAIC Promoted to future release
--- 19 APR 95 SAIC Revised in accord with reviewer comments
--- 01 DEC 95 SAIC Corrected for 2.0.1
--- 27 JAN 96 SAIC Eliminated potential 32/64 bit conflict for 2.1
--- 24 FEB 97 PWB.CTA Corrected out-of-range value
---!
-
-with Report;
-with System;
-with TCTouch;
-with Ada.Characters.Handling;
-procedure C354003 is
-
- function ID(Local_Value: Integer) return Integer renames Report.Ident_Int;
- function ID(Local_Value: String) return String renames Report.Ident_Str;
-
- function ID(Local_Value: String) return Wide_String is
- begin
- return Ada.Characters.Handling.To_Wide_String( ID( Local_Value ) );
- end ID;
-
- Half_Max_Binary_Value : constant := System.Max_Binary_Modulus / 2;
-
- type Max_Binary is mod System.Max_Binary_Modulus;
- type Max_NonBinary is mod System.Max_Nonbinary_Modulus;
- type Half_Max_Binary is mod Half_Max_Binary_Value;
-
- type Medium is mod 2048;
- type Medium_Plus is mod 2042;
- type Medium_Minus is mod 2111;
-
- type Small is mod 2;
- type Finger is mod 5;
-
- type Finger_Id is (Thumb, Index, Middle, Ring, Pinkie);
-
- subtype Midrange is Medium_Minus range 222 .. 1111;
-
- AMB, BMB : Max_Binary;
- AHMB, BHMB : Half_Max_Binary;
- AM, BM : Medium;
- AMP, BMP : Medium_Plus;
- AMM, BMM : Medium_Minus;
- AS, BS : Small;
- AF, BF : Finger;
-
- procedure Wide_Value_Fault( S: Wide_String ) is
- -- check 'Wide_Value for failure modes
- begin
- -- the evaluation of the 'Wide_Value expression should raise C_E
- TCTouch.Assert_Not( Midrange'Wide_Value(S) = 0, "Wide_Value_Fault" );
- if Midrange'Wide_Value(S) not in Midrange'Base then
- Report.Failed("'Wide_Value raised no exception");
- end if;
- exception
- when Constraint_Error => null; -- expected case
- when others =>
- Report.Failed("'Wide_Value raised wrong exception");
- end Wide_Value_Fault;
-
-
- The_Cap, The_Toe : Natural;
-
- procedure Check_Non_Static_Cases( Lower_Bound,Upper_Bound : Medium ) is
- subtype Non_Static is Medium range Lower_Bound..Upper_Bound;
- begin
- -- First, Last, Range, Min, Max, Succ, Pred, Pos, and Val
-
- TCTouch.Assert( Non_Static'First = Medium(The_Toe), "Non_Static'First" );
- TCTouch.Assert( Non_Static'Last = Non_Static(The_Cap),
- "Non_Static'Last" );
- TCTouch.Assert( Non_Static(The_Cap/2) in Non_Static'Range,
- "Non_Static'Range" );
- TCTouch.Assert( Non_Static'Min(Medium(Report.Ident_Int(100)),
- Medium(Report.Ident_Int(200))) = 100,
- "Non_Static'Min" );
- TCTouch.Assert( Non_Static'Max(Medium(Report.Ident_Int(100)),
- Medium(Report.Ident_Int(200))) = 200,
- "Non_Static'Max" );
- TCTouch.Assert( Non_Static'Succ(Non_Static(The_Cap))
- = Medium'Succ(Upper_Bound),
- "Non_Static'Succ" );
- TCTouch.Assert( Non_Static'Pred(Medium(Report.Ident_Int(The_Cap)))
- = Non_Static(Report.Ident_Int(The_Cap-1)),
- "Non_Static'Pred" );
- TCTouch.Assert( Non_Static'Pos(Upper_Bound) = Non_Static(The_Cap),
- "Non_Static'Pos" );
- TCTouch.Assert( Non_Static'Val(Non_Static(The_Cap)) = Upper_Bound,
- "Non_Static'Val" );
-
- end Check_Non_Static_Cases;
-
-
-begin -- Main test procedure.
-
- Report.Test ("C354003", "Check Wide_String attributes of modular types" );
-
- Wide_Strings_Needed: declare
-
- Max_Bin_Mod_Div_3 : constant := Max_Binary'Modulus/3;
- Max_Non_Mod_Div_4 : constant := Max_NonBinary'Modulus/4;
-
- begin
-
--- Wide_Image
-
- TCTouch.Assert( Half_Max_Binary'Wide_Image(255) = " 255",
- "Half_Max_Binary'Wide_Image" );
-
- TCTouch.Assert( Medium'Wide_Image(0) = " 0", "Medium'Wide_Image" );
-
- TCTouch.Assert( Medium_Plus'Wide_Image(Medium_Plus'Last) = " 2041",
- "Medium_Plus'Wide_Image" );
-
- TCTouch.Assert( Medium_Minus'Wide_Image(Medium_Minus(ID(1024))) = " 1024",
- "Medium_Minus'Wide_Image" );
-
- TCTouch.Assert( Small'Wide_Image(1) = " 1", "Small'Wide_Image" );
-
- TCTouch.Assert( Midrange'Wide_Image(Midrange(ID(333))) = " 333",
- "Midrange'Wide_Image" );
-
--- Wide_Value
-
- TCTouch.Assert( Half_Max_Binary'Wide_Value("255") = 255,
- "Half_Max_Binary'Wide_Value" );
-
- TCTouch.Assert( Medium'Wide_Value(" 0 ") = 0, "Medium'Wide_Value" );
-
- TCTouch.Assert( Medium_Plus'Wide_Value(ID("2041")) = Medium_Plus'Last,
- "Medium_Plus'Wide_Value" );
-
- TCTouch.Assert( Medium_Minus'Wide_Value("+1_4 ") = 14,
- "Medium_Minus'Wide_Value" );
-
- TCTouch.Assert( Small'Wide_Value("+1") = 1, "Small'Wide_Value" );
-
- TCTouch.Assert( Midrange'Wide_Value(ID("333")) = 333,
- "Midrange'Wide_Value" );
-
- TCTouch.Assert( Midrange'Wide_Value(ID("1E3")) = 1000,
- "Midrange'Wide_Value(""1E3"")" );
-
- Wide_Value_Fault( "bad input" );
- Wide_Value_Fault( "-333" );
- Wide_Value_Fault( "9999" );
- Wide_Value_Fault( ".1" );
- Wide_Value_Fault( "1e-1" );
-
- end Wide_Strings_Needed;
-
- The_Toe := Report.Ident_Int(25);
- The_Cap := Report.Ident_Int(256);
- Check_Non_Static_Cases( Medium(Report.Ident_Int(The_Toe)),
- Medium(Report.Ident_Int(The_Cap)) );
-
- The_Toe := Report.Ident_Int(40);
- The_Cap := Report.Ident_Int(2047);
- Check_Non_Static_Cases( Medium(Report.Ident_Int(The_Toe)),
- Medium(Report.Ident_Int(The_Cap)) );
-
- Report.Result;
-
-end C354003;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c360002.a b/gcc/testsuite/ada/acats/tests/c3/c360002.a
deleted file mode 100644
index 95cb3ef07d7..00000000000
--- a/gcc/testsuite/ada/acats/tests/c3/c360002.a
+++ /dev/null
@@ -1,268 +0,0 @@
--- C360002.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that modular types may be used as array indices.
---
--- Check that if aliased appears in the component_definition of an
--- array_type that each component of the array is aliased.
---
--- Check that references to aliased array objects produce correct
--- results, and that out-of-bounds indexing correctly produces
--- Constraint_Error.
---
--- TEST DESCRIPTION:
--- This test defines several array types and subtypes indexed by modular
--- types; some aliased some not, some with aliased components, some not.
---
--- It then checks that assignments move the correct data.
---
---
--- CHANGE HISTORY:
--- 28 SEP 95 SAIC Initial version
--- 23 APR 96 SAIC Doc fixes, fixed constrained/unconstrained conflict
--- 13 FEB 97 PWB.CTA Removed illegal declarations and affected code
---!
-
-------------------------------------------------------------------- C360002
-
-with Report;
-
-procedure C360002 is
-
- Verbose : Boolean := Report.Ident_Bool( False );
-
- type Mod_128 is mod 128;
-
- function Ident_128( I: Integer ) return Mod_128 is
- begin
- return Mod_128( Report.Ident_Int( I ) );
- end Ident_128;
-
- type Unconstrained_Array
- is array( Mod_128 range <> ) of Integer;
-
- type Unconstrained_Array_Aliased
- is array( Mod_128 range <> ) of aliased Integer;
-
- type Access_All_Unconstrained_Array
- is access all Unconstrained_Array;
-
- type Access_All_Unconstrained_Array_Aliased
- is access all Unconstrained_Array_Aliased;
-
- subtype Array_01_10
- is Unconstrained_Array(01..10);
-
- subtype Array_11_20
- is Unconstrained_Array(11..20);
-
- subtype Array_Aliased_01_10
- is Unconstrained_Array_Aliased(01..10);
-
- subtype Array_Aliased_11_20
- is Unconstrained_Array_Aliased(11..20);
-
- subtype Access_All_01_10_Array
- is Access_All_Unconstrained_Array(01..10);
-
- subtype Access_All_01_10_Array_Aliased
- is Access_All_Unconstrained_Array_Aliased(01..10);
-
- subtype Access_All_11_20_Array
- is Access_All_Unconstrained_Array(11..20);
-
- subtype Access_All_11_20_Array_Aliased
- is Access_All_Unconstrained_Array_Aliased(11..20);
-
-
--- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
-
- -- these 'filler' functions create unique values for every element that
- -- is used and/or tested in this test.
-
- Well_Bottom : Integer := 0;
-
- function Filler( Size : Mod_128 ) return Unconstrained_Array is
- It : Unconstrained_Array( 0..Size-1 );
- begin
- for Eyes in It'Range loop
- It(Eyes) := Integer( Eyes ) + Well_Bottom;
- end loop;
- Well_Bottom := Well_Bottom + It'Length;
- return It;
- end Filler;
-
- function Filler( Size : Mod_128 ) return Unconstrained_Array_Aliased is
- It : Unconstrained_Array_Aliased( 0..Size-1 );
- begin
- for Ayes in It'Range loop
- It(Ayes) := Integer( Ayes ) + Well_Bottom;
- end loop;
- Well_Bottom := Well_Bottom + It'Length;
- return It;
- end Filler;
-
--- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
-
- An_Integer : Integer;
-
- type AAI is access all Integer;
-
- An_Integer_Access : AAI;
-
- Array_Item_01_10 : Array_01_10 := Filler(10); -- 0..9
-
- Array_Item_11_20 : Array_11_20 := Filler(10); -- 10..19 (sliding)
-
- Array_Aliased_Item_01_10 : Array_Aliased_01_10 := Filler(10); -- 20..29
-
- Array_Aliased_Item_11_20 : Array_Aliased_11_20 := Filler(10); -- 30..39
-
- Aliased_Array_Item_01_10 : aliased Array_01_10 := Filler(10); -- 40..49
-
- Aliased_Array_Item_11_20 : aliased Array_11_20 := Filler(10); -- 50..59
-
- Aliased_Array_Aliased_Item_01_10 : aliased Array_Aliased_01_10
- := Filler(10); -- 60..69
-
- Aliased_Array_Aliased_Item_11_20 : aliased Array_Aliased_11_20
- := Filler(10); -- 70..79
-
- Check_Item : Access_All_Unconstrained_Array;
-
- Check_Aliased_Item : Access_All_Unconstrained_Array_Aliased;
-
--- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
-
- procedure Fail( Message : String; CI, SB : Integer ) is
- begin
- Report.Failed("Wrong value passed " & Message);
- if Verbose then
- Report.Comment("got" & Integer'Image(CI) &
- " should be" & Integer'Image(SB) );
- end if;
- end Fail;
-
- procedure Check_Array_01_10( Checked_Item : Array_01_10;
- Low_SB : Integer ) is
- begin
- for Index in Checked_Item'Range loop
- if (Checked_Item(Index) /= (Low_SB +Integer(Index)-1)) then
- Fail("unaliased 1..10", Checked_Item(Index),
- (Low_SB +Integer(Index)-1));
- end if;
- end loop;
- end Check_Array_01_10;
-
- procedure Check_Array_11_20( Checked_Item : Array_11_20;
- Low_SB : Integer ) is
- begin
- for Index in Checked_Item'Range loop
- if (Checked_Item(Index) /= (Low_SB +Integer(Index)-11)) then
- Fail("unaliased 11..20", Checked_Item(Index),
- (Low_SB +Integer(Index)-11));
- end if;
- end loop;
- end Check_Array_11_20;
-
- procedure Check_Single_Integer( The_Integer, SB : Integer;
- Message : String ) is
- begin
- if The_Integer /= SB then
- Report.Failed("Wrong integer value for " & Message );
- end if;
- end Check_Single_Integer;
-
--- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
-
-begin -- Main test procedure.
-
- Report.Test ("C360002", "Check that modular types may be used as array " &
- "indices. Check that if aliased appears in " &
- "the component_definition of an array_type that " &
- "each component of the array is aliased. Check " &
- "that references to aliased array objects " &
- "produce correct results, and that out of bound " &
- "references to aliased objects correctly " &
- "produce Constraint_Error" );
- -- start with checks that the Filler assignments produced the expected
- -- result. This is a "case 0" test to check that nothing REALLY surprising
- -- is happening
-
- Check_Array_01_10( Array_Item_01_10, 0 );
- Check_Array_11_20( Array_Item_11_20, 10 );
-
- -- check that having the variable aliased makes no difference
- Check_Array_01_10( Aliased_Array_Item_01_10, 40 );
- Check_Array_11_20( Aliased_Array_Item_11_20, 50 );
-
- -- now check that conversion between array types where the only
- -- difference in the definitions is that the components are aliased works
-
- Check_Array_01_10( Unconstrained_Array( Array_Aliased_Item_01_10 ), 20 );
- Check_Array_11_20( Unconstrained_Array( Array_Aliased_Item_11_20 ), 30 );
-
- -- check that conversion of an aliased object with aliased components
- -- also works
-
- Check_Array_01_10( Unconstrained_Array( Aliased_Array_Aliased_Item_01_10 ),
- 60 );
- Check_Array_11_20( Unconstrained_Array( Aliased_Array_Aliased_Item_11_20 ),
- 70 );
-
- -- check that the bounds will slide
-
- Check_Array_01_10( Array_01_10( Array_Item_11_20 ), 10 );
- Check_Array_11_20( Array_11_20( Array_Item_01_10 ), 0 );
-
- -- point at some of the components and check them
-
- An_Integer_Access := Array_Aliased_Item_01_10(5)'Access;
-
- Check_Single_Integer( An_Integer_Access.all, 24,
- "Aliased component 'Access");
-
- An_Integer_Access := Aliased_Array_Aliased_Item_01_10(7)'Access;
-
- Check_Single_Integer( An_Integer_Access.all, 66,
- "Aliased Aliased component 'Access");
-
- -- check some assignments
-
- Array_Item_01_10 := Aliased_Array_Item_01_10;
- Check_Array_01_10( Array_Item_01_10, 40 );
-
- Aliased_Array_Item_01_10 := Aliased_Array_Item_11_20(11..20);
- Check_Array_01_10( Aliased_Array_Item_01_10, 50 );
-
- Aliased_Array_Aliased_Item_11_20(11..20)
- := Aliased_Array_Aliased_Item_01_10;
- Check_Array_11_20( Unconstrained_Array( Aliased_Array_Aliased_Item_11_20 ),
- 60 );
-
- Report.Result;
-
-end C360002;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c371001.a b/gcc/testsuite/ada/acats/tests/c3/c371001.a
deleted file mode 100644
index f6823570b06..00000000000
--- a/gcc/testsuite/ada/acats/tests/c3/c371001.a
+++ /dev/null
@@ -1,388 +0,0 @@
--- C371001.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that if a discriminant constraint depends on a discriminant,
--- the evaluation of the expressions in the constraint is deferred
--- until an object of the subtype is created. Check for cases of
--- records with private type component.
---
--- TEST DESCRIPTION:
--- This transition test defines record type and incomplete types with
--- discriminant components which depend on the discriminants. The
--- discriminants are calculated by function calls. The test verifies
--- that Constraint_Error is raised during the object creations when
--- values of discriminants are incompatible with the subtypes.
---
--- Inspired by C37214A.ADA and C37216A.ADA.
---
---
--- CHANGE HISTORY:
--- 11 Apr 96 SAIC Initial version for ACVC 2.1.
--- 06 Oct 96 SAIC Added LM references. Replaced "others exception"
--- with "unexpected exception"
---
---!
-
-with Report;
-
-procedure C371001 is
-
- subtype Small_Int is Integer range 1..10;
-
- Func1_Cons : Integer := 0;
-
- ---------------------------------------------------------
- function Func1 return Integer is
- begin
- Func1_Cons := Func1_Cons + Report.Ident_Int(1);
- return Func1_Cons;
- end Func1;
-
-
-begin
- Report.Test ("C371001", "Check that if a discriminant constraint " &
- "depends on a discriminant, the evaluation of the " &
- "expressions in the constraint is deferred until " &
- "object declarations");
-
- ---------------------------------------------------------
- -- Constraint checks on an object declaration of a record.
-
- begin
-
- declare
-
- package C371001_0 is
-
- type PT_W_Disc (D : Small_Int) is private;
- type Rec_W_Private (D1 : Integer) is
- record
- C : PT_W_Disc (D1);
- end record;
-
- type Rec (D3 : Integer) is
- record
- C1 : Rec_W_Private (D3);
- end record;
-
- private
- type PT_W_Disc (D : Small_Int) is
- record
- Str : String (1 .. D) := (others => '*');
- end record;
-
- end C371001_0;
-
- --=====================================================--
-
- Obj : C371001_0.Rec(Report.Ident_Int(0)); -- Constraint_Error raised.
-
- begin
- Report.Failed ("Obj - Constraint_Error should be raised");
- if Obj.C1.D1 /= 0 then
- Report.Failed ("Obj - Shouldn't get here");
- end if;
-
- exception
- when others =>
- Report.Failed ("Obj - exception raised too late");
- end;
-
- exception
- when Constraint_Error => -- Exception expected.
- null;
- when others =>
- Report.Failed ("Obj - unexpected exception raised");
- end;
-
- -------------------------------------------------------------------
- -- Constraint checks on an object declaration of an array.
-
- begin
- declare
-
- package C371001_1 is
-
- type PT_W_Disc (D : Small_Int) is private;
- type Rec_W_Private (D1 : Integer) is
- record
- C : PT_W_Disc (D1);
- end record;
-
- type Rec_01 (D3 : Integer) is
- record
- C1 : Rec_W_Private (D3);
- end record;
-
- type Arr is array (1 .. 5) of
- Rec_01(Report.Ident_Int(0)); -- No Constraint_Error
- -- raised.
- private
- type PT_W_Disc (D : Small_Int) is
- record
- Str : String (1 .. D) := (others => '*');
- end record;
-
- end C371001_1;
-
- --=====================================================--
-
- begin
- declare
- Obj1 : C371001_1.Arr; -- Constraint_Error raised.
- begin
- Report.Failed ("Obj1 - Constraint_Error should be raised");
- if Obj1(1).D3 /= 0 then
- Report.Failed ("Obj1 - Shouldn't get here");
- end if;
-
- exception
- when others =>
- Report.Failed ("Obj1 - exception raised too late");
- end;
-
- exception
- when Constraint_Error => -- Exception expected.
- null;
- when others =>
- Report.Failed ("Obj1 - unexpected exception raised");
- end;
-
- exception
- when Constraint_Error =>
- Report.Failed ("Arr - Constraint_Error raised");
- when others =>
- Report.Failed ("Arr - unexpected exception raised");
- end;
-
-
- -------------------------------------------------------------------
- -- Constraint checks on an object declaration of an access type.
-
- begin
- declare
-
- package C371001_2 is
-
- type PT_W_Disc (D : Small_Int) is private;
- type Rec_W_Private (D1 : Integer) is
- record
- C : PT_W_Disc (D1);
- end record;
-
- type Rec_02 (D3 : Integer) is
- record
- C1 : Rec_W_Private (D3);
- end record;
-
- type Acc_Rec2 is access Rec_02 -- No Constraint_Error
- (Report.Ident_Int(11)); -- raised.
-
- private
- type PT_W_Disc (D : Small_Int) is
- record
- Str : String (1 .. D) := (others => '*');
- end record;
-
- end C371001_2;
-
- --=====================================================--
-
- begin
- declare
- Obj2 : C371001_2.Acc_Rec2; -- No Constraint_Error
- -- raised.
- begin
- Obj2 := new C371001_2.Rec_02 (Report.Ident_Int(11));
- -- Constraint_Error raised.
-
- Report.Failed ("Obj2 - Constraint_Error should be raised");
- if Obj2.D3 /= 1 then
- Report.Failed ("Obj2 - Shouldn't get here");
- end if;
-
- exception
- when Constraint_Error => -- Exception expected.
- null;
- when others =>
- Report.Failed ("Obj2 - unexpected exception raised in " &
- "assignment");
- end;
-
- exception
- when Constraint_Error =>
- Report.Failed ("Obj2 - Constraint_Error raised in declaration");
- when others =>
- Report.Failed ("Obj2 - unexpected exception raised in " &
- "declaration");
- end;
-
- exception
- when Constraint_Error =>
- Report.Failed ("Acc_Rec2 - Constraint_Error raised");
- when others =>
- Report.Failed ("Acc_Rec2 - unexpected exception raised");
- end;
-
- -------------------------------------------------------------------
- -- Constraint checks on an object declaration of a subtype.
-
- Func1_Cons := -1;
-
- begin
- declare
-
- package C371001_3 is
-
- type PT_W_Disc (D1, D2 : Small_Int) is private;
- type Rec_W_Private (D3, D4 : Integer) is
- record
- C : PT_W_Disc (D3, D4);
- end record;
-
- type Rec_03 (D5 : Integer) is
- record
- C1 : Rec_W_Private (D5, Func1); -- Func1 evaluated,
- end record; -- value 0.
-
- subtype Subtype_Rec is Rec_03(1); -- No Constraint_Error
- -- raised.
- private
- type PT_W_Disc (D1, D2 : Small_Int) is
- record
- Str1 : String (1 .. D1) := (others => '*');
- Str2 : String (1 .. D2) := (others => '*');
- end record;
-
- end C371001_3;
-
- --=====================================================--
-
- begin
- declare
- Obj3 : C371001_3.Subtype_Rec; -- Constraint_Error raised.
- begin
- Report.Failed ("Obj3 - Constraint_Error should be raised");
- if Obj3.D5 /= 1 then
- Report.Failed ("Obj3 - Shouldn't get here");
- end if;
-
- exception
- when others =>
- Report.Failed ("Obj3 - exception raised too late");
- end;
-
- exception
- when Constraint_Error => -- Exception expected.
- null;
- when others =>
- Report.Failed ("Obj3 - unexpected exception raised");
- end;
-
- exception
- when Constraint_Error =>
- Report.Failed ("Subtype_Rec - Constraint_Error raised");
- when others =>
- Report.Failed ("Subtype_Rec - unexpected exception raised");
- end;
-
- -------------------------------------------------------------------
- -- Constraint checks on an object declaration of an incomplete type.
-
- Func1_Cons := 10;
-
- begin
- declare
-
- package C371001_4 is
-
- type Rec_04 (D3 : Integer);
- type PT_W_Disc (D : Small_Int) is private;
- type Rec_W_Private (D1, D2 : Small_Int) is
- record
- C : PT_W_Disc (D2);
- end record;
-
- type Rec_04 (D3 : Integer) is
- record
- C1 : Rec_W_Private (D3, Func1); -- Func1 evaluated
- end record; -- value 11.
-
- type Acc_Rec4 is access Rec_04 (1); -- No Constraint_Error
- -- raised.
- private
- type PT_W_Disc (D : Small_Int) is
- record
- Str : String (1 .. D) := (others => '*');
- end record;
-
- end C371001_4;
-
- --=====================================================--
-
- begin
- declare
- Obj4 : C371001_4.Acc_Rec4; -- No Constraint_Error
- -- raised.
- begin
- Obj4 := new C371001_4.Rec_04 (1); -- Constraint_Error raised.
-
- Report.Failed ("Obj4 - Constraint_Error should be raised");
- if Obj4.D3 /= 1 then
- Report.Failed ("Obj4 - Shouldn't get here");
- end if;
-
- exception
- when Constraint_Error => -- Exception expected.
- null;
- when others =>
- Report.Failed ("Obj4 - unexpected exception raised in " &
- "assignment");
- end;
-
- exception
- when Constraint_Error =>
- Report.Failed ("Obj4 - Constraint_Error raised in declaration");
- when others =>
- Report.Failed ("Obj4 - unexpected exception raised in " &
- "declaration");
- end;
-
- exception
- when Constraint_Error =>
- Report.Failed ("Acc_Rec4 - Constraint_Error raised");
- when others =>
- Report.Failed ("Acc_Rec4 - unexpected exception raised");
- end;
-
- Report.Result;
-
-exception
- when others =>
- Report.Failed ("Discriminant value checked too soon");
- Report.Result;
-
-end C371001;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c371002.a b/gcc/testsuite/ada/acats/tests/c3/c371002.a
deleted file mode 100644
index ea532550cd8..00000000000
--- a/gcc/testsuite/ada/acats/tests/c3/c371002.a
+++ /dev/null
@@ -1,364 +0,0 @@
--- C371002.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that if a discriminant constraint depends on a discriminant,
--- the evaluation of the expressions in the constraint is deferred until
--- an object of the subtype is created. Check for cases of records.
---
--- TEST DESCRIPTION:
--- This transition test defines record types with discriminant components
--- which depend on the discriminants. The discriminants are calculated
--- by function calls. The test verifies that Constraint_Error is raised
--- during the object creations when values of discriminants are
--- incompatible with the subtypes.
---
--- Inspired by C37213A.ADA, C37213C.ADA, C37215A.ADA and C37215C.ADA.
---
---
--- CHANGE HISTORY:
--- 05 Apr 96 SAIC Initial version for ACVC 2.1.
---
---!
-
-with Report;
-
-procedure C371002 is
-
- subtype Small_Int is Integer range 1..10;
-
- type Rec_W_Disc (Disc1, Disc2 : Small_Int) is
- record
- Str1 : String (1 .. Disc1) := (others => '*');
- Str2 : String (1 .. Disc2) := (others => '*');
- end record;
-
- type My_Array is array (Small_Int range <>) of Integer;
-
- Func1_Cons : Integer := 0;
-
- ---------------------------------------------------------
- function Chk (Cons : Integer;
- Value : Integer;
- Message : String) return Boolean is
- begin
- if Cons /= Value then
- Report.Failed (Message & ": Func1_Cons is " &
- Integer'Image(Func1_Cons));
- end if;
- return True;
- end Chk;
-
- ---------------------------------------------------------
- function Func1 return Integer is
- begin
- Func1_Cons := Func1_Cons + Report.Ident_Int(1);
- return Func1_Cons;
- end Func1;
-
-begin
- Report.Test ("C371002", "Check that if a discriminant constraint " &
- "depends on a discriminant, the evaluation of the " &
- "expressions in the constraint is deferred until " &
- "object declarations");
-
- ---------------------------------------------------------
- declare
- type Rec1 (D3 : Integer) is
- record
- C1 : Rec_W_Disc (D3, Func1); -- Func1 evaluated, value 1.
- end record;
-
- Chk1 : Boolean := Chk (Func1_Cons, 1,
- "Func1 not evaluated for Rec1");
-
- Obj1 : Rec1 (1); -- Func1 not evaluated again.
- Obj2 : Rec1 (2); -- Func1 not evaluated again.
-
- Chk2 : Boolean := Chk (Func1_Cons, 1,
- "Func1 evaluated too many times");
- begin
- if Obj1 /= (D3 => 1,
- C1 => (Disc1 => 1,
- Disc2 => 1,
- Str1 => (others => '*'),
- Str2 => (others => '*'))) or
- Obj2 /= (D3 => 2,
- C1 => (Disc1 => 2,
- Disc2 => 1,
- Str1 => (others => '*'),
- Str2 => (others => '*'))) then
- Report.Failed ("Obj1 & Obj2 - Discriminant values not correct");
- end if;
- end;
-
- ---------------------------------------------------------
- Func1_Cons := -11;
-
- declare
- type Rec_Of_Rec_01 (D3 : Integer) is
- record
- C1 : Rec_W_Disc (D3, Func1); -- Func1 evaluated, value -10.
- end record; -- Constraint_Error not raised.
-
- type Rec_Of_MyArr_01 (D3 : Integer) is
- record
- C1 : My_Array (Func1 .. D3); -- Func1 evaluated, value -9.
- end record; -- Constraint_Error not raised.
-
- type Rec_Of_Rec_02 (D3 : Integer) is
- record
- C1 : Rec_W_Disc (D3, 1);
- end record;
-
- type Rec_Of_MyArr_02 (D3 : Integer) is
- record
- C1 : My_Array (D3 .. 1);
- end record;
-
- begin
-
- ---------------------------------------------------------
- begin
- declare
- Obj3 : Rec_Of_Rec_01(1); -- Constraint_Error raised.
- begin
- Report.Failed ("Obj3 - Constraint_Error should be raised");
- if Obj3 /= (1, (1, 1, others => (others => '*'))) then
- Report.Comment ("Obj3 - Shouldn't get here");
- end if;
- end;
-
- exception
- when Constraint_Error => -- Exception expected.
- null;
- when others =>
- Report.Failed ("Obj3 - others exception raised");
- end;
-
- ---------------------------------------------------------
- begin
- declare
- subtype Subtype_Rec is Rec_Of_Rec_01(1);
- -- No Constraint_Error raised.
- begin
- declare
- Obj4 : Subtype_Rec; -- Constraint_Error raised.
- begin
- Report.Failed ("Obj4 - Constraint_Error should be raised");
- if Obj4 /= (D3 => 1,
- C1 => (Disc1 => 1,
- Disc2 => 1,
- Str1 => (others => '*'),
- Str2 => (others => '*'))) then
- Report.Comment ("Obj4 - Shouldn't get here");
- end if;
- end;
-
- exception
- when Constraint_Error => -- Exception expected.
- null;
- when others =>
- Report.Failed ("Obj4 - others exception raised");
- end;
-
- exception
- when Constraint_Error =>
- Report.Failed ("Subtype_Rec - Constraint_Error raised");
- when others =>
- Report.Failed ("Subtype_Rec - others exception raised");
- end;
-
- ---------------------------------------------------------
- begin
- declare
- type Arr is array (1..5) -- No Constraint_Error raised.
- of Rec_Of_Rec_01(1);
-
- begin
- declare
- Obj5 : Arr; -- Constraint_Error raised.
- begin
- Report.Failed ("Obj5 - Constraint_Error should be raised");
- if Obj5 /= (1..5 => (1, (1, 1, others => (others => '*')))) then
- Report.Comment ("Obj5 - Shouldn't get here");
- end if;
- end;
-
- exception
- when Constraint_Error => -- Exception expected.
- null;
- when others =>
- Report.Failed ("Obj5 - others exception raised");
- end;
-
- exception
- when Constraint_Error =>
- Report.Failed ("Arr - Constraint_Error raised");
- when others =>
- Report.Failed ("Arr - others exception raised");
- end;
-
- ---------------------------------------------------------
- begin
- declare
- type Rec_Of_Rec_Of_MyArr is
- record
- C1 : Rec_Of_MyArr_01(1); -- No Constraint_Error raised.
- end record;
- begin
- declare
- Obj6 : Rec_Of_Rec_Of_MyArr; -- Constraint_Error raised.
- begin
- Report.Failed ("Obj6 - Constraint_Error should be raised");
- if Obj6 /= (C1 => (1, (1, 1))) then
- Report.Comment ("Obj6 - Shouldn't get here");
- end if;
- end;
-
- exception
- when Constraint_Error => -- Exception expected.
- null;
- when others =>
- Report.Failed ("Obj6 - others exception raised");
- end;
-
- exception
- when Constraint_Error =>
- Report.Failed ("Rec_Of_Rec_Of_MyArr - Constraint_Error raised");
- when others =>
- Report.Failed ("Rec_Of_Rec_Of_MyArr - others exception raised");
- end;
-
- ---------------------------------------------------------
- begin
- declare
- type New_Rec is
- new Rec_Of_MyArr_01(1); -- No Constraint_Error raised.
-
- begin
- declare
- Obj7 : New_Rec; -- Constraint_Error raised.
- begin
- Report.Failed ("Obj7 - Constraint_Error should be raised");
- if Obj7 /= (1, (1, 1)) then
- Report.Comment ("Obj7 - Shouldn't get here");
- end if;
- end;
-
- exception
- when Constraint_Error => -- Exception expected.
- null;
- when others =>
- Report.Failed ("Obj7 - others exception raised");
- end;
-
- exception
- when Constraint_Error =>
- Report.Failed ("New_Rec - Constraint_Error raised");
- when others =>
- Report.Failed ("New_Rec - others exception raised");
- end;
-
- ---------------------------------------------------------
- begin
- declare
- type Acc_Rec is
- access Rec_Of_Rec_02 (Report.Ident_Int(0));
- -- No Constraint_Error raised.
- begin
- declare
- Obj8 : Acc_Rec; -- No Constraint_Error raised.
-
- begin
- Obj8 := new Rec_Of_Rec_02 (Report.Ident_Int(0));
- -- Constraint_Error raised.
-
- Report.Failed ("Obj8 - Constraint_Error should be raised");
- if Obj8.all /= (D3 => 1,
- C1 => (Disc1 => 1,
- Disc2 => 1,
- Str1 => (others => '*'),
- Str2 => (others => '*'))) then
- Report.Comment ("Obj8 - Shouldn't get here");
- end if;
- end;
-
- exception
- when Constraint_Error => -- Exception expected.
- null;
- when others =>
- Report.Failed ("Obj8 - others exception raised");
- end;
-
- exception
- when Constraint_Error =>
- Report.Failed ("Acc_Rec - Constraint_Error raised");
- when others =>
- Report.Failed ("Acc_Rec - others exception raised");
- end;
-
- ---------------------------------------------------------
- begin
- declare
- type Acc_Rec_MyArr is access
- Rec_Of_MyArr_02; -- No Constraint_Error
- -- raised for either
- Obj9 : Acc_Rec_MyArr; -- declaration.
-
- begin
- Obj9 := new Rec_Of_MyArr_02 (Report.Ident_Int(0));
- -- Constraint_Error raised.
-
- Report.Failed ("Obj9 - Constraint_Error should be raised");
-
- if Obj9.all /= (1, (1, 1)) then
- Report.Comment ("Obj9 - Shouldn't get here");
- end if;
-
- exception
- when Constraint_Error => -- Exception expected.
- null;
- when others =>
- Report.Failed ("Obj9 - others exception raised");
- end;
-
- exception
- when Constraint_Error =>
- Report.Failed ("Acc_Rec_MyArr - Constraint_Error raised");
- when others =>
- Report.Failed ("Acc_Rec_MyArr - others exception raised");
- end;
-
- end;
-
- Report.Result;
-
-exception
- when others =>
- Report.Failed ("Discriminant value checked too soon");
- Report.Result;
-
-end C371002;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c371003.a b/gcc/testsuite/ada/acats/tests/c3/c371003.a
deleted file mode 100644
index c4a8345f610..00000000000
--- a/gcc/testsuite/ada/acats/tests/c3/c371003.a
+++ /dev/null
@@ -1,474 +0,0 @@
--- C371003.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that if a discriminant constraint depends on a discriminant,
--- the evaluation of the expressions in the constraint is deferred
--- until an object of the subtype is created. Check for cases of
--- records where the component containing the constraint is present
--- in the subtype.
---
--- TEST DESCRIPTION:
--- This transition test defines record types with discriminant components
--- which depend on the discriminants. The discriminants are calculated
--- by function calls. The test verifies that Constraint_Error is raised
--- during the object creations when values of discriminants are
--- incompatible with the subtypes. Also check for cases, where the
--- component is absent.
---
--- Inspired by C37213E.ADA, C37213G.ADA, C37215E.ADA, and C37215G.ADA.
---
---
--- CHANGE HISTORY:
--- 10 Apr 96 SAIC Initial version for ACVC 2.1.
--- 14 Jul 96 SAIC Modified test description. Added exception handler
--- for VObj_10 assignment.
--- 26 Oct 96 SAIC Added LM references.
---
---!
-
-with Report;
-
-procedure C371003 is
-
- subtype Small_Int is Integer range 1..10;
-
- type Rec_W_Disc (Disc1, Disc2 : Small_Int) is
- record
- Str1 : String (1 .. Disc1) := (others => '*');
- Str2 : String (1 .. Disc2) := (others => '*');
- end record;
-
- type My_Array is array (Small_Int range <>) of Integer;
-
- Func1_Cons : Integer := 0;
-
- ---------------------------------------------------------
- function Chk (Cons : Integer;
- Value : Integer;
- Message : String) return Boolean is
- begin
- if Cons /= Value then
- Report.Failed (Message & ": Func1_Cons is " &
- Integer'Image(Func1_Cons));
- end if;
- return True;
- end Chk;
-
- ---------------------------------------------------------
- function Func1 return Integer is
- begin
- Func1_Cons := Func1_Cons + Report.Ident_Int(1);
- return Func1_Cons;
- end Func1;
-
-
-begin
- Report.Test ("C371003", "Check that if a discriminant constraint " &
- "depends on a discriminant, the evaluation of the " &
- "expressions in the constraint is deferred until " &
- "object declarations");
-
- ---------------------------------------------------------
- declare
- type VRec_01 (D3 : Integer) is
- record
- case D3 is
- when -5..10 =>
- C1 : Rec_W_Disc (D3, Func1); -- Func1 evaluated, value 1.
- when others =>
- C2 : Integer := Report.Ident_Int(0);
- end case;
- end record;
-
- Chk1 : Boolean := Chk (Func1_Cons, 1,
- "Func1 not evaluated for VRec_01");
-
- VObj_1 : VRec_01(1); -- Func1 not evaluated again
- VObj_2 : VRec_01(2); -- Func1 not evaluated again
-
- Chk2 : Boolean := Chk (Func1_Cons, 1,
- "Func1 evaluated too many times");
-
- begin
- if VObj_1 /= (D3 => 1,
- C1 => (Disc1 => 1,
- Disc2 => 1,
- Str1 => (others => '*'),
- Str2 => (others => '*'))) or
- VObj_2 /= (D3 => 2,
- C1 => (Disc1 => 2,
- Disc2 => 1,
- Str1 => (others => '*'),
- Str2 => (others => '*'))) then
- Report.Failed ("VObj_1 & VObj_2 - Discriminant values not correct");
- end if;
- end;
-
- ---------------------------------------------------------
- Func1_Cons := -11;
-
- declare
- type VRec_Of_VRec_01 (D3 : Integer) is
- record
- case D3 is
- when -5..10 =>
- C1 : Rec_W_Disc (Func1, D3); -- Func1 evaluated, value -10.
- when others => -- Constraint_Error not raised.
- C2 : Integer := Report.Ident_Int(0);
- end case;
- end record;
-
- type VRec_Of_VRec_02 (D3 : Integer) is
- record
- case D3 is
- when -5..10 =>
- C1 : Rec_W_Disc (1, D3);
- when others =>
- C2 : Integer := Report.Ident_Int(0);
- end case;
- end record;
-
- type VRec_Of_MyArr_01 (D3 : Integer) is
- record
- case D3 is
- when -5..10 =>
- C1 : My_Array (Func1..D3); -- Func1 evaluated, value -9.
- when others => -- Constraint_Error not raised.
- C2 : Integer := Report.Ident_Int(0);
- end case;
- end record;
-
- type VRec_Of_MyArr_02 (D3 : Integer) is
- record
- case D3 is
- when -5..10 =>
- C1 : My_Array (D3..1);
- when others =>
- C2 : Integer := Report.Ident_Int(0);
- end case;
- end record;
-
- begin
-
- ---------------------------------------------------------
- -- Component containing the constraint is present.
- begin
- declare
- VObj_3 : VRec_Of_VRec_01(1); -- Constraint_Error raised.
- begin
- Report.Failed ("VObj_3 - Constraint_Error should be raised");
- if VObj_3 /= (1, (1, 1, others => (others => '*'))) then
- Report.Comment ("VObj_3 - Shouldn't get here");
- end if;
- end;
-
- exception
- when Constraint_Error => -- Exception expected.
- null;
- when others =>
- Report.Failed ("VObj_3 - unexpected exception raised");
- end;
-
- ---------------------------------------------------------
- -- Component containing the constraint is present.
- begin
- declare
- subtype Subtype_VRec is -- No Constraint_Error raised.
- VRec_Of_VRec_01(Report.Ident_Int(1));
- begin
- declare
- VObj_4 : Subtype_VRec; -- Constraint_Error raised.
- begin
- Report.Failed ("VObj_4 - Constraint_Error should be raised");
- if VObj_4 /= (D3 => 1,
- C1 => (Disc1 => 1,
- Disc2 => 1,
- Str1 => (others => '*'),
- Str2 => (others => '*'))) then
- Report.Comment ("VObj_4 - Shouldn't get here");
- end if;
- end;
-
- exception
- when Constraint_Error => -- Exception expected.
- null;
- when others =>
- Report.Failed ("VObj_4 - unexpected exception raised");
- end;
-
- exception
- when Constraint_Error =>
- Report.Failed ("Subtype_VRec - Constraint_Error raised");
- when others =>
- Report.Failed ("Subtype_VRec - unexpected exception raised");
- end;
-
- ---------------------------------------------------------
- -- Component containing the constraint is absent.
- begin
- declare
- type Arr is array (1..5) of
- VRec_Of_VRec_01(Report.Ident_Int(-6)); -- No Constraint_Error
- VObj_5 : Arr; -- for either declaration.
-
- begin
- if VObj_5 /= (1 .. 5 => (-6, 0)) then
- Report.Comment ("VObj_5 - wrong values");
- end if;
- end;
-
- exception
- when others =>
- Report.Failed ("Arr - unexpected exception raised");
- end;
-
- ---------------------------------------------------------
- -- Component containing the constraint is present.
- begin
- declare
- type Rec_Of_Rec_Of_MyArr is
- record
- C1 : VRec_Of_MyArr_01(1); -- No Constraint_Error raised.
- end record;
- begin
- declare
- Obj_6 : Rec_Of_Rec_Of_MyArr; -- Constraint_Error raised.
- begin
- Report.Failed ("Obj_6 - Constraint_Error should be raised");
- if Obj_6 /= (C1 => (1, (1, 1))) then
- Report.Comment ("Obj_6 - Shouldn't get here");
- end if;
- end;
-
- exception
- when Constraint_Error => -- Exception expected.
- null;
- when others =>
- Report.Failed ("Obj_6 - unexpected exception raised");
- end;
-
- exception
- when Constraint_Error =>
- Report.Failed ("Rec_Of_Rec_Of_MyArr - Constraint_Error raised");
- when others =>
- Report.Failed ("Rec_Of_Rec_Of_MyArr - unexpected exception " &
- "raised");
- end;
-
- ---------------------------------------------------------
- -- Component containing the constraint is absent.
- begin
- declare
- type New_VRec_Arr is
- new VRec_Of_MyArr_01(11); -- No Constraint_Error raised
- Obj_7 : New_VRec_Arr; -- for either declaration.
-
- begin
- if Obj_7 /= (11, 0) then
- Report.Failed ("Obj_7 - value incorrect");
- end if;
- end;
-
- exception
- when others =>
- Report.Failed ("New_VRec_Arr - unexpected exception raised");
- end;
-
- ---------------------------------------------------------
- -- Component containing the constraint is present.
- begin
- declare
- type New_VRec is new
- VRec_Of_VRec_02(Report.Ident_Int(0)); -- No Constraint_Error
- -- raised.
- begin
- declare
- VObj_8 : New_VRec; -- Constraint_Error raised.
- begin
- Report.Failed ("VObj_8 - Constraint_Error should be raised");
- if VObj_8 /= (1, (1, 1, others => (others => '*'))) then
- Report.Comment ("VObj_8 - Shouldn't get here");
- end if;
- end;
-
- exception
- when Constraint_Error => -- Exception expected.
- null;
- when others =>
- Report.Failed ("VObj_8 - unexpected exception raised");
- end;
-
- exception
- when Constraint_Error =>
- Report.Failed ("New_VRec - Constraint_Error raised");
- when others =>
- Report.Failed ("New_VRec - unexpected exception raised");
- end;
-
- ---------------------------------------------------------
- -- Component containing the constraint is absent.
- begin
- declare
- subtype Sub_VRec is
- VRec_Of_VRec_02(Report.Ident_Int(11)); -- No Constraint_Error
- VObj_9 : Sub_VRec; -- raised for either
- -- declaration.
- begin
- if VObj_9 /= (11, 0) then
- Report.Comment ("VObj_9 - wrong values");
- end if;
- end;
-
- exception
- when others =>
- Report.Failed ("Sub_VRec - unexpected exception raised");
- end;
-
- ---------------------------------------------------------
- -- Component containing the constraint is present.
- begin
- declare
- type Acc_VRec_01 is access
- VRec_Of_VRec_02(Report.Ident_Int(0)); -- No Constraint_Error
- -- raised.
- begin
- declare
- VObj_10 : Acc_VRec_01; -- No Constraint_Error
- -- raised.
- begin
- VObj_10 := new VRec_Of_VRec_02
- (Report.Ident_Int(0)); -- Constraint_Error
- -- raised.
- Report.Failed ("VObj_10 - Constraint_Error should be raised");
- if VObj_10.all /= (1, (1, 1, others => (others => '*'))) then
- Report.Comment ("VObj_10 - Shouldn't get here");
- end if;
-
- exception
- when Constraint_Error => -- Exception expected.
- null;
- when others =>
- Report.Failed ("VObj_10 - unexpected exception raised");
- end;
-
- exception
- when Constraint_Error =>
- Report.Failed ("VObj_10 - Constraint_Error exception raised");
- when others =>
- Report.Failed ("VObj_10 - unexpected exception raised at " &
- "declaration");
- end;
-
- exception
- when Constraint_Error =>
- Report.Failed ("Acc_VRec_01 - Constraint_Error raised");
- when others =>
- Report.Failed ("Acc_VRec_01 - unexpected exception raised");
- end;
-
- ---------------------------------------------------------
- -- Component containing the constraint is absent.
- begin
- declare
- type Acc_VRec_02 is access
- VRec_Of_VRec_02(11); -- No Constraint_Error
- -- raised for either
- VObj_11 : Acc_VRec_02; -- declaration.
-
- begin
- VObj_11 := new VRec_Of_VRec_02(11);
- if VObj_11.all /= (11, 0) then
- Report.Comment ("VObj_11 - wrong values");
- end if;
- end;
-
- exception
- when others =>
- Report.Failed ("Acc_VRec_02 - unexpected exception raised");
- end;
-
- ---------------------------------------------------------
- -- Component containing the constraint is present.
- begin
- declare
- type Acc_VRec_03 is access
- VRec_Of_MyArr_02; -- No Constraint_Error
- -- raised for either
- VObj_12 : Acc_VRec_03; -- declaration.
- begin
- VObj_12 := new VRec_Of_MyArr_02
- (Report.Ident_Int(0)); -- Constraint_Error raised.
-
- Report.Failed ("VObj_12 - Constraint_Error should be raised");
- if VObj_12.all /= (1, (1, 1)) then
- Report.Comment ("VObj_12 - Shouldn't get here");
- end if;
-
- exception
- when Constraint_Error => -- Exception expected.
- null;
- when others =>
- Report.Failed ("VObj_12 - unexpected exception raised");
- end;
-
- exception
- when Constraint_Error =>
- Report.Failed ("Acc_VRec_03 - Constraint_Error raised");
- when others =>
- Report.Failed ("Acc_VRec_03 - unexpected exception raised");
- end;
-
- ---------------------------------------------------------
- -- Component containing the constraint is absent.
- begin
- declare
- type Acc_VRec_04 is access
- VRec_Of_MyArr_02(11); -- No Constraint_Error
- -- raised for either
- VObj_13 : Acc_VRec_04; -- declaration.
-
- begin
- VObj_13 := new VRec_Of_MyArr_02(11);
- if VObj_13.all /= (11, 0) then
- Report.Comment ("VObj_13 - wrong values");
- end if;
- end;
-
- exception
- when others =>
- Report.Failed ("Acc_VRec_04 - unexpected exception raised");
- end;
-
- end;
-
- Report.Result;
-
-exception
- when others =>
- Report.Failed ("Discriminant value checked too soon");
- Report.Result;
-
-end C371003;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c380001.a b/gcc/testsuite/ada/acats/tests/c3/c380001.a
deleted file mode 100644
index 0ebe4d31cfb..00000000000
--- a/gcc/testsuite/ada/acats/tests/c3/c380001.a
+++ /dev/null
@@ -1,128 +0,0 @@
--- C380001.A
---
--- Grant of Unlimited Rights
---
--- The Ada Conformity Assessment Authority (ACAA) holds unlimited
--- rights in the software and documentation contained herein. Unlimited
--- rights are the same as those granted by the U.S. Government for older
--- parts of the Ada Conformity Assessment Test Suite, and are defined
--- in DFAR 252.227-7013(a)(19). By making this public release, the ACAA
--- intends to confer upon all recipients unlimited rights equal to those
--- held by the ACAA. These rights include rights to use, duplicate,
--- release or disclose the released technical data and computer software
--- in whole or in part, in any manner and for any purpose whatsoever, and
--- to have or permit others to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE ACAA MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that checks are made properly when a per-object expression contains
--- an attribute whose prefix denotes the current instance of the type.
--- (Defect Report 8652/0002, as reflected in Technical Corrigendum 1,
--- RM95 3.8(18/1)).
---
--- CHANGE HISTORY:
--- 9 FEB 2001 PHL Initial version.
--- 29 JUN 2002 RLB Readied for release.
---
---!
-with Ada.Exceptions;
-use Ada.Exceptions;
-with Report;
-use Report;
-procedure C380001 is
-
- type Negative is range Integer'First .. -1;
-
- type R1 is
- record
- C : Negative := Negative (Ident_Int (R1'Size));
- end record;
-
-
- type R2;
-
- type R3 (D1 : access R2; D2 : Natural) is limited null record;
-
- type R2 is limited
- record
- C : R3 (R2'Access, Ident_Int (-1));
- end record;
-
-begin
- Test ("C380001", "Check that checks are made properly when a " &
- "per-object expression contains an attribute whose " &
- "prefix denotes the current instance of the type");
- begin
- declare
- X : R1;
- begin
- Failed
- ("No exception raised when evaluating a per-object expression " &
- "containing an attribute - 1");
- end;
- exception
- when Constraint_Error =>
- null;
- when E: others =>
- Failed ("Exception " & Exception_Name (E) &
- " raised - " & Exception_Information (E) & " - 1");
- end;
-
- declare
- type A is access R1;
- X : A;
- begin
- X := new R1;
- Failed ("No exception raised when evaluating a per-object expression " &
- "containing an attribute - 2");
- exception
- when Constraint_Error =>
- null;
- when E: others =>
- Failed ("Exception " & Exception_Name (E) &
- " raised - " & Exception_Information (E) & " - 2");
- end;
-
- begin
- declare
- X : R2;
- begin
- Failed
- ("No exception raised when elaborating a per-object constraint " &
- "containing an attribute - 3");
- end;
- exception
- when Constraint_Error =>
- null;
- when E: others =>
- Failed ("Exception " & Exception_Name (E) &
- " raised - " & Exception_Information (E) & " - 3");
- end;
-
- declare
- type A is access R2;
- X : A;
- begin
- X := new R2;
- Failed
- ("No exception raised when evaluating a per-object constraint " &
- "containing an attribute - 4");
- exception
- when Constraint_Error =>
- null;
- when E: others =>
- Failed ("Exception " & Exception_Name (E) &
- " raised - " & Exception_Information (E) & " - 4");
- end;
-
- Result;
-end C380001;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c380002.a b/gcc/testsuite/ada/acats/tests/c3/c380002.a
deleted file mode 100644
index ae58676cb26..00000000000
--- a/gcc/testsuite/ada/acats/tests/c3/c380002.a
+++ /dev/null
@@ -1,72 +0,0 @@
--- C380002.A
---
--- Grant of Unlimited Rights
---
--- The Ada Conformity Assessment Authority (ACAA) holds unlimited
--- rights in the software and documentation contained herein. Unlimited
--- rights are the same as those granted by the U.S. Government for older
--- parts of the Ada Conformity Assessment Test Suite, and are defined
--- in DFAR 252.227-7013(a)(19). By making this public release, the ACAA
--- intends to confer upon all recipients unlimited rights equal to those
--- held by the ACAA. These rights include rights to use, duplicate,
--- release or disclose the released technical data and computer software
--- in whole or in part, in any manner and for any purpose whatsoever, and
--- to have or permit others to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE ACAA MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that an expression in a per-object discriminant constraint which is
--- part of a named association is evaluated once for each association.
--- (Defect Report 8652/0002, as reflected in Technical Corrigendum 1,
--- RM95 3.8(18.1/1)).
---
--- CHANGE HISTORY:
--- 9 FEB 2001 PHL Initial version.
--- 29 JUN 2002 RLB Readied for release.
---
---!
-with Ada.Exceptions;
-use Ada.Exceptions;
-with Report;
-use Report;
-procedure C380002 is
-
- F_Val : Integer := Ident_Int (0);
-
- function F return Integer is
- begin
- F_Val := F_Val + Ident_Int (1);
- return F_Val;
- end F;
-
- type R1;
-
- type R2 (D0 : Integer; D1 : access R1; D2 : Integer; D3 : Integer) is
- limited null record;
-
- type R1 is limited
- record
- C : R2 (D1 => R1'Access, D0 | D2 | D3 => F);
- end record;
-
-begin
- Test ("C380002", "Check that an expression in a per-object discriminant " &
- "constraint which is part of a named association is " &
- "evaluated once for each association");
-
- if not Equal (F_Val, 3) then
- Failed ("Expression not evaluated the proper number of times");
- end if;
-
- Result;
-end C380002;
-
diff --git a/gcc/testsuite/ada/acats/tests/c3/c380003.a b/gcc/testsuite/ada/acats/tests/c3/c380003.a
deleted file mode 100644
index 451d177036c..00000000000
--- a/gcc/testsuite/ada/acats/tests/c3/c380003.a
+++ /dev/null
@@ -1,223 +0,0 @@
--- C380003.A
---
--- Grant of Unlimited Rights
---
--- The Ada Conformity Assessment Authority (ACAA) holds unlimited
--- rights in the software and documentation contained herein. Unlimited
--- rights are the same as those granted by the U.S. Government for older
--- parts of the Ada Conformity Assessment Test Suite, and are defined
--- in DFAR 252.227-7013(a)(19). By making this public release, the ACAA
--- intends to confer upon all recipients unlimited rights equal to those
--- held by the ACAA. These rights include rights to use, duplicate,
--- release or disclose the released technical data and computer software
--- in whole or in part, in any manner and for any purpose whatsoever, and
--- to have or permit others to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE ACAA MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that per-object expressions are evaluated as specified for
--- protected components. (Defect Report 8652/0002, as reflected in
--- Technical Corrigendum 1, RM95 3.6(22/1) and 3.8(18/1)).
---
--- CHANGE HISTORY:
--- 9 FEB 2001 PHL Initial version.
--- 29 JUN 2002 RLB Readied for release.
---
---!
-with Report;
-use Report;
-procedure C380003 is
-
- subtype Sm is Integer range 1 .. 10;
-
- type Rec (D1, D2 : Sm) is
- record
- null;
- end record;
-
-begin
- Test ("C380003",
- "Check compatibility of discriminant expressions" &
- " when the constraint depends on discriminants, " &
- "and the discriminants have defaults - protected components");
-
- declare
- protected type Cons (D3 : Integer := Ident_Int (11)) is
- function C1_D1 return Integer;
- function C1_D2 return Integer;
- private
- C1 : Rec (D3, 1);
- end Cons;
- protected body Cons is
- function C1_D1 return Integer is
- begin
- return C1.D1;
- end C1_D1;
- function C1_D2 return Integer is
- begin
- return C1.D2;
- end C1_D2;
- end Cons;
-
- function Is_Ok
- (C : Cons; D3 : Integer; C1_D1 : Integer; C1_D2 : Integer)
- return Boolean is
- begin
- return C.D3 = D3 and C.C1_D1 = C1_D1 and C.C1_D2 = C1_D2;
- end Is_Ok;
-
- begin
- begin
- declare
- X : Cons;
- begin
- Failed ("Discriminant check not performed - 1");
- if not Is_Ok (X, 1, 1, 1) then
- Comment ("Shouldn't get here");
- end if;
- end;
- exception
- when Constraint_Error =>
- null;
- when others =>
- Failed ("Unexpected exception - 1");
- end;
-
- begin
- declare
- type Acc_Cons is access Cons;
- X : Acc_Cons;
- begin
- X := new Cons;
- Failed ("Discriminant check not performed - 2");
- begin
- if not Is_Ok (X.all, 1, 1, 1) then
- Comment ("Irrelevant");
- end if;
- end;
- exception
- when Constraint_Error =>
- null;
- when others =>
- Failed ("Unexpected exception raised - 2");
- end;
- exception
- when others =>
- Failed ("Constraint checked too soon - 2");
- end;
-
- begin
- declare
- subtype Scons is Cons;
- begin
- declare
- X : Scons;
- begin
- Failed ("Discriminant check not performed - 3");
- if not Is_Ok (X, 1, 1, 1) then
- Comment ("Irrelevant");
- end if;
- end;
- exception
- when Constraint_Error =>
- null;
- when others =>
- Failed ("Unexpected exception raised - 3");
- end;
- exception
- when others =>
- Failed ("Constraint checked too soon - 3");
- end;
-
- begin
- declare
- type Arr is array (1 .. 5) of Cons;
- begin
- declare
- X : Arr;
- begin
- Failed ("Discriminant check not performed - 4");
- for I in Arr'Range loop
- if not Is_Ok (X (I), 1, 1, 1) then
- Comment ("Irrelevant");
- end if;
- end loop;
- end;
- exception
- when Constraint_Error =>
- null;
- when others =>
- Failed ("Unexpected exception raised - 4");
- end;
- exception
- when others =>
- Failed ("Constraint checked too soon - 4");
- end;
-
- begin
- declare
- type Nrec is
- record
- C1 : Cons;
- end record;
- begin
- declare
- X : Nrec;
- begin
- Failed ("Discriminant check not performed - 5");
- if not Is_Ok (X.C1, 1, 1, 1) then
- Comment ("Irrelevant");
- end if;
- end;
- exception
- when Constraint_Error =>
- null;
- when others =>
- Failed ("Unexpected exception raised - 5");
- end;
- exception
- when others =>
- Failed ("Constraint checked too soon - 5");
- end;
-
- begin
- declare
- type Drec is new Cons;
- begin
- declare
- X : Drec;
- begin
- Failed ("Discriminant check not performed - 6");
- if not Is_Ok (Cons (X), 1, 1, 1) then
- Comment ("Irrelevant");
- end if;
- end;
- exception
- when Constraint_Error =>
- null;
- when others =>
- Failed ("Unexpected exception raised - 6");
- end;
- exception
- when others =>
- Failed ("Constraint checked too soon - 6");
- end;
-
- end;
-
- Result;
-
-exception
- when others =>
- Failed ("Constraint check done too early");
- Result;
-end C380003;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c380004.a b/gcc/testsuite/ada/acats/tests/c3/c380004.a
deleted file mode 100644
index f83728b5f48..00000000000
--- a/gcc/testsuite/ada/acats/tests/c3/c380004.a
+++ /dev/null
@@ -1,385 +0,0 @@
--- C380004.A
---
--- Grant of Unlimited Rights
---
--- The Ada Conformity Assessment Authority (ACAA) holds unlimited
--- rights in the software and documentation contained herein. Unlimited
--- rights are the same as those granted by the U.S. Government for older
--- parts of the Ada Conformity Assessment Test Suite, and are defined
--- in DFAR 252.227-7013(a)(19). By making this public release, the ACAA
--- intends to confer upon all recipients unlimited rights equal to those
--- held by the ACAA. These rights include rights to use, duplicate,
--- release or disclose the released technical data and computer software
--- in whole or in part, in any manner and for any purpose whatsoever, and
--- to have or permit others to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE ACAA MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that per-object expressions are evaluated as specified for entry
--- families and protected components. (Defect Report 8652/0002,
--- as reflected in Technical Corrigendum 1, RM95 3.6(22/1), 3.8(18/1), and
--- 9.5.2(22/1)).
---
--- CHANGE HISTORY:
--- 9 FEB 2001 PHL Initial version.
--- 29 JUN 2002 RLB Readied for release.
---
---!
-with Report;
-use Report;
-procedure C380004 is
-
- type Rec (D1, D2 : Positive) is
- record
- null;
- end record;
-
- F1_Poe : Integer;
-
- function Chk (Poe : Integer; Value : Integer; Message : String)
- return Boolean is
- begin
- if Poe /= Value then
- Failed (Message & ": Poe is " & Integer'Image (Poe));
- end if;
- return True;
- end Chk;
-
- function F1 return Integer is
- begin
- F1_Poe := F1_Poe - Ident_Int (1);
- return F1_Poe;
- end F1;
-
- generic
- type T is limited private;
- with function Is_Ok (X : T;
- Param1 : Integer;
- Param2 : Integer;
- Param3 : Integer) return Boolean;
- procedure Check;
-
- procedure Check is
- begin
-
- declare
- type Poe is new T;
- Chk1 : Boolean := Chk (F1_Poe, 17, "F1 evaluated");
- X : Poe; -- F1 evaluated
- Y : Poe; -- F1 evaluated
- Chk2 : Boolean := Chk (F1_Poe, 15, "F1 not evaluated");
- begin
- if not Is_Ok (T (X), 16, 16, 17) or
- not Is_Ok (T (Y), 15, 15, 17) then
- Failed ("Discriminant values not correct - 0");
- end if;
- end;
-
- declare
- type Poe is new T;
- begin
- begin
- declare
- X : Poe;
- begin
- if not Is_Ok (T (X), 14, 14, 17) then
- Failed ("Discriminant values not correct - 1");
- end if;
- end;
- exception
- when others =>
- Failed ("Unexpected exception - 1");
- end;
-
- declare
- type Acc_Poe is access Poe;
- X : Acc_Poe;
- begin
- X := new Poe;
- begin
- if not Is_Ok (T (X.all), 13, 13, 17) then
- Failed ("Discriminant values not correct - 2");
- end if;
- end;
- exception
- when others =>
- Failed ("Unexpected exception raised - 2");
- end;
-
- declare
- subtype Spoe is Poe;
- X : Spoe;
- begin
- if not Is_Ok (T (X), 12, 12, 17) then
- Failed ("Discriminant values not correct - 3");
- end if;
- exception
- when others =>
- Failed ("Unexpected exception raised - 3");
- end;
-
- declare
- type Arr is array (1 .. 2) of Poe;
- X : Arr;
- begin
- if Is_Ok (T (X (1)), 11, 11, 17) and then
- Is_Ok (T (X (2)), 10, 10, 17) then
- null;
- elsif Is_Ok (T (X (2)), 11, 11, 17) and then
- Is_Ok (T (X (1)), 10, 10, 17) then
- null;
- else
- Failed ("Discriminant values not correct - 4");
- end if;
- exception
- when others =>
- Failed ("Unexpected exception raised - 4");
- end;
-
- declare
- type Nrec is
- record
- C1, C2 : Poe;
- end record;
- X : Nrec;
- begin
- if Is_Ok (T (X.C1), 8, 8, 17) and then
- Is_Ok (T (X.C2), 9, 9, 17) then
- null;
- elsif Is_Ok (T (X.C2), 8, 8, 17) and then
- Is_Ok (T (X.C1), 9, 9, 17) then
- null;
- else
- Failed ("Discriminant values not correct - 5");
- end if;
- exception
- when others =>
- Failed ("Unexpected exception raised - 5");
- end;
-
- declare
- type Drec is new Poe;
- X : Drec;
- begin
- if not Is_Ok (T (X), 7, 7, 17) then
- Failed ("Discriminant values not correct - 6");
- end if;
- exception
- when others =>
- Failed ("Unexpected exception raised - 6");
- end;
- end;
- end Check;
-
-
-begin
- Test ("C380004",
- "Check evaluation of discriminant expressions " &
- "when the constraint depends on a discriminant, " &
- "and the discriminants have defaults - discriminant-dependent" &
- "entry families and protected components");
-
-
- Comment ("Discriminant-dependent entry families for task types");
-
- F1_Poe := 18;
-
- declare
- task type Poe (D3 : Positive := F1) is
- entry E (D3 .. F1); -- F1 evaluated
- entry Is_Ok (D3 : Integer;
- E_First : Integer;
- E_Last : Integer;
- Ok : out Boolean);
- end Poe;
- task body Poe is
- begin
- loop
- select
- accept Is_Ok (D3 : Integer;
- E_First : Integer;
- E_Last : Integer;
- Ok : out Boolean) do
- declare
- Cnt : Natural;
- begin
- if Poe.D3 = D3 then
- -- Can't think of a better way to check the
- -- bounds of the entry family.
- begin
- Cnt := E (E_First)'Count;
- Cnt := E (E_Last)'Count;
- exception
- when Constraint_Error =>
- Ok := False;
- return;
- end;
- begin
- Cnt := E (E_First - 1)'Count;
- Ok := False;
- return;
- exception
- when Constraint_Error =>
- null;
- when others =>
- Ok := False;
- return;
- end;
- begin
- Cnt := E (E_Last + 1)'Count;
- Ok := False;
- return;
- exception
- when Constraint_Error =>
- null;
- when others =>
- Ok := False;
- return;
- end;
- Ok := True;
- else
- Ok := False;
- return;
- end if;
- end;
- end Is_Ok;
- or
- terminate;
- end select;
- end loop;
- end Poe;
-
- function Is_Ok
- (C : Poe; D3 : Integer; E_First : Integer; E_Last : Integer)
- return Boolean is
- Ok : Boolean;
- begin
- C.Is_Ok (D3, E_First, E_Last, Ok);
- return Ok;
- end Is_Ok;
-
- procedure Chk is new Check (Poe, Is_Ok);
-
- begin
- Chk;
- end;
-
-
- Comment ("Discriminant-dependent entry families for protected types");
-
- F1_Poe := 18;
-
- declare
- protected type Poe (D3 : Integer := F1) is
- entry E (D3 .. F1); -- F1 evaluated
- function Is_Ok (D3 : Integer; E_First : Integer; E_Last : Integer)
- return Boolean;
- end Poe;
- protected body Poe is
- entry E (for I in D3 .. F1) when True is
- begin
- null;
- end E;
- function Is_Ok (D3 : Integer; E_First : Integer; E_Last : Integer)
- return Boolean is
- Cnt : Natural;
- begin
- if Poe.D3 = D3 then
- -- Can't think of a better way to check the
- -- bounds of the entry family.
- begin
- Cnt := E (E_First)'Count;
- Cnt := E (E_Last)'Count;
- exception
- when Constraint_Error =>
- return False;
- end;
- begin
- Cnt := E (E_First - 1)'Count;
- return False;
- exception
- when Constraint_Error =>
- null;
- when others =>
- return False;
- end;
- begin
- Cnt := E (E_Last + 1)'Count;
- return False;
- exception
- when Constraint_Error =>
- null;
- when others =>
- return False;
- end;
- return True;
- else
- return False;
- end if;
- end Is_Ok;
- end Poe;
-
- function Is_Ok
- (C : Poe; D3 : Integer; E_First : Integer; E_Last : Integer)
- return Boolean is
- begin
- return C.Is_Ok (D3, E_First, E_Last);
- end Is_Ok;
-
- procedure Chk is new Check (Poe, Is_Ok);
-
- begin
- Chk;
- end;
-
- Comment ("Protected components");
-
- F1_Poe := 18;
-
- declare
- protected type Poe (D3 : Integer := F1) is
- function C1_D1 return Integer;
- function C1_D2 return Integer;
- private
- C1 : Rec (D3, F1); -- F1 evaluated
- end Poe;
- protected body Poe is
- function C1_D1 return Integer is
- begin
- return C1.D1;
- end C1_D1;
- function C1_D2 return Integer is
- begin
- return C1.D2;
- end C1_D2;
- end Poe;
-
- function Is_Ok (C : Poe; D3 : Integer; C1_D1 : Integer; C1_D2 : Integer)
- return Boolean is
- begin
- return C.D3 = D3 and C.C1_D1 = C1_D1 and C.C1_D2 = C1_D2;
- end Is_Ok;
-
- procedure Chk is new Check (Poe, Is_Ok);
-
- begin
- Chk;
- end;
-
- Result;
-
-exception
- when others =>
- Failed ("Unexpected exception");
- Result;
-
-end C380004;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c3900010.a b/gcc/testsuite/ada/acats/tests/c3/c3900010.a
deleted file mode 100644
index 6d9ddb4a1db..00000000000
--- a/gcc/testsuite/ada/acats/tests/c3/c3900010.a
+++ /dev/null
@@ -1,147 +0,0 @@
--- C3900010.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- See C3900011.AM.
---
--- TEST DESCRIPTION:
--- See C3900011.AM.
---
--- TEST FILES:
--- This test consists of the following files:
---
--- => C3900010.A
--- C3900011.AM
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 15 May 96 SAIC ACVC 2.1: Modified prologue. Added pragma Elaborate
--- for Ada.Calendar.
---
---!
-
-with Ada.Calendar;
-pragma Elaborate (Ada.Calendar);
-
-package C3900010 is
-
-
- -- Declarations used by component Display_On and procedure Display.
-
- type Device_Enum is (Null_Device, Teletype, Console, Big_Screen);
- type Display_Counters is array (Device_Enum) of Natural;
-
- Display_Count_For : Display_Counters := (others => 0);
-
-
- -- Declarations required for component Arrival_Time.
-
- Default_Time : constant Ada.Calendar.Time :=
- Ada.Calendar.Time_Of (1901, 1, 1);
- Alert_Time : constant Ada.Calendar.Time :=
- Ada.Calendar.Time_Of (1991, 6, 15);
-
-
- type Alert_Type is tagged record -- Root tagged type.
- Arrival_Time : Ada.Calendar.Time := Default_Time;
- Display_On : Device_Enum := Null_Device;
- end record;
-
-
- procedure Display (A : in Alert_Type); -- To be inherited by
- -- all derivatives.
-
- procedure Handle (A : in out Alert_Type); -- To be inherited by
- -- all derivatives.
-
-
-
- type Low_Alert_Type is new Alert_Type with record -- Record extension of
- Level : Integer := 0; -- root tagged type.
- end record;
-
- -- Inherits procedure Display from Alert.
- -- Inherits procedure Handle from Alert.
-
- function Level_Of (LA : in Low_Alert_Type) -- To be inherited by
- return Integer; -- all derivatives.
-
-
-
- -- Declarations required for component Action_Officer;
-
- type Person_Enum is (Nobody, Duty_Officer,
- Watch_Commander, Commanding_Officer);
-
-
-
- type Medium_Alert_Type is new Low_Alert_Type with record
- Action_Officer : Person_Enum := Nobody; -- Record extension of
- end record; -- record extension.
-
- -- Inherits (inherited) procedure Display from Low_Alert_Type.
- -- Inherits (inherited) procedure Handle from Low_Alert_Type.
-
- -- Inherits function Level_Of from Low_Alert_Type.
-
- procedure Assign_Officer (MA : in out Medium_Alert_Type;
- To : in Person_Enum);
-
-
-end C3900010;
-
-
- --==================================================================--
-
-
-package body C3900010 is
-
-
- procedure Display (A : in Alert_Type) is
- begin
- Display_Count_For (A.Display_On) := Display_Count_For (A.Display_On) + 1;
- end Display;
-
-
- procedure Handle (A : in out Alert_Type) is
- begin
- A.Arrival_Time := Alert_Time;
- end Handle;
-
-
- function Level_Of (LA : in Low_Alert_Type) return Integer is
- begin
- return (LA.Level + 1);
- end Level_Of;
-
-
- procedure Assign_Officer (MA : in out Medium_Alert_Type;
- To : in Person_Enum) is
- begin
- MA.Action_Officer := To;
- end Assign_Officer;
-
-
-end C3900010;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c390002.a b/gcc/testsuite/ada/acats/tests/c3/c390002.a
deleted file mode 100644
index b3d11afed26..00000000000
--- a/gcc/testsuite/ada/acats/tests/c3/c390002.a
+++ /dev/null
@@ -1,165 +0,0 @@
--- C390002.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that a tagged base type may be declared, and derived
--- from in simple, private and extended forms. (Overlaps with C390B04)
--- Check that the package Ada.Tags is present and correctly implemented.
--- Check for the correct operation of Expanded_Name, External_Tag and
--- Internal_Tag within that package. Check that the exception Tag_Error
--- is correctly raised on calling Internal_Tag with bad input.
---
--- TEST DESCRIPTION:
--- This test declares a tagged type, and derives three types from it.
--- These types are then used to test the presence and function of the
--- package Ada.Tags.
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 19 Dec 94 SAIC Removed RM references from objective text.
--- 27 Jan 96 SAIC Update RM references for 2.1
---
---!
-
-with Report;
-with Ada.Tags;
-
-procedure C390002 is
-
- package Vehicle is
-
- type Object is tagged limited private; -- ancestor type
- procedure Create( The_Vehicle : in out Object; Wheels : in Natural );
- function Wheels( The_Vehicle : Object ) return Natural;
-
- private
-
- type Object is tagged limited record
- Wheel_Count : Natural := 0;
- end record;
-
- end Vehicle;
-
- package Motivators is
-
- type Bicycle is new Vehicle.Object with null record; -- simple
-
- type Car is new Vehicle.Object with record -- extended
- Convertible : Boolean;
- end record;
-
- type Truck is new Vehicle.Object with private; -- private
-
- private
-
- type Truck is new Vehicle.Object with record
- Air_Horn : Boolean;
- end record;
-
- end Motivators;
-
- package body Vehicle is
-
- procedure Create( The_Vehicle : in out Object; Wheels : in Natural ) is
- begin
- The_Vehicle.Wheel_Count := Wheels;
- end Create;
-
- function Wheels( The_Vehicle : Object ) return Natural is
- begin
- return The_Vehicle.Wheel_Count;
- end Wheels;
-
- end Vehicle;
-
- function TC_ID_Tag( Tag : in Ada.Tags.Tag ) return Ada.Tags.Tag is
- begin
- return Ada.Tags.Internal_Tag( Ada.Tags.External_Tag( Tag ) );
- Report.Comment("This message intentionally blank.");
- end TC_ID_Tag;
-
- procedure Check_Tags( Machine : in Vehicle.Object'Class;
- Expected_Name : in String;
- External_Tag : in String ) is
- The_Tag : constant Ada.Tags.Tag := Machine'Tag;
- use type Ada.Tags.Tag;
- begin
- if Ada.Tags.Expanded_Name(The_Tag) /= Expected_Name then
- Report.Failed ("Failed in Check_Tags, Expanded_Name "
- & Expected_Name);
- end if;
- if Ada.Tags.External_Tag(The_Tag) /= External_Tag then
- Report.Failed ("Failed in Check_Tags, External_Tag "
- & Expected_Name);
- end if;
- if Ada.Tags.Internal_Tag(External_Tag) /= The_Tag then
- Report.Failed ("Failed in Check_Tags, Internal_Tag "
- & Expected_Name);
- end if;
- end Check_Tags;
-
- procedure Check_Exception is
- Boeing_777_Id : Ada.Tags.Tag;
- begin
- Boeing_777_Id := Ada.Tags.Internal_Tag("!@#$%^:*\/?"" not a tag!");
- Report.Failed ("Failed in Check_Exception, no exception");
- Boeing_777_Id := TC_ID_Tag( Boeing_777_Id );
- exception
- when Ada.Tags.Tag_Error => null;
- when others =>
- Report.Failed ("Failed in Check_Exception, wrong exception");
- end Check_Exception;
-
- use Motivators;
- Two_Wheeler : Bicycle;
- Four_Wheeler : Car;
- Eighteen_Wheeler : Truck;
-
-begin -- Main test procedure.
-
- Report.Test ("C390002", "Check that a tagged type may be declared and " &
- "derived from in simple, private and extended forms. " &
- "Check package Ada.Tags" );
-
- Create( Two_Wheeler, 2 );
- Create( Four_Wheeler, 4 );
- Create( Eighteen_Wheeler, 18 );
-
- Check_Tags( Machine => Two_Wheeler,
- Expected_Name => "C390002.MOTIVATORS.BICYCLE",
- External_Tag => Bicycle'External_Tag );
- Check_Tags( Machine => Four_Wheeler,
- Expected_Name => "C390002.MOTIVATORS.CAR",
- External_Tag => Car'External_Tag );
- Check_Tags( Machine => Eighteen_Wheeler,
- Expected_Name => "C390002.MOTIVATORS.TRUCK",
- External_Tag => Truck'External_Tag );
-
- Check_Exception;
-
- Report.Result;
-
-end C390002;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c390003.a b/gcc/testsuite/ada/acats/tests/c3/c390003.a
deleted file mode 100644
index 643aad1cd18..00000000000
--- a/gcc/testsuite/ada/acats/tests/c3/c390003.a
+++ /dev/null
@@ -1,419 +0,0 @@
--- C390003.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that for a subtype S of a tagged type T, S'Class denotes a
--- class-wide subtype. Check that T'Tag denotes the tag of the type T,
--- and that, for a class-wide tagged type X, X'Tag denotes the tag of X.
--- Check that the tags of stand alone objects, record and array
--- components, aggregates, and formal parameters identify their type.
--- Check that the tag of a value of a formal parameter is that of the
--- actual parameter, even if the actual is passed by a view conversion.
---
--- TEST DESCRIPTION:
--- This test defines a class hierarchy (based on C390002) and
--- uses it to determine the correctness of the resulting tag
--- information generated by the compiler. A type is defined in the
--- class which contains components of the class as part of its
--- definition. This is to reduce the overall number of types
--- required, and to achieve the required nesting to accomplish
--- this test. The model is that of a car carrier truck; both car
--- and truck being in the class of Vehicle.
---
--- Class Hierarchy:
--- Vehicle - - - - - - - (Bicycle)
--- / | \ / \
--- Truck Car Q_Machine Tandem Motorcycle
--- |
--- Auto_Carrier
--- Contains:
--- Auto_Carrier( Car )
--- Q_Machine( Car, Motorcycle )
---
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 19 Dec 94 SAIC Removed ARM references from objective text.
--- 20 Dec 94 SAIC Replaced three unnecessary extension
--- aggregates with simple aggregates.
--- 16 Oct 95 SAIC Fixed bugs for ACVC 2.0.1
---
---!
-
------------------------------------------------------------------ C390003_1
-
-with Ada.Tags;
-package C390003_1 is -- Vehicle
-
- type TC_Keys is (Veh, MC, Tand, Car, Q, Truk, Heavy);
- type States is (Good, Flat, Worn);
-
- type Wheel_List is array(Positive range <>) of States;
-
- type Object(Wheels: Positive) is tagged record
- Wheel_State : Wheel_List(1..Wheels);
- end record;
-
- procedure TC_Validate( It: Object; Key: TC_Keys );
- procedure TC_Validate( It: Object'Class; The_Tag: Ada.Tags.Tag );
-
- procedure Create( The_Vehicle : in out Object; Tyres : in States );
- procedure Rotate( The_Vehicle : in out Object );
- function Wheels( The_Vehicle : Object ) return Positive;
-
-end C390003_1; -- Vehicle;
-
------------------------------------------------------------------ C390003_2
-
-with C390003_1;
-package C390003_2 is -- Motivators
-
- package Vehicle renames C390003_1;
- subtype Bicycle is Vehicle.Object(2); -- constrained subtype
-
- type Motorcycle is new Bicycle with record
- Displacement : Natural;
- end record;
- procedure TC_Validate( It: Motorcycle; Key: Vehicle.TC_Keys );
-
- type Tandem is new Bicycle with null record;
- procedure TC_Validate( It: Tandem; Key: Vehicle.TC_Keys );
-
- type Car is new Vehicle.Object(4) with -- extended, constrained
- record
- Displacement : Natural;
- end record;
- procedure TC_Validate( It: Car; Key: Vehicle.TC_Keys );
-
- type Truck is new Vehicle.Object with -- extended, unconstrained
- record
- Tare : Natural;
- end record;
- procedure TC_Validate( It: Truck; Key: Vehicle.TC_Keys );
-
-end C390003_2; -- Motivators;
-
------------------------------------------------------------------ C390003_3
-
-with C390003_1;
-with C390003_2;
-package C390003_3 is -- Special_Trucks
- package Vehicle renames C390003_1;
- package Motivators renames C390003_2;
- Max_Cars_On_Vehicle : constant := 6;
- type Cargo_Index is range 0..Max_Cars_On_Vehicle;
- type Cargo is array(Cargo_Index range 1..Max_Cars_On_Vehicle)
- of Motivators.Car;
- type Auto_Carrier is new Motivators.Truck(18) with
- record
- Load_Count : Cargo_Index := 0;
- Payload : Cargo;
- end record;
- procedure TC_Validate( It: Auto_Carrier; Key: Vehicle.TC_Keys );
- procedure Load ( The_Car : in Motivators.Car;
- Onto : in out Auto_Carrier);
- procedure Unload( The_Car : out Motivators.Car;
- Off_of : in out Auto_Carrier);
-end C390003_3;
-
------------------------------------------------------------------ C390003_4
-
-with C390003_1;
-with C390003_2;
-package C390003_4 is -- James_Bond
-
- package Vehicle renames C390003_1;
- package Motivators renames C390003_2;
-
- type Q_Machine is new Vehicle.Object(4) with record
- Car_Part : Motivators.Car;
- Bike_Part : Motivators.Motorcycle;
- end record;
- procedure TC_Validate( It: Q_Machine; Key: Vehicle.TC_Keys );
-
-end C390003_4;
-
------------------------------------------------------------------ C390003_1
-
-with Report;
-with Ada.Tags;
-package body C390003_1 is -- Vehicle
-
- function "="(A,B: Ada.Tags.Tag) return Boolean renames Ada.Tags."=";
-
- procedure TC_Validate( It: Object; Key: TC_Keys ) is
- begin
- if Key /= Veh then
- Report.Failed("Expected Veh Key");
- end if;
- end TC_Validate;
-
- procedure TC_Validate( It: Object'Class; The_Tag: Ada.Tags.Tag ) is
- begin
- if It'Tag /= The_Tag then
- Report.Failed("Unexpected Tag for classwide formal");
- end if;
- end TC_Validate;
-
- procedure Create( The_Vehicle : in out Object; Tyres : in States ) is
- begin
- The_Vehicle.Wheel_State := ( others => Tyres );
- end Create;
-
- function Wheels( The_Vehicle : Object ) return Positive is
- begin
- return The_Vehicle.Wheels;
- end Wheels;
-
- procedure Rotate( The_Vehicle : in out Object ) is
- Push : States;
- Pulled : States
- := The_Vehicle.Wheel_State(The_Vehicle.Wheel_State'Last);
- begin
- for Finger in
- The_Vehicle.Wheel_State'First..The_Vehicle.Wheel_State'Last loop
- Push := The_Vehicle.Wheel_State(Finger);
- The_Vehicle.Wheel_State(Finger) := Pulled;
- Pulled := Push;
- end loop;
- end Rotate;
-
-end C390003_1; -- Vehicle;
-
------------------------------------------------------------------ C390003_2
-
-with Ada.Tags;
-with Report;
-package body C390003_2 is -- Motivators
-
- function "="(A,B: Ada.Tags.Tag) return Boolean renames Ada.Tags."=";
- function "="(A,B: Vehicle.TC_Keys) return Boolean renames Vehicle."=";
-
- procedure TC_Validate( It: Motorcycle; Key: Vehicle.TC_Keys ) is
- begin
- if Key /= Vehicle.MC then
- Report.Failed("Expected MC Key");
- end if;
- end TC_Validate;
-
- procedure TC_Validate( It: Tandem; Key: Vehicle.TC_Keys ) is
- begin
- if Key /= Vehicle.Tand then
- Report.Failed("Expected Tand Key");
- end if;
- end TC_Validate;
-
- procedure TC_Validate( It: Car; Key: Vehicle.TC_Keys ) is
- begin
- if Key /= Vehicle.Car then
- Report.Failed("Expected Car Key");
- end if;
- end TC_Validate;
-
- procedure TC_Validate( It: Truck; Key: Vehicle.TC_Keys ) is
- begin
- if Key /= Vehicle.Truk then
- Report.Failed("Expected Truk Key");
- end if;
- end TC_Validate;
-end C390003_2; -- Motivators;
-
------------------------------------------------------------------ C390003_3
-
-with Ada.Tags;
-with Report;
-package body C390003_3 is -- Special_Trucks
-
- function "="(A,B: Ada.Tags.Tag) return Boolean renames Ada.Tags."=";
- function "="(A,B: Vehicle.TC_Keys) return Boolean renames Vehicle."=";
-
- procedure TC_Validate( It: Auto_Carrier; Key: Vehicle.TC_Keys ) is
- begin
- if Key /= Vehicle.Heavy then
- Report.Failed("Expected Heavy Key");
- end if;
- end TC_Validate;
-
- procedure Load ( The_Car : in Motivators.Car;
- Onto : in out Auto_Carrier) is
- begin
- Onto.Load_Count := Onto.Load_Count +1;
- Onto.Payload(Onto.Load_Count) := The_Car;
- end Load;
- procedure Unload( The_Car : out Motivators.Car;
- Off_of : in out Auto_Carrier) is
- begin
- The_Car := Off_of.Payload(Off_of.Load_Count);
- Off_of.Load_Count := Off_of.Load_Count -1;
- end Unload;
-
-end C390003_3;
-
------------------------------------------------------------------ C390003_4
-
-with Report, Ada.Tags;
-package body C390003_4 is -- James_Bond
-
- function "="(A,B: Ada.Tags.Tag) return Boolean renames Ada.Tags."=";
- function "="(A,B: Vehicle.TC_Keys) return Boolean renames Vehicle."=";
-
- procedure TC_Validate( It: Q_Machine; Key: Vehicle.TC_Keys ) is
- begin
- if Key /= Vehicle.Q then
- Report.Failed("Expected Q Key");
- end if;
- end TC_Validate;
-
-end C390003_4;
-
-------------------------------------------------------------------- C390003
-
-with Report;
-with C390003_1;
-with C390003_2;
-with C390003_3;
-with C390003_4;
-procedure C390003 is
-
- package Vehicle renames C390003_1; use Vehicle;
- package Motivators renames C390003_2;
- package Special_Trucks renames C390003_3;
- package James_Bond renames C390003_4;
-
- -- The cast, in order of complexity:
-
- Pennys_Bike : Motivators.Bicycle;
- Weekender : Motivators.Tandem;
- Qs_Moped : Motivators.Motorcycle;
- Ms_Limo : Motivators.Car;
- Yard_Van : Motivators.Truck(8);
- Specter_X : Special_Trucks.Auto_Carrier;
- Gen_II : James_Bond.Q_Machine;
-
-
- -- Check compatibility with the corresponding class wide type.
-
- procedure Vehicle_Shop( It : in out Vehicle.Object'Class;
- Key : in Vehicle.TC_Keys ) is
-
- -- Check that Subtype'Class is defined for tagged subtypes.
- procedure Bike_Shop( Bike: in out Motivators.Bicycle'Class ) is
- begin
- -- Dispatch to appropriate TC_Validate
- Vehicle.TC_Validate( Bike, Key );
- end Bike_Shop;
-
- begin
- Vehicle.TC_Validate( It, Key );
- if Vehicle.Wheels( It ) = 2 then
- Bike_Shop( It ); -- only call Bike_Shop when It has 2 wheels
- end if;
- end Vehicle_Shop;
-
-begin -- Main test procedure.
-
- Report.Test ("C390003", "Check that for a subtype S of a tagged type " &
- "T, S'Class denotes a class-wide subtype. Check that " &
- "T'Tag denotes the tag of the type T, and that, for a " &
- "class-wide tagged type X, X'Tag denotes the tag of X. " &
- "Check that the tags of stand alone objects, record and " &
- "array components, aggregates, and formal parameters " &
- "identify their type. Check that the tag of a value of a " &
- "formal parameter is that of the actual parameter, even " &
- "if the actual is passed by a view conversion" );
-
--- Check that the tags of stand alone objects, record and array
--- components, aggregates, and formal parameters identify their type.
--- Check that the tag of a value of a formal parameter is that of the
--- actual parameter, even if the actual is passed by a view conversion.
-
- Vehicle_Shop( Pennys_Bike, Veh );
- Vehicle_Shop( Weekender, Tand );
- Vehicle_Shop( Qs_Moped, MC );
- Vehicle_Shop( Ms_Limo, Car );
- Vehicle_Shop( Yard_Van, Truk );
- Vehicle_Shop( Specter_X, Heavy );
- Vehicle_Shop( Specter_X.Payload(1), Car );
- Vehicle_Shop( Gen_II, Q );
- Vehicle_Shop( Gen_II.Car_Part, Car );
- Vehicle_Shop( Gen_II.Bike_Part, MC );
-
- Vehicle.TC_Validate( Pennys_Bike, Vehicle.Object'Tag );
- Vehicle.TC_Validate( Weekender, Motivators.Tandem'Tag );
- Vehicle.TC_Validate( Qs_Moped, Motivators.Motorcycle'Tag );
- Vehicle.TC_Validate( Ms_Limo, Motivators.Car'Tag );
- Vehicle.TC_Validate( Yard_Van, Motivators.Truck'Tag );
- Vehicle.TC_Validate( Specter_X, Special_Trucks.Auto_Carrier'Tag );
- Vehicle.TC_Validate( Specter_X.Payload(1), Motivators.Car'Tag );
- Vehicle.TC_Validate( Gen_II, James_Bond.Q_Machine'Tag );
- Vehicle.TC_Validate( Gen_II.Car_Part, Motivators.Car'Tag );
- Vehicle.TC_Validate( Gen_II.Bike_Part, Motivators.Motorcycle'Tag );
-
--- Check the tag generated for an aggregate.
-
- Rentals: declare
- Mikes_Rental : Vehicle.Object'Class :=
- Vehicle.Object'( 3, (Good, Flat, Worn));
- Diannes_Car : Vehicle.Object'Class :=
- Motivators.Tandem'( Wheels => 2,
- Wheel_State => (Good, Good) );
- Jims_Bike : Vehicle.Object'Class :=
- Motivators.Motorcycle'( Pennys_Bike
- with Displacement => 350 );
- Bills_Limo : Vehicle.Object'Class :=
- Motivators.Car'( Wheels => 4,
- Wheel_State => (others => Good),
- Displacement => 282 );
- Alans_Car : Vehicle.Object'Class :=
- Motivators.Truck'( 18, (others => Worn),
- Tare => 5_500 );
- Pats_Truck : Vehicle.Object'Class := Specter_X;
- Keiths_Car : Vehicle.Object'Class := Gen_II;
- Isaacs_Bus : Vehicle.Object'Class := Keiths_Car;
-
- begin
- Vehicle.TC_Validate( Mikes_Rental, Vehicle.Object'Tag );
- Vehicle.TC_Validate( Diannes_Car, Motivators.Tandem'Tag );
- Vehicle.TC_Validate( Jims_Bike, Motivators.Motorcycle'Tag );
- Vehicle.TC_Validate( Bills_Limo, Motivators.Car'Tag );
- Vehicle.TC_Validate( Alans_Car, Motivators.Truck'Tag );
- Vehicle.TC_Validate( Pats_Truck, Special_Trucks.Auto_Carrier'Tag );
- Vehicle.TC_Validate( Keiths_Car, James_Bond.Q_Machine'Tag );
- end Rentals;
-
--- Check the tag of parameters.
--- Check that the tag is not affected by view conversion.
-
- Vehicle.TC_Validate( Vehicle.Object( Gen_II ), James_Bond.Q_Machine'Tag );
- Vehicle.TC_Validate( Vehicle.Object( Ms_Limo ), Motivators.Car'Tag );
- Vehicle.TC_Validate( Motivators.Bicycle( Weekender ),
- Motivators.Tandem'Tag );
- Vehicle.TC_Validate( Motivators.Bicycle( Gen_II.Bike_Part ),
- Motivators.Motorcycle'Tag );
-
- Report.Result;
-
-end C390003;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c390004.a b/gcc/testsuite/ada/acats/tests/c3/c390004.a
deleted file mode 100644
index 2c120bab92b..00000000000
--- a/gcc/testsuite/ada/acats/tests/c3/c390004.a
+++ /dev/null
@@ -1,404 +0,0 @@
--- C390004.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that the tags of allocated objects correctly identify the
--- type of the allocated object. Check that the tag corresponds
--- correctly to the value resulting from both normal and view
--- conversion. Check that the tags of accessed values designating
--- aliased objects correctly identify the type of the object. Check
--- that the tag of a function result correctly evaluates. Check this
--- for class-wide functions. The tag of a class-wide function result
--- should be the tag appropriate to the actual value returned, not the
--- tag of the ancestor type.
---
--- TEST DESCRIPTION:
--- This test defines a class hierarchy of types, with reference
--- semantics (an access type to the class-wide type). Similar in
--- structure to C392005, this test checks that dynamic allocation does
--- not adversely impact the tagging of types.
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
---
---!
-
-package C390004_1 is -- DMV
- type Equipment is ( T_Veh, T_Car, T_Con, T_Jep );
-
- type Vehicle is tagged record
- Wheels : Natural := 4;
- Parked : Boolean := False;
- end record;
-
- function Wheels ( It: Vehicle ) return Natural;
- procedure Park ( It: in out Vehicle );
- procedure UnPark ( It: in out Vehicle );
- procedure Set_Wheels( It: in out Vehicle; To_Count: in Natural );
- procedure TC_Check ( It: in Vehicle; To_Equip: in Equipment );
-
- type Car is new Vehicle with record
- Passengers : Natural := 0;
- end record;
-
- function Passengers ( It: Car ) return Natural;
- procedure Load_Passengers( It: in out Car; To_Count: in Natural );
- procedure Park ( It: in out Car );
- procedure TC_Check ( It: in Car; To_Equip: in Equipment );
-
- type Convertible is new Car with record
- Top_Up : Boolean := True;
- end record;
-
- function Top_Up ( It: Convertible ) return Boolean;
- procedure Lower_Top( It: in out Convertible );
- procedure Park ( It: in out Convertible );
- procedure Raise_Top( It: in out Convertible );
- procedure TC_Check ( It: in Convertible; To_Equip: in Equipment );
-
- type Jeep is new Convertible with record
- Windshield_Up : Boolean := True;
- end record;
-
- function Windshield_Up ( It: Jeep ) return Boolean;
- procedure Lower_Windshield( It: in out Jeep );
- procedure Park ( It: in out Jeep );
- procedure Raise_Windshield( It: in out Jeep );
- procedure TC_Check ( It: in Jeep; To_Equip: in Equipment );
-
-end C390004_1;
-
-with Report;
-package body C390004_1 is
-
- procedure Set_Wheels( It: in out Vehicle; To_Count: in Natural ) is
- begin
- It.Wheels := To_Count;
- end Set_Wheels;
-
- function Wheels( It: Vehicle ) return Natural is
- begin
- return It.Wheels;
- end Wheels;
-
- procedure Park ( It: in out Vehicle ) is
- begin
- It.Parked := True;
- end Park;
-
- procedure UnPark ( It: in out Vehicle ) is
- begin
- It.Parked := False;
- end UnPark;
-
- procedure TC_Check ( It: in Vehicle; To_Equip: in Equipment ) is
- begin
- if To_Equip /= T_Veh then
- Report.Failed ("Failed, called Vehicle for "
- & Equipment'Image(To_Equip));
- end if;
- end TC_Check;
-
- procedure TC_Check ( It: in Car; To_Equip: in Equipment ) is
- begin
- if To_Equip /= T_Car then
- Report.Failed ("Failed, called Car for "
- & Equipment'Image(To_Equip));
- end if;
- end TC_Check;
-
- procedure TC_Check ( It: in Convertible; To_Equip: in Equipment ) is
- begin
- if To_Equip /= T_Con then
- Report.Failed ("Failed, called Convertible for "
- & Equipment'Image(To_Equip));
- end if;
- end TC_Check;
-
- procedure TC_Check ( It: in Jeep; To_Equip: in Equipment ) is
- begin
- if To_Equip /= T_Jep then
- Report.Failed ("Failed, called Jeep for "
- & Equipment'Image(To_Equip));
- end if;
- end TC_Check;
-
- procedure Load_Passengers( It: in out Car; To_Count: in Natural ) is
- begin
- It.Passengers := To_Count;
- UnPark( It );
- end Load_Passengers;
-
- procedure Park( It: in out Car ) is
- begin
- It.Passengers := 0;
- Park( Vehicle( It ) );
- end Park;
-
- function Passengers( It: Car ) return Natural is
- begin
- return It.Passengers;
- end Passengers;
-
- procedure Raise_Top( It: in out Convertible ) is
- begin
- It.Top_Up := True;
- end Raise_Top;
-
- procedure Lower_Top( It: in out Convertible ) is
- begin
- It.Top_Up := False;
- end Lower_Top;
-
- function Top_Up ( It: Convertible ) return Boolean is
- begin
- return It.Top_Up;
- end Top_Up;
-
- procedure Park ( It: in out Convertible ) is
- begin
- It.Top_Up := True;
- Park( Car( It ) );
- end Park;
-
- procedure Raise_Windshield( It: in out Jeep ) is
- begin
- It.Windshield_Up := True;
- end Raise_Windshield;
-
- procedure Lower_Windshield( It: in out Jeep ) is
- begin
- It.Windshield_Up := False;
- end Lower_Windshield;
-
- function Windshield_Up( It: Jeep ) return Boolean is
- begin
- return It.Windshield_Up;
- end Windshield_Up;
-
- procedure Park( It: in out Jeep ) is
- begin
- It.Windshield_Up := True;
- Park( Convertible( It ) );
- end Park;
-end C390004_1;
-
-with Report;
-with Ada.Tags;
-with C390004_1;
-procedure C390004 is
- package DMV renames C390004_1;
-
- The_Vehicle : aliased DMV.Vehicle;
- The_Car : aliased DMV.Car;
- The_Convertible : aliased DMV.Convertible;
- The_Jeep : aliased DMV.Jeep;
-
- type C_Reference is access all DMV.Car'Class;
- type V_Reference is access all DMV.Vehicle'Class;
-
- Designator : V_Reference;
- Storage : Natural;
-
- procedure Valet( It: in out DMV.Vehicle'Class ) is
- begin
- DMV.Park( It );
- end Valet;
-
- procedure TC_Match( Object: DMV.Vehicle'Class;
- Taglet: Ada.Tags.Tag;
- Where : String ) is
- use Ada.Tags;
- begin
- if Object'Tag /= Taglet then
- Report.Failed("Tag mismatch: " & Where);
- end if;
- end TC_Match;
-
- procedure Parking_Validation( It: DMV.Vehicle; TC_Message: String ) is
- begin
- if DMV.Wheels( It ) /= 1 or not It.Parked then
- Report.Failed ("Failed Vehicle " & TC_Message);
- end if;
- end Parking_Validation;
-
- procedure Parking_Validation( It: DMV.Car; TC_Message: String ) is
- begin
- if DMV.Wheels( It ) /= 2 or DMV.Passengers( It ) /= 0
- or not It.Parked then
- Report.Failed ("Failed Car " & TC_Message);
- end if;
- end Parking_Validation;
-
- procedure Parking_Validation( It: DMV.Convertible;
- TC_Message: String ) is
- begin
- if DMV.Wheels( It ) /= 3 or DMV.Passengers( It ) /= 0
- or not DMV.Top_Up( It ) or not It.Parked then
- Report.Failed ("Failed Convertible " & TC_Message);
- end if;
- end Parking_Validation;
-
- procedure Parking_Validation( It: DMV.Jeep; TC_Message: String ) is
- begin
- if DMV.Wheels( It ) /= 4 or DMV.Passengers( It ) /= 0
- or not DMV.Top_Up( It ) or not DMV.Windshield_Up( It )
- or not It.Parked then
- Report.Failed ("Failed Jeep " & TC_Message);
- end if;
- end Parking_Validation;
-
- function Wash( It: V_Reference; TC_Expect : Ada.Tags.Tag )
- return DMV.Vehicle'Class is
- This_Machine : DMV.Vehicle'Class := It.all;
- begin
- TC_Match( It.all, TC_Expect, "Class-wide object in Wash" );
- Storage := DMV.Wheels( This_Machine );
- return This_Machine;
- end Wash;
-
- function Wash( It: C_Reference; TC_Expect : Ada.Tags.Tag )
- return DMV.Car'Class is
- This_Machine : DMV.Car'Class := It.all;
- begin
- TC_Match( It.all, TC_Expect, "Class-wide object in Wash" );
- Storage := DMV.Wheels( This_Machine );
- return This_Machine;
- end Wash;
-
-begin
-
- Report.Test( "C390004", "Check that the tags of allocated objects "
- & "correctly identify the type of the allocated "
- & "object. Check that tags resulting from "
- & "normal and view conversions. Check tags of "
- & "accessed values designating aliased objects. "
- & "Check function result tags" );
-
- DMV.Set_Wheels( The_Vehicle, 1 );
- DMV.Set_Wheels( The_Car, 2 );
- DMV.Set_Wheels( The_Convertible, 3 );
- DMV.Set_Wheels( The_Jeep, 4 );
-
- Valet( The_Vehicle );
- Valet( The_Car );
- Valet( The_Convertible );
- Valet( The_Jeep );
-
- Parking_Validation( The_Vehicle, "setup" );
- Parking_Validation( The_Car, "setup" );
- Parking_Validation( The_Convertible, "setup" );
- Parking_Validation( The_Jeep, "setup" );
-
--- Check that the tags of allocated objects correctly identify the type
--- of the allocated object.
-
- Designator := new DMV.Vehicle;
- DMV.TC_Check( Designator.all, DMV.T_Veh );
- TC_Match( Designator.all, DMV.Vehicle'Tag, "allocated Vehicle" );
-
- Designator := new DMV.Car;
- DMV.TC_Check( Designator.all, DMV.T_Car );
- TC_Match( Designator.all, DMV.Car'Tag, "allocated Car");
-
- Designator := new DMV.Convertible;
- DMV.TC_Check( Designator.all, DMV.T_Con );
- TC_Match( Designator.all, DMV.Convertible'Tag, "allocated Convertible" );
-
- Designator := new DMV.Jeep;
- DMV.TC_Check( Designator.all, DMV.T_Jep );
- TC_Match( Designator.all, DMV.Jeep'Tag, "allocated Jeep" );
-
--- Check that view conversion causes the correct dispatch
- DMV.TC_Check( DMV.Vehicle( The_Jeep ), DMV.T_Veh );
- DMV.TC_Check( DMV.Car( The_Jeep ), DMV.T_Car );
- DMV.TC_Check( DMV.Convertible( The_Jeep ), DMV.T_Con );
-
--- And that view conversion does not change the tag
- TC_Match( DMV.Vehicle( The_Jeep ), DMV.Jeep'Tag, "View Conv Veh" );
- TC_Match( DMV.Car( The_Jeep ), DMV.Jeep'Tag, "View Conv Car" );
- TC_Match( DMV.Convertible( The_Jeep ), DMV.Jeep'Tag, "View Conv Jep" );
-
--- Check that the tags of accessed values designating aliased objects
--- correctly identify the type of the object.
- Designator := The_Vehicle'Access;
- DMV.TC_Check( Designator.all, DMV.T_Veh );
- TC_Match( Designator.all, DMV.Vehicle'Tag, "aliased Vehicle" );
-
- Designator := The_Car'Access;
- DMV.TC_Check( Designator.all, DMV.T_Car );
- TC_Match( Designator.all, DMV.Car'Tag, "aliased Car" );
-
- Designator := The_Convertible'Access;
- DMV.TC_Check( Designator.all, DMV.T_Con );
- TC_Match( Designator.all, DMV.Convertible'Tag, "aliased Convertible" );
-
- Designator := The_Jeep'Access;
- DMV.TC_Check( Designator.all, DMV.T_Jep );
- TC_Match( Designator.all, DMV.Jeep'Tag, "aliased Jeep" );
-
--- Check that the tag of a function result correctly evaluates.
--- Check this for class-wide functions. The tag of a class-wide
--- function result should be the tag appropriate to the actual value
--- returned, not the tag of the ancestor type.
- Function_Check: declare
- A_Vehicle : V_Reference := new DMV.Vehicle'( The_Vehicle );
- A_Car : C_Reference := new DMV.Car'( The_Car );
- A_Convertible : C_Reference := new DMV.Convertible'( The_Convertible );
- A_Jeep : C_Reference := new DMV.Jeep'( The_Jeep );
- begin
- DMV.Unpark( A_Vehicle.all );
- DMV.Load_Passengers( A_Car.all, 5 );
- DMV.Load_Passengers( A_Convertible.all, 6 );
- DMV.Load_Passengers( A_Jeep.all, 7 );
- DMV.Lower_Top( DMV.Convertible(A_Convertible.all) );
- DMV.Lower_Top( DMV.Jeep(A_Jeep.all) );
- DMV.Lower_Windshield( DMV.Jeep(A_Jeep.all) );
-
- if DMV.Wheels( Wash( A_Jeep, DMV.Jeep'Tag ) ) /= 4
- or Storage /= 4 then
- Report.Failed("Did not correctly wash Jeep");
- end if;
-
- if DMV.Wheels( Wash( A_Convertible, DMV.Convertible'Tag ) ) /= 3
- or Storage /= 3 then
- Report.Failed("Did not correctly wash Convertible");
- end if;
-
- if DMV.Wheels( Wash( A_Car, DMV.Car'Tag ) ) /= 2
- or Storage /= 2 then
- Report.Failed("Did not correctly wash Car");
- end if;
-
- if DMV.Wheels( Wash( A_Vehicle, DMV.Vehicle'Tag ) ) /= 1
- or Storage /= 1 then
- Report.Failed("Did not correctly wash Vehicle");
- end if;
-
- end Function_Check;
-
- Report.Result;
-end C390004;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c3900050.a b/gcc/testsuite/ada/acats/tests/c3/c3900050.a
deleted file mode 100644
index 8a00b265654..00000000000
--- a/gcc/testsuite/ada/acats/tests/c3/c3900050.a
+++ /dev/null
@@ -1,157 +0,0 @@
--- C3900050.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- See C3900053.AM.
---
--- TEST DESCRIPTION:
--- See C3900053.AM.
---
--- TEST FILES:
--- This test consists of the following files:
---
--- => C3900050.A
--- C3900051.A
--- C3900052.A
--- C3900053.AM
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 15 May 96 SAIC ACVC 2.1: Modified prologue. Added pragma Elaborate
--- for Ada.Calendar.
---
---!
-
-with Ada.Calendar;
-pragma Elaborate (Ada.Calendar);
-
-package C3900050 is -- Alert system abstraction.
-
- -- Declarations used by component Arrival_Time.
-
- Default_Time : constant Ada.Calendar.Time :=
- Ada.Calendar.Time_Of (1901, 1, 1);
- Alert_Time : constant Ada.Calendar.Time :=
- Ada.Calendar.Time_Of (1991, 6, 15);
-
-
- -- Declarations used by component Display_On and procedure Display.
-
- type Device_Enum is (Null_Device, Teletype, Console, Big_Screen);
- type Display_Counters is array (Device_Enum) of Natural;
-
- Display_Count_For : Display_Counters := (others => 0);
-
-
-
- type Alert_Type is tagged private; -- Root tagged type.
-
- procedure Set_Display (A : in out Alert_Type; -- To be inherited by
- D : in Device_Enum); -- all derivatives.
-
- procedure Display (A : in Alert_Type); -- To be inherited by
- -- all derivatives.
-
- procedure Handle (A : in out Alert_Type); -- To be overridden by
- -- all derivatives.
-
-
- -- The following functions are needed to verify the values of the
- -- root tagged type's private components.
-
- function Get_Time (A: Alert_Type) return Ada.Calendar.Time;
-
- function Get_Display (A: Alert_Type) return Device_Enum;
-
- function Initial_Values_Okay (A : in Alert_Type)
- return Boolean;
-
- function Bad_Final_Values (A : in Alert_Type)
- return Boolean;
-
-private
-
- type Alert_Type is tagged record -- Root tagged type.
- Arrival_Time : Ada.Calendar.Time := Default_Time;
- Display_On : Device_Enum := Null_Device;
- end record;
-
-
-end C3900050;
-
-
- --==================================================================--
-
-
-package body C3900050 is -- Alert system abstraction.
-
-
- procedure Set_Display (A : in out Alert_Type;
- D : in Device_Enum) is
- begin
- A.Display_On := D;
- end Set_Display;
-
-
- procedure Display (A : in Alert_Type) is
- begin
- Display_Count_For (A.Display_On) := Display_Count_For (A.Display_On) + 1;
- end Display;
-
-
- procedure Handle (A : in out Alert_Type) is
- begin
- A.Arrival_Time := Alert_Time;
- Display (A);
- end Handle;
-
-
- function Get_Time (A: Alert_Type) return Ada.Calendar.Time is
- begin
- return A.Arrival_Time;
- end Get_Time;
-
-
- function Get_Display (A: Alert_Type) return Device_Enum is
- begin
- return A.Display_On;
- end Get_Display;
-
-
- function Initial_Values_Okay (A : in Alert_Type) return Boolean is
- begin
- return (A = (Arrival_Time => Default_Time, -- Check "=" operator
- Display_On => Null_Device)); -- availability.
- end Initial_Values_Okay; -- Aggregate with
- -- named associations.
-
- function Bad_Final_Values (A : in Alert_Type) return Boolean is
- begin
- return (A /= (Alert_Time, Null_Device)); -- Check "/=" operator
- -- availability.
- end Bad_Final_Values; -- Aggregate with
- -- positional assoc.
-
-end C3900050;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c3900051.a b/gcc/testsuite/ada/acats/tests/c3/c3900051.a
deleted file mode 100644
index d23a62bff45..00000000000
--- a/gcc/testsuite/ada/acats/tests/c3/c3900051.a
+++ /dev/null
@@ -1,137 +0,0 @@
--- C3900051.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- See C3900053.AM.
---
--- TEST DESCRIPTION:
--- See C3900053.AM.
---
--- TEST FILES:
--- This test consists of the following files:
---
--- C3900050.A
--- => C3900051.A
--- C3900052.A
--- C3900053.AM
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 15 May 96 SAIC ACVC 2.1: Modified prologue. Added pragma Elaborate
--- for Ada.Calendar.
---
---!
-
-with C3900050; -- Alert system abstraction.
-package C3900051 is -- Extended alert system abstraction.
-
-
- type Low_Alert_Type is new C3900050.Alert_Type
- with private; -- Private extension of
- -- root tagged type.
-
- -- Inherits procedure Display from Alert_Type.
-
- procedure Handle (LA : in out Low_Alert_Type); -- Override parent's
- -- primitive subprog.
-
- procedure Set_Level (LA : in out Low_Alert_Type; -- To be inherited by
- L : in Integer); -- all derivatives.
-
-
- -- The following functions are needed to verify the values of the
- -- extension's private components.
-
- function Get_Level (LA: Low_Alert_Type) return Integer;
-
- function Initial_Values_Okay (LA : in Low_Alert_Type)
- return Boolean; -- Override parent's
- -- primitive subprog.
-
- function Bad_Final_Values (LA : in Low_Alert_Type) -- Override parent's
- return Boolean; -- primitive subprog.
-
-
-private
-
- type Low_Alert_Type is new C3900050.Alert_Type with record
- Level : Integer := 0;
- end record;
-
-end C3900051;
-
-
- --==================================================================--
-
-
-with Ada.Calendar;
-pragma Elaborate (Ada.Calendar);
-
-package body C3900051 is -- Extended alert system abstraction.
-
- use C3900050; -- Alert system abstraction.
-
-
- procedure Set_Level (LA : in out Low_Alert_Type;
- L : in Integer) is
- begin
- LA.Level := L;
- end Set_Level;
-
-
- procedure Handle (LA : in out Low_Alert_Type) is
- begin
- Handle (Alert_Type (LA)); -- Call parent's operation (type conversion).
- Set_Level (LA, 1); -- Call newly declared operation.
- Set_Display (Alert_Type(LA),
- Teletype); -- Call parent's operation (type conversion).
- Display (LA);
- end Handle;
-
-
- function Get_Level (LA: Low_Alert_Type) return Integer is
- begin
- return LA.Level;
- end Get_Level;
-
-
- function Initial_Values_Okay (LA : in Low_Alert_Type) return Boolean is
- begin
- -- Call parent's operation (type conversion).
- return (Initial_Values_Okay (Alert_Type (LA)) and
- LA.Level = 0);
- end Initial_Values_Okay;
-
-
- function Bad_Final_Values (LA : in Low_Alert_Type) return Boolean is
- use type Ada.Calendar.Time;
- begin
- return (Get_Time(LA) /= Alert_Time or
- Get_Display(LA) /= Teletype or
- LA.Level /= 1);
- end Bad_Final_Values;
-
-
-end C3900051;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c3900052.a b/gcc/testsuite/ada/acats/tests/c3/c3900052.a
deleted file mode 100644
index 11d26db4a2d..00000000000
--- a/gcc/testsuite/ada/acats/tests/c3/c3900052.a
+++ /dev/null
@@ -1,138 +0,0 @@
--- C3900052.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- See C3900053.AM.
---
--- TEST DESCRIPTION:
--- See C3900053.AM.
---
--- TEST FILES:
--- This test consists of the following files:
---
--- C3900050.A
--- C3900051.A
--- => C3900052.A
--- C3900053.AM
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 15 May 96 SAIC ACVC 2.1: Modified prologue. Added pragma Elaborate
--- for Ada.Calendar.
---
---!
-
-with C3900051; -- Extended alert system abstraction.
-package C3900052 is -- Further extended alert system abstraction.
-
-
- -- Declarations used by component Action_Officer;
-
- type Person_Enum is (Nobody, Duty_Officer,
- Watch_Commander, Commanding_Officer);
-
-
- type Medium_Alert_Type is new C3900051.Low_Alert_Type
- with private; -- Private extension of
- -- private extension.
-
- -- Inherits (inherited) procedure Display from Low_Alert_Type.
- -- Inherits function Level_Of from Low_Alert_Type.
-
- procedure Handle (MA : in out Medium_Alert_Type); -- Override parent's
- -- primitive subprog.
-
- procedure Assign_Officer (MA : in out Medium_Alert_Type;
- To : in Person_Enum);
-
-
- -- The following functions are needed to verify the values of the
- -- extension's private components.
-
- function Initial_Values_Okay (MA : in Medium_Alert_Type)
- return Boolean; -- Override parent's
- -- primitive subprog.
-
- function Bad_Final_Values (MA: in Medium_Alert_Type) -- Override parent's
- return Boolean; -- primitive subprog.
-
-private
-
- type Medium_Alert_Type is new C3900051.Low_Alert_Type with record
- Action_Officer : Person_Enum := Nobody;
- end record;
-
-end C3900052;
-
-
- --==================================================================--
-
-
-with C3900050; -- Basic alert abstraction.
-with Ada.Calendar;
-pragma Elaborate (Ada.Calendar);
-
-package body C3900052 is -- Further extended alert system abstraction.
-
- use C3900050; -- Enumeration values directly visible.
- use C3900051; -- Extended alert system abstraction.
-
-
- procedure Assign_Officer (MA : in out Medium_Alert_Type;
- To : in Person_Enum) is
- begin
- MA.Action_Officer := To;
- end Assign_Officer;
-
-
- procedure Handle (MA : in out Medium_Alert_Type) is
- begin
- Handle (Low_Alert_Type (MA)); -- Call parent's op (type conversion).
- Set_Level (MA, 2); -- Call inherited operation.
- Assign_Officer (MA, Duty_Officer); -- Call newly declared operation.
- Set_Display (MA, Console); -- Call inherited operation.
- Display (MA); -- Call doubly inherited operation.
- end Handle;
-
-
- function Initial_Values_Okay (MA : in Medium_Alert_Type) return Boolean is
- begin
- -- Call parent's operation (type conversion).
- return (Initial_Values_Okay (Low_Alert_Type (MA)) and
- MA.Action_Officer = Nobody);
- end Initial_Values_Okay;
-
-
- function Bad_Final_Values (MA : in Medium_Alert_Type) return Boolean is
- use type Ada.Calendar.Time;
- begin
- return (Get_Time(MA) /= Alert_Time or
- Get_Display(MA) /= Console or
- Get_Level(MA) /= 2 or
- MA.Action_Officer /= Duty_Officer);
- end Bad_Final_Values;
-
-
-end C3900052;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c3900060.a b/gcc/testsuite/ada/acats/tests/c3/c3900060.a
deleted file mode 100644
index b77219c5758..00000000000
--- a/gcc/testsuite/ada/acats/tests/c3/c3900060.a
+++ /dev/null
@@ -1,159 +0,0 @@
--- C3900060.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- See C3900063.AM.
---
--- TEST DESCRIPTION:
--- See C3900063.AM.
---
--- TEST FILES:
--- This test consists of the following files:
---
--- => C3900060.A
--- C3900061.A
--- C3900062.A
--- C3900063.AM
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 04 Jun 96 SAIC ACVC 2.1: Modified prologue. Added pragma Elaborate
--- for Ada.Calendar.
---
---!
-
-with Ada.Calendar;
-pragma Elaborate (Ada.Calendar);
-
-package C3900060 is -- Alert system abstraction.
-
-
- -- Declarations used by component Arrival_Time.
-
- Default_Time : constant Ada.Calendar.Time :=
- Ada.Calendar.Time_Of (1901, 1, 1);
- Alert_Time : constant Ada.Calendar.Time :=
- Ada.Calendar.Time_Of (1991, 6, 15);
-
-
- -- Declarations used by component Display_On and procedure Display.
-
- type Device_Enum is (Null_Device, Teletype, Console, Big_Screen);
- type Display_Counters is array (Device_Enum) of Natural;
-
- Display_Count_For : Display_Counters := (others => 0);
-
-
-
- type Alert_Type is tagged private; -- Root tagged type.
-
- procedure Set_Display (A : in out Alert_Type; -- To be inherited by
- D : in Device_Enum); -- all derivatives.
-
- procedure Display (A : in Alert_Type); -- To be inherited by
- -- all derivatives.
-
- procedure Handle (A : in out Alert_Type); -- To be overridden by
- -- all derivatives.
-
-
- -- The following functions are needed to verify the values of the
- -- root tagged type's private components.
-
- function Get_Time (A: Alert_Type) return Ada.Calendar.Time;
-
- function Get_Display (A: Alert_Type) return Device_Enum;
-
- function Initial_Values_Okay (A : in Alert_Type)
- return Boolean;
-
- function Bad_Final_Values (A : in Alert_Type)
- return Boolean;
-
-private
-
- type Alert_Type is tagged record -- Root tagged type.
- Arrival_Time : Ada.Calendar.Time := Default_Time;
- Display_On : Device_Enum := Null_Device;
- end record;
-
-
-end C3900060;
-
-
- --==================================================================--
-
-
-package body C3900060 is
-
-
- procedure Set_Display (A : in out Alert_Type;
- D : in Device_Enum) is
- begin
- A.Display_On := D;
- end Set_Display;
-
-
- procedure Display (A : in Alert_Type) is
- begin
- Display_Count_For (A.Display_On) := Display_Count_For (A.Display_On) + 1;
- end Display;
-
-
- procedure Handle (A : in out Alert_Type) is
- begin
- A.Arrival_Time := Alert_Time;
- Display (A);
- end Handle;
-
-
- function Get_Time (A: Alert_Type) return Ada.Calendar.Time is
- begin
- return A.Arrival_Time;
- end Get_Time;
-
-
- function Get_Display (A: Alert_Type) return Device_Enum is
- begin
- return A.Display_On;
- end Get_Display;
-
-
- function Initial_Values_Okay (A : in Alert_Type) return Boolean is
- begin
- return (A = (Arrival_Time => Default_Time, -- Check "=" operator
- Display_On => Null_Device)); -- availability.
- end Initial_Values_Okay; -- Aggregate with
- -- named associations.
-
- function Bad_Final_Values (A : in Alert_Type) return Boolean is
- begin
- return (A /= (Alert_Time, Null_Device)); -- Check "/=" operator
- -- availability.
- end Bad_Final_Values; -- Aggregate with
- -- positional assoc.
-
-end C3900060;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c3900061.a b/gcc/testsuite/ada/acats/tests/c3/c3900061.a
deleted file mode 100644
index f776dcdb8ac..00000000000
--- a/gcc/testsuite/ada/acats/tests/c3/c3900061.a
+++ /dev/null
@@ -1,138 +0,0 @@
--- C3900061.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- See C3900063.AM.
---
--- TEST DESCRIPTION:
--- See C3900063.AM.
---
--- TEST FILES:
--- This test consists of the following files:
---
--- C3900060.A
--- => C3900061.A
--- C3900062.A
--- C3900063.AM
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 04 Jun 96 SAIC ACVC 2.1: Modified prologue. Added pragma Elaborate
--- for Ada.Calendar.
---
---!
-
-with C3900060; -- Alert system abstraction.
-package C3900061 is -- Extended alert abstraction.
-
-
- type Low_Alert_Type is new C3900060.Alert_Type
- with private; -- Private extension of
- -- root tagged type.
-
- -- Inherits procedure Display from Alert_Type.
-
- procedure Handle (LA : in out Low_Alert_Type); -- Override parent's
- -- primitive subprog.
-
- procedure Set_Level (LA : in out Low_Alert_Type; -- To be inherited by
- L : in Integer); -- all derivatives.
-
-
- -- The following functions are needed to verify the values of the
- -- extension's private components.
-
- function Get_Level (LA: Low_Alert_Type) return Integer;
-
- function Initial_Values_Okay (LA : in Low_Alert_Type)
- return Boolean; -- Override parent's
- -- primitive subprog.
-
- function Bad_Final_Values (LA : in Low_Alert_Type) -- Override parent's
- return Boolean; -- primitive subprog.
-
-
-private
-
- type Low_Alert_Type is new C3900060.Alert_Type with record
- Level : Integer := 0;
- end record;
-
-end C3900061;
-
-
- --==================================================================--
-
-
-with Ada.Calendar;
-pragma Elaborate (Ada.Calendar);
-
-package body C3900061 is
-
- use C3900060; -- Alert system abstraction.
-
-
- procedure Set_Level (LA : in out Low_Alert_Type;
- L : in Integer) is
- begin
- LA.Level := L;
- end Set_Level;
-
-
- procedure Handle (LA : in out Low_Alert_Type) is
- begin
- Handle (Alert_Type (LA)); -- Call parent's operation (type conversion).
- Set_Level (LA, 1); -- Call newly declared operation.
- Set_Display (Alert_Type(LA),
- Teletype); -- Call parent's operation (type conversion).
- Display (LA); -- Call inherited operation.
- end Handle;
-
-
- function Get_Level (LA: Low_Alert_Type) return Integer is
- begin
- return LA.Level;
- end Get_Level;
-
-
- function Initial_Values_Okay (LA : in Low_Alert_Type) return Boolean is
- begin
- -- Call parent's operation (type conversion).
- return (Initial_Values_Okay (Alert_Type (LA)) and
- LA.Level = 0);
- end Initial_Values_Okay;
-
-
- function Bad_Final_Values (LA : in Low_Alert_Type) return Boolean is
- use type Ada.Calendar.Time;
- begin
- return (Get_Time(LA) /= Alert_Time or
- Get_Display(LA) /= Teletype or
- LA.Level /= 1);
- end Bad_Final_Values;
-
-
-end C3900061;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c3900062.a b/gcc/testsuite/ada/acats/tests/c3/c3900062.a
deleted file mode 100644
index 87a1cd5a340..00000000000
--- a/gcc/testsuite/ada/acats/tests/c3/c3900062.a
+++ /dev/null
@@ -1,137 +0,0 @@
--- C3900062.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- See C3900063.AM.
---
--- TEST DESCRIPTION:
--- See C3900063.AM.
---
--- TEST FILES:
--- This test consists of the following files:
---
--- C3900060.A
--- C3900061.A
--- => C3900062.A
--- C3900063.AM
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 04 Jun 96 SAIC ACVC 2.1: Modified prologue. Added pragma Elaborate
--- for Ada.Calendar.
---
---!
-
-with C3900061; -- Extended alert system abstraction.
-package C3900062 is -- Further extended alert system abstraction.
-
-
- -- Declarations used by component Action_Officer;
-
- type Person_Enum is (Nobody, Duty_Officer,
- Watch_Commander, Commanding_Officer);
-
-
- type Medium_Alert_Type is new C3900061.Low_Alert_Type
- with record -- Record extension of
- Action_Officer : Person_Enum := Nobody; -- private extension.
- end record;
-
-
- -- Inherits (inherited) procedure Display from Low_Alert_Type.
- -- Inherits function Level_Of from Low_Alert_Type.
-
- procedure Handle (MA : in out Medium_Alert_Type); -- Override parent's
- -- primitive subprog.
-
- procedure Assign_Officer (MA : in out Medium_Alert_Type;
- To : in Person_Enum);
-
-
- -- The following functions are needed to verify the values of the
- -- extension's private components.
-
- function Initial_Values_Okay (MA : in Medium_Alert_Type)
- return Boolean; -- Override parent's
- -- primitive subprog.
-
- function Bad_Final_Values (MA: in Medium_Alert_Type) -- Override parent's
- return Boolean; -- primitive subprog.
-
-
-end C3900062;
-
-
- --==================================================================--
-
-
-with C3900060; -- Basic alert abstraction.
-
-with Ada.Calendar;
-pragma Elaborate (Ada.Calendar);
-
-package body C3900062 is
-
- use C3900060; -- Enumeration values directly visible.
- use C3900061; -- Extended alert system abstraction.
-
-
- procedure Assign_Officer (MA : in out Medium_Alert_Type;
- To : in Person_Enum) is
- begin
- MA.Action_Officer := To;
- end Assign_Officer;
-
-
- procedure Handle (MA : in out Medium_Alert_Type) is
- begin
- Handle (Low_Alert_Type (MA)); -- Call parent's op (type conversion).
- Set_Level (MA, 2); -- Call inherited operation.
- Assign_Officer (MA, Duty_Officer); -- Call newly declared operation.
- Set_Display (MA, Console); -- Call inherited operation.
- Display (MA); -- Call doubly inherited operation.
- end Handle;
-
-
- function Initial_Values_Okay (MA : in Medium_Alert_Type) return Boolean is
- begin
- -- Call parent's operation (type conversion).
- return (Initial_Values_Okay (Low_Alert_Type (MA)) and
- MA.Action_Officer = Nobody);
- end Initial_Values_Okay;
-
-
- function Bad_Final_Values (MA : in Medium_Alert_Type) return Boolean is
- use type Ada.Calendar.Time;
- begin
- return (Get_Time(MA) /= Alert_Time or
- Get_Display(MA) /= Console or
- Get_Level(MA) /= 2 or
- MA.Action_Officer /= Duty_Officer);
- end Bad_Final_Values;
-
-
-end C3900062;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c390007.a b/gcc/testsuite/ada/acats/tests/c3/c390007.a
deleted file mode 100644
index 46f59f66c56..00000000000
--- a/gcc/testsuite/ada/acats/tests/c3/c390007.a
+++ /dev/null
@@ -1,374 +0,0 @@
--- C390007.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that the tag of an object of a tagged type is preserved by
--- type conversion and parameter passing.
---
--- TEST DESCRIPTION:
--- The fact that the tag of an object is not changed is verified by
--- making dispatching calls to primitive operations, and confirming that
--- the proper body is executed. Objects of both specific and class-wide
--- types are checked.
---
--- The dispatching calls are made in two contexts. The first is a
--- straightforward dispatching call made from within a class-wide
--- operation. The second is a redispatch from within a primitive
--- operation.
---
--- For the parameter passing case, the initial class-wide and specific
--- objects are passed directly in calls to the class-wide and primitive
--- operations. The redispatch is accomplished by initializing a local
--- class-wide object in the primitive operation to the value of the
--- formal parameter, and using the local object as the actual in the
--- (re)dispatching call.
---
--- For the type conversion case, the initial class-wide object is assigned
--- a view conversion of an object of a specific type:
---
--- type T is tagged ...
--- type DT is new T with ...
---
--- A : DT;
--- B : T'Class := T(A); -- Despite conversion, tag of B is that of DT.
---
--- The class-wide object is then passed directly in calls to the
--- class-wide and primitive operations. For the initial object of a
--- specific type, however, a view conversion of the object is passed,
--- forcing a non-dispatching call in the primitive operation case. Within
--- the primitive operation, a view conversion of the formal parameter to
--- a class-wide type is then used to force a (re)dispatching call.
---
--- For the type conversion and parameter passing case, a combining of
--- view conversion and parameter passing of initial specific objects are
--- called directly to the class-wide and primitive operations.
---
---
--- CHANGE HISTORY:
--- 28 Jun 95 SAIC Initial prerelease version.
--- 23 Apr 96 SAIC Added use C390007_0 in the main.
---
---!
-
-package C390007_0 is
-
- type Call_ID_Kind is (None, Parent_Outer, Parent_Inner,
- Derived_Outer, Derived_Inner);
-
- type Root_Type is abstract tagged null record;
-
- procedure Outer_Proc (X : in out Root_Type) is abstract;
- procedure Inner_Proc (X : in out Root_Type) is abstract;
-
- procedure ClassWide_Proc (X : in out Root_Type'Class);
-
-end C390007_0;
-
-
- --==================================================================--
-
-
-package body C390007_0 is
-
- procedure ClassWide_Proc (X : in out Root_Type'Class) is
- begin
- Inner_Proc (X);
- end ClassWide_Proc;
-
-end C390007_0;
-
-
- --==================================================================--
-
-
-package C390007_0.C390007_1 is
-
- type Param_Parent_Type is new Root_Type with record
- Last_Call : Call_ID_Kind := None;
- end record;
-
- procedure Outer_Proc (X : in out Param_Parent_Type);
- procedure Inner_Proc (X : in out Param_Parent_Type);
-
-end C390007_0.C390007_1;
-
-
- --==================================================================--
-
-
-package body C390007_0.C390007_1 is
-
- procedure Outer_Proc (X : in out Param_Parent_Type) is
- begin
- X.Last_Call := Parent_Outer;
- end Outer_Proc;
-
- procedure Inner_Proc (X : in out Param_Parent_Type) is
- begin
- X.Last_Call := Parent_Inner;
- end Inner_Proc;
-
-end C390007_0.C390007_1;
-
-
- --==================================================================--
-
-
-package C390007_0.C390007_1.C390007_2 is
-
- type Param_Derived_Type is new Param_Parent_Type with null record;
-
- procedure Outer_Proc (X : in out Param_Derived_Type);
- procedure Inner_Proc (X : in out Param_Derived_Type);
-
-end C390007_0.C390007_1.C390007_2;
-
-
- --==================================================================--
-
-
-package body C390007_0.C390007_1.C390007_2 is
-
- procedure Outer_Proc (X : in out Param_Derived_Type) is
- Y : Root_Type'Class := X;
- begin
- Inner_Proc (Y); -- Redispatch.
- Root_Type'Class (X) := Y;
- end Outer_Proc;
-
- procedure Inner_Proc (X : in out Param_Derived_Type) is
- begin
- X.Last_Call := Derived_Inner;
- end Inner_Proc;
-
-end C390007_0.C390007_1.C390007_2;
-
-
- --==================================================================--
-
-
-package C390007_0.C390007_3 is
-
- type Convert_Parent_Type is new Root_Type with record
- First_Call : Call_ID_Kind := None;
- Second_Call : Call_ID_Kind := None;
- end record;
-
- procedure Outer_Proc (X : in out Convert_Parent_Type);
- procedure Inner_Proc (X : in out Convert_Parent_Type);
-
-end C390007_0.C390007_3;
-
-
- --==================================================================--
-
-
-package body C390007_0.C390007_3 is
-
- procedure Outer_Proc (X : in out Convert_Parent_Type) is
- begin
- X.First_Call := Parent_Outer;
- Inner_Proc (Root_Type'Class(X)); -- Redispatch.
- end Outer_Proc;
-
- procedure Inner_Proc (X : in out Convert_Parent_Type) is
- begin
- X.Second_Call := Parent_Inner;
- end Inner_Proc;
-
-end C390007_0.C390007_3;
-
-
- --==================================================================--
-
-
-package C390007_0.C390007_3.C390007_4 is
-
- type Convert_Derived_Type is new Convert_Parent_Type with null record;
-
- procedure Outer_Proc (X : in out Convert_Derived_Type);
- procedure Inner_Proc (X : in out Convert_Derived_Type);
-
-end C390007_0.C390007_3.C390007_4;
-
-
- --==================================================================--
-
-
-package body C390007_0.C390007_3.C390007_4 is
-
- procedure Outer_Proc (X : in out Convert_Derived_Type) is
- begin
- X.First_Call := Derived_Outer;
- Inner_Proc (Root_Type'Class(X)); -- Redispatch.
- end Outer_Proc;
-
- procedure Inner_Proc (X : in out Convert_Derived_Type) is
- begin
- X.Second_Call := Derived_Inner;
- end Inner_Proc;
-
-end C390007_0.C390007_3.C390007_4;
-
-
- --==================================================================--
-
-
-with C390007_0.C390007_1.C390007_2;
-with C390007_0.C390007_3.C390007_4;
-use C390007_0;
-
-with Report;
-procedure C390007 is
-begin
- Report.Test ("C390007", "Check that the tag of an object of a tagged " &
- "type is preserved by type conversion and parameter passing");
-
-
- --
- -- Check that tags are preserved by parameter passing:
- --
-
- Parameter_Passing_Subtest:
- declare
- Specific_A : C390007_0.C390007_1.C390007_2.Param_Derived_Type;
- Specific_B : C390007_0.C390007_1.C390007_2.Param_Derived_Type;
-
- ClassWide_A : C390007_0.C390007_1.Param_Parent_Type'Class := Specific_A;
- ClassWide_B : C390007_0.C390007_1.Param_Parent_Type'Class := Specific_B;
-
- use C390007_0.C390007_1;
- use C390007_0.C390007_1.C390007_2;
- begin
-
- Outer_Proc (Specific_A);
- if Specific_A.Last_Call /= Derived_Inner then
- Report.Failed ("Parameter passing: tag not preserved in call to " &
- "primitive operation with specific operand");
- end if;
-
- C390007_0.ClassWide_Proc (Specific_B);
- if Specific_B.Last_Call /= Derived_Inner then
- Report.Failed ("Parameter passing: tag not preserved in call to " &
- "class-wide operation with specific operand");
- end if;
-
- Outer_Proc (ClassWide_A);
- if ClassWide_A.Last_Call /= Derived_Inner then
- Report.Failed ("Parameter passing: tag not preserved in call to " &
- "primitive operation with class-wide operand");
- end if;
-
- C390007_0.ClassWide_Proc (ClassWide_B);
- if ClassWide_B.Last_Call /= Derived_Inner then
- Report.Failed ("Parameter passing: tag not preserved in call to " &
- "class-wide operation with class-wide operand");
- end if;
-
- end Parameter_Passing_Subtest;
-
-
- --
- -- Check that tags are preserved by type conversion:
- --
-
- Type_Conversion_Subtest:
- declare
- Specific_A : C390007_0.C390007_3.C390007_4.Convert_Derived_Type;
- Specific_B : C390007_0.C390007_3.C390007_4.Convert_Derived_Type;
-
- ClassWide_A : C390007_0.C390007_3.Convert_Parent_Type'Class :=
- C390007_0.C390007_3.Convert_Parent_Type(Specific_A);
- ClassWide_B : C390007_0.C390007_3.Convert_Parent_Type'Class :=
- C390007_0.C390007_3.Convert_Parent_Type(Specific_B);
-
- use C390007_0.C390007_3;
- use C390007_0.C390007_3.C390007_4;
- begin
-
- Outer_Proc (Convert_Parent_Type(Specific_A));
- if (Specific_A.First_Call /= Parent_Outer) or
- (Specific_A.Second_Call /= Derived_Inner)
- then
- Report.Failed ("Type conversion: tag not preserved in call to " &
- "primitive operation with specific operand");
- end if;
-
- Outer_Proc (ClassWide_A);
- if (ClassWide_A.First_Call /= Derived_Outer) or
- (ClassWide_A.Second_Call /= Derived_Inner)
- then
- Report.Failed ("Type conversion: tag not preserved in call to " &
- "primitive operation with class-wide operand");
- end if;
-
- C390007_0.ClassWide_Proc (Convert_Parent_Type(Specific_B));
- if (Specific_B.Second_Call /= Derived_Inner) then
- Report.Failed ("Type conversion: tag not preserved in call to " &
- "class-wide operation with specific operand");
- end if;
-
- C390007_0.ClassWide_Proc (ClassWide_B);
- if (ClassWide_A.Second_Call /= Derived_Inner) then
- Report.Failed ("Type conversion: tag not preserved in call to " &
- "class-wide operation with class-wide operand");
- end if;
-
- end Type_Conversion_Subtest;
-
-
- --
- -- Check that tags are preserved by type conversion and parameter passing:
- --
-
- Type_Conversion_And_Parameter_Passing_Subtest:
- declare
- Specific_A : C390007_0.C390007_1.C390007_2.Param_Derived_Type;
- Specific_B : C390007_0.C390007_1.C390007_2.Param_Derived_Type;
-
- use C390007_0.C390007_1;
- use C390007_0.C390007_1.C390007_2;
- begin
-
- Outer_Proc (Param_Parent_Type (Specific_A));
- if Specific_A.Last_Call /= Parent_Outer then
- Report.Failed ("Type conversion and parameter passing: tag not " &
- "preserved in call to primitive operation with " &
- "specific operand");
- end if;
-
- C390007_0.ClassWide_Proc (Param_Parent_Type (Specific_B));
- if Specific_B.Last_Call /= Derived_Inner then
- Report.Failed ("Type conversion and parameter passing: tag not " &
- "preserved in call to class-wide operation with " &
- "specific operand");
- end if;
-
- end Type_Conversion_And_Parameter_Passing_Subtest;
-
-
- Report.Result;
-
-end C390007;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c390010.a b/gcc/testsuite/ada/acats/tests/c3/c390010.a
deleted file mode 100644
index 1590e5027ab..00000000000
--- a/gcc/testsuite/ada/acats/tests/c3/c390010.a
+++ /dev/null
@@ -1,216 +0,0 @@
--- C390010.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that if S is a subtype of a tagged type T, and if S is
--- constrained, then the allowable values of S'Class are only those
--- that, when converted to T, belong to S.
---
--- TEST DESCRIPTION:
--- This test defines a small tagged hierarchy of discriminated tagged
--- records, and constrained subtypes of those tagged record types.
--- It then uses access to the classwide of the constrained subtype
--- to check the objective.
---
---
--- CHANGE HISTORY:
--- 09 APR 96 SAIC Initial version
--- 03 NOV 96 SAIC Revised for 2.1 release
--- 31 DEC 97 EDS Restored use of intermediate access variable
--- to eliminate raising of Program_Error
--- 13 SEP 99 RLB Repaired previous change to avoid premature
--- subtype check.
--- 28 JUN 02 RLB Added pragma Elaborate_All (Report);.
---!
-
------------------------------------------------------------------ C390010_0
-
-with Report; pragma Elaborate_All (Report);
-package C390010_0 is
-
- -- the defined subprograms will allow checking the placement of
- -- constraint_checks
-
- -- define a discriminated tagged type, and a constrained subtype of
- -- that type:
-
- type Discr_Tag_Record( Disc: Boolean ) is tagged record
- FieldA : Character := 'A';
- case Disc is
- when True => FieldB : Character := 'B';
- when False => FieldC : Character := 'C';
- end case;
- end record;
-
- procedure Dispatching_Op( DTO : in out Discr_Tag_Record );
-
- Authentic : Boolean := Report.Ident_Bool( True );
-
- subtype True_Record is Discr_Tag_Record( Authentic );
-
-
- -- derive a type, "passing through" one discriminant, adding one
- -- discriminant, and a constrained subtype of THAT type:
-
- type Derived_Record( Disc1, Disc2: Boolean ) is
- new Discr_Tag_Record( Disc1 ) with record
- FieldD : Character := 'D';
- case Disc2 is
- when True => FieldE : Character := 'E';
- when False => FieldF : Character := 'F';
- end case;
- end record;
-
- procedure Dispatching_Op( DR : in out Derived_Record );
-
- subtype True_True_Derived is Derived_Record( Authentic, Authentic );
-
-
- -- now, define an access to classwide type, using the classwide from the
- -- constrained subtype of the root (or parent) type:
-
- type Subtype_Parent_Class_Access is access all True_Record'Class;
- type Parent_Class_Access is access all Discr_Tag_Record'Class;
-
- procedure PCW_Op( SPCA : in Subtype_Parent_Class_Access );
-
-end C390010_0;
-
--- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- C390010_0
-
-with Report;
-with TCTouch;
-package body C390010_0 is
-
- procedure Dispatching_Op( DTO : in out Discr_Tag_Record ) is
- begin
- TCTouch.Touch('1'); --------------------------------------------------- 1
- if DTO.Disc then
- TCTouch.Touch(DTO.FieldB); ------------------------------------------ B
- else
- TCTouch.Touch(DTO.FieldC); ------------------------------------------ C
- end if;
- end Dispatching_Op;
-
-
- procedure Dispatching_Op( DR : in out Derived_Record ) is
- begin
- TCTouch.Touch('2'); --------------------------------------------------- 2
- if DR.Disc1 then
- TCTouch.Touch(DR.FieldB); ------------------------------------------ B
- else
- TCTouch.Touch(DR.FieldC); ------------------------------------------ C
- end if;
- if DR.Disc2 then
- TCTouch.Touch(DR.FieldE); ------------------------------------------ E
- else
- TCTouch.Touch(DR.FieldF); ------------------------------------------ F
- end if;
- end Dispatching_Op;
-
- procedure PCW_Op( SPCA : in Subtype_Parent_Class_Access ) is
- begin
-
- -- the following line is the "heart" of this test, objects of all types
- -- covered by the classwide type will be passed to this subprogram in
- -- the execution of the test.
- if SPCA.Disc then
- TCTouch.Touch(SPCA.FieldB); ------------------------------------------ B
- else
- TCTouch.Touch(SPCA.FieldC); ------------------------------------------ C
- end if;
-
- Dispatching_Op( SPCA.all ); -- check that this dispatches correctly,
- -- with discriminants correctly represented
-
- end PCW_Op;
-
-end C390010_0;
-
-------------------------------------------------------------------- C390010
-
-with Report;
-with TCTouch;
-with C390010_0;
-procedure C390010 is
-
- package CP renames C390010_0;
-
- procedure Check_Element( Item : access CP.Discr_Tag_Record'Class ) is
- begin
-
- -- the implicit conversion from the general access parameter to the more
- -- constrained subtype access type in the following call should cause
- -- Constraint_Error in the cases where the object is not correctly
- -- constrained
-
- CP.PCW_Op( Item.all'Access );
-
- exception
- when Constraint_Error => TCTouch.Touch('X'); -------------------------- X
- when others => Report.Failed("Unanticipated exception in Check_Element");
-
- end Check_Element;
-
- An_Item : CP.Parent_Class_Access;
-
-begin -- Main test procedure.
-
- Report.Test ("C390010", "Check that if S is a subtype of a tagged type " &
- "T, and if S is constrained, then the allowable " &
- "values of S'Class are only those that, when " &
- "converted to T, belong to S" );
-
- An_Item := new CP.Discr_Tag_Record(True);
- Check_Element( An_Item );
- TCTouch.Validate("B1B","Case 1");
-
- An_Item := new CP.Discr_Tag_Record(False);
- Check_Element( An_Item );
- TCTouch.Validate("X","Case 2");
-
- An_Item := new CP.True_Record;
- Check_Element( An_Item );
- TCTouch.Validate("B1B","Case 3");
-
- An_Item := new CP.Derived_Record(False, False);
- Check_Element( An_Item );
- TCTouch.Validate("X","Case 4");
-
- An_Item := new CP.Derived_Record(False, True);
- Check_Element( An_Item );
- TCTouch.Validate("X","Case 5");
-
- An_Item := new CP.Derived_Record(True, False);
- Check_Element( An_Item );
- TCTouch.Validate("B2BF","Case 6");
-
- An_Item := new CP.True_True_Derived;
- Check_Element( An_Item );
- TCTouch.Validate("B2BE","Case 7");
-
- Report.Result;
-
-end C390010;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c390011.a b/gcc/testsuite/ada/acats/tests/c3/c390011.a
deleted file mode 100644
index 74cf0eb0468..00000000000
--- a/gcc/testsuite/ada/acats/tests/c3/c390011.a
+++ /dev/null
@@ -1,250 +0,0 @@
--- C390011.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that tagged types declared within generic package declarations
--- generate distinct tags for each instance of the generic.
---
--- TEST DESCRIPTION:
--- This test defines a very simple generic package (with the expectation
--- that it should be easily be shared), and a few instances of that
--- package. In true user-like fashion, two of the instances are identical
--- (to wit: IIO is new Integer_IO(Integer)). The tags generated for each
--- of them are placed into a list. The last action of the test is to
--- check that everything in the list is unique.
---
--- Almost as an aside, this test defines functions that return T'Base and
--- T'Class, and then exercises these functions.
---
--- (JPR) persistent objects really need a function like:
--- function Get_Object return T'class;
---
---
--- CHANGE HISTORY:
--- 20 OCT 95 SAIC Initial version
--- 23 APR 96 SAIC Commentary Corrections 2.1
---
---!
-
------------------------------------------------------------------ C390011_0
-
-with Ada.Tags;
-package C390011_0 is
-
- procedure Add_Tag_To_List( T : Ada.Tags.Tag; X_Name, X_Tag: String );
-
- procedure Check_List_For_Duplicates;
-
-end C390011_0;
-
--- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
-
-with Report;
-package body C390011_0 is
-
- use type Ada.Tags.Tag;
- type SP is access String;
-
- type List_Item;
- type List_P is access List_Item;
- type List_Item is record
- The_Tag : Ada.Tags.Tag;
- Exp_Name : SP;
- Ext_Tag : SP;
- Next : List_P;
- end record;
-
- The_List : List_P;
-
- procedure Add_Tag_To_List ( T : Ada.Tags.Tag; X_Name, X_Tag: String ) is
- begin -- prepend the tag information to the list
- The_List := new List_Item'( The_Tag => T,
- Exp_Name => new String'(X_Name),
- Ext_Tag => new String'(X_Tag),
- Next => The_List );
- end Add_Tag_To_List;
-
- procedure Check_List_For_Duplicates is
- Finger : List_P;
- Thumb : List_P := The_List;
- begin --
- while Thumb /= null loop
- Finger := Thumb.Next;
- while Finger /= null loop
- -- Check that the tag is unique
- if Finger.The_Tag = Thumb.The_Tag then
- Report.Failed("Duplicate Tag");
- end if;
-
- -- Check that the Expanded name is unique
- if Finger.Exp_Name.all = Thumb.Exp_Name.all then
- Report.Failed("Tag name " & Finger.Exp_Name.all & " repeats");
- end if;
-
- -- Check that the External Tag is unique
-
- if Finger.Ext_Tag.all = Thumb.Ext_Tag.all then
- Report.Failed("External Tag " & Finger.Ext_Tag.all & " repeats");
- end if;
- Finger := Finger.Next;
- end loop;
- Thumb := Thumb.Next;
- end loop;
- end Check_List_For_Duplicates;
-
-begin
- -- some things I just don't trust...
- if The_List /= null then
- Report.Failed("Implicit default for The_List not null");
- end if;
-end C390011_0;
-
------------------------------------------------------------------ C390011_1
-
-generic
- type Index is (<>);
- type Item is private;
-package C390011_1 is
-
- type List is array(Index range <>) of Item;
- type ListP is access all List;
-
- type Table is tagged record
- Data: ListP;
- end record;
-
- function Sort( T: in Table'Class ) return Table'Class;
-
- function Stable_Table return Table'Class;
-
- function Table_End( T: Table ) return Index'Base;
-
-end C390011_1;
-
--- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
-
-package body C390011_1 is
-
- -- In a user program this package would DO something
-
- function Sort( T: in Table'Class ) return Table'Class is
- begin
- return T;
- end Sort;
-
- Empty : Table'Class := Table'( Data => null );
-
- function Stable_Table return Table'Class is
- begin
- return Empty;
- end Stable_Table;
-
- function Table_End( T: Table ) return Index'Base is
- begin
- return Index'Base( T.Data.all'Last );
- end Table_End;
-
-end C390011_1;
-
------------------------------------------------------------------ C390011_2
-
-with C390011_1;
-package C390011_2 is new C390011_1( Index => Character, Item => Float );
-
------------------------------------------------------------------ C390011_3
-
-with C390011_1;
-package C390011_3 is new C390011_1( Index => Character, Item => Float );
-
------------------------------------------------------------------ C390011_4
-
-with C390011_1;
-package C390011_4 is new C390011_1( Index => Integer, Item => Character );
-
------------------------------------------------------------------ C390011_5
-
-with C390011_3;
-with C390011_4;
-package C390011_5 is
-
- type Table_3 is new C390011_3.Table with record
- Serial_Number : Integer;
- end record;
-
- type Table_4 is new C390011_4.Table with record
- Serial_Number : Integer;
- end record;
-
-end C390011_5;
-
--- no package body C390011_5 required
-
-------------------------------------------------------------------- C390011
-
-with Report;
-with C390011_0;
-with C390011_2;
-with C390011_3;
-with C390011_4;
-with C390011_5;
-with Ada.Tags;
-procedure C390011 is
-
-begin -- Main test procedure.
-
- Report.Test ("C390011", "Check that tagged types declared within " &
- "generic package declarations generate distinct " &
- "tags for each instance of the generic. " &
- "Check that 'Base may be used as a subtype mark. " &
- "Check that T'Base and T'Class are allowed as " &
- "the subtype mark in a function result" );
-
- -- build the tag information table
- C390011_0.Add_Tag_To_List(T => C390011_2.Table'Tag,
- X_Name => Ada.Tags.Expanded_Name(C390011_2.Table'Tag),
- X_Tag => Ada.Tags.External_Tag(C390011_2.Table'Tag) );
-
- C390011_0.Add_Tag_To_List(T => C390011_3.Table'Tag,
- X_Name => Ada.Tags.Expanded_Name(C390011_3.Table'Tag),
- X_Tag => Ada.Tags.External_Tag(C390011_3.Table'Tag) );
-
- C390011_0.Add_Tag_To_List(T => C390011_4.Table'Tag,
- X_Name => Ada.Tags.Expanded_Name(C390011_4.Table'Tag),
- X_Tag => Ada.Tags.External_Tag(C390011_4.Table'Tag) );
-
- C390011_0.Add_Tag_To_List(T => C390011_5.Table_3'Tag,
- X_Name => Ada.Tags.Expanded_Name(C390011_5.Table_3'Tag),
- X_Tag => Ada.Tags.External_Tag(C390011_5.Table_3'Tag) );
-
- C390011_0.Add_Tag_To_List(T => C390011_5.Table_4'Tag,
- X_Name => Ada.Tags.Expanded_Name(C390011_5.Table_4'Tag),
- X_Tag => Ada.Tags.External_Tag(C390011_5.Table_4'Tag) );
-
- -- preform the check for distinct tags
- C390011_0.Check_List_For_Duplicates;
-
- Report.Result;
-
-end C390011;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c390a010.a b/gcc/testsuite/ada/acats/tests/c3/c390a010.a
deleted file mode 100644
index 18016de0999..00000000000
--- a/gcc/testsuite/ada/acats/tests/c3/c390a010.a
+++ /dev/null
@@ -1,127 +0,0 @@
--- C390A010.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- See C390A011.AM.
---
--- TEST DESCRIPTION:
--- See C390A011.AM.
---
--- TEST FILES:
--- This test consists of the following files:
---
--- F390A00.A
--- => C390A010.A
--- C390A011.AM
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 04 Jun 96 SAIC ACVC 2.1: Modified prologue.
---
---!
-
-with F390A00; -- Alert system abstraction.
-package C390A010 is
-
-
- type Low_Alert_Type is new F390A00.Alert_Type with record
- Level : Integer := 0; -- Record extension of
- end record; -- root tagged type.
-
- -- Inherits procedure Display from Alert_Type.
-
- procedure Handle (LA : in out Low_Alert_Type); -- Override parent's
- -- primitive subprog.
-
- function Level_Of (LA : in Low_Alert_Type) -- To be inherited by
- return Integer; -- all derivatives.
-
-
-
- -- Declarations required for component Action_Officer;
-
- type Person_Enum is (Nobody, Duty_Officer,
- Watch_Commander, Commanding_Officer);
-
-
- type Medium_Alert_Type is new Low_Alert_Type with record
- Action_Officer : Person_Enum := Nobody; -- Record extension of
- end record; -- record extension.
-
- -- Inherits (inherited) procedure Display from Low_Alert_Type.
- -- Inherits function Level_Of from Low_Alert_Type.
-
- procedure Handle (MA : in out Medium_Alert_Type); -- Override parent's
- -- primitive subprog.
-
- procedure Assign_Officer (MA : in out Medium_Alert_Type;
- To : in Person_Enum);
-
-
-end C390A010;
-
-
- --==================================================================--
-
-
-package body C390A010 is
-
- use F390A00; -- Alert system abstraction.
-
-
- function Level_Of (LA : in Low_Alert_Type) return Integer is
- begin
- return (LA.Level + 1);
- end Level_Of;
-
-
- procedure Handle (LA : in out Low_Alert_Type) is
- begin
- Handle (Alert_Type (LA)); -- Call parent's op (type conversion).
- LA.Level := Level_Of (LA); -- Call newly declared operation.
- LA.Display_On := Teletype;
- Display (LA); -- Call inherited operation.
- end Handle;
-
-
- procedure Assign_Officer (MA : in out Medium_Alert_Type;
- To : in Person_Enum) is
- begin
- MA.Action_Officer := To;
- end Assign_Officer;
-
-
- procedure Handle (MA : in out Medium_Alert_Type) is
- begin
- Handle (Low_Alert_Type (MA)); -- Call parent's op (type conversion).
- MA.Level := Level_Of (MA); -- Call inherited operation.
- Assign_Officer (MA, Duty_Officer); -- Call newly declared operation.
- MA.Display_On := Console;
- Display (MA); -- Call twice-inherited operation.
- end Handle;
-
-
-end C390A010;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c390a020.a b/gcc/testsuite/ada/acats/tests/c3/c390a020.a
deleted file mode 100644
index 29cd3ca9786..00000000000
--- a/gcc/testsuite/ada/acats/tests/c3/c390a020.a
+++ /dev/null
@@ -1,90 +0,0 @@
--- C390A020.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- See C390A022.AM.
---
--- TEST DESCRIPTION:
--- See C390A022.AM.
---
--- TEST FILES:
--- This test consists of the following files:
---
--- F390A00.A
--- => C390A020.A
--- C390A021.A
--- C390A022.AM
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 04 Jun 96 SAIC ACVC 2.1: Modified prologue.
---
---!
-
-with F390A00; -- Alert system abstraction.
-package C390A020 is
-
-
- type Low_Alert_Type is new F390A00.Alert_Type with record
- Level : Integer := 0; -- Record extension of
- end record; -- root tagged type.
-
- -- Inherits procedure Display from Alert_Type.
-
- procedure Handle (LA : in out Low_Alert_Type); -- Override parent's
- -- primitive subprog.
-
- function Level_Of (LA : in Low_Alert_Type) -- To be inherited by
- return Integer; -- all derivatives.
-
-
-end C390A020;
-
-
- --==================================================================--
-
-
-package body C390A020 is
-
- use F390A00; -- Alert system abstraction.
-
-
- function Level_Of (LA : in Low_Alert_Type) return Integer is
- begin
- return (LA.Level + 1);
- end Level_Of;
-
-
- procedure Handle (LA : in out Low_Alert_Type) is
- begin
- Handle (Alert_Type (LA)); -- Call parent's oper. (type conversion).
- LA.Level := Level_Of (LA); -- Call newly declared operation.
- LA.Display_On := Teletype;
- Display (LA); -- Call inherited operation.
- end Handle;
-
-
-end C390A020;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c390a021.a b/gcc/testsuite/ada/acats/tests/c3/c390a021.a
deleted file mode 100644
index 5d099f3704c..00000000000
--- a/gcc/testsuite/ada/acats/tests/c3/c390a021.a
+++ /dev/null
@@ -1,133 +0,0 @@
--- C390A021.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- See C390A022.AM.
---
--- TEST DESCRIPTION:
--- See C390A022.AM.
---
--- TEST FILES:
--- This test consists of the following files:
---
--- F390A00.A
--- C390A020.A
--- => C390A021.A
--- C390A022.AM
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 04 Jun 96 SAIC ACVC 2.1: Modified prologue.
---
---!
-
-with C390A020; -- Extended alert abstraction.
-package C390A021 is
-
-
- -- Declarations used by component Action_Officer;
-
- type Person_Enum is (Nobody, Duty_Officer,
- Watch_Commander, Commanding_Officer);
-
-
- type Medium_Alert_Type is new C390A020.Low_Alert_Type
- with private; -- Private extension of
- -- record extension.
-
- -- Inherits (inherited) procedure Display from Low_Alert_Type.
- -- Inherits function Level_Of from Low_Alert_Type.
-
- procedure Handle (MA : in out Medium_Alert_Type); -- Override parent's
- -- primitive subprog.
-
- procedure Assign_Officer (MA : in out Medium_Alert_Type;
- To : in Person_Enum);
-
-
- -- The following two functions are needed to verify the values of the
- -- extension's private components.
-
- function Initial_Values_Okay (MA : in Medium_Alert_Type)
- return Boolean;
-
- function Bad_Final_Values (MA : in Medium_Alert_Type)
- return Boolean;
-
-
-private
-
- type Medium_Alert_Type is new C390A020.Low_Alert_Type with record
- Action_Officer : Person_Enum := Nobody;
- end record;
-
-end C390A021;
-
-
- --==================================================================--
-
-
-with F390A00; -- Basic alert abstraction.
-use F390A00;
-package body C390A021 is
-
- use C390A020; -- Extended alert abstraction.
-
-
- procedure Assign_Officer (MA : in out Medium_Alert_Type;
- To : in Person_Enum) is
- begin
- MA.Action_Officer := To;
- end Assign_Officer;
-
-
- procedure Handle (MA : in out Medium_Alert_Type) is
- begin
- Handle (Low_Alert_Type (MA)); -- Call parent's op (type conversion).
- MA.Level := Level_Of (MA); -- Call inherited operation.
- Assign_Officer (MA, Duty_Officer); -- Call newly declared operation.
- MA.Display_On := Console;
- Display (MA); -- Call twice-inherited operation.
- end Handle;
-
-
- function Initial_Values_Okay (MA : in Medium_Alert_Type) return Boolean is
- begin
- return (MA = (Arrival_Time => Default_Time, -- Check "=" operator
- Display_On => Null_Device, -- availability.
- Level => 0, -- Aggregate with
- Action_Officer => Nobody)); -- named associations.
- end Initial_Values_Okay;
-
-
- function Bad_Final_Values (MA : in Medium_Alert_Type) return Boolean is
- begin
- return (MA /= (Alert_Time, Console, -- Check "/=" operator
- 2 , Duty_Officer)); -- availability.
- end Bad_Final_Values; -- Aggregate with
- -- positional assoc.
-
-end C390A021;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c390a030.a b/gcc/testsuite/ada/acats/tests/c3/c390a030.a
deleted file mode 100644
index 51554a49adc..00000000000
--- a/gcc/testsuite/ada/acats/tests/c3/c390a030.a
+++ /dev/null
@@ -1,188 +0,0 @@
--- C390A030.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- See C390A031.AM.
---
--- TEST DESCRIPTION:
--- See C390A031.AM.
---
--- TEST FILES:
--- This test consists of the following files:
---
--- F390A00.A
--- => C390A030.A
--- C390A031.AM
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 04 Jun 96 SAIC ACVC 2.1: Modified prologue.
---
---!
-
-with F390A00; -- Alert system abstraction.
-package C390A030 is
-
-
- type Low_Alert_Type is new F390A00.Alert_Type -- Private extension of
- with private; -- root tagged type.
-
- -- Inherits procedure Display from Alert_Type.
-
- procedure Handle (LA : in out Low_Alert_Type); -- Override parent's
- -- primitive subprog.
-
- function Level_Of (LA : in Low_Alert_Type) -- To be inherited by
- return Integer; -- all derivatives.
-
-
- -- The following two functions are needed to verify the values of the
- -- extension's private components.
-
- function Initial_Values_Okay (LA : in Low_Alert_Type)
- return Boolean;
-
- function Bad_Final_Values (LA : in Low_Alert_Type)
- return Boolean;
-
-
- -- Declarations used by private extension component.
-
- type Person_Enum is (Nobody, Duty_Officer,
- Watch_Commander, Commanding_Officer);
-
-
- type Medium_Alert_Type is new Low_Alert_Type -- Private extension of
- with private; -- private extension.
-
- -- Inherits (inherited) procedure Display from Low_Alert_Type.
- -- Inherits function Level_Of from Low_Alert_Type.
-
- procedure Handle (MA : in out Medium_Alert_Type); -- Override parent's
- -- primitive subprog.
-
- procedure Assign_Officer (MA : in out Medium_Alert_Type;
- To : in Person_Enum);
-
-
- -- The following two functions are needed to verify the values of the
- -- extension's private components.
-
- function Initial_Values_Okay (MA : in Medium_Alert_Type)
- return Boolean; -- Override parent's
- -- operation.
-
- function Bad_Final_Values (MA : in Medium_Alert_Type)
- return Boolean; -- Override parent's
- -- operation.
-
-private
-
- type Low_Alert_Type is new F390A00.Alert_Type with record
- Level : Integer := 0;
- end record;
-
-
- type Medium_Alert_Type is new Low_Alert_Type with record
- Action_Officer : Person_Enum := Nobody;
- end record;
-
-end C390A030;
-
-
- --==================================================================--
-
-
-package body C390A030 is
-
- use F390A00; -- Alert system abstraction.
-
-
- function Level_Of (LA : in Low_Alert_Type) return Integer is
- begin
- return (LA.Level + 1);
- end Level_Of;
-
-
- procedure Handle (LA : in out Low_Alert_Type) is
- begin
- Handle (Alert_Type (LA)); -- Call parent's operation (type conversion).
- LA.Level := Level_Of (LA); -- Call newly declared operation.
- LA.Display_On := Teletype;
- Display (LA); -- Call inherited operation.
- end Handle;
-
-
- function Initial_Values_Okay (LA : in Low_Alert_Type) return Boolean is
- begin
- return (LA = (Arrival_Time => Default_Time, -- Check "=" operator
- Display_On => Null_Device, -- availability.
- Level => 0)); -- Aggregate with
- end Initial_Values_Okay; -- named associations.
-
-
- function Bad_Final_Values (LA : in Low_Alert_Type) return Boolean is
- begin
- return (LA /= (Alert_Time, Teletype, 1)); -- Check "/=" operator
- -- availability.
- end Bad_Final_Values; -- Aggregate with
- -- positional assoc.
-
- procedure Assign_Officer (MA : in out Medium_Alert_Type;
- To : in Person_Enum) is
- begin
- MA.Action_Officer := To;
- end Assign_Officer;
-
-
- procedure Handle (MA : in out Medium_Alert_Type) is
- begin
- Handle (Low_Alert_Type (MA)); -- Call parent's op (type conversion).
- MA.Level := Level_Of (MA); -- Call inherited operation.
- Assign_Officer (MA, Duty_Officer); -- Call newly declared operation.
- MA.Display_On := Console;
- Display (MA); -- Call twice-inherited operation.
- end Handle;
-
-
- function Initial_Values_Okay (MA : in Medium_Alert_Type) return Boolean is
- begin
- -- Call parent's operation (type conversion).
- return (Initial_Values_Okay (Low_Alert_Type (MA)) and
- MA.Action_Officer = Nobody);
- end Initial_Values_Okay;
-
-
- function Bad_Final_Values (MA : in Medium_Alert_Type) return Boolean is
- begin
- return not (MA = (Arrival_Time => Alert_Time, -- Check "=" operator
- Display_On => Console, -- availability.
- Level => 2, -- Aggregate with
- Action_Officer => Duty_Officer));-- named associations.
- end Bad_Final_Values;
-
-
-end C390A030;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c391001.a b/gcc/testsuite/ada/acats/tests/c3/c391001.a
deleted file mode 100644
index bca7525765f..00000000000
--- a/gcc/testsuite/ada/acats/tests/c3/c391001.a
+++ /dev/null
@@ -1,329 +0,0 @@
--- C391001.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that structures nesting discriminated records as
--- components in record extension are correctly supported. Check
--- for this using limited private structures.
--- Check that record extensions inherit all the visible components
--- of their ancestor types.
--- Check that discriminants are correctly inherited.
---
--- TEST DESCRIPTION:
--- This test defines a textbook object, a serial number plaque.
--- This object is used in each of several other structures modeled
--- after those used in an existing antenna modeling software system.
--- Record types discriminated and undiscriminated are nested to
--- produce a layered design. Some parametrization is programmatic;
--- some parametrization is data-driven.
---
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 19 Dec 94 SAIC Removed RM references from objective text.
--- 19 Apr 95 SAIC Added "limited" to full type def of "Object"
---
---!
-
- package C391001_1 is
- type Object is tagged limited private;
- -- Constructor operation
- procedure Create( The_Plaque : in out Object );
- -- Selector operations
- function "="( Left_Plaque,Right_Plaque : Object ) return Boolean;
- function TC_Match( Left_Plaque : Object; Right_Natural : Natural )
- return Boolean;
- function Serial_Number( A_Plaque : Object ) return Natural;
- Unserialized : exception; -- Serial_Number called before Create
- Reserialized : exception; -- Create called twice
- private
- type Object is tagged limited record
- Serial_Number : Natural := 0;
- end record;
- end C391001_1;
-
- package body C391001_1 is
- Counter : Natural := 0;
- procedure Create( The_Plaque : in out Object ) is
- begin
- if The_Plaque.Serial_Number = 0 then
- Counter := Counter +1;
- The_Plaque.Serial_Number := Counter;
- else
- raise Reserialized;
- end if;
- end Create;
-
- function "="( Left_Plaque,Right_Plaque : Object ) return Boolean is
- begin
- return (Left_Plaque.Serial_Number = Right_Plaque.Serial_Number)
- and then -- two uninitialized plates are unequal
- (Left_Plaque.Serial_Number /= 0);
- end "=";
-
- function TC_Match( Left_Plaque : Object; Right_Natural : Natural )
- return Boolean is
- begin
- return (Left_Plaque.Serial_Number = Right_Natural);
- end TC_Match;
-
- function Serial_Number( A_Plaque : Object ) return Natural is
- begin
- if A_Plaque.Serial_Number = 0 then
- raise Unserialized;
- end if;
- return A_Plaque.Serial_Number;
- end Serial_Number;
- end C391001_1;
-
- with C391001_1;
- package C391001_2 is -- package Boards is
-
- package Plaque renames C391001_1;
-
- type Modes is (Receiving, Transmitting, Standby);
- type Link(Mode: Modes := Standby) is record
- case Mode is
- when Receiving => TC_R : Integer := 100;
- when Transmitting => TC_T : Integer := 200;
- when Standby => TC_S : Integer := 300; -- TGA, TSA, SSA
- end case;
- end record;
-
- type Data_Formats is (S_Band, KU_Band, UHF);
-
-
- type Transceiver(Band: Data_Formats) is tagged limited record
- ID : Plaque.Object;
- The_Link: Link;
- case Band is
- when S_Band => TC_S_Band_Data : Integer := 1; -- TGA, SSA
- when KU_Band => TC_KU_Band_Data : Integer := 2; -- TSA
- when UHF => TC_UHF_Data : Integer := 3;
- end case;
- end record;
- end C391001_2;
-
- with C391001_1;
- with C391001_2;
- package C391001_3 is -- package Modules
- package Plaque renames C391001_1;
- package Boards renames C391001_2;
- use type Boards.Modes;
- use type Boards.Data_Formats;
-
- type Command_Formats is ( Set_Compression_Code,
- Set_Data_Rate,
- Set_Power_State );
-
- type Electronics_Module(EBand : Boards.Data_Formats;
- The_Command_Format: Command_Formats)
- is new Boards.Transceiver(EBand) with record
- case The_Command_Format is
- when Set_Compression_Code => TC_SCC : Integer := 10; -- SSA
- when Set_Data_Rate => TC_SDR : Integer := 20; -- TGA
- when Set_Power_State => TC_SPS : Integer := 30; -- TSA
- end case;
- end record;
- end C391001_3;
-
- with Report;
- with C391001_1;
- with C391001_2;
- with C391001_3;
- procedure C391001 is
- package Plaque renames C391001_1;
- package Boards renames C391001_2;
- package Modules renames C391001_3;
- use type Boards.Modes;
- use type Boards.Data_Formats;
- use type Modules.Command_Formats;
-
- type Azimuth is range 0..359;
-
- type Ground_Antenna(The_Band : Boards.Data_Formats;
- The_Command_Format: Modules.Command_Formats) is
- record
- ID : Plaque.Object;
- Electronics : Modules.Electronics_Module(The_Band,The_Command_Format);
- Pointing : Azimuth;
- end record;
-
- type Space_Antenna(The_Band : Boards.Data_Formats := Boards.KU_Band;
- The_Command : Modules.Command_Formats
- := Modules.Set_Power_State)
- is
- record
- ID : Plaque.Object;
- Electronics : Modules.Electronics_Module(The_Band,The_Command);
- end record;
-
- The_Ground_Antenna : Ground_Antenna (Boards.S_Band,
- Modules.Set_Data_Rate);
- The_Space_Antenna : Space_Antenna;
- Space_Station_Antenna : Space_Antenna (Boards.S_Band,
- Modules.Set_Compression_Code);
-
-
- procedure Validate( Condition : Boolean; Message: String ) is
- begin
- if not Condition then
- Report.Failed("Failed " & Message );
- end if;
- end Validate;
-
- begin
- Report.Test("C391001", "Check nested tagged discriminated "
- & "record structures");
-
- Plaque.Create( The_Ground_Antenna.ID ); -- 1
- Plaque.Create( The_Ground_Antenna.Electronics.ID ); -- 2
- Plaque.Create( The_Space_Antenna.ID ); -- 3
- Plaque.Create( The_Space_Antenna.Electronics.ID ); -- 4
- Plaque.Create( Space_Station_Antenna.ID ); -- 5
- Plaque.Create( Space_Station_Antenna.Electronics.ID );-- 6
-
- The_Ground_Antenna.Pointing := 180;
- Validate( The_Ground_Antenna.The_Band = Boards.S_Band, "TGA discr 1" );
- Validate( The_Ground_Antenna.The_Command_Format = Modules.Set_Data_Rate,
- "TGA discr 2" );
- Validate( Plaque.TC_Match(The_Ground_Antenna.ID,1), "TGA comp 1" );
- Validate( The_Ground_Antenna.Electronics.EBand = Boards.S_Band,
- "TGA comp 2.discr 1" );
- Validate( The_Ground_Antenna.Electronics.The_Command_Format
- = Modules.Set_Data_Rate, "TGA comp 2.discr 2" );
- Validate( The_Ground_Antenna.Electronics.TC_SDR = 20,
- "TGA comp 2.1" );
- Validate( Plaque.TC_Match( The_Ground_Antenna.Electronics.ID, 2 ),
- "TGA comp 2.inher.1" );
- Validate( The_Ground_Antenna.Electronics.The_Link.Mode = Boards.Standby,
- "TGA comp 2.inher.2.discr" );
- Validate( The_Ground_Antenna.Electronics.The_Link.TC_S = 300,
- "TGA comp 2.inher.2.1" );
- Validate( The_Ground_Antenna.Electronics.TC_S_Band_Data = 1,
- "TGA comp 2.inher.3" );
- Validate( The_Ground_Antenna.Pointing = 180, "TGA comp 3" );
-
- Validate( The_Space_Antenna.The_Band = Boards.KU_Band, "TSA discr 1");
- Validate( The_Space_Antenna.The_Command = Modules.Set_Power_State,
- "TSA discr 2");
- Validate( Plaque.TC_Match(The_Space_Antenna.ID,3),
- "TSA comp 1");
- Validate( The_Space_Antenna.Electronics.EBand = Boards.KU_Band,
- "TSA comp 2.discr 1");
- Validate( The_Space_Antenna.Electronics.The_Command_Format
- = Modules.Set_Power_State, "TSA comp 2.discr 2");
- Validate( Plaque.TC_Match(The_Space_Antenna.Electronics.ID,4),
- "TSA comp 2.inher.1");
- Validate( The_Space_Antenna.Electronics.The_Link.Mode = Boards.Standby,
- "TSA comp 2.inher.2.discr");
- Validate( The_Space_Antenna.Electronics.The_Link.TC_S = 300,
- "TSA comp 2.inher.2.1");
- Validate( The_Space_Antenna.Electronics.TC_KU_Band_Data = 2,
- "TSA comp 2.inher.3");
- Validate( The_Space_Antenna.Electronics.TC_SPS = 30,
- "TSA comp 2.1");
-
- Validate( Space_Station_Antenna.The_Band = Boards.S_Band, "SSA discr 1");
- Validate( Space_Station_Antenna.The_Command = Modules.Set_Compression_Code,
- "SSA discr 2");
- Validate( Plaque.TC_Match(Space_Station_Antenna.ID,5),
- "SSA comp 1");
- Validate( Space_Station_Antenna.Electronics.EBand = Boards.S_Band,
- "SSA comp 2.discr 1");
- Validate( Space_Station_Antenna.Electronics.The_Command_Format
- = Modules.Set_Compression_Code, "SSA comp 2.discr 2");
- Validate( Plaque.TC_Match(Space_Station_Antenna.Electronics.ID,6),
- "SSA comp 2.inher.1");
- Validate( Space_Station_Antenna.Electronics.The_Link.Mode = Boards.Standby,
- "SSA comp 2.inher.2.discr");
- Validate( Space_Station_Antenna.Electronics.The_Link.TC_S = 300,
- "SSA comp 2.inher.2.1");
- Validate( Space_Station_Antenna.Electronics.TC_S_Band_Data = 1,
- "SSA comp 2.inher.3");
- Validate( Space_Station_Antenna.Electronics.TC_SCC = 10,
- "SSA comp 2.1");
-
- The_Ground_Antenna.Electronics.TC_SDR := 1001;
- The_Ground_Antenna.Electronics.The_Link :=
-(Boards.Transmitting,2001);
- The_Ground_Antenna.Electronics.TC_S_Band_Data := 3001;
- The_Ground_Antenna.Pointing := 41;
-
- The_Space_Antenna.Electronics.The_Link := (Boards.Receiving,1010);
- The_Space_Antenna.Electronics.TC_KU_Band_Data := 2020;
- The_Space_Antenna.Electronics.TC_SPS := 3030;
-
- Space_Station_Antenna.Electronics.The_Link
- := The_Space_Antenna.Electronics.The_Link;
- Space_Station_Antenna.Electronics.The_Link.TC_R := 111;
- Space_Station_Antenna.Electronics.TC_S_Band_Data := 222;
- Space_Station_Antenna.Electronics.TC_SCC := 333;
-
- ----------------------------------------------------------------------
- begin -- should fail discriminant check
- The_Ground_Antenna.Electronics.TC_SCC := 909;
- Report.Failed("Discriminant check, no exception");
- exception
- when Constraint_Error => null;
- when others =>
- Report.Failed("Discriminant check, wrong exception");
- end;
-
- Validate( The_Ground_Antenna.Electronics.TC_SDR = 1001,
- "assigned value 1");
- Validate( The_Ground_Antenna.Electronics.The_Link.Mode
- = Boards.Transmitting,
- "assigned value 2.1");
- Validate( The_Ground_Antenna.Electronics.The_Link.TC_T = 2001,
- "assigned value 2.2");
- Validate( The_Ground_Antenna.Electronics.TC_S_Band_Data = 3001,
- "assigned value 3");
- Validate( The_Ground_Antenna.Pointing = 41,
- "assigned value 4");
-
- Validate( The_Space_Antenna.Electronics.The_Link.Mode = Boards.Receiving,
- "assigned value 5.1");
- Validate( The_Space_Antenna.Electronics.The_Link.TC_R = 1010,
- "assigned value 5.2");
- Validate( The_Space_Antenna.Electronics.TC_KU_Band_Data = 2020,
- "assigned value 6");
- Validate( The_Space_Antenna.Electronics.TC_SPS = 3030,
- "assigned value 7");
-
- Validate( Space_Station_Antenna.Electronics.The_Link.Mode
- = Boards.Receiving,
- "assigned value 8.1");
- Validate( Space_Station_Antenna.Electronics.The_Link.TC_R = 111,
- "assigned value 8.2");
- Validate( Space_Station_Antenna.Electronics.TC_S_Band_Data = 222,
- "assigned value 9");
- Validate( Space_Station_Antenna.Electronics.TC_SCC = 333,
- "assigned value 10");
-
- Report.Result;
-
-end C391001;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c391002.a b/gcc/testsuite/ada/acats/tests/c3/c391002.a
deleted file mode 100644
index 77fbfb32816..00000000000
--- a/gcc/testsuite/ada/acats/tests/c3/c391002.a
+++ /dev/null
@@ -1,493 +0,0 @@
--- C391002.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that structures nesting discriminated records as
--- components in record extension are correctly supported.
--- Check that record extensions inherit all the visible components
--- of their ancestor types.
--- Check that discriminants are correctly inherited.
---
--- TEST DESCRIPTION:
--- This test defines a simple class hierarchy, where the final
--- derivations exercise the different possible "permissions" available
--- to a designer. Extension aggregates for discriminated types are used
--- to set values of these final types. The key difference between
--- this test and C391001 is that the types are visible, and allow the
--- creation of complex discriminated extension aggregates. Another
--- layer of derivation is present to more robustly check that the
--- inheritance is correctly supported.
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 16 Dec 94 SAIC Removed offending parenthesis in aggregate
--- extensions, corrected typo: TC_MC SB TC_PC,
--- corrected visibility errors for literals,
--- added qualification for aggregate expressions
--- used in extension aggregates, corrected parameter
--- order in call to Communications.Creator
--- 01 MAY 95 SAIC Removed "limited" from the definition of Mil_Comm
--- 14 OCT 95 SAIC Fixed some value bugs for ACVC 2.0.1
--- 04 MAR 96 SAIC Altered 3 overambitious extension aggregates
--- 11 APR 96 SAIC Updated documentation for 2.1
--- 27 FEB 97 PWB.CTA Deleted extra (illegal) component association
---!
-
------------------------------------------------------------------ C391002_1
-
-package C391002_1 is
-
- type Object is tagged private;
-
- -- Constructor operation
- procedure Create( The_Plaque : in out Object );
-
- -- Selector operations
- function TC_Match( Left_Plaque : Object; Right_Natural : Natural )
- return Boolean;
-
- function Serial_Number( A_Plaque : Object ) return Natural;
-
- Unserialized : exception; -- Serial_Number called before Create
- Reserialized : exception; -- Create called twice
-
-private
- type Object is tagged record
- Serial_Number : Natural := 0;
- end record;
-end C391002_1;
-
--- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
-
-package body C391002_1 is
-
- Counter : Natural := 0;
-
- procedure Create( The_Plaque : in out Object ) is
- begin
- if The_Plaque.Serial_Number = 0 then
- Counter := Counter +1;
- The_Plaque.Serial_Number := Counter;
- else
- raise Reserialized;
- end if;
- end Create;
-
- function TC_Match( Left_Plaque : Object; Right_Natural : Natural )
- return Boolean is
- begin
- return (Left_Plaque.Serial_Number = Right_Natural);
- end TC_Match;
-
- function Serial_Number( A_Plaque : Object ) return Natural is
- begin
- if A_Plaque.Serial_Number = 0 then
- raise Unserialized;
- end if;
- return A_Plaque.Serial_Number;
- end Serial_Number;
-end C391002_1;
-
------------------------------------------------------------------ C391002_2
-
-with C391002_1;
-package C391002_2 is -- package Boards is
-
- package Plaque renames C391002_1;
-
- type Modes is (Receiving, Transmitting, Standby);
- type Link(Mode: Modes := Standby) is record
- case Mode is
- when Receiving => TC_R : Integer := 100;
- when Transmitting => TC_T : Integer := 200;
- when Standby => TC_S : Integer := 300; -- TGA, TSA, SSA
- end case;
- end record;
-
- type Data_Formats is (S_Band, KU_Band, UHF);
-
- type Transceiver(Band: Data_Formats) is tagged record
- ID : Plaque.Object;
- The_Link: Link;
- case Band is
- when S_Band => TC_S_Band_Data : Integer := 1; -- TGA, SSA, Milnet
- when KU_Band => TC_KU_Band_Data : Integer := 2; -- TSA, Usenet
- when UHF => TC_UHF_Data : Integer := 3; -- Gossip
- end case;
- end record;
-end C391002_2;
-
------------------------------------------------------------------ C391002_3
-
-with C391002_1;
-with C391002_2;
-package C391002_3 is -- package Modules
-
- package Plaque renames C391002_1;
- package Boards renames C391002_2;
- use type Boards.Modes;
- use type Boards.Data_Formats;
-
- type Command_Formats is ( Set_Compression_Code,
- Set_Data_Rate,
- Set_Power_State );
-
- type Electronics_Module(EBand : Boards.Data_Formats;
- The_Command : Command_Formats)
- is new Boards.Transceiver(EBand) with record
- case The_Command is
- when Set_Compression_Code => TC_SCC : Integer := 10; -- SSA, Gossip
- when Set_Data_Rate => TC_SDR : Integer := 20; -- TGA, Usenet
- when Set_Power_State => TC_SPS : Integer := 30; -- TSA, Milnet
- end case;
- end record;
-end C391002_3;
-
------------------------------------------------------------------ C391002_4
-
-with C391002_3;
-package C391002_4 is -- Communications
- package Modules renames C391002_3;
-
- type Public_Comm is new Modules.Electronics_Module with
- record
- TC_VC : Integer;
- end record;
-
- type Private_Comm is new Modules.Electronics_Module with private;
-
- type Mil_Comm is new Modules.Electronics_Module with private;
-
- procedure Creator( Plugs : in Modules.Electronics_Module;
- Gives : out Mil_Comm);
-
- function Creator( Key : Integer; Plugs : in Modules.Electronics_Module )
- return Private_Comm;
-
- procedure Setup( It : in out Public_Comm; Value : in Integer );
- procedure Setup( It : in out Private_Comm; Value : in Integer );
- procedure Setup( It : in out Mil_Comm; Value : in Integer );
-
- function Selector( It : Public_Comm ) return Integer;
- function Selector( It : Private_Comm ) return Integer;
- function Selector( It : Mil_Comm ) return Integer;
-
-private
- type Private_Comm is new Modules.Electronics_Module with
- record
- TC_PC : Integer;
- end record;
-
- type Mil_Comm is new Modules.Electronics_Module with
- record
- TC_MC : Integer;
- end record;
-end C391002_4; -- Communications
-
--- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
-
-with Report;
-with TCTouch;
-package body C391002_4 is -- Communications
-
- procedure Creator( Plugs : in Modules.Electronics_Module;
- Gives : out Mil_Comm) is
- begin
- Gives := ( Plugs with TC_MC => -1 );
- end Creator;
-
- function Creator( Key : Integer; Plugs : in Modules.Electronics_Module )
- return Private_Comm is
- begin
- return ( Plugs with TC_PC => Key );
- end Creator;
-
- procedure Setup( It : in out Public_Comm; Value : in Integer ) is
- begin
- It.TC_VC := Value;
- TCTouch.Assert( Value = 1, "Public_Comm");
- end Setup;
-
- procedure Setup( It : in out Private_Comm; Value : in Integer ) is
- begin
- It.TC_PC := Value;
- TCTouch.Assert( Value = 2, "Private_Comm");
- end Setup;
-
- procedure Setup( It : in out Mil_Comm; Value : in Integer ) is
- begin
- It.TC_MC := Value;
- TCTouch.Assert( Value = 3, "Private_Comm");
- end Setup;
-
- function Selector( It : Public_Comm ) return Integer is
- begin
- return It.TC_VC;
- end Selector;
-
- function Selector( It : Private_Comm ) return Integer is
- begin
- return It.TC_PC;
- end Selector;
-
- function Selector( It : Mil_Comm ) return Integer is
- begin
- return It.TC_MC;
- end Selector;
-
-end C391002_4; -- Communications
-
-------------------------------------------------------------------- C391002
-
-with Report;
-with TCTouch;
-with C391002_1;
-with C391002_2;
-with C391002_3;
-with C391002_4;
-procedure C391002 is
-
- package Plaque renames C391002_1;
- package Boards renames C391002_2;
- package Modules renames C391002_3;
- package Communications renames C391002_4;
-
- procedure Assert( Condition: Boolean; Message: String )
- renames TCTouch.Assert;
-
- use type Boards.Modes;
- use type Boards.Data_Formats;
- use type Modules.Command_Formats;
-
- type Azimuth is range 0..359;
-
- type Ground_Antenna(The_Band : Boards.Data_Formats;
- The_Command : Modules.Command_Formats) is
- record
- ID : Plaque.Object;
- Electronics : Modules.Electronics_Module(The_Band,The_Command);
- Pointing : Azimuth;
- end record;
-
- type Space_Antenna(The_Band : Boards.Data_Formats := Boards.KU_Band;
- The_Command : Modules.Command_Formats
- := Modules.Set_Power_State)
- is
- record
- ID : Plaque.Object;
- Electronics : Modules.Electronics_Module(The_Band,The_Command);
- end record;
-
- The_Ground_Antenna : Ground_Antenna (Boards.S_Band,
- Modules.Set_Data_Rate);
- The_Space_Antenna : Space_Antenna;
- Space_Station_Antenna : Space_Antenna (Boards.UHF,
- Modules.Set_Compression_Code);
-
- Gossip : Communications.Public_Comm (Boards.UHF,
- Modules.Set_Compression_Code);
- Usenet : Communications.Private_Comm (Boards.KU_Band,
- Modules.Set_Data_Rate);
- Milnet : Communications.Mil_Comm (Boards.S_Band,
- Modules.Set_Power_State);
-
-
-begin
-
- Report.Test("C391002", "Check nested tagged discriminated"
- & " record structures");
-
- Plaque.Create( The_Ground_Antenna.ID ); -- 1
- Plaque.Create( The_Ground_Antenna.Electronics.ID ); -- 2
- Plaque.Create( The_Space_Antenna.ID ); -- 3
- Plaque.Create( The_Space_Antenna.Electronics.ID ); -- 4
- Plaque.Create( Space_Station_Antenna.ID ); -- 5
- Plaque.Create( Space_Station_Antenna.Electronics.ID );-- 6
-
- The_Ground_Antenna := ( The_Band => Boards.S_Band,
- The_Command => Modules.Set_Data_Rate,
- ID => The_Ground_Antenna.ID,
- Electronics =>
- ( Boards.Transceiver'(
- Band => Boards.S_Band,
- ID => The_Ground_Antenna.Electronics.ID,
- The_Link => ( Mode => Boards.Transmitting,
- TC_T => 222 ),
- TC_S_Band_Data => 8 )
- with EBand => Boards.S_Band,
- The_Command => Modules.Set_Data_Rate,
- TC_SDR => 11 ),
- Pointing => 270 );
-
- The_Space_Antenna := ( The_Band => Boards.S_Band,
- The_Command => Modules.Set_Data_Rate,
- ID => The_Space_Antenna.ID,
- Electronics =>
- ( Boards.Transceiver'(
- Band => Boards.S_Band,
- ID => The_Space_Antenna.Electronics.ID,
- The_Link => ( Mode => Boards.Transmitting,
- TC_T => 456 ),
- TC_S_Band_Data => 88 )
- with
- EBand => Boards.S_Band,
- The_Command => Modules.Set_Data_Rate,
- TC_SDR => 42
- ) );
-
- Space_Station_Antenna := ( Boards.UHF, Modules.Set_Compression_Code,
- Space_Station_Antenna.ID,
- ( Boards.Transceiver'(
- Boards.UHF,
- Space_Station_Antenna.Electronics.ID,
- ( Boards.Transmitting, 202 ),
- 42 )
- with Boards.UHF,
- Modules.Set_Compression_Code,
- TC_SCC => 101
- ) );
-
- Assert( The_Ground_Antenna.The_Band = Boards.S_Band, "TGA disc 1" );
- Assert( The_Ground_Antenna.The_Command = Modules.Set_Data_Rate,
- "TGA disc 2" );
- Assert( Plaque.TC_Match(The_Ground_Antenna.ID,1), "TGA comp 3" );
- Assert( The_Ground_Antenna.Electronics.EBand = Boards.S_Band,
- "TGA comp 2.disc 1" );
- Assert( The_Ground_Antenna.Electronics.The_Command
- = Modules.Set_Data_Rate,
- "TGA comp 2.disc 2" );
- Assert( The_Ground_Antenna.Electronics.TC_SDR = 11,
- "TGA comp 2.1" );
- Assert( Plaque.TC_Match( The_Ground_Antenna.Electronics.ID, 2 ),
- "TGA comp 2.inher.1" );
- Assert( The_Ground_Antenna.Electronics.The_Link.Mode = Boards.Transmitting,
- "TGA comp 2.inher.2.disc" );
- Assert( The_Ground_Antenna.Electronics.The_Link.TC_T = 222,
- "TGA comp 2.inher.2.1" );
- Assert( The_Ground_Antenna.Electronics.TC_S_Band_Data = 8,
- "TGA comp 2.inher.3" );
- Assert( The_Ground_Antenna.Pointing = 270, "TGA comp 3" );
-
- Assert( The_Space_Antenna.The_Band = Boards.S_Band, "TSA disc 1");
- Assert( The_Space_Antenna.The_Command = Modules.Set_Data_Rate,
- "TSA disc 2");
- Assert( Plaque.TC_Match(The_Space_Antenna.ID,3),
- "TSA comp 1");
- Assert( The_Space_Antenna.Electronics.EBand = Boards.S_Band,
- "TSA comp 2.disc 1");
- Assert( The_Space_Antenna.Electronics.The_Command = Modules.Set_Data_Rate,
- "TSA comp 2.disc 2");
- Assert( The_Space_Antenna.Electronics.TC_SDR = 42,
- "TSA comp 2.1");
- Assert( Plaque.TC_Match(The_Space_Antenna.Electronics.ID,4),
- "TSA comp 2.inher.1");
- Assert( The_Space_Antenna.Electronics.The_Link.Mode = Boards.Transmitting,
- "TSA comp 2.inher.2.disc");
- Assert( The_Space_Antenna.Electronics.The_Link.TC_T = 456,
- "TSA comp 2.inher.2.1");
- Assert( The_Space_Antenna.Electronics.TC_S_Band_Data = 88,
- "TSA comp 2.inher.3");
-
- Assert( Space_Station_Antenna.The_Band = Boards.UHF, "SSA disc 1");
- Assert( Space_Station_Antenna.The_Command = Modules.Set_Compression_Code,
- "SSA disc 2");
- Assert( Plaque.TC_Match(Space_Station_Antenna.ID,5),
- "SSA comp 1");
- Assert( Space_Station_Antenna.Electronics.EBand = Boards.UHF,
- "SSA comp 2.disc 1");
- Assert( Space_Station_Antenna.Electronics.The_Command
- = Modules.Set_Compression_Code,
- "SSA comp 2.disc 2");
- Assert( Space_Station_Antenna.Electronics.TC_SCC = 101,
- "SSA comp 2.1");
- Assert( Plaque.TC_Match(Space_Station_Antenna.Electronics.ID,6),
- "SSA comp 2.inher.1");
- Assert( Space_Station_Antenna.Electronics.The_Link.Mode
- = Boards.Transmitting,
- "SSA comp 2.inher.2.disc");
- Assert( Space_Station_Antenna.Electronics.The_Link.TC_T = 202,
- "SSA comp 2.inher.2.1");
- Assert( Space_Station_Antenna.Electronics.TC_UHF_Data = 42,
- "SSA comp 2.inher.3");
-
-
- The_Space_Antenna := ( The_Band => Boards.S_Band,
- The_Command => Modules.Set_Power_State,
- ID => The_Space_Antenna.ID,
- Electronics =>
- ( Boards.Transceiver'(
- Band => Boards.S_Band,
- ID => The_Space_Antenna.Electronics.ID,
- The_Link => ( Mode => Boards.Transmitting,
- TC_T => 1 ),
- TC_S_Band_Data => 5 )
- with
- EBand => Boards.S_Band,
- The_Command => Modules.Set_Power_State,
- TC_SPS => 101
- ) );
-
- Communications.Creator( The_Space_Antenna.Electronics, Milnet );
- Assert( Communications.Selector( Milnet ) = -1, "Milnet creator" );
-
- Usenet := Communications.Creator( -2,
- ( Boards.Transceiver'(
- Band => Boards.KU_Band,
- ID => The_Space_Antenna.Electronics.ID,
- The_Link => ( Boards.Transmitting, TC_T => 101 ),
- TC_KU_Band_Data => 395 )
- with Boards.KU_Band, Modules.Set_Data_Rate, 66 ) );
-
- Assert( Communications.Selector( Usenet ) = -2, "Usenet creator" );
-
- Gossip := (
- Modules.Electronics_Module'(
- Boards.Transceiver'(
- Band => Boards.UHF,
- ID => The_Space_Antenna.Electronics.ID,
- The_Link => ( Boards.Transmitting, TC_T => 101 ),
- TC_UHF_Data => 395 )
- with
- Boards.UHF, Modules.Set_Compression_Code, 66 )
- with
- TC_VC => -3 );
-
- Assert( Gossip.TC_VC = -3, "Gossip Aggregate" );
-
- Communications.Setup( Gossip, 1 ); -- (Boards.UHF,
- -- Modules.Set_Compression_Code)
- Communications.Setup( Usenet, 2 ); -- (Boards.KU_Band,
- -- Modules.Set_Data_Rate)
- Communications.Setup( Milnet, 3 ); -- (Boards.S_Band,
- -- Modules.Set_Power_State)
-
- Assert( Communications.Selector( Gossip ) = 1, "Gossip Setup" );
- Assert( Communications.Selector( Usenet ) = 2, "Usenet Setup" );
- Assert( Communications.Selector( Milnet ) = 3, "Milnet Setup" );
-
- Report.Result;
-
-end C391002;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c392002.a b/gcc/testsuite/ada/acats/tests/c3/c392002.a
deleted file mode 100644
index 41493c22779..00000000000
--- a/gcc/testsuite/ada/acats/tests/c3/c392002.a
+++ /dev/null
@@ -1,349 +0,0 @@
--- C392002.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that the use of a class-wide formal parameter allows for the
--- proper dispatching of objects to the appropriate implementation of
--- a primitive operation. Check this in the case where the root tagged
--- type is defined in a generic package, and the type derived from it is
--- defined in that same generic package.
---
--- TEST DESCRIPTION:
--- Declare a root tagged type, and some associated primitive operations.
--- Extend the root type, and override one or more primitive operations,
--- inheriting the other primitive operations from the root type.
--- Derive from the extended type, again overriding some primitive
--- operations and inheriting others (including some that the parent
--- inherited).
--- Define a subprogram with a class-wide parameter, inside of which is a
--- call on a dispatching primitive operation. These primitive operations
--- modify global variables (the class-wide parameter has mode IN).
---
--- The following hierarchy of tagged types and primitive operations is
--- utilized in this test:
---
---
--- type Vehicle (root)
--- |
--- type Motorcycle
--- |
--- | Operations
--- | Engine_Size
--- | Catalytic_Converter
--- | Emissions_Produced
--- |
--- type Automobile (extended from Motorcycle)
--- |
--- | Operations
--- | (Engine_Size) (inherited)
--- | Catalytic_Converter (overridden)
--- | Emissions_Produced (overridden)
--- |
--- type Truck (extended from Automobile)
--- |
--- | Operations
--- | (Engine_Size) (inherited twice - Motorcycle)
--- | (Catalytic_Converter) (inherited - Automobile)
--- | Emissions_Produced (overridden)
---
---
--- In this test, we are concerned with the following selection of dispatching
--- calls, accomplished with the use of a Vehicle'Class IN procedure
--- parameter :
---
--- \ Type
--- Prim. Op \ Motorcycle Automobile Truck
--- \------------------------------------------------
--- Engine_Size | X X X
--- Catalytic_Converter | X X X
--- Emissions_Produced | X X X
---
---
---
--- The location of the declaration and derivation of the root and extended
--- types will be varied over a series of tests. Locations of declaration
--- and derivation for a particular test are marked with an asterisk (*).
---
--- Root type:
---
--- Declared in package.
--- * Declared in generic package.
---
--- Extended types:
---
--- * Derived in parent location.
--- Derived in a nested package.
--- Derived in a nested subprogram.
--- Derived in a nested generic package.
--- Derived in a separate package.
--- Derived in a separate visible child package.
--- Derived in a separate private child package.
---
--- Primitive Operations:
---
--- * Procedures with same parameter profile.
--- Procedures with different parameter profile.
--- * Functions with same parameter profile.
--- Functions with different parameter profile.
--- * Mixture of Procedures and Functions.
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 09 May 96 SAIC Made single-file for 2.1
---
---!
-
-------------------------------------------------------------------- C392002_0
-
--- Declare the root and extended types, along with their primitive
--- operations in a generic package.
-
-generic
-
- type Cubic_Inches is range <>;
- type Emission_Measure is digits <>;
- Emissions_per_Engine_Cubic_Inch : Emission_Measure;
-
-package C392002_0 is -- package Vehicle_Simulation
-
- --
- -- Equipment types and their primitive operations.
- --
-
- -- Root type.
-
- type Vehicle is abstract tagged
- record
- Weight : Integer;
- Wheels : Positive;
- end record;
-
- -- Abstract operations of type Vehicle.
- function Engine_Size (V : in Vehicle) return Cubic_Inches
- is abstract;
- function Catalytic_Converter (V : in Vehicle) return Boolean
- is abstract;
- function Emissions_Produced (V : in Vehicle) return Emission_Measure
- is abstract;
-
- --
-
- type Motorcycle is new Vehicle with
- record
- Size_Of_Engine : Cubic_Inches;
- end record;
-
- -- Primitive operations of type Motorcycle.
- function Engine_Size (V : in Motorcycle) return Cubic_Inches;
- function Catalytic_Converter (V : in Motorcycle) return Boolean;
- function Emissions_Produced (V : in Motorcycle) return Emission_Measure;
-
- --
-
- type Automobile is new Motorcycle with
- record
- Passenger_Capacity : Integer;
- end record;
-
- -- Function Engine_Size inherited from parent (Motorcycle).
- -- Primitive operations (Overridden).
- function Catalytic_Converter (V : in Automobile) return Boolean;
- function Emissions_Produced (V : in Automobile) return Emission_Measure;
-
- --
-
- type Truck is new Automobile with
- record
- Hauling_Capacity : Natural;
- end record;
-
- -- Function Engine_Size inherited twice.
- -- Function Catalytic_Converter inherited from parent (Automobile).
- -- Primitive operation (Overridden).
- function Emissions_Produced (V : in Truck) return Emission_Measure;
-
-end C392002_0;
-
--- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
-
-package body c392002_0 is
-
- --
- -- Primitive operations for Motorcycle.
- --
-
- function Engine_Size (V : in Motorcycle) return Cubic_Inches is
- begin
- return (V.Size_Of_Engine);
- end Engine_Size;
-
-
- function Catalytic_Converter (V : in Motorcycle) return Boolean is
- begin
- return (False);
- end Catalytic_Converter;
-
-
- function Emissions_Produced (V : in Motorcycle) return Emission_Measure is
- begin
- return 100.00;
- end Emissions_Produced;
-
- --
- -- Overridden operations for Automobile type.
- --
-
- function Catalytic_Converter (V : in Automobile) return Boolean is
- begin
- return (True);
- end Catalytic_Converter;
-
-
- function Emissions_Produced (V : in Automobile) return Emission_Measure is
- begin
- return 200.00;
- end Emissions_Produced;
-
- --
- -- Overridden operation for Truck type.
- --
-
- function Emissions_Produced (V : in Truck) return Emission_Measure is
- begin
- return 300.00;
- end Emissions_Produced;
-
-end C392002_0;
-
---------------------------------------------------------------------- C392002
-
-with C392002_0; -- with Vehicle_Simulation;
-with Report;
-
-procedure C392002 is
-
- type Decade is (c1970, c1980, c1990);
- type Vehicle_Emissions is digits 6;
- type Engine_Emissions_by_Decade is array (Decade) of Vehicle_Emissions;
- subtype Engine_Size is Integer range 100 .. 1000;
-
- Five_Tons : constant Natural := 10000;
- Catalytic_Converter_Offset : constant Vehicle_Emissions := 0.8;
- Truck_Adjustment_Factor : constant Vehicle_Emissions := 1.2;
-
-
- Engine_Emission_Factor : Engine_Emissions_by_Decade := (c1970 => 10.00,
- c1980 => 8.00,
- c1990 => 5.00);
-
- -- Instantiate generic package for 1970 simulation.
-
- package Sim_1970 is new C392002_0
- (Cubic_Inches => Engine_Size,
- Emission_Measure => Vehicle_Emissions,
- Emissions_Per_Engine_Cubic_Inch => Engine_Emission_Factor (c1970));
-
-
- -- Declare and initialize vehicle objects.
-
- Cycle_1970 : Sim_1970.Motorcycle := (Weight => 400,
- Wheels => 2,
- Size_Of_Engine => 100);
-
- Auto_1970 : Sim_1970.Automobile := (2000, 4, 500, 5);
-
- Truck_1970 : Sim_1970.Truck := (Weight => 5000,
- Wheels => 18,
- Size_Of_Engine => 1000,
- Passenger_Capacity => 2,
- Hauling_Capacity => Five_Tons);
-
- -- Function Get_Engine_Size performs a dispatching call on a
- -- primitive operation that has been defined for an ancestor type and
- -- inherited by each type derived from the ancestor.
-
- function Get_Engine_Size (V : in Sim_1970.Vehicle'Class)
- return Engine_Size is
- begin
- return (Sim_1970.Engine_Size (V)); -- Dispatch according to tag.
- end Get_Engine_Size;
-
-
- -- Function Catalytic_Converter_Present performs a dispatching call on
- -- a primitive operation that has been defined for an ancestor type,
- -- overridden in the parent extended type, and inherited by the subsequent
- -- extended type.
-
- function Catalytic_Converter_Present (V : in Sim_1970.Vehicle'Class)
- return Boolean is
- begin
- return (Sim_1970.Catalytic_Converter (V)); -- Dispatch according to tag.
- end Catalytic_Converter_Present;
-
-
- -- Function Air_Quality_Measure performs a dispatching call on
- -- a primitive operation that has been defined for an ancestor type, and
- -- overridden in each subsequent extended type.
-
- function Air_Quality_Measure (V : in Sim_1970.Vehicle'Class)
- return Vehicle_Emissions is
- begin
- return (Sim_1970.Emissions_Produced (V)); -- Dispatch according to tag.
- end Air_Quality_Measure;
-
--- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
-
-begin -- Main test procedure.
-
- Report.Test ("C392002", "Check that the use of a class-wide parameter "
- & "allows for proper dispatching where root type "
- & "and extended types are declared in the same "
- & "generic package" );
-
- if (Get_Engine_Size (Cycle_1970) /= 100) or
- (Get_Engine_Size (Auto_1970) /= 500) or
- (Get_Engine_Size (Truck_1970) /= 1000)
- then
- Report.Failed ("Failed dispatch to Get_Engine_Size");
- end if;
-
- if Catalytic_Converter_Present (Cycle_1970) or
- not Catalytic_Converter_Present (Auto_1970) or
- not Catalytic_Converter_Present (Truck_1970)
- then
- Report.Failed ("Failed dispatch to Catalytic_Converter_Present");
- end if;
-
- if ((Air_Quality_Measure (Cycle_1970) /= 100.00) or
- (Air_Quality_Measure (Auto_1970) /= 200.00) or
- (Air_Quality_Measure (Truck_1970) /= 300.00))
- then
- Report.Failed ("Failed dispatch to Air_Quality_Measure");
- end if;
-
- Report.Result;
-
-end C392002;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c392003.a b/gcc/testsuite/ada/acats/tests/c3/c392003.a
deleted file mode 100644
index d7c5be22867..00000000000
--- a/gcc/testsuite/ada/acats/tests/c3/c392003.a
+++ /dev/null
@@ -1,453 +0,0 @@
--- C392003.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that the use of a class-wide formal parameter allows for the
--- proper dispatching of objects to the appropriate implementation of
--- a primitive operation. Check this where the root tagged type is
--- defined in a package, and the extended type is defined in a nested
--- package.
---
--- TEST DESCRIPTION:
--- Declare a root tagged type, and some associated primitive operations.
--- Extend the root type, and override one or more primitive operations,
--- inheriting the other primitive operations from the root type.
--- Derive from the extended type, again overriding some primitive
--- operations and inheriting others (including some that the parent
--- inherited).
--- Define a subprogram with a class-wide parameter, inside of which is a
--- call on a dispatching primitive operation. These primitive operations
--- modify global variables (the class-wide parameter has mode IN).
---
---
---
--- The following hierarchy of tagged types and primitive operations is
--- utilized in this test:
---
--- type Bank_Account (root)
--- |
--- | Operations
--- | Increment_Bank_Reserve
--- | Assign_Representative
--- | Increment_Counters
--- | Open
--- |
--- type Savings_Account (extended from Bank_Account)
--- |
--- | Operations
--- | (Increment_Bank_Reserve) (inherited)
--- | Assign_Representative (overridden)
--- | Increment_Counters (overridden)
--- | Open (overridden)
--- |
--- type Preferred_Account (extended from Savings_Account)
--- |
--- | Operations
--- | (Increment_Bank_Reserve) (inherited twice - Bank_Acct.)
--- | (Assign_Representative) (inherited - Savings_Acct.)
--- | Increment_Counters (overridden)
--- | Open (overridden)
---
---
--- In this test, we are concerned with the following selection of dispatching
--- calls, accomplished with the use of a Bank_Account'Class IN procedure
--- parameter :
---
--- \ Type
--- Prim. Op \ Bank_Account Savings_Account Preferred_Account
--- \------------------------------------------------
--- Increment_Bank_Reserve| X X
--- Assign_Representative | X
--- Increment_Counters | X X X
---
---
---
--- The location of the declaration and derivation of the root and extended
--- types will be varied over a series of tests. Locations of declaration
--- and derivation for a particular test are marked with an asterisk (*).
---
--- Root type:
---
--- * Declared in package.
--- Declared in generic package.
---
--- Extended types:
---
--- Derived in parent location.
--- * Derived in a nested package.
--- Derived in a nested subprogram.
--- Derived in a nested generic package.
--- Derived in a separate package.
--- Derived in a separate visible child package.
--- Derived in a separate private child package.
---
--- Primitive Operations:
---
--- * Procedures with same parameter profile.
--- Procedures with different parameter profile.
--- * Functions with same parameter profile.
--- Functions with different parameter profile.
--- * Mixture of Procedures and Functions.
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
---
---!
-
-
- with Report;
-
- procedure C392003 is
-
- --
- -- Types and subtypes.
- --
-
- type Dollar_Amount is new float;
- type Interest_Rate is delta 0.001 range 0.000 .. 1.000;
- type Account_Types is (Bank, Savings, Preferred, Total);
- type Account_Counter is array (Account_Types) of integer;
- type Account_Rep is (President, Manager, New_Account_Manager, Teller);
-
- --
- -- Constants.
- --
-
- Opening_Balance : constant Dollar_Amount := 100.00;
- Current_Rate : constant Interest_Rate := 0.030;
- Preferred_Minimum_Balance : constant Dollar_Amount := 1000.00;
-
- --
- -- Global Variables
- --
-
- Bank_Reserve : Dollar_Amount := 0.00;
- Daily_Representative : Account_Rep := New_Account_Manager;
- Number_Of_Accounts : Account_Counter := (Bank => 0,
- Savings => 0,
- Preferred => 0,
- Total => 0);
-
- -- Root tagged type and primitive operations declared in internal
- -- package (Accounts).
- -- Extended types (and primitive operations) derived in nested packages.
-
- --=================================================================--
-
- package Accounts is
-
- --
- -- Root account type and primitive operations.
- --
-
- -- Root type.
-
- type Bank_Account is tagged
- record
- Balance : Dollar_Amount;
- end record;
-
- -- Primitive operations of Bank_Account.
-
- function Increment_Bank_Reserve (Acct : in Bank_Account)
- return Dollar_Amount;
- function Assign_Representative (Acct : in Bank_Account)
- return Account_Rep;
- procedure Increment_Counters (Acct : in Bank_Account);
- procedure Open (Acct : in out Bank_Account);
-
- --=================================================================--
-
- package S_And_L is
-
- -- Declare extended type in a nested package.
-
- type Savings_Account is new Bank_Account with
- record
- Rate : Interest_Rate;
- end record;
-
- -- Function Increment_Bank_Reserve inherited from
- -- parent (Bank_Account).
-
- -- Primitive operations (Overridden).
- function Assign_Representative (Acct : in Savings_Account)
- return Account_Rep;
- procedure Increment_Counters (Acct : in Savings_Account);
- procedure Open (Acct : in out Savings_Account);
-
-
- --=================================================================--
-
- package Premium is
-
- -- Declare further extended type in a nested package.
-
- type Preferred_Account is new Savings_Account with
- record
- Minimum_Balance : Dollar_Amount;
- end record;
-
- -- Function Increment_Bank_Reserve inherited twice.
- -- Function Assign_Representative inherited from parent
- -- (Savings_Account).
-
- -- Primitive operation (Overridden).
- procedure Increment_Counters (Acct : in Preferred_Account);
- procedure Open (Acct : in out Preferred_Account);
-
- -- Function used to verify Open operation for Preferred_Account
- -- objects.
- function Verify_Open (Acct : in Preferred_Account) return Boolean;
-
- end Premium;
-
- end S_And_L;
-
- end Accounts;
-
- --=================================================================--
-
- package body Accounts is
-
- --
- -- Primitive operations for Bank_Account.
- --
-
- function Increment_Bank_Reserve (Acct : in Bank_Account)
- return Dollar_Amount is
- begin
- return (Bank_Reserve + Acct.Balance);
- end Increment_Bank_Reserve;
-
- function Assign_Representative (Acct : in Bank_Account)
- return Account_Rep is
- begin
- return Account_Rep'(Teller);
- end Assign_Representative;
-
- procedure Increment_Counters (Acct : in Bank_Account) is
- begin
- Number_Of_Accounts (Bank) := Number_Of_Accounts (Bank) + 1;
- Number_Of_Accounts (Total) := Number_Of_Accounts (Total) + 1;
- end Increment_Counters;
-
- procedure Open (Acct : in out Bank_Account) is
- begin
- Acct.Balance := Opening_Balance;
- end Open;
-
- --=================================================================--
-
- package body S_And_L is
-
- --
- -- Overridden operations for Savings_Account type.
- --
-
- function Assign_Representative (Acct : in Savings_Account)
- return Account_Rep is
- begin
- return (Manager);
- end Assign_Representative;
-
- procedure Increment_Counters (Acct : in Savings_Account) is
- begin
- Number_Of_Accounts (Savings) := Number_Of_Accounts (Savings) + 1;
- Number_Of_Accounts (Total) := Number_Of_Accounts (Total) + 1;
- end Increment_Counters;
-
- procedure Open (Acct : in out Savings_Account) is
- begin
- Open (Bank_Account(Acct));
- Acct.Rate := Current_Rate;
- Acct.Balance := 2.0 * Opening_Balance;
- end Open;
-
- --=================================================================--
-
- package body Premium is
-
- --
- -- Overridden operations for Preferred_Account type.
- --
-
- procedure Increment_Counters (Acct : in Preferred_Account) is
- begin
- Number_Of_Accounts (Preferred) :=
- Number_Of_Accounts (Preferred) + 1;
- Number_Of_Accounts (Total) :=
- Number_Of_Accounts (Total) + 1;
- end Increment_Counters;
-
- procedure Open (Acct : in out Preferred_Account) is
- begin
- Open (Savings_Account(Acct));
- Acct.Minimum_Balance := Preferred_Minimum_Balance;
- Acct.Balance := Acct.Minimum_Balance;
- end Open;
-
- --
- -- Function used to verify Open operation for Preferred_Account
- -- objects.
- --
-
- function Verify_Open (Acct : in Preferred_Account)
- return Boolean is
- begin
- return (Acct.Balance = Preferred_Minimum_Balance and
- Acct.Rate = Current_Rate and
- Acct.Minimum_Balance = Preferred_Minimum_Balance);
- end Verify_Open;
-
- end Premium;
-
- end S_And_L;
-
- end Accounts;
-
- --=================================================================--
-
- -- Declare account objects.
-
- B_Account : Accounts.Bank_Account;
- S_Account : Accounts.S_And_L.Savings_Account;
- P_Account : Accounts.S_And_L.Premium.Preferred_Account;
-
- -- Procedures to operate on accounts.
- -- Each uses a class-wide IN parameter, as well as a call to a
- -- dispatching operation.
-
- -- Function Tabulate_Account performs a dispatching call on a primitive
- -- operation that has been overridden for each of the extended types.
-
- procedure Tabulate_Account (Acct : in Accounts.Bank_Account'Class) is
- begin
- Accounts.Increment_Counters (Acct); -- Dispatch according to tag.
- end Tabulate_Account;
-
- -- Function Accumulate_Reserve performs a dispatching call on a
- -- primitive operation that has been defined for the root type and
- -- inherited by each derived type.
-
- function Accumulate_Reserve (Acct : in Accounts.Bank_Account'Class)
- return Dollar_Amount is
- begin
- -- Dispatch according to tag.
- return (Accounts.Increment_Bank_Reserve (Acct));
- end Accumulate_Reserve;
-
- -- Procedure Resolve_Dispute performs a dispatching call on a primitive
- -- operation that has been defined in the root type, overridden in the
- -- first derived extended type, and inherited by the subsequent extended
- -- type.
-
- procedure Resolve_Dispute (Acct : in Accounts.Bank_Account'Class) is
- begin
- -- Dispatch according to tag.
- Daily_Representative := Accounts.Assign_Representative (Acct);
- end Resolve_Dispute;
-
- --=================================================================--
-
- begin -- Main test procedure.
-
- Report.Test ("C392003", "Check that the use of a class-wide parameter " &
- "allows for proper dispatching where root type " &
- "is declared in a nested package, and " &
- "subsequent extended types are derived in " &
- "further nested packages" );
-
- Bank_Account_Subtest:
- begin
- Accounts.Open (B_Account);
-
- -- Demonstrate class-wide parameter allowing dispatch by a primitive
- -- operation that has been defined for this specific type.
- Bank_Reserve := Accumulate_Reserve (Acct => B_Account);
- Tabulate_Account (B_Account);
-
- if (Bank_Reserve /= Opening_Balance) or
- (Number_Of_Accounts (Bank) /= 1) or
- (Number_Of_Accounts (Total) /= 1)
- then
- Report.Failed ("Failed in Bank_Account_Subtest");
- end if;
-
- end Bank_Account_Subtest;
-
-
- Savings_Account_Subtest:
- begin
- Accounts.S_And_L.Open (Acct => S_Account);
-
- -- Demonstrate class-wide parameter allowing dispatch by a primitive
- -- operation that has been overridden for this extended type.
- Resolve_Dispute (Acct => S_Account);
- Tabulate_Account (S_Account);
-
- if (Daily_Representative /= Manager) or
- (Number_Of_Accounts (Savings) /= 1) or
- (Number_Of_Accounts (Total) /= 2)
- then
- Report.Failed ("Failed in Savings_Account_Subtest");
- end if;
-
- end Savings_Account_Subtest;
-
-
-
- Preferred_Account_Subtest:
- begin
- Accounts.S_And_L.Premium.Open (P_Account);
-
- -- Verify that the correct implementation of Open (overridden) was
- -- used for the Preferred_Account object.
- if not Accounts.S_And_L.Premium.Verify_Open (P_Account) then
- Report.Failed ("Incorrect values for init. Preferred Acct object");
- end if;
-
- -- Demonstrate class-wide parameter allowing dispatch by a primitive
- -- operation that has been twice inherited by this extended type.
- Bank_Reserve := Accumulate_Reserve (Acct => P_Account);
-
- -- Demonstrate class-wide parameter allowing dispatch by a primitive
- -- operation that has been overridden for this extended type (the
- -- operation was overridden by its parent type as well).
- Tabulate_Account (P_Account);
-
- if Bank_Reserve /= 1100.00 or
- Number_Of_Accounts (Preferred) /= 1 or
- Number_Of_Accounts (Total) /= 3
- then
- Report.Failed ("Failed in Preferred_Account_Subtest");
- end if;
-
- end Preferred_Account_Subtest;
-
- Report.Result;
-
- end C392003;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c392004.a b/gcc/testsuite/ada/acats/tests/c3/c392004.a
deleted file mode 100644
index 0851db1d287..00000000000
--- a/gcc/testsuite/ada/acats/tests/c3/c392004.a
+++ /dev/null
@@ -1,189 +0,0 @@
--- C392004.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that subprograms inherited from tagged derivations, which are
--- subsequently redefined for the derived type, are available to the
--- package defining the new class via view conversion. Check
--- that operations performed on objects using view conversion do not
--- affect the extended fields. Check that visible operations not masked
--- by the deriving package remain available to the client, and do not
--- affect the extended fields.
---
--- TEST DESCRIPTION:
--- This test declares a tagged type, with a constructor operation,
--- derives a type from that tagged type, and declares a constructor
--- operation which masks the inherited operation. It then tests
--- that the correct constructor is called, and that the extended
--- part of the derived type remains untouched as appropriate.
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 19 Dec 94 SAIC Removed RM references from objective text.
--- 04 Jan 94 SAIC Fixed objective typo, removed dead code.
---
---!
-
-with Report;
-
-package C392004_1 is
-
- type Vehicle is tagged private;
-
- procedure Create ( The_Vehicle : out Vehicle; TC_Flag : Natural );
- procedure Start ( The_Vehicle : in out Vehicle );
-
-private
-
- type Vehicle is tagged record
- Engine_On : Boolean;
- end record;
-
-end C392004_1;
-
-package body C392004_1 is
- procedure Create ( The_Vehicle : out Vehicle; TC_Flag : Natural ) is
- begin
- case TC_Flag is
- when 1 => null; -- expected flag for this subprogram
- when others =>
- Report.Failed ("Called Vehicle Create");
- end case;
- The_Vehicle := (Engine_On => False);
- end Create;
-
- procedure Start ( The_Vehicle : in out Vehicle ) is
- begin
- The_Vehicle.Engine_On := True;
- end Start;
-
-end C392004_1;
-
-----------------------------------------------------------------------------
-
-with C392004_1;
-package C392004_2 is
-
- type Car is new C392004_1.Vehicle with record
- Convertible : Boolean;
- end record;
-
- -- masking definition
- procedure Create( The_Car : out Car; TC_Flag : Natural );
-
- type Limo is new Car with null record;
-
- procedure Create( The_Limo : out Limo; TC_Flag : Natural );
-
-end C392004_2;
-
-----------------------------------------------------------------------------
-
-with Report;
-package body C392004_2 is
-
- procedure Create( The_Car : out Car; TC_Flag : Natural ) is
- begin
- case TC_Flag is
- when 2 => null; -- expected flag for this subprogram
- when others => Report.Failed ("Called Car Create");
- end case;
- C392004_1.Create( C392004_1.Vehicle(The_Car), 1);
- The_Car.Convertible := False;
- end Create;
-
- procedure Create( The_Limo : out Limo; TC_Flag : Natural ) is
- begin
- case TC_Flag is
- when 3 => null; -- expected flag for this subprogram
- when others => Report.Failed ("Called Limo Create");
- end case;
- C392004_1.Create( C392004_1.Vehicle(The_Limo), 1);
- The_Limo.Convertible := True;
- end Create;
-
-end C392004_2;
-
-----------------------------------------------------------------------------
-
-with Report;
-with C392004_1; use C392004_1;
-with C392004_2; use C392004_2;
-procedure C392004 is
-
- My_Car : Car;
- Your_Car : Limo;
-
- procedure TC_Assert( Is_True : Boolean; Message : String ) is
- begin
- if not Is_True then
- Report.Failed (Message);
- end if;
- end TC_Assert;
-
-begin -- Main test procedure.
-
- Report.Test ("C392004", "Check subprogram inheritance & visibility " &
- "for derived tagged types" );
-
- My_Car.Convertible := False;
- Create( Vehicle( My_Car ), 1 );
- TC_Assert( not My_Car.Convertible, "Altered descendent component 1");
-
- Create( Your_Car, 3 );
- TC_Assert( Your_Car.Convertible, "Did not set inherited component 2");
-
- My_Car.Convertible := True;
- Create( Vehicle( My_Car ), 1 );
- TC_Assert( My_Car.Convertible, "Altered descendent component 3");
-
- Create( My_Car, 2 );
- TC_Assert( not My_Car.Convertible, "Did not set extending component 4");
-
- My_Car.Convertible := False;
- Start( Vehicle( My_Car ) );
- TC_Assert( not My_Car.Convertible , "Altered descendent component 5");
-
- Start( My_Car );
- TC_Assert( not My_Car.Convertible, "Altered unreferenced component 6");
-
- Your_Car.Convertible := False;
- Start( Vehicle( Your_Car ) );
- TC_Assert( not Your_Car.Convertible , "Altered descendent component 7");
-
- Start( Your_Car );
- TC_Assert( not Your_Car.Convertible, "Altered unreferenced component 8");
-
- My_Car.Convertible := True;
- Start( Vehicle( My_Car ) );
- TC_Assert( My_Car.Convertible, "Altered descendent component 9");
-
- Start( My_Car );
- TC_Assert( My_Car.Convertible, "Altered unreferenced component 10");
-
- Report.Result;
-
-end C392004;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c392005.a b/gcc/testsuite/ada/acats/tests/c3/c392005.a
deleted file mode 100644
index be49cd48b75..00000000000
--- a/gcc/testsuite/ada/acats/tests/c3/c392005.a
+++ /dev/null
@@ -1,367 +0,0 @@
--- C392005.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that, for an implicitly declared dispatching operation that is
--- overridden, the body executed is the body for the overriding
--- subprogram, even if the overriding occurs in a private part.
---
--- Check for the case where the overriding operations are declared in a
--- public child unit of the package declaring the parent type, and the
--- descendant type is a private extension.
---
--- Check for both dispatching and nondispatching calls.
---
---
--- TEST DESCRIPTION:
--- Consider:
---
--- package Parent is
--- type Root is tagged ...
--- procedure Vis_Op (P: Root);
--- private
--- procedure Pri_Op (P: Root);
--- end Parent;
---
--- package Parent.Child is
--- type Derived is new Root with private;
--- -- Implicit Vis_Op (P: Derived) declared here.
---
--- procedure Pri_Op (P: Derived); -- (A)
--- ...
--- private
--- type Derived is new Root with record...
--- -- Implicit Pri_Op (P: Derived) declared here.
-
--- procedure Vis_Op (P: Derived); -- (B)
--- ...
--- end Parent.Child;
---
--- Type Derived inherits both Vis_Op and Pri_Op from the ancestor type
--- Root. Note, however, that Vis_Op is implicitly declared in the visible
--- part, whereas Pri_Op is implicitly declared in the private part
--- (inherited subprograms for a private extension are implicitly declared
--- after the private_extension_declaration if the corresponding
--- declaration from the ancestor is visible at that place; otherwise the
--- inherited subprogram is not declared for the private extension,
--- although it might be for the full type).
---
--- Even though Root's version of Pri_Op hasn't been implicitly declared
--- for Derived at the time Derived's version of Pri_Op has been
--- explicitly declared, the explicit Pri_Op still overrides the implicit
--- version.
--- Also, even though the explicit Vis_Op for Derived is declared in the
--- private part it still overrides the implicit version declared in the
--- visible part. Calls with tag Derived will execute (A) and (B).
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 26 Nov 96 SAIC Improved for ACVC 2.1
---
---!
-
-package C392005_0 is
-
- type Remote_Camera is tagged private;
-
- type Depth_Of_Field is range 5 .. 100;
- type Shutter_Speed is (One, Two_Fifty, Four_Hundred, Thousand);
- type Aperture is (Eight, Sixteen, Thirty_Two);
-
- -- ...Other declarations.
-
- procedure Focus (Cam : in out Remote_Camera;
- Depth : in Depth_Of_Field);
-
- procedure Self_Test (C: in out Remote_Camera'Class);
-
- -- ...Other operations.
-
- function TC_Get_Depth (C: Remote_Camera) return Depth_Of_Field;
- function TC_Get_Speed (C: Remote_Camera) return Shutter_Speed;
-
-private
-
- type Remote_Camera is tagged record
- DOF : Depth_Of_Field := 10;
- Shutter: Shutter_Speed := One;
- FStop : Aperture := Eight;
- end record;
-
- procedure Set_Shutter_Speed (C : in out Remote_Camera;
- Speed : in Shutter_Speed);
-
- -- For the basic remote camera, shutter speed might be set as a function of
- -- focus perhaps, thus it is declared as a private operation (usable
- -- only internally within the abstraction).
-
- function Set_Aperture (C : Remote_Camera) return Aperture;
-
-end C392005_0;
-
-
- --==================================================================--
-
-
-package body C392005_0 is
-
- procedure Focus (Cam : in out Remote_Camera;
- Depth : in Depth_Of_Field) is
- begin
- -- Artificial for testing purposes.
- Cam.DOF := 46;
- end Focus;
-
- -----------------------------------------------------------
- procedure Set_Shutter_Speed (C : in out Remote_Camera;
- Speed : in Shutter_Speed) is
- begin
- -- Artificial for testing purposes.
- C.Shutter := Thousand;
- end Set_Shutter_Speed;
-
- -----------------------------------------------------------
- function Set_Aperture (C : Remote_Camera) return Aperture is
- begin
- -- Artificial for testing purposes.
- return Thirty_Two;
- end Set_Aperture;
-
- -----------------------------------------------------------
- procedure Self_Test (C: in out Remote_Camera'Class) is
- TC_Dummy_Depth : constant Depth_Of_Field := 23;
- TC_Dummy_Speed : constant Shutter_Speed := Four_Hundred;
- begin
-
- -- Test focus at various depths:
- Focus(C, TC_Dummy_Depth);
- -- ...Additional calls to Focus.
-
- -- Test various shutter speeds:
- Set_Shutter_Speed(C, TC_Dummy_Speed);
- -- ...Additional calls to Set_Shutter_Speed.
-
- end Self_Test;
-
- -----------------------------------------------------------
- function TC_Get_Depth (C: Remote_Camera) return Depth_Of_Field is
- begin
- return C.DOF;
- end TC_Get_Depth;
-
- -----------------------------------------------------------
- function TC_Get_Speed (C: Remote_Camera) return Shutter_Speed is
- begin
- return C.Shutter;
- end TC_Get_Speed;
-
-end C392005_0;
-
- --==================================================================--
-
-
-package C392005_0.C392005_1 is
-
- type Auto_Speed is new Remote_Camera with private;
-
-
- -- procedure Focus (C : in out Auto_Speed; -- Implicitly declared
- -- Depth : in Depth_Of_Field) -- here.
-
- -- For the improved remote camera, shutter speed can be set manually,
- -- so it is declared as a public operation.
-
- -- The order of declarations for Set_Aperture and Set_Shutter_Speed are
- -- reversed from the original declarations to trap potential compiler
- -- problems related to subprogram ordering.
-
- function Set_Aperture (C : Auto_Speed) return Aperture; -- Overrides
- -- inherited op.
-
- procedure Set_Shutter_Speed (C : in out Auto_Speed; -- Overrides
- Speed : in Shutter_Speed);-- inherited op.
-
- -- Set_Shutter_Speed and Set_Aperture override the operations inherited
- -- from the parent, even though the inherited operations are not implicitly
- -- declared until the private part below.
-
- type New_Camera is private;
-
- function TC_Get_Aper (C: New_Camera) return Aperture;
-
- -- ...Other operations.
-
-private
- type Film_Speed is (One_Hundred, Two_Hundred, Four_Hundred);
-
- type Auto_Speed is new Remote_Camera with record
- ASA : Film_Speed;
- end record;
-
- -- procedure Set_Shutter_Speed (C : in out Auto_Speed; -- Implicitly
- -- Speed : in Shutter_Speed) -- declared
- -- here.
-
- -- function Set_Aperture (C : Auto_Speed) return Aperture; -- Implicitly
- -- declared.
-
- procedure Focus (C : in out Auto_Speed; -- Overrides
- Depth : in Depth_Of_Field); -- inherited op.
-
- -- For the improved remote camera, perhaps the focusing algorithm is
- -- different, so the original Focus operation is overridden here.
-
- Auto_Camera : Auto_Speed;
-
- type New_Camera is record
- Aper : Aperture := Set_Aperture (Auto_Camera); -- Calls the overridden,
- end record; -- not the inherited op.
-
-end C392005_0.C392005_1;
-
-
- --==================================================================--
-
-
-package body C392005_0.C392005_1 is
-
- procedure Focus (C : in out Auto_Speed;
- Depth : in Depth_Of_Field) is
- begin
- -- Artificial for testing purposes.
- C.DOF := 57;
- end Focus;
-
- ---------------------------------------------------------------
- procedure Set_Shutter_Speed (C : in out Auto_Speed;
- Speed : in Shutter_Speed) is
- begin
- -- Artificial for testing purposes.
- C.Shutter := Two_Fifty;
- end Set_Shutter_Speed;
-
- -----------------------------------------------------------
- function Set_Aperture (C : Auto_Speed) return Aperture is
- begin
- -- Artificial for testing purposes.
- return Sixteen;
- end Set_Aperture;
-
- -----------------------------------------------------------
- function TC_Get_Aper (C: New_Camera) return Aperture is
- begin
- return C.Aper;
- end TC_Get_Aper;
-
-end C392005_0.C392005_1;
-
-
- --==================================================================--
-
-
-with C392005_0.C392005_1;
-
-with Report;
-
-procedure C392005 is
- Basic_Camera : C392005_0.Remote_Camera;
- Auto_Camera1 : C392005_0.C392005_1.Auto_Speed;
- Auto_Camera2 : C392005_0.C392005_1.Auto_Speed;
- Auto_Depth : C392005_0.Depth_Of_Field := 67;
- New_Camera1 : C392005_0.C392005_1.New_Camera;
- TC_Expected_Basic_Depth : constant C392005_0.Depth_Of_Field := 46;
- TC_Expected_Auto_Depth : constant C392005_0.Depth_Of_Field := 57;
- TC_Expected_Basic_Speed : constant C392005_0.Shutter_Speed
- := C392005_0.Thousand;
- TC_Expected_Auto_Speed : constant C392005_0.Shutter_Speed
- := C392005_0.Two_Fifty;
- TC_Expected_New_Aper : constant C392005_0.Aperture
- := C392005_0.Sixteen;
-
- use type C392005_0.Depth_Of_Field;
- use type C392005_0.Shutter_Speed;
- use type C392005_0.Aperture;
-
-begin
- Report.Test ("C392005", "Dispatching for overridden primitive " &
- "subprograms: private extension declared in child unit, " &
- "parent is tagged private whose full view is tagged record");
-
--- Call the class-wide operation for Remote_Camera'Class, which itself makes
--- dispatching calls to Focus and Set_Shutter_Speed:
-
-
- -- For an object of type Remote_Camera, the dispatching calls should
- -- dispatch to the bodies declared for the root type:
-
- C392005_0.Self_Test(Basic_Camera);
-
- if C392005_0.TC_Get_Depth (Basic_Camera) /= TC_Expected_Basic_Depth
- or else C392005_0.TC_Get_Speed (Basic_Camera) /= TC_Expected_Basic_Speed
- then
- Report.Failed ("Calls dispatched incorrectly for root type");
- end if;
-
-
- -- For an object of type Auto_Speed, the dispatching calls should
- -- dispatch to the bodies declared for the derived type:
-
- C392005_0.Self_Test(Auto_Camera1);
-
- if C392005_0.C392005_1.TC_Get_Depth(Auto_Camera1) /= TC_Expected_Auto_Depth
-
- or
- C392005_0.C392005_1.TC_Get_Speed(Auto_Camera1) /= TC_Expected_Auto_Speed
- then
- Report.Failed ("Calls dispatched incorrectly for derived type");
- end if;
-
- -- For an object of type Auto_Speed, a non-dispatching call to Focus should
-
- -- execute the body declared for the derived type (even through it is
- -- declared in the private part).
-
- C392005_0.C392005_1.Focus (Auto_Camera2, Auto_Depth);
-
- if C392005_0.C392005_1.TC_Get_Depth(Auto_Camera2) /= TC_Expected_Auto_Depth
-
- then
- Report.Failed ("Non-dispatching call to privately overriding " &
- "subprogram executed the wrong body");
- end if;
-
- -- For an object of type New_Camera, the initialization using Set_Ap
- -- should execute the overridden body, not the inherited one.
-
- if C392005_0.C392005_1.TC_Get_Aper (New_Camera1) /= TC_Expected_New_Aper
- then
- Report.Failed ("Non-dispatching call to visible overriding " &
- "subprogram executed the wrong body");
- end if;
-
- Report.Result;
-
-end C392005;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c392008.a b/gcc/testsuite/ada/acats/tests/c3/c392008.a
deleted file mode 100644
index 27b4e2a8644..00000000000
--- a/gcc/testsuite/ada/acats/tests/c3/c392008.a
+++ /dev/null
@@ -1,401 +0,0 @@
--- C392008.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that the use of a class-wide formal parameter allows for the
--- proper dispatching of objects to the appropriate implementation of
--- a primitive operation. Check this for the case where the root tagged
--- type is defined in a package and the extended type is defined in a
--- dependent package.
---
--- TEST DESCRIPTION:
--- Declare a root tagged type, and some associated primitive operations,
--- in a visible library package.
--- Extend the root type in another visible library package, and override
--- one or more primitive operations, inheriting the other primitive
--- operations from the root type.
--- Derive from the extended type in yet another visible library package,
--- again overriding some primitive operations and inheriting others
--- (including some that the parent inherited).
--- Define subprograms with class-wide parameters, inside of which is a
--- call on a dispatching primitive operation. These primitive
--- operations modify the objects of the specific class passed as actuals
--- to the class-wide formal parameter (class-wide formal parameter has
--- mode IN OUT).
---
--- The following hierarchy of tagged types and primitive operations is
--- utilized in this test:
---
--- package Bank
--- type Account (root)
--- |
--- | Operations
--- | proc Deposit
--- | proc Withdrawal
--- | func Balance
--- | proc Service_Charge
--- | proc Add_Interest
--- | proc Open
--- |
--- package Checking
--- type Account (extended from Bank.Account)
--- |
--- | Operations
--- | proc Deposit (inherited)
--- | proc Withdrawal (inherited)
--- | func Balance (inherited)
--- | proc Service_Charge (inherited)
--- | proc Add_Interest (inherited)
--- | proc Open (overridden)
--- |
--- package Interest_Checking
--- type Account (extended from Checking.Account)
--- |
--- | Operations
--- | proc Deposit (inherited twice - Bank.Acct.)
--- | proc Withdrawal (inherited twice - Bank.Acct.)
--- | func Balance (inherited twice - Bank.Acct.)
--- | proc Service_Charge (inherited twice - Bank.Acct.)
--- | proc Add_Interest (overridden)
--- | proc Open (overridden)
--- |
---
--- In this test, we are concerned with the following selection of dispatching
--- calls, accomplished with the use of a Bank.Account'Class IN OUT formal
--- parameter :
---
--- \ Type
--- Prim. Op \ Bank.Account Checking.Account Interest_Checking.Account
--- \---------------------------------------------------------
-
--- Service_Charge | X X X
--- Add_Interest | X X X
--- Open | X X X
---
---
---
--- The location of the declaration of the root and derivation of extended
--- types will be varied over a series of tests. Locations of declaration
--- and derivation for a particular test are marked with an asterisk (*).
---
--- Root type:
---
--- * Declared in package.
--- Declared in generic package.
---
--- Extended types:
---
--- Derived in parent location.
--- Derived in a nested package.
--- Derived in a nested subprogram.
--- Derived in a nested generic package.
--- * Derived in a separate package.
--- Derived in a separate visible child package.
--- Derived in a separate private child package.
---
--- Primitive Operations:
---
--- * Procedures with same parameter profile.
--- Procedures with different parameter profile.
--- Functions with same parameter profile.
--- Functions with different parameter profile.
--- Mixture of Procedures and Functions.
---
---
--- TEST FILES:
--- This test depends on the following foundation code:
---
--- C392008_0.A
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 20 Nov 95 SAIC C392B04 became C392008 for ACVC 2.0.1
---
---!
-
------------------------------------------------------------------ C392008_0
-
-package C392008_0 is -- package Bank
-
- type Dollar_Amount is range -30_000..30_000;
-
- type Account is tagged
- record
- Current_Balance: Dollar_Amount;
- end record;
-
- -- Primitive operations.
-
- procedure Deposit (A : in out Account;
- X : in Dollar_Amount);
- procedure Withdrawal (A : in out Account;
- X : in Dollar_Amount);
- function Balance (A : in Account) return Dollar_Amount;
- procedure Service_Charge (A : in out Account);
- procedure Add_Interest (A : in out Account);
- procedure Open (A : in out Account);
-
-end C392008_0;
-
--- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
-
-package body C392008_0 is
-
- -- Primitive operations for type Account.
-
- procedure Deposit (A : in out Account;
- X : in Dollar_Amount) is
- begin
- A.Current_Balance := A.Current_Balance + X;
- end Deposit;
-
- procedure Withdrawal(A : in out Account;
- X : in Dollar_Amount) is
- begin
- A.Current_Balance := A.Current_Balance - X;
- end Withdrawal;
-
- function Balance (A : in Account) return Dollar_Amount is
- begin
- return (A.Current_Balance);
- end Balance;
-
- procedure Service_Charge (A : in out Account) is
- begin
- A.Current_Balance := A.Current_Balance - 5_00;
- end Service_Charge;
-
- procedure Add_Interest (A : in out Account) is
- Interest_On_Account : Dollar_Amount := 0_00;
- begin
- A.Current_Balance := A.Current_Balance + Interest_On_Account;
- end Add_Interest;
-
- procedure Open (A : in out Account) is
- Initial_Deposit : Dollar_Amount := 10_00;
- begin
- A.Current_Balance := Initial_Deposit;
- end Open;
-
-end C392008_0;
-
------------------------------------------------------------------ C392008_1
-
-with C392008_0; -- package Bank
-
-package C392008_1 is -- package Checking
-
- package Bank renames C392008_0;
-
- type Account is new Bank.Account with
- record
- Overdraft_Fee : Bank.Dollar_Amount;
- end record;
-
- -- Overridden primitive operation.
-
- procedure Open (A : in out Account);
-
- -- Inherited primitive operations.
- -- procedure Deposit (A : in out Account;
- -- X : in Bank.Dollar_Amount);
- -- procedure Withdrawal (A : in out Account;
- -- X : in Bank.Dollar_Amount);
- -- function Balance (A : in Account) return Bank.Dollar_Amount;
- -- procedure Service_Charge (A : in out Account);
- -- procedure Add_Interest (A : in out Account);
-
-end C392008_1;
-
--- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
-
-package body C392008_1 is
-
- -- Overridden primitive operation.
-
- procedure Open (A : in out Account) is
- Check_Guarantee : Bank.Dollar_Amount := 10_00;
- Initial_Deposit : Bank.Dollar_Amount := 20_00;
- begin
- A.Current_Balance := Initial_Deposit;
- A.Overdraft_Fee := Check_Guarantee;
- end Open;
-
-end C392008_1;
-
------------------------------------------------------------------ C392008_2
-
-with C392008_0; -- with Bank;
-with C392008_1; -- with Checking;
-
-package C392008_2 is -- package Interest_Checking
-
- package Bank renames C392008_0;
- package Checking renames C392008_1;
-
- subtype Interest_Rate is Bank.Dollar_Amount range 0..100; -- was digits 4;
-
- Current_Rate : Interest_Rate := 0_02;
-
- type Account is new Checking.Account with
- record
- Rate : Interest_Rate;
- end record;
-
- -- Overridden primitive operations.
-
- procedure Add_Interest (A : in out Account);
- procedure Open (A : in out Account);
-
- -- "Twice" inherited primitive operations (from Bank.Account)
- -- procedure Deposit (A : in out Account;
- -- X : in Bank.Dollar_Amount);
- -- procedure Withdrawal (A : in out Account;
- -- X : in Bank.Dollar_Amount);
- -- function Balance (A : in Account) return Bank.Dollar_Amount;
- -- procedure Service_Charge (A : in out Account);
-
-end C392008_2;
-
--- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
-
-package body C392008_2 is
-
- -- Overridden primitive operations.
-
- procedure Add_Interest (A : in out Account) is
- Interest_On_Account : Bank.Dollar_Amount
- := Bank.Dollar_Amount( Bank."*"( A.Current_Balance, A.Rate ));
- begin
- A.Current_Balance := Bank."+"( A.Current_Balance, Interest_On_Account);
- end Add_Interest;
-
- procedure Open (A : in out Account) is
- Initial_Deposit : Bank.Dollar_Amount := 30_00;
- begin
- Checking.Open (Checking.Account (A));
- A.Current_Balance := Initial_Deposit;
- A.Rate := Current_Rate;
- end Open;
-
-end C392008_2;
-
-------------------------------------------------------------------- C392008
-
-with C392008_0; use C392008_0; -- package Bank
-with C392008_1; use C392008_1; -- package Checking;
-with C392008_2; use C392008_2; -- package Interest_Checking;
-with Report;
-
-procedure C392008 is
-
- package Bank renames C392008_0;
- package Checking renames C392008_1;
- package Interest_Checking renames C392008_2;
-
- B_Acct : Bank.Account;
- C_Acct : Checking.Account;
- IC_Acct : Interest_Checking.Account;
-
- --
- -- Define procedures with class-wide formal parameters of mode IN OUT.
- --
-
- -- This procedure will perform a dispatching call on the
- -- overridden primitive operation Open.
-
- procedure New_Account (Acct : in out Bank.Account'Class) is
- begin
- Open (Acct); -- Dispatch according to tag of class-wide parameter.
- end New_Account;
-
- -- This procedure will perform a dispatching call on the inherited
- -- primitive operation (for all types derived from the root Bank.Account)
- -- Service_Charge.
-
- procedure Apply_Service_Charge (Acct: in out Bank.Account'Class) is
- begin
- Service_Charge (Acct); -- Dispatch according to tag of class-wide parm.
- end Apply_Service_Charge;
-
- -- This procedure will perform a dispatching call on the
- -- inherited/overridden primitive operation Add_Interest.
-
- procedure Annual_Interest (Acct: in out Bank.Account'Class) is
- begin
- Add_Interest (Acct); -- Dispatch according to tag of class-wide parm.
- end Annual_Interest;
-
-begin
-
- Report.Test ("C392008", "Check that the use of a class-wide formal " &
- "parameter allows for the proper dispatching " &
- "of objects to the appropriate implementation " &
- "of a primitive operation");
-
- -- Check the dispatch to primitive operations overridden for each
- -- extended type.
- New_Account (B_Acct);
- New_Account (C_Acct);
- New_Account (IC_Acct);
-
- if (B_Acct.Current_Balance /= 10_00) or
- (C_Acct.Current_Balance /= 20_00) or
- (IC_Acct.Current_Balance /= 30_00)
- then
- Report.Failed ("Failed dispatch to multiply overridden prim. oper.");
- end if;
-
-
- Annual_Interest (B_Acct);
- Annual_Interest (C_Acct);
- Annual_Interest (IC_Acct); -- Check the dispatch to primitive operation
- -- overridden from a parent type which inherited
- -- the operation from the root type.
- if (B_Acct.Current_Balance /= 10_00) or
- (C_Acct.Current_Balance /= 20_00) or
- (IC_Acct.Current_Balance /= 90_00)
- then
- Report.Failed ("Failed dispatch to overridden primitive operation");
- end if;
-
-
- Apply_Service_Charge (Acct => B_Acct);
- Apply_Service_Charge (Acct => C_Acct);
- Apply_Service_Charge (Acct => IC_Acct); -- Check the dispatch to a
- -- primitive operation twice
- -- inherited from the root
- -- tagged type.
- if (B_Acct.Current_Balance /= 5_00) or
- (C_Acct.Current_Balance /= 15_00) or
- (IC_Acct.Current_Balance /= 85_00)
- then
- Report.Failed ("Failed dispatch to Apply_Service_Charge");
- end if;
-
- Report.Result;
-
-end C392008;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c392010.a b/gcc/testsuite/ada/acats/tests/c3/c392010.a
deleted file mode 100644
index ec168780cbf..00000000000
--- a/gcc/testsuite/ada/acats/tests/c3/c392010.a
+++ /dev/null
@@ -1,512 +0,0 @@
--- C392010.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that a subprogram dispatches correctly with a controlling
--- access parameter. Check that a subprogram dispatches correctly
--- when it has access parameters that are not controlling.
--- Check with and without default expressions.
---
--- TEST DESCRIPTION:
--- The three packages define layers of tagged types. The root tagged
--- type contains a character value used to check that the right object
--- got passed to the right routine. Each subprogram has a unique
--- TCTouch tag, upper case values are used for subprograms, lower case
--- values are used for object values.
---
--- Notes on style: the "tagged" comment lines --I and --A represent
--- commentary about what gets inherited and what becomes abstract,
--- respectively. The author felt these to be necessary with this test
--- to reduce some of the additional complexities.
---
---3.9.2(16,17,18,20);6.0
---
--- CHANGE HISTORY:
--- 22 SEP 95 SAIC Initial version
--- 22 APR 96 SAIC Revised for 2.1
--- 05 JAN 98 EDS Change return type of C392010_2.Func_W_Non to make
--- it override.
--- 21 JUN 00 RLB Changed expected result to reflect the appropriate
--- value of the default expression.
--- 20 JUL 00 RLB Removed entire call pending resolution by the ARG.
-
---!
-
------------------------------------------------------------------ C392010_0
-
-package C392010_0 is
-
- -- define a root tagged type
- type Tagtype_Level_0 is tagged record
- Ch_Item : Character;
- end record;
-
- type Access_Procedure is access procedure( P: Tagtype_Level_0 );
-
- procedure Proc_1( P: Tagtype_Level_0 );
-
- procedure Proc_2( P: Tagtype_Level_0 );
-
- function A_Default_Value return Tagtype_Level_0;
-
- procedure Proc_w_Ap_and_Cp( AP : Access_Procedure;
- Cp : Tagtype_Level_0 );
- -- has both access procedure and controlling parameter
-
- procedure Proc_w_Ap_and_Cp_w_Def( AP : Access_Procedure := Proc_2'Access;
- Cp : Tagtype_Level_0
- := A_Default_Value ); ------------ z
- -- has both access procedure and controlling parameter with defaults
-
- -- for the objective:
--- Check that access parameters may be controlling.
-
- procedure Proc_w_Cp_Ap( Cp_Ap : access Tagtype_Level_0 );
- -- has access parameter that is controlling
-
- function Func_w_Cp_Ap_and_Cr( Cp_Ap : access Tagtype_Level_0 )
- return Tagtype_Level_0;
- -- has access parameter that is controlling, and controlling result
-
- Level_0_Global_Object : aliased Tagtype_Level_0
- := ( Ch_Item => 'a' ); ---------------------------- a
-
-end C392010_0;
-
--- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
-
-with TCTouch;
-package body C392010_0 is
-
- procedure Proc_1( P: Tagtype_Level_0 ) is
- begin
- TCTouch.Touch('A'); --------------------------------------------------- A
- TCTouch.Touch(P.Ch_Item); -- depends on the value passed -------------- ?
- end Proc_1;
-
- procedure Proc_2( P: Tagtype_Level_0 ) is
- begin
- TCTouch.Touch('B'); --------------------------------------------------- B
- TCTouch.Touch(P.Ch_Item); -- depends on the value passed -------------- ?
- end Proc_2;
-
- function A_Default_Value return Tagtype_Level_0 is
- begin
- return (Ch_Item => 'z'); ---------------------------------------------- z
- end A_Default_Value;
-
- procedure Proc_w_Ap_and_Cp( Ap : Access_Procedure;
- Cp : Tagtype_Level_0 ) is
- begin
- TCTouch.Touch('C'); --------------------------------------------------- C
- Ap.all( Cp );
- end Proc_w_Ap_and_Cp;
-
- procedure Proc_w_Ap_and_Cp_w_Def( AP : Access_Procedure := Proc_2'Access;
- Cp : Tagtype_Level_0
- := A_Default_Value ) is
- begin
- TCTouch.Touch('D'); --------------------------------------------------- D
- Ap.all( Cp );
- end Proc_w_Ap_and_Cp_w_Def;
-
- procedure Proc_w_Cp_Ap( Cp_Ap : access Tagtype_Level_0 ) is
- begin
- TCTouch.Touch('E'); --------------------------------------------------- E
- TCTouch.Touch(Cp_Ap.Ch_Item); -- depends on the value passed ---------- ?
- end Proc_w_Cp_Ap;
-
- function Func_w_Cp_Ap_and_Cr( Cp_Ap : access Tagtype_Level_0 )
- return Tagtype_Level_0 is
- begin
- TCTouch.Touch('F'); --------------------------------------------------- F
- TCTouch.Touch(Cp_Ap.Ch_Item); -- depends on the value passed ---------- ?
- return ( Ch_Item => 'b' ); -------------------------------------------- b
- end Func_w_Cp_Ap_and_Cr;
-
-end C392010_0;
-
------------------------------------------------------------------ C392010_1
-
-with C392010_0;
-package C392010_1 is
-
- type Tagtype_Level_1 is new C392010_0.Tagtype_Level_0 with record
- Int_Item : Integer;
- end record;
-
- type Access_Tagtype_Level_1 is access all Tagtype_Level_1'Class;
-
- -- the following procedures are inherited by the above declaration:
- --I procedure Proc_1( P: Tagtype_Level_1 );
- --I
- --I procedure Proc_2( P: Tagtype_Level_1 );
- --I
- --I procedure Proc_w_Ap_and_Cp( AP : C392010_0.Access_Procedure;
- --I Cp : Tagtype_Level_1 );
- --I
- --I procedure Proc_w_Ap_and_Cp_w_Def
- --I ( AP : C392010_0.Access_Procedure := Proc_2'Access;
- --I Cp : Tagtype_Level_1 := A_Default_Value );
- --I
- --I procedure Proc_w_Cp_Ap( Cp_Ap : access Tagtype_Level_1 );
- --I
-
- -- the following functions become abstract due to the above declaration:
- --A function A_Default_Value return Tagtype_Level_1;
- --A
- --A function Func_w_Cp_Ap_and_Cr( Cp_Ap : access Tagtype_Level_1 )
- --A return Tagtype_Level_1;
-
- -- so, in the interest of testing dispatching, we override them all:
- -- except Proc_1 and Proc_2
-
- procedure Proc_w_Ap_and_Cp( AP : C392010_0.Access_Procedure;
- Cp : Tagtype_Level_1 );
-
- function A_Default_Value return Tagtype_Level_1;
-
- procedure Proc_w_Ap_and_Cp_w_Def(
- AP : C392010_0.Access_Procedure := C392010_0.Proc_2'Access;
- Cp : Tagtype_Level_1 := A_Default_Value );
-
- procedure Proc_w_Cp_Ap( Cp_Ap : access Tagtype_Level_1 );
-
- function Func_w_Cp_Ap_and_Cr( Cp_Ap : access Tagtype_Level_1 )
- return Tagtype_Level_1;
-
- -- to test the objective:
--- Check that a subprogram dispatches correctly when it has
--- access parameters that are not controlling.
-
- procedure Proc_w_Non( Cp_Ap : access Tagtype_Level_1;
- NonCp_Ap : access C392010_0.Tagtype_Level_0
- := C392010_0.Level_0_Global_Object'Access );
-
- function Func_w_Non( Cp_Ap : access Tagtype_Level_1;
- NonCp_Ap : access C392010_0.Tagtype_Level_0
- := C392010_0.Level_0_Global_Object'Access )
- return Access_Tagtype_Level_1;
-
- Level_1_Global_Object : aliased Tagtype_Level_1
- := ( Int_Item => 0,
- Ch_Item => 'c' ); --------------------------- c
-
-end C392010_1;
-
--- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
-
-with TCTouch;
-package body C392010_1 is
-
- procedure Proc_w_Ap_and_Cp( AP : C392010_0.Access_Procedure;
- Cp : Tagtype_Level_1 ) is
- begin
- TCTouch.Touch('G'); --------------------------------------------------- G
- Ap.All( C392010_0.Tagtype_Level_0( Cp ) );
- end Proc_w_Ap_and_Cp;
-
- procedure Proc_w_Ap_and_Cp_w_Def(
- AP : C392010_0.Access_Procedure := C392010_0.Proc_2'Access;
- Cp : Tagtype_Level_1 := A_Default_Value )
- is
- begin
- TCTouch.Touch('H'); --------------------------------------------------- H
- Ap.All( C392010_0.Tagtype_Level_0( Cp ) );
- end Proc_w_Ap_and_Cp_w_Def;
-
- procedure Proc_w_Cp_Ap( Cp_Ap : access Tagtype_Level_1 ) is
- begin
- TCTouch.Touch('I'); --------------------------------------------------- I
- TCTouch.Touch(Cp_Ap.Ch_Item); -- depends on the value passed ---------- ?
- end Proc_w_Cp_Ap;
-
- function A_Default_Value return Tagtype_Level_1 is
- begin
- return ( Int_Item => 0, Ch_Item => 'y' ); ---------------------------- y
- end A_Default_Value;
-
- function Func_w_Cp_Ap_and_Cr( Cp_Ap : access Tagtype_Level_1 )
- return Tagtype_Level_1 is
- begin
- TCTouch.Touch('J'); --------------------------------------------------- J
- TCTouch.Touch(Cp_Ap.Ch_Item); -- depends on the value passed ---------- ?
- return ( Int_Item => 2, Ch_Item => 'd' ); ----------------------------- d
- end Func_w_Cp_Ap_and_Cr;
-
- procedure Proc_w_Non( Cp_Ap : access Tagtype_Level_1;
- NonCp_Ap : access C392010_0.Tagtype_Level_0
- := C392010_0.Level_0_Global_Object'Access ) is
- begin
- TCTouch.Touch('K'); --------------------------------------------------- K
- TCTouch.Touch(Cp_Ap.Ch_Item); ----- depends on the value passed ------- ?
- TCTouch.Touch(NonCp_Ap.Ch_Item); -- depends on the value passed ------- ?
- end Proc_w_Non;
-
- Own_Item : aliased Tagtype_Level_1 := ( Int_Item => 3, Ch_Item => 'e' );
-
- function Func_w_Non( Cp_Ap : access Tagtype_Level_1;
- NonCp_Ap : access C392010_0.Tagtype_Level_0
- := C392010_0.Level_0_Global_Object'Access )
- return Access_Tagtype_Level_1 is
- begin
- TCTouch.Touch('L'); --------------------------------------------------- L
- TCTouch.Touch(Cp_Ap.Ch_Item); ----- depends on the value passed ------- ?
- TCTouch.Touch(NonCp_Ap.Ch_Item); -- depends on the value passed ------- ?
- return Own_Item'Access; ----------------------------------------------- e
- end Func_w_Non;
-
-end C392010_1;
-
-
-
------------------------------------------------------------------ C392010_2
-
-with C392010_0;
-with C392010_1;
-package C392010_2 is
-
- Lev2_Level_0_Global_Object : aliased C392010_0.Tagtype_Level_0
- := ( Ch_Item => 'f' ); ---------------------------- f
-
- type Tagtype_Level_2 is new C392010_1.Tagtype_Level_1 with record
- Another_Int_Item : Integer;
- end record;
-
- type Access_Tagtype_Level_2 is access all Tagtype_Level_2;
-
- -- the following procedures are inherited by the above declaration:
- --I procedure Proc_1( P: Tagtype_Level_2 );
- --I
- --I procedure Proc_2( P: Tagtype_Level_2 );
- --I
- --I procedure Proc_w_Ap_and_Cp( AP : C392010_0.Access_Procedure;
- --I Cp : Tagtype_Level_2 );
- --I
- --I procedure Proc_w_Ap_and_Cp_w_Def
- --I (AP: C392010_0.Access_Procedure := C392010_0. Proc_2'Access;
- --I CP: Tagtype_Level_2 := A_Default_Value );
- --I
- --I procedure Proc_w_Cp_Ap( Cp_Ap : access Tagtype_Level_2 );
- --I
- --I procedure Proc_w_Non( Cp_Ap : access Tagtype_Level_2;
- --I NonCp_Ap : access C392010_0.Tagtype_Level_0
- --I := C392010_0.Level_0_Global_Object'Access );
-
- -- the following functions become abstract due to the above declaration:
- --A function Func_w_Cp_Ap_and_Cr( Cp_Ap : access Tagtype_Level_2 )
- --A return Tagtype_Level_2;
- --A
- --A function A_Default_Value
- --A return Access_Tagtype_Level_2;
-
- -- so we override the interesting ones to check the objective:
--- Check that a subprogram with parameters of distinct tagged types may
--- be primitive for only one type (i.e. the other tagged types must be
--- declared in other packages). Check that the subprogram does not
--- dispatch for the other type(s).
-
- procedure Proc_w_Non( Cp_Ap : access Tagtype_Level_2;
- NonCp_Ap : access C392010_0.Tagtype_Level_0
- := Lev2_Level_0_Global_Object'Access );
-
- function Func_w_Non( Cp_Ap : access Tagtype_Level_2;
- NonCp_Ap : access C392010_0.Tagtype_Level_0
- := Lev2_Level_0_Global_Object'Access )
- return C392010_1.Access_Tagtype_Level_1;
-
- -- and override the other abstract functions
- function Func_w_Cp_Ap_and_Cr( Cp_Ap : access Tagtype_Level_2 )
- return Tagtype_Level_2;
-
- function A_Default_Value return Tagtype_Level_2;
-
-end C392010_2;
-
--- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
-
-with TCTouch;
-with Report;
-package body C392010_2 is
-
- procedure Proc_w_Non( Cp_Ap : access Tagtype_Level_2;
- NonCp_Ap : access C392010_0.Tagtype_Level_0
- := Lev2_Level_0_Global_Object'Access ) is
- begin
- TCTouch.Touch('M'); --------------------------------------------------- M
- TCTouch.Touch(Cp_Ap.Ch_Item); ----- depends on the value passed ------- ?
- TCTouch.Touch(NonCp_Ap.Ch_Item); -- depends on the value passed ------- ?
- end Proc_w_Non;
-
- function A_Default_Value return Tagtype_Level_2 is
- begin
- return ( Another_Int_Item | Int_Item => 0, Ch_Item => 'x' ); -------- x
- end A_Default_Value;
-
- Own : aliased Tagtype_Level_2
- := ( Another_Int_Item | Int_Item => 4, Ch_Item => 'g' );
-
- function Func_w_Non( Cp_Ap : access Tagtype_Level_2;
- NonCp_Ap : access C392010_0.Tagtype_Level_0
- := Lev2_Level_0_Global_Object'Access )
- return C392010_1.Access_Tagtype_Level_1 is
- begin
- TCTouch.Touch('N'); --------------------------------------------------- N
- TCTouch.Touch(Cp_Ap.Ch_Item); ----- depends on the value passed ------- ?
- TCTouch.Touch(NonCp_Ap.Ch_Item); -- depends on the value passed ------- ?
- return Own'Access; ---------------------------------------------------- g
- end Func_w_Non;
-
- function Func_w_Cp_Ap_and_Cr( Cp_Ap : access Tagtype_Level_2 )
- return Tagtype_Level_2 is
- begin
- TCTouch.Touch('P'); --------------------------------------------------- P
- TCTouch.Touch(Cp_Ap.Ch_Item); ----- depends on the value passed ------- ?
- return ( Another_Int_Item | Int_Item => 5, Ch_Item => 'h' ); ---------- h
- end Func_w_Cp_Ap_and_Cr;
-
-end C392010_2;
-
-
-
-------------------------------------------------------------------- C392010
-
-with Report;
-with TCTouch;
-with C392010_0, C392010_1, C392010_2;
-
-procedure C392010 is
-
- type Access_Class_0 is access all C392010_0.Tagtype_Level_0'Class;
-
- -- define an array of class-wide pointers:
- type Zero_Dispatch_List is array(Natural range <>) of Access_Class_0;
-
- Item_0 : aliased C392010_0.Tagtype_Level_0 := ( Ch_Item => 'k' ); ------ k
- Item_1 : aliased C392010_1.Tagtype_Level_1 := ( Ch_Item => 'm', ------ m
- Int_Item => 1 );
- Item_2 : aliased C392010_2.Tagtype_Level_2 := ( Ch_Item => 'n', ------ n
- Int_Item => 1,
- Another_Int_Item => 1 );
-
- Z: Zero_Dispatch_List(1..3) := (Item_0'Access,Item_1'Access,Item_2'Access);
-
- procedure Subtest_1( Items: Zero_Dispatch_List ) is
- -- there is little difference between the actions for _1 and _2 in
- -- this subtest due to the nature of _2 inheriting most operations
- --
- -- this subtest checks operations available to Level_0'Class
- begin
- for I in Items'Range loop
-
- C392010_0.Proc_w_Ap_and_Cp( C392010_0.Proc_1'Access, Items(I).all );
- -- CAk, GAm, GAn
- -- actual is class-wide, operation should dispatch
-
- case I is -- use defaults
- when 1 => C392010_0.Proc_w_Ap_and_Cp_w_Def;
- -- DBz
- when 2 => C392010_1.Proc_w_Ap_and_Cp_w_Def;
- -- HBy
- when 3 => null; -- Removed following pending resolution by ARG
- -- (see AI-00239):
- -- C392010_2.Proc_w_Ap_and_Cp_w_Def;
- -- HBx
- when others => Report.Failed("Unexpected loop value");
- end case;
-
- C392010_0.Proc_w_Ap_and_Cp_w_Def -- override defaults
- ( C392010_0.Proc_1'Access, Items(I).all );
- -- DAk, HAm, HAn
-
- C392010_0.Proc_w_Cp_Ap( Items(I) );
- -- Ek, Im, In
-
- -- function return value is controlling for procedure call
- C392010_0.Proc_w_Ap_and_Cp_w_Def( C392010_0.Proc_1'Access,
- C392010_0.Func_w_Cp_Ap_and_Cr( Items(I) ) );
- -- FkDAb, JmHAd, PnHAh
- -- note that the function evaluates first
-
- end loop;
- end Subtest_1;
-
--- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
-
- type Access_Class_1 is access all C392010_1.Tagtype_Level_1'Class;
-
- type One_Dispatch_List is array(Natural range <>) of Access_Class_1;
-
- Object_1 : aliased C392010_1.Tagtype_Level_1 := ( Ch_Item => 'p', ----- p
- Int_Item => 1 );
- Object_2 : aliased C392010_2.Tagtype_Level_2 := ( Ch_Item => 'q', ----- q
- Int_Item => 1,
- Another_Int_Item => 1 );
-
- D: One_Dispatch_List(1..2) := (Object_1'Access, Object_2'Access);
-
- procedure Subtest_2( Items: One_Dispatch_List ) is
- -- this subtest checks operations available to Level_1'Class,
- -- specifically those operations that are not testable in subtest_1,
- -- the operations with parameters of the two tagged type objects.
- begin
- for I in Items'Range loop
-
- C392010_1.Proc_w_Non( -- t_1, t_2
- C392010_1.Func_w_Non( Items(I),
- C392010_0.Tagtype_Level_0(Z(I).all)'Access ), -- Lpk Nqm
- C392010_0.Tagtype_Level_0(Z(I+1).all)'Access ); -- Kem Mgn
-
- end loop;
- end Subtest_2;
-
-begin -- Main test procedure.
-
- Report.Test ("C392010", "Check that a subprogram dispatches correctly " &
- "with a controlling access parameter. " &
- "Check that a subprogram dispatches correctly " &
- "when it has access parameters that are not " &
- "controlling. Check with and without default " &
- "expressions" );
-
- Subtest_1( Z );
-
- -- Original result:
- --TCTouch.Validate( "CAkDBzDAkEkFkDAb"
- -- & "GAmHByHAmImJmHAd"
- -- & "GAnHBxHAnInPnHAh", "Subtest 1" );
-
- -- Result pending resultion of AI-239:
- TCTouch.Validate( "CAkDBzDAkEkFkDAb"
- & "GAmHByHAmImJmHAd"
- & "GAnHAnInPnHAh", "Subtest 1" );
-
- Subtest_2( D );
-
- TCTouch.Validate( "LpkKem" & "NqmMgn", "Subtest 2" );
-
- Report.Result;
-
-end C392010;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c392011.a b/gcc/testsuite/ada/acats/tests/c3/c392011.a
deleted file mode 100644
index c32ec77c0d0..00000000000
--- a/gcc/testsuite/ada/acats/tests/c3/c392011.a
+++ /dev/null
@@ -1,299 +0,0 @@
--- C392011.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that if a function call with a controlling result is itself
--- a controlling operand of an enclosing call on a dispatching operation,
--- then its controlling tag value is determined by the controlling tag
--- value of the enclosing call.
---
--- TEST DESCRIPTION:
--- The test builds and traverses a "ragged" list; a linked list which
--- contains data elements of three different types (all rooted at
--- Level_0'Class). The traversal of this list checks the objective
--- by calling the dispatching operation "Check" using an item from the
--- list, and calling the function create; thus causing the controlling
--- result of the function to be determined by evaluating the value of
--- the other controlling parameter to the two-parameter Check.
---
---
--- CHANGE HISTORY:
--- 22 SEP 95 SAIC Initial version
--- 23 APR 96 SAIC Corrected commentary, differentiated integer.
---
---!
-
------------------------------------------------------------------ C392011_0
-
-package C392011_0 is
-
- type Level_0 is tagged record
- Ch_Item : Character;
- end record;
-
- function Create return Level_0;
- -- primitive dispatching function
-
- procedure Check( Left, Right: in Level_0 );
- -- has controlling parameters
-
-end C392011_0;
-
--- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
-
-with Report;
-with TCTouch;
-package body C392011_0 is
-
- The_Character : Character := 'A';
-
- function Create return Level_0 is
- Created_Item_0 : constant Level_0 := ( Ch_Item => The_Character );
- begin
- The_Character := Character'Succ(The_Character);
- TCTouch.Touch('A'); -- --- ---- ----- ---- --- -- --- ---- ----- ---- -- A
- return Created_Item_0;
- end Create;
-
- procedure Check( Left, Right: in Level_0 ) is
- begin
- TCTouch.Touch('B'); -- --- ---- ----- ---- --- -- --- ---- ----- ---- -- B
- end Check;
-
-end C392011_0;
-
------------------------------------------------------------------ C392011_1
-
-with C392011_0;
-package C392011_1 is
-
- type Level_1 is new C392011_0.Level_0 with record
- Int_Item : Integer;
- end record;
-
- -- note that Create becomes abstract upon this derivation hence:
-
- function Create return Level_1;
-
- procedure Check( Left, Right: in Level_1 );
-
-end C392011_1;
-
--- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
-
-with TCTouch;
-package body C392011_1 is
-
- Integer_1 : Integer := 0;
-
- function Create return Level_1 is
- Created_Item_1 : constant Level_1
- := ( C392011_0.Create with Int_Item => Integer_1 );
- -- note call to ^--------------^ -- A
- begin
- Integer_1 := Integer'Succ(Integer_1);
- TCTouch.Touch('C'); -- --- ---- ----- ---- --- -- --- ---- ----- ---- -- C
- return Created_Item_1;
- end Create;
-
- procedure Check( Left, Right: in Level_1 ) is
- begin
- TCTouch.Touch('D'); -- --- ---- ----- ---- --- -- --- ---- ----- ---- -- D
- end Check;
-
-end C392011_1;
-
------------------------------------------------------------------ C392011_2
-
-with C392011_1;
-package C392011_2 is
-
- type Level_2 is new C392011_1.Level_1 with record
- Another_Int_Item : Integer;
- end record;
-
- -- note that Create becomes abstract upon this derivation hence:
-
- function Create return Level_2;
-
- procedure Check( Left, Right: in Level_2 );
-
-end C392011_2;
-
--- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
-
-with TCTouch;
-package body C392011_2 is
-
- Integer_2 : Integer := 100;
-
- function Create return Level_2 is
- Created_Item_2 : constant Level_2
- := ( C392011_1.Create with Another_Int_Item => Integer_2 );
- -- note call to ^--------------^ -- AC
- begin
- Integer_2 := Integer'Succ(Integer_2);
- TCTouch.Touch('E'); -- --- ---- ----- ---- --- -- --- ---- ----- ---- -- E
- return Created_Item_2;
- end Create;
-
- procedure Check( Left, Right: in Level_2 ) is
- begin
- TCTouch.Touch('F'); -- --- ---- ----- ---- --- -- --- ---- ----- ---- -- F
- end Check;
-
-end C392011_2;
-
-------------------------------------------------------- C392011_2.C392011_3
-
-with C392011_0;
-package C392011_2.C392011_3 is
-
- type Wide_Reference is access all C392011_0.Level_0'Class;
-
- type Ragged_Element;
-
- type List_Pointer is access Ragged_Element;
-
- type Ragged_Element is record
- Data : Wide_Reference;
- Next : List_Pointer;
- end record;
-
- procedure Build_List;
-
- procedure Traverse_List;
-
-end C392011_2.C392011_3;
-
--- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
-
-package body C392011_2.C392011_3 is
-
- The_List : List_Pointer;
-
- procedure Build_List is
- begin
-
- -- build a list that looks like:
- -- Level_2, Level_1, Level_2, Level_1, Level_0
- --
- -- the mechanism is to create each object, "pushing" the existing list
- -- onto the end: cons( new_item, car, cdr )
-
- The_List :=
- new Ragged_Element'( new C392011_0.Level_0'(C392011_0.Create), null );
- -- Level_0 >> A
-
- The_List :=
- new Ragged_Element'( new C392011_1.Level_1'(C392011_1.Create), The_List );
- -- Level_1 -> Level_0 >> AC
-
- The_List :=
- new Ragged_Element'( new C392011_2.Level_2'(C392011_2.Create), The_List );
- -- Level_2 -> Level_1 -> Level_0 >> ACE
-
- The_List :=
- new Ragged_Element'( new C392011_1.Level_1'(C392011_1.Create), The_List );
- -- Level_1 -> Level_2 -> Level_1 -> Level_0 >> AC
-
- The_List :=
- new Ragged_Element'( new C392011_2.Level_2'(C392011_2.Create), The_List );
- -- Level_2 -> Level_1 -> Level_2 -> Level_1 -> Level_0 >> ACE
-
- end Build_List;
-
- procedure Traverse_List is
-
- Next_Item : List_Pointer := The_List;
-
- -- Check that if a function call with a controlling result is itself
- -- a controlling operand of an enclosing call on a dispatching operation,
- -- then its controlling tag value is determined by the controlling tag
- -- value of the enclosing call.
-
- -- Level_2 -> Level_1 -> Level_2 -> Level_1 -> Level_0
-
- begin
-
- while Next_Item /= null loop -- here we go!
- -- these calls better dispatch according to the value in the particular
- -- list item; causing the call to create to dispatch accordingly.
- -- why do it twice? To make sure order makes no difference
-
- C392011_0.Check(Next_Item.Data.all, C392011_0.Create);
- -- Create will touch first, then Check touches
-
- C392011_0.Check(C392011_0.Create, Next_Item.Data.all);
-
- -- Here's what's s'pos'd to 'appen:
- -- Check( Lev_2, Create ) >> ACEF
- -- Check( Create, Lev_2 ) >> ACEF
- -- Check( Lev_1, Create ) >> ACD
- -- Check( Create, Lev_1 ) >> ACD
- -- Check( Lev_2, Create ) >> ACEF
- -- Check( Create, Lev_2 ) >> ACEF
- -- Check( Lev_1, Create ) >> ACD
- -- Check( Create, Lev_1 ) >> ACD
- -- Check( Lev_0, Create ) >> AB
- -- Check( Create, Lev_0 ) >> AB
-
- Next_Item := Next_Item.Next;
- end loop;
- end Traverse_List;
-
-end C392011_2.C392011_3;
-
-------------------------------------------------------------------- C392011
-
-with Report;
-with TCTouch;
-with C392011_2.C392011_3;
-
-procedure C392011 is
-
-begin -- Main test procedure.
-
- Report.Test ("C392011", "Check that if a function call with a " &
- "controlling result is itself a controlling " &
- "operand of an enclosing call on a dispatching " &
- "operation, then its controlling tag value is " &
- "determined by the controlling tag value of " &
- "the enclosing call" );
-
- C392011_2.C392011_3.Build_List;
- TCTouch.Validate( "A" & "AC" & "ACE" & "AC" & "ACE", "Build List" );
-
- C392011_2.C392011_3.Traverse_List;
- TCTouch.Validate( "ACEFACEF" &
- "ACDACD" &
- "ACEFACEF" &
- "ACDACD" &
- "ABAB",
- "Traverse List" );
-
- Report.Result;
-
-end C392011;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c392013.a b/gcc/testsuite/ada/acats/tests/c3/c392013.a
deleted file mode 100644
index 3873d9e62d5..00000000000
--- a/gcc/testsuite/ada/acats/tests/c3/c392013.a
+++ /dev/null
@@ -1,179 +0,0 @@
--- C392013.A
---
--- Grant of Unlimited Rights
---
--- The Ada Conformity Assessment Authority (ACAA) holds unlimited
--- rights in the software and documentation contained herein. Unlimited
--- rights are the same as those granted by the U.S. Government for older
--- parts of the Ada Conformity Assessment Test Suite, and are defined
--- in DFAR 252.227-7013(a)(19). By making this public release, the ACAA
--- intends to confer upon all recipients unlimited rights equal to those
--- held by the ACAA. These rights include rights to use, duplicate,
--- release or disclose the released technical data and computer software
--- in whole or in part, in any manner and for any purpose whatsoever, and
--- to have or permit others to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that the "/=" implicitly declared with the declaration of "=" for
--- a tagged type is legal and can be used in a dispatching call.
--- (Defect Report 8652/0010, as reflected in Technical Corrigendum 1).
---
--- CHANGE HISTORY:
--- 23 JAN 2001 PHL Initial version.
--- 16 MAR 2001 RLB Readied for release; added identity and negative
--- result cases.
--- 24 MAY 2001 RLB Corrected the result for the 9 vs. 9 case.
---!
-with Report;
-use Report;
-procedure C392013 is
-
- package P1 is
- type T is tagged
- record
- C1 : Integer;
- end record;
- function "=" (L, R : T) return Boolean;
- end P1;
-
- package P2 is
- type T is new P1.T with private;
- function Make (Ancestor : P1.T; X : Float) return T;
- private
- type T is new P1.T with
- record
- C2 : Float;
- end record;
- function "=" (L, R : T) return Boolean;
- end P2;
-
- package P3 is
- type T is new P2.T with
- record
- C3 : Character;
- end record;
- private
- function "=" (L, R : T) return Boolean;
- function Make (Ancestor : P1.T; X : Float) return T;
- end P3;
-
-
- package body P1 is separate;
- package body P2 is separate;
- package body P3 is separate;
-
-
- type Cwat is access P1.T'Class;
- type Cwat_Array is array (Positive range <>) of Cwat;
-
- A : constant Cwat_Array :=
- (1 => new P1.T'(C1 => Ident_Int (3)),
- 2 => new P2.T'(P2.Make (Ancestor => (C1 => Ident_Int (5)), X => 4.0)),
- 3 => new P2.T'(P2.Make (Ancestor => (C1 => Ident_Int (-5)), X => 4.2)),
- 4 => new P1.T'(C1 => Ident_Int (-3)),
- 5 => new P2.T'(P2.Make (Ancestor => (C1 => Ident_Int (5)), X => 3.6)),
- 6 => new P1.T'(C1 => Ident_Int (4)),
- 7 => new P3.T'(P2.Make
- (Ancestor => (C1 => Ident_Int (4)), X => 1.2) with
- Ident_Char ('a')),
- 8 => new P3.T'(P2.Make
- (Ancestor => (C1 => Ident_Int (-4)), X => 1.3) with
- Ident_Char ('A')),
- 9 => new P3.T'(P2.Make
- (Ancestor => (C1 => Ident_Int (4)), X => 1.0) with
- Ident_Char ('B')));
-
- type Truth is ('F', 'T');
- type Truth_Table is array (Positive range <>, Positive range <>) of Truth;
-
- Equality : constant Truth_Table (A'Range, A'Range) := ("TFFTFFFFF",
- "FTTFTFFFF",
- "FTTFFFFFF",
- "TFFTFFFFF",
- "FTFFTFFFF",
- "FFFFFTFFF",
- "FFFFFFTTF",
- "FFFFFFTTF",
- "FFFFFFFFT");
-
-begin
- Test ("C392013", "Check that the ""/="" implicitly declared " &
- "with the declaration of ""="" for a tagged " &
- "type is legal and can be used in a dispatching call");
-
- for I in A'Range loop
- for J in A'Range loop
- -- Test identity:
- if P1."=" (A (I).all, A (J).all) /=
- (not P1."/=" (A (I).all, A (J).all)) then
- Failed ("Incorrect identity comparing objects" &
- Positive'Image (I) & " and" & Positive'Image (J));
- end if;
- -- Test the result of "/=":
- if Equality (I, J) = 'T' then
- if P1."/=" (A (I).all, A (J).all) then
- Failed ("Incorrect result comparing objects" &
- Positive'Image (I) & " and" & Positive'Image (J) & " - T");
- end if;
- else
- if not P1."/=" (A (I).all, A (J).all) then
- Failed ("Incorrect result comparing objects" &
- Positive'Image (I) & " and" & Positive'Image (J) & " - F");
- end if;
- end if;
- end loop;
- end loop;
-
- Result;
-end C392013;
-separate (C392013)
-package body P1 is
-
- function "=" (L, R : T) return Boolean is
- begin
- return abs L.C1 = abs R.C1;
- end "=";
-
-end P1;
-separate (C392013)
-package body P2 is
-
- function "=" (L, R : T) return Boolean is
- begin
- return P1."=" (P1.T (L), P1.T (R)) and then abs (L.C2 - R.C2) <= 0.5;
- end "=";
-
-
- function Make (Ancestor : P1.T; X : Float) return T is
- begin
- return (Ancestor with X);
- end Make;
-
-end P2;
-with Ada.Characters.Handling;
-separate (C392013)
-package body P3 is
-
- function "=" (L, R : T) return Boolean is
- begin
- return P2."=" (P2.T (L), P2.T (R)) and then
- Ada.Characters.Handling.To_Upper (L.C3) =
- Ada.Characters.Handling.To_Upper (R.C3);
- end "=";
-
- function Make (Ancestor : P1.T; X : Float) return T is
- begin
- return (P2.Make (Ancestor, X) with ' ');
- end Make;
-
-end P3;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c392014.a b/gcc/testsuite/ada/acats/tests/c3/c392014.a
deleted file mode 100644
index 89d403eaad3..00000000000
--- a/gcc/testsuite/ada/acats/tests/c3/c392014.a
+++ /dev/null
@@ -1,225 +0,0 @@
--- C392014.A
---
--- Grant of Unlimited Rights
---
--- The Ada Conformity Assessment Authority (ACAA) holds unlimited
--- rights in the software and documentation contained herein. Unlimited
--- rights are the same as those granted by the U.S. Government for older
--- parts of the Ada Conformity Assessment Test Suite, and are defined
--- in DFAR 252.227-7013(a)(19). By making this public release, the ACAA
--- intends to confer upon all recipients unlimited rights equal to those
--- held by the ACAA. These rights include rights to use, duplicate,
--- release or disclose the released technical data and computer software
--- in whole or in part, in any manner and for any purpose whatsoever, and
--- to have or permit others to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that objects designated by X'Access (where X is of a class-wide
--- type) and new T'Class'(...) are dynamically tagged and can be used in
--- dispatching calls. (Defect Report 8652/0010).
---
--- CHANGE HISTORY:
--- 18 JAN 2001 PHL Initial version
--- 15 MAR 2001 RLB Readied for release.
-
---!
-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 (D => Ident_Int (17));
- subtype S1 is C392014_1.T'Class;
-
- X0 : aliased C392014_0.T'Class := C392014_0.Create (Ident_Int (5218));
- X1 : aliased C392014_1.T'Class := C392014_1.Create (Ident_Int (8253));
-
- Y0 : aliased S0 := C392014_0.Create (Ident_Int (2693));
- Y1 : aliased S1 := C392014_1.Create (Ident_Int (5622));
-
- procedure TC_Check (Subtest : String; Expected : Integer) is
- begin
- if C392014_0.Result = Expected then
- Comment ("Subtest " & Subtest & " Passed");
- else
- Failed ("Subtest " & Subtest & " Failed");
- end if;
- C392014_0.Result := Ident_Int (0);
- end TC_Check;
-
-begin
- Test ("C392014",
- "Check that objects designated by X'Access " &
- "(where X is of a class-wide type) and New T'Class'(...) " &
- "are dynamically tagged and can be used in dispatching " &
- "calls");
-
- C392014_0.P (X0'Access);
- TC_Check ("X0'Access", Ident_Int (29));
- C392014_0.P (new C392014_0.T'Class'(C392014_0.Create (Ident_Int (12850))));
- TC_Check ("New C392014_0.T'Class", Ident_Int (27));
- C392014_1.P (X1'Access);
- TC_Check ("X1'Access", Ident_Int (212));
- C392014_1.P (new C392014_1.T'Class'(C392014_1.Create (Ident_Int (2031))));
- TC_Check ("New C392014_1.T'Class", Ident_Int (65));
- C392014_0.P (Y0'Access);
- TC_Check ("Y0'Access", Ident_Int (18));
- C392014_0.P (new S0'(C392014_0.Create (Ident_Int (6893))));
- TC_Check ("New S0", Ident_Int (20));
- C392014_1.P (Y1'Access);
- TC_Check ("Y1'Access", Ident_Int (18));
- C392014_1.P (new S1'(C392014_1.Create (Ident_Int (1861))));
- TC_Check ("New S1", Ident_Int (56));
-
- Result;
-end C392014;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c392a01.a b/gcc/testsuite/ada/acats/tests/c3/c392a01.a
deleted file mode 100644
index 8ad78914231..00000000000
--- a/gcc/testsuite/ada/acats/tests/c3/c392a01.a
+++ /dev/null
@@ -1,265 +0,0 @@
--- C392A01.A
- --
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
- --
- -- OBJECTIVE:
- -- Check that the use of a class-wide formal parameter allows for the
- -- proper dispatching of objects to the appropriate implementation of
- -- a primitive operation. Check this for the root tagged type defined
- -- in a package, and the extended type is defined in that same package.
- --
- -- TEST DESCRIPTION:
- -- Declare a root tagged type, and some associated primitive operations.
- -- Extend the root type, and override one or more primitive operations,
- -- inheriting the other primitive operations from the root type.
- -- Derive from the extended type, again overriding some primitive
- -- operations and inheriting others (including some that the parent
- -- inherited).
- -- Define a subprogram with a class-wide parameter, inside of which is a
- -- call on a dispatching primitive operation. These primitive operations
- -- modify global variables (the class-wide parameter has mode IN).
- --
- --
- --
- -- The following hierarchy of tagged types and primitive operations is
- -- utilized in this test:
- --
- -- type Bank_Account (root)
- -- |
- -- | Operations
- -- | Increment_Bank_Reserve
- -- | Assign_Representative
- -- | Increment_Counters
- -- | Open
- -- |
- -- type Savings_Account (extended from Bank_Account)
- -- |
- -- | Operations
- -- | (Increment_Bank_Reserve) (inherited)
- -- | Assign_Representative (overridden)
- -- | Increment_Counters (overridden)
- -- | Open (overridden)
- -- |
- -- type Preferred_Account (extended from Savings_Account)
- -- |
- -- | Operations
- -- | (Increment_Bank_Reserve) (inherited twice - Bank_Acct.)
- -- | (Assign_Representative) (inherited - Savings_Acct.)
- -- | Increment_Counters (overridden)
- -- | Open (overridden)
- --
- --
- -- In this test, we are concerned with the following selection of dispatching
- -- calls, accomplished with the use of a Bank_Account'Class IN procedure
- -- parameter :
- --
- -- \ Type
- -- Prim. Op \ Bank_Account Savings_Account Preferred_Account
- -- \------------------------------------------------
- -- Increment_Bank_Reserve| X X X
- -- Assign_Representative | X
- -- Increment_Counters | X X X
- --
- --
- --
- -- The location of the declaration and derivation of the root and extended
- -- types will be varied over a series of tests. Locations of declaration
- -- and derivation for a particular test are marked with an asterisk (*).
- --
- -- Root type:
- --
- -- * Declared in package.
- -- Declared in generic package.
- --
- -- Extended types:
- --
- -- * Derived in parent location.
- -- Derived in a nested package.
- -- Derived in a nested subprogram.
- -- Derived in a nested generic package.
- -- Derived in a separate package.
- -- Derived in a separate visible child package.
- -- Derived in a separate private child package.
- --
- -- Primitive Operations:
- --
- -- * Procedures with same parameter profile.
- -- Procedures with different parameter profile.
- -- Functions with same parameter profile.
- -- Functions with different parameter profile.
- -- Mixture of Procedures and Functions.
- --
- --
- -- TEST FILES:
- -- This test depends on the following foundation code:
- --
- -- F392A00.A
- --
- -- The following files comprise this test:
- --
- -- => C392A01.A
- --
- --
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
---
- --!
-
- with F392A00; -- package Accounts
- with Report;
-
- procedure C392A01 is
-
- package Accounts renames F392A00;
-
- -- Declare account objects.
-
- B_Account : Accounts.Bank_Account;
- S_Account : Accounts.Savings_Account;
- P_Account : Accounts.Preferred_Account;
-
- -- Procedures to operate on accounts.
- -- Each uses a class-wide IN parameter, as well as a call to a
- -- dispatching operation.
-
- -- Procedure Tabulate_Account performs a dispatching call on a primitive
- -- operation that has been overridden for each of the extended types.
-
- procedure Tabulate_Account (Acct : in Accounts.Bank_Account'Class) is
- begin
- Accounts.Increment_Counters (Acct); -- Dispatch according to tag.
- end Tabulate_Account;
-
-
- -- Procedure Accumulate_Reserve performs a dispatching call on a
- -- primitive operation that has been defined for the root type and
- -- inherited by each derived type.
-
- procedure Accumulate_Reserve (Acct : in Accounts.Bank_Account'Class) is
- begin
- Accounts.Increment_Bank_Reserve (Acct); -- Dispatch according to tag.
- end Accumulate_Reserve;
-
-
- -- Procedure Resolve_Dispute performs a dispatching call on a primitive
- -- operation that has been defined in the root type, overridden in the
- -- first derived extended type, and inherited by the subsequent extended
- -- type.
-
- procedure Resolve_Dispute (Acct : in Accounts.Bank_Account'Class) is
- begin
- Accounts.Assign_Representative (Acct); -- Dispatch according to tag.
- end Resolve_Dispute;
-
-
-
- begin -- Main test procedure.
-
- Report.Test ("C392A01", "Check that the use of a class-wide parameter " &
- "allows for proper dispatching where root type " &
- "and extended types are declared in the same " &
- "package" );
-
- Bank_Account_Subtest:
- declare
- use Accounts;
- begin
- Accounts.Open (B_Account);
-
- -- Demonstrate class-wide parameter allowing dispatch by a primitive
- -- operation that has been defined for this specific type.
- Accumulate_Reserve (Acct => B_Account);
- Tabulate_Account (B_Account);
-
- if (Accounts.Bank_Reserve /= Accounts.Opening_Balance) or
- (Accounts.Number_Of_Accounts (Bank) /= 1) or
- (Accounts.Number_Of_Accounts (Total) /= 1)
- then
- Report.Failed ("Failed in Bank_Account_Subtest");
- end if;
-
- end Bank_Account_Subtest;
-
-
- Savings_Account_Subtest:
- declare
- use Accounts;
- begin
- Accounts.Open (Acct => S_Account);
-
- -- Demonstrate class-wide parameter allowing dispatch by a primitive
- -- operation that has been inherited by this extended type.
- Accumulate_Reserve (Acct => S_Account);
-
- -- Demonstrate class-wide parameter allowing dispatch by a primitive
- -- operation that has been overridden for this extended type.
- Resolve_Dispute (Acct => S_Account);
- Tabulate_Account (S_Account);
-
- if Accounts.Bank_Reserve /= (3.0 * Accounts.Opening_Balance) or
- Accounts.Daily_Representative /= Accounts.Manager or
- Accounts.Number_Of_Accounts (Savings) /= 1 or
- Accounts.Number_Of_Accounts (Total) /= 2
- then
- Report.Failed ("Failed in Savings_Account_Subtest");
- end if;
-
- end Savings_Account_Subtest;
-
-
- Preferred_Account_Subtest:
- declare
- use Accounts;
- begin
- Accounts.Open (P_Account);
-
- -- Verify that the correct implementation of Open (overridden) was
- -- used for the Preferred_Account object.
- if not Accounts.Verify_Open (P_Account) then
- Report.Failed ("Incorrect values for init. Preferred Acct object");
- end if;
-
- -- Demonstrate class-wide parameter allowing dispatch by a primitive
- -- operation that has been twice inherited by this extended type.
- Accumulate_Reserve (Acct => P_Account);
-
- -- Demonstrate class-wide parameter allowing dispatch by a primitive
- -- operation that has been overridden for this extended type (the
- -- operation was overridden by its parent type as well).
- Tabulate_Account (P_Account);
-
- if Accounts.Bank_Reserve /= 1300.00 or
- Accounts.Number_Of_Accounts (Preferred) /= 1 or
- Accounts.Number_Of_Accounts (Total) /= 3
- then
- Report.Failed ("Failed in Preferred_Account_Subtest");
- end if;
-
- end Preferred_Account_Subtest;
-
-
- Report.Result;
-
- end C392A01;
-
diff --git a/gcc/testsuite/ada/acats/tests/c3/c392c05.a b/gcc/testsuite/ada/acats/tests/c3/c392c05.a
deleted file mode 100644
index 6bd3cece77e..00000000000
--- a/gcc/testsuite/ada/acats/tests/c3/c392c05.a
+++ /dev/null
@@ -1,164 +0,0 @@
--- C392C05.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that for a call to a dispatching subprogram the subprogram
--- body which is executed is determined by the controlling tag for
--- the case where the call has statically tagged controlling operands
--- of the type T. Check this for various operands of tagged types:
--- objects (declared or allocated), formal parameters, view conversions,
--- function calls (both primitive and non-primitive).
---
--- TEST DESCRIPTION:
--- This test uses foundation F392C00 to test the usages of statically
--- tagged objects and values. The calls to Validate indicate the
--- expected sequence of procedure calls since the previous call to
--- Validate. Static tags can be determined at compile time, and
--- hence this is a test of correct overload resolution for tagged types.
--- A clever compiler which unrolls loops and does path analysis on
--- access values will be able to perform the same kind of determination
--- for all of the code in this test.
---
--- TEST FILES:
--- The following files comprise this test:
---
--- F392C00.A (foundation code)
--- C392C05.A
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 19 Dec 94 SAIC Removed RM references from objective text.
--- 24 Oct 95 SAIC Updated for ACVC 2.0.1
--- 13 Feb 97 PWB.CTA Corrected assumption that "or" operands are
--- evaluated in textual order.
---!
-
-with Report;
-with TCTouch;
-with F392C00_1;
-procedure C392C05 is -- Hardware_Store
-
- package Switch renames F392C00_1;
-
- subtype Switch_Class is Switch.Toggle'Class;
-
- type Reference is access all Switch_Class;
-
- A_Switch : aliased Switch.Toggle;
- A_Dimmer : aliased Switch.Dimmer;
- An_Autodim : aliased Switch.Auto_Dimmer;
-
- type Light_Bank is array(Positive range <>) of Reference;
-
- Lamps : Light_Bank(1..3);
-
-begin -- Main test procedure.
-
- Report.Test ("C392C05", "Check that a dispatching subprogram call is "
- & "determined by the controlling tag for statically "
- & "tagged controlling operands" );
-
--- Check use of static tagged declared objects,
--- and static tagged formal parameters
--- Must call correct version of flip based on type of controlling op.
-
--- Turn on the lights!
-
- Switch.Flip( A_Switch );
- TCTouch.Validate( "A", "Declared Toggle" );
-
- Switch.Flip( A_Dimmer );
- TCTouch.Validate( "GBA", "Declared Dimmer" );
-
- Switch.Flip( An_Autodim );
- TCTouch.Validate( "KGBA", "Declared Auto_Dimmer" );
-
- Lamps(1) := new Switch.Toggle;
- Lamps(2) := new Switch.Dimmer;
- Lamps(3) := new Switch.Auto_Dimmer;
-
--- Check use of static tagged allocated objects,
--- and static tagged formal parameters in a loop which may dynamically
--- dispatch. If an optimizer unrolls the loop, it may then be statically
--- determined, and no dispatching will occur. Either interpretation is
--- correct.
- for Knob in Lamps'Range loop
- Switch.Flip( Lamps(Knob).all );
- end loop;
- TCTouch.Validate( "AGBAKGBA", "Allocated Objects" );
-
--- Check use of static tagged declared objects,
--- calling non-primitive functions.
- if not Switch.TC_Non_Disp( A_Switch ) then
- Report.Failed( "Bad Value 1" );
- end if;
- TCTouch.Validate( "X", "Nonprimitive Function" );
-
- if not Switch.TC_Non_Disp( A_Dimmer ) then
- Report.Failed( "Bad Value 2" );
- end if;
- TCTouch.Validate( "Y", "Nonprimitive Function" );
-
- if not Switch.TC_Non_Disp( An_Autodim ) then
- Report.Failed( "Bad Value 3" );
- end if;
- TCTouch.Validate( "Z", "Nonprimitive Function" );
-
- A_Switch := Switch.Create;
- A_Dimmer := Switch.Create;
- An_Autodim := Switch.Create;
- TCTouch.Validate( "123", "Primitive Function" );
-
--- View conversions
- Switch.Brighten( An_Autodim, 50 );
-
- Switch.Flip( Switch.Toggle( A_Switch ) );
- Switch.Flip( Switch.Toggle( A_Dimmer ) );
- Switch.Flip( Switch.Dimmer( An_Autodim ) );
- TCTouch.Validate( "DAAGBA", "View Conversions" );
-
--- statically tagged controlling operands (specific types) provided to
--- class-wide functions
- if Switch.On( A_Switch )
- or Switch.On( A_Dimmer )
- or Switch.On( An_Autodim ) then
- Report.Failed( "Bad Value 4" );
- end if;
- TCTouch.Validate( "BBB", "Class-wide" );
-
--- statically tagged controlling operands qualified expressions provided to
--- primitive functions, also using context to determine call to a
--- class-wide function.
- if Switch.Off( Switch.Toggle'( Switch.Create ) )
- or else Switch.Off( Switch.Dimmer'( Switch.Create ) )
- or else Switch.Off( Switch.Auto_Dimmer'( Switch.Create ) ) then
- Report.Failed( "Bad Value 5" );
- end if;
- TCTouch.Validate( "1C2C3C", "Qualified Expression/Class-Wide" );
-
- Report.Result;
-
-end C392C05;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c392c07.a b/gcc/testsuite/ada/acats/tests/c3/c392c07.a
deleted file mode 100644
index f13cc0b01a0..00000000000
--- a/gcc/testsuite/ada/acats/tests/c3/c392c07.a
+++ /dev/null
@@ -1,190 +0,0 @@
--- C392C07.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that for a call to a dispatching subprogram the subprogram
--- body which is executed is determined by the controlling tag for
--- the case where the call has dynamic tagged controlling operands
--- of the type T. Check for calls to these same subprograms where
--- the operands are of specific statically tagged types:
--- objects (declared or allocated), formal parameters, view
--- conversions, and function calls (both primitive and non-primitive).
---
--- TEST DESCRIPTION:
--- This test uses foundation F392C00 to test the usages of statically
--- tagged objects and values. This test is derived in part from
--- C392C05.
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 24 Oct 95 SAIC Updated for ACVC 2.0.1
---
---!
-
-with Report;
-with TCTouch;
-with F392C00_1;
-procedure C392C07 is -- Hardware_Store
- package Switch renames F392C00_1;
-
- subtype Switch_Class is Switch.Toggle'Class;
-
- type Reference is access all Switch_Class;
-
- A_Switch : aliased Switch.Toggle;
- A_Dimmer : aliased Switch.Dimmer;
- An_Autodim : aliased Switch.Auto_Dimmer;
-
- type Light_Bank is array(Positive range <>) of Reference;
-
- Lamps : Light_Bank(1..3);
-
--- dynamically tagged controlling operands : class wide formal parameters
- procedure Clamp( Device : in out Switch_Class; On : Boolean := False ) is
- begin
- if Switch.On( Device ) /= On then
- Switch.Flip( Device );
- end if;
- end Clamp;
- function Class_Item(Bank_Pos: Positive) return Switch_Class is
- begin
- return Lamps(Bank_Pos).all;
- end Class_Item;
-
-begin -- Main test procedure.
- Report.Test ("C392C07", "Check that a dispatching subprogram call is "
- & "determined by the controlling tag for "
- & "dynamically tagged controlling operands" );
-
- Lamps := ( A_Switch'Access, A_Dimmer'Access, An_Autodim'Access );
-
--- dynamically tagged operands referring to
--- statically tagged declared objects
- for Knob in Lamps'Range loop
- Clamp( Lamps(Knob).all, On => True );
- end loop;
- TCTouch.Validate( "BABGBABKGBA", "Clamping On Lamps" );
-
- Lamps(1) := new Switch.Toggle;
- Lamps(2) := new Switch.Dimmer;
- Lamps(3) := new Switch.Auto_Dimmer;
-
--- turn the full bank of switches ON
--- dynamically tagged allocated objects
- for Knob in Lamps'Range loop
- Clamp( Lamps(Knob).all, On => True );
- end loop;
- TCTouch.Validate( "BABGBABKGBA", "Dynamic Allocated");
-
--- Double check execution correctness
- if Switch.Off( Lamps(1).all )
- or Switch.Off( Lamps(2).all )
- or Switch.Off( Lamps(3).all ) then
- Report.Failed( "Bad Value" );
- end if;
- TCTouch.Validate( "CCC", "Class-wide");
-
--- turn the full bank of switches OFF
- for Knob in Lamps'Range loop
- Switch.Flip( Lamps(Knob).all );
- end loop;
- TCTouch.Validate( "AGBAKGBA", "Dynamic Allocated, Primitive Ops");
-
--- check switches for OFF
--- a few function calls as operands
- for Knob in Lamps'Range loop
- if not Switch.Off( Class_Item(Knob) ) then
- Report.Failed("At function tests, Switch not OFF");
- end if;
- end loop;
- TCTouch.Validate( "CCC",
- "Using function returning class-wide type");
-
--- Switches are all OFF now.
--- dynamically tagged view conversion
- Clamp( Switch_Class( A_Switch ) );
- Clamp( Switch_Class( A_Dimmer ) );
- Clamp( Switch_Class( An_Autodim ) );
- TCTouch.Validate( "BABGBABKGBA", "View Conversions" );
-
--- dynamically tagged controlling operands : declared class wide objects
--- calling primitive functions
- declare
- Dine_O_Might : Switch_Class := Switch.TC_CW_TI( 't' );
- begin
- Switch.Flip( Dine_O_Might );
- if Switch.On( Dine_O_Might ) then
- Report.Failed( "Exploded at Dine_O_Might" );
- end if;
- TCTouch.Validate( "WAB", "Dispatching function 1" );
- end;
-
- declare
- Dyne_A_Mite : Switch_Class := Switch.TC_CW_TI( 'd' );
- begin
- Switch.Flip( Dyne_A_Mite );
- if Switch.On( Dyne_A_Mite ) then
- Report.Failed( "Exploded at Dyne_A_Mite" );
- end if;
- TCTouch.Validate( "WGBAB", "Dispatching function 2" );
- end;
-
- declare
- Din_Um_Out : Switch_Class := Switch.TC_CW_TI( 'a' );
- begin
- Switch.Flip( Din_Um_Out );
- if Switch.Off( Din_Um_Out ) then
- Report.Failed( "Exploded at Din_Um_Out" );
- end if;
- TCTouch.Validate( "WKCC", "Dispatching function 3" );
-
--- Non-dispatching function calls.
- if not Switch.TC_Non_Disp( Switch.Toggle( Din_Um_Out ) ) then
- Report.Failed( "Non primitive, via view conversion" );
- end if;
- TCTouch.Validate( "X", "View Conversion 1" );
-
- if not Switch.TC_Non_Disp( Switch.Dimmer( Din_Um_Out ) ) then
- Report.Failed( "Non primitive, via view conversion" );
- end if;
- TCTouch.Validate( "Y", "View Conversion 2" );
- end;
-
- -- a few more function calls as operands (oops)
- if not Switch.On( Switch.Toggle'( Switch.Create ) ) then
- Report.Failed("Toggle did not create ""On""");
- end if;
-
- if Switch.Off( Switch.Dimmer'( Switch.Create ) ) then
- Report.Failed("Dimmer created ""Off""");
- end if;
-
- if Switch.Off( Switch.Auto_Dimmer'( Switch.Create ) ) then
- Report.Failed("Auto_Dimmer created ""Off""");
- end if;
-
- Report.Result;
-end C392C07;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c392d01.a b/gcc/testsuite/ada/acats/tests/c3/c392d01.a
deleted file mode 100644
index bb6e192028c..00000000000
--- a/gcc/testsuite/ada/acats/tests/c3/c392d01.a
+++ /dev/null
@@ -1,324 +0,0 @@
--- C392D01.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that, for an implicitly declared dispatching operation that is
--- overridden, the body executed is the body for the overriding
--- subprogram, even if the overriding occurs in a private part.
--- Check that, for an implicitly declared dispatching operation that is
--- NOT overridden, the body executed is the body of the corresponding
--- subprogram of the parent type.
---
--- Check for the case where the overriding (and non-overriding) operations
--- are declared for a private extension (and its full type) in a public
--- child unit of the package declaring the ancestor type, and the ancestor
--- type is a tagged private type whose full view is itself a derived type.
---
--- TEST DESCRIPTION:
--- Consider:
---
--- package Parent is
--- type Root is tagged ...
--- procedure Vis_Op (P: Root);
--- private
--- procedure Pri_Op (P: Root); -- (A)
--- end Parent;
---
--- package Intermediate is
--- type Mid is tagged private;
--- private
--- type Mid is new Parent.Root with record ...
--- -- Implicit Vis_Op (P: Mid) declared here.
---
--- procedure Vis_Op (P: Mid); -- (B)
--- end Intermediate;
---
--- package Intermediate.Child is
--- type Derived is new Mid with private;
---
--- procedure Pri_Op (P: Derived); -- (C)
--- ...
---
--- private
--- type Derived is new Mid with record...
--- -- Implicit Vis_Op (P: Derived) declared here.
--- ...
--- end Intermediate.Child;
---
--- Type Derived inherits Vis_Op from the parent type Mid. Note, however,
--- that it is implicitly declared in the private part (inherited
--- subprograms for a derived_type_definition -- in this case, the full
--- type -- are implicitly declared at the earliest place within the
--- immediate scope of the type_declaration where the corresponding
--- declaration from the parent is visible).
---
--- Because Parent.Pri_Op is never visible within the immediate scope
--- of Mid, it is not implicitly declared for Mid. Thus, it is also not
--- implicitly declared for Derived. As a result, the version of Pri_Op
--- declared at (C) above does not override an inherited version of
--- Parent.Pri_Op and is totally unrelated to it.
---
--- Dispatching calls with tag Mid will execute (A) and (B). Dispatching
--- calls with tag Derived from Parent will execute the bodies of (B)
--- and (A). Dispatching calls with tag Derived from Parent.Child
--- will execute the bodies of (B) and (C).
---
--- TEST FILES:
--- The following files comprise this test:
---
--- F392D00.A
--- C392D01.A
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
---
---!
-
-with F392D00;
-package C392D01_0 is
-
- type Zoom_Camera is tagged private;
-
- procedure Self_Test (C : in out Zoom_Camera'Class);
-
- -- ...Additional operations.
-
-
- function TC_Correct_Result (C : Zoom_Camera;
- D : F392D00.Depth_Of_Field;
- S : F392D00.Shutter_Speed) return Boolean;
-
-private
-
- type Magnification is (Low, Medium, High);
-
- type Zoom_Camera is new F392D00.Remote_Camera with record
- Mag : Magnification;
- end record;
-
- -- procedure Focus (C : in out Zoom_Camera; -- Implicitly
- -- Depth : in Depth_Of_Field) -- declared
- -- here.
-
- procedure Focus (C : in out Zoom_Camera; -- Overrides
- Depth : in F392D00.Depth_Of_Field); -- inherited op.
-
- -- For the remote zoom camera, perhaps the focusing algorithm is different
- -- in some way, so the original Focus operation is overridden here.
-
- -- Since the partial view is not an extension, the overriding operation
- -- must be declared after the full type. This version of Focus, although
- -- not visible for type Zoom_Camera from outside the package, can still be
- -- dispatched to.
-
-
- -- Note: F392D00.Set_Shutter_Speed is inherited by Zoom_Camera from
- -- F392D00.Remote_Camera, but since the operation never becomes visible
- -- within the immediate scope of Zoom_Camera, it is never implicitly
- -- declared.
-
-end C392D01_0;
-
-
- --==================================================================--
-
-
-package body C392D01_0 is
-
- procedure Focus (C : in out Zoom_Camera;
- Depth : in F392D00.Depth_Of_Field) is
- begin
- -- Artificial for testing purposes.
- C.DOF := 83;
- end Focus;
-
- -----------------------------------------------------------
- -- Indirect call to F392D00.Self_Test since the main does not know
- -- that Zoom_Camera is a private extension of F392D00.Basic_Camera.
- procedure Self_Test (C : in out Zoom_Camera'Class) is
- begin
- F392D00.Self_Test (C);
- -- ...Additional self-testing.
- end Self_Test;
-
- -----------------------------------------------------------
- function TC_Correct_Result (C : Zoom_Camera;
- D : F392D00.Depth_Of_Field;
- S : F392D00.Shutter_Speed) return Boolean is
- use type F392D00.Depth_Of_Field;
- use type F392D00.Shutter_Speed;
- begin
- return (C.DOF = D and C.Shutter = S);
- end TC_Correct_Result;
-
-end C392D01_0;
-
-
- --==================================================================--
-
-
-with F392D00;
-package C392D01_0.C392D01_1 is
-
- type Film_Speed is private;
-
- type Auto_Speed is new Zoom_Camera with private;
-
- -- Implicit function TC_Correct_Result (Auto_Speed) declared here.
-
- procedure Set_Shutter_Speed (C : in out Auto_Speed;
- Speed : in F392D00.Shutter_Speed);
-
- -- This version of Set_Shutter_Speed does NOT override the operation
- -- inherited from Zoom_Camera, because the inherited operation is never
- -- visible (and thus, is never implicitly declared) within the immediate
- -- scope of type Auto_Speed.
-
- procedure Self_Test (C : in out Auto_Speed'Class);
-
- -- ...Other operations.
-
-private
- type Film_Speed is (One_Hundred, Two_Hundred, Four_Hundred);
-
- type Auto_Speed is new Zoom_Camera with record
- ASA : Film_Speed;
- end record;
-
- -- procedure Focus (C : in out Auto_Speed; -- Implicitly
- -- Depth : in F392D00.Depth_Of_Field); -- declared
- -- here.
-
-end C392D01_0.C392D01_1;
-
-
- --==================================================================--
-
-
-package body C392D01_0.C392D01_1 is
-
- procedure Set_Shutter_Speed (C : in out Auto_Speed;
- Speed : in F392D00.Shutter_Speed) is
- begin
- -- Artificial for testing purposes.
- C.Shutter := F392D00.Two_Fifty;
- end Set_Shutter_Speed;
-
- -------------------------------------------------------
- procedure Self_Test (C : in out Auto_Speed'Class) is
- begin
- -- Artificial for testing purposes.
- Set_Shutter_Speed (C, F392D00.Thousand);
- Focus (C, 27);
- end Self_Test;
-
-end C392D01_0.C392D01_1;
-
-
- --==================================================================--
-
-
-with F392D00;
-with C392D01_0.C392D01_1;
-
-with Report;
-
-procedure C392D01 is
- Zooming_Camera : C392D01_0.Zoom_Camera;
- Auto_Camera1 : C392D01_0.C392D01_1.Auto_Speed;
- Auto_Camera2 : C392D01_0.C392D01_1.Auto_Speed;
-
- TC_Expected_Zoom_Depth : constant F392D00.Depth_Of_Field := 83;
- TC_Expected_Auto_Depth : constant F392D00.Depth_Of_Field := 83;
- TC_Expected_Depth : constant F392D00.Depth_Of_Field := 83;
- TC_Expected_Zoom_Speed : constant F392D00.Shutter_Speed
- := F392D00.Thousand;
- TC_Expected_Auto_Speed : constant F392D00.Shutter_Speed
- := F392D00.Thousand;
- TC_Expected_Speed : constant F392D00.Shutter_Speed
- := F392D00.Two_Fifty;
-
- use type F392D00.Depth_Of_Field;
- use type F392D00.Shutter_Speed;
-
-begin
- Report.Test ("C392D01", "Dispatching for overridden and non-overridden " &
- "primitive subprograms: private extension declared in child " &
- "unit, parent is tagged private whose full view is derived " &
- "type");
-
-
-
--- Call the class-wide operation (Self_Test) for Zoom_Camera'Class, which
--- itself calls the class-wide operation for Remote_Camera'Class, which
--- in turn makes dispatching calls to Focus and Set_Shutter_Speed:
-
-
- -- For an object of type Zoom_Camera, the dispatching call to Focus should
- -- dispatch to the body explicitly declared for Zoom_Camera. The dispatching
- -- to Set_Shutter_Speed should dispatch to the body declared for
- -- Remote_Camera:
-
- C392D01_0.Self_Test(Zooming_Camera);
-
- if not C392D01_0.TC_Correct_Result (Zooming_Camera,
- TC_Expected_Zoom_Depth,
- TC_Expected_Zoom_Speed)
- then
- Report.Failed ("Calls dispatched incorrectly for tagged private type");
- end if;
-
- -- For an object of type Auto_Speed, the dispatching call to Focus should
- -- dispatch to the body explicitly declared for Zoom_Camera. The dispatching
- -- call to Set_Shutter_Speed should dispatch to the body explicitly declared
- -- for Remote_Camera:
-
- C392D01_0.Self_Test(Auto_Camera1);
-
- if not C392D01_0.C392D01_1.TC_Correct_Result (Auto_Camera1,
- TC_Expected_Auto_Depth,
- TC_Expected_Auto_Speed)
- then
- Report.Failed ("Calls dispatched incorrectly for private extension");
- end if;
-
- -- Call to Self_Test from C392D01_0.C392D01_1 invokes the dispatching call
- -- to Focus which should dispatch to the body explicitly declared for
- -- Zoom_Camera. The dispatching call to Set_Shutter_Speed should dispatch
- -- to the body explicitly declared for Auto_Speed:
-
- C392D01_0.C392D01_1.Self_Test(Auto_Camera2);
-
- if not C392D01_0.C392D01_1.TC_Correct_Result (Auto_Camera2,
- TC_Expected_Depth,
- TC_Expected_Speed)
- then
- Report.Failed ("Call to explicit subprogram executed the wrong body");
- end if;
-
- Report.Result;
-
-end C392D01;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c392d02.a b/gcc/testsuite/ada/acats/tests/c3/c392d02.a
deleted file mode 100644
index d8e012cbe2d..00000000000
--- a/gcc/testsuite/ada/acats/tests/c3/c392d02.a
+++ /dev/null
@@ -1,185 +0,0 @@
--- C392D02.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that a primitive procedure declared in a private part is not
--- overridden by a procedure explicitly declared at a place where the
--- primitive procedure in question is not visible.
---
--- Check for the case where the non-overriding operation is declared in a
--- separate (non-child) package from that declaring the parent type, and
--- the descendant type is a record extension.
---
--- TEST DESCRIPTION:
--- Consider:
---
--- package P is
--- type Root is tagged ...
--- private
--- procedure Pri_Op (A: Root);
--- end P;
---
--- with P;
--- package Q is
--- type Derived is new P.Root with record...
--- procedure Pri_Op (A: Derived); -- Does NOT override parent's Op.
--- ...
--- end Q;
---
--- Type Derived inherits Pri_Op from the parent type Root. However,
--- because P.Pri_Op is never visible within the immediate scope of
--- Derived, it is not implicitly declared for Derived. As a result,
--- the explicit Q.Pri_Op does not override P.Pri_Op and is totally
--- unrelated to it.
---
--- Dispatching calls to P.Pri_Op with operands of tag Derived will
--- not dispatch to Q.Pri_Op; the body executed will be that of P.Pri_Op.
---
--- TEST FILES:
--- The following files comprise this test:
---
--- F392D00.A
--- C392D02.A
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
---
---!
-
-with F392D00;
-package C392D02_0 is
-
- type Aperture is (Eight, Sixteen);
-
- type Auto_Speed is new F392D00.Remote_Camera with record
- -- ...
- FStop : Aperture;
- end record;
-
-
- procedure Set_Shutter_Speed (C : in out Auto_Speed;
- Speed : in F392D00.Shutter_Speed);
- -- Does NOT override.
-
- -- This version of Set_Shutter_Speed does NOT override the operation
- -- inherited from the parent, because the inherited operation is never
- -- visible (and thus, is never implicitly declared) within the immediate
- -- scope of type Auto_Speed.
-
- procedure Self_Test (C : in out Auto_Speed'Class);
-
- -- ...Other operations.
-
-end C392D02_0;
-
-
- --==================================================================--
-
-
-package body C392D02_0 is
-
- procedure Set_Shutter_Speed (C : in out Auto_Speed;
- Speed : in F392D00.Shutter_Speed) is
- begin
- -- Artificial for testing purposes.
- C.Shutter := F392D00.Four_Hundred;
- end Set_Shutter_Speed;
-
- ----------------------------------------------------
- procedure Self_Test (C : in out Auto_Speed'Class) is
- begin
- -- Should dispatch to the Set_Shutter_Speed explicitly declared
- -- for Auto_Speed.
- Set_Shutter_Speed (C, F392D00.Two_Fifty);
- end Self_Test;
-
-end C392D02_0;
-
-
- --==================================================================--
-
-
-with F392D00;
-with C392D02_0;
-
-with Report;
-
-procedure C392D02 is
- Basic_Camera : F392D00.Remote_Camera;
- Auto_Camera1 : C392D02_0.Auto_Speed;
- Auto_Camera2 : C392D02_0.Auto_Speed;
-
- TC_Expected_Basic_Speed : constant F392D00.Shutter_Speed
- := F392D00.Thousand;
- TC_Expected_Speed : constant F392D00.Shutter_Speed
- := F392D00.Four_Hundred;
-
- use type F392D00.Shutter_Speed;
-
-begin
- Report.Test ("C392D02", "Dispatching for non-overridden primitive " &
- "subprograms: record extension declared in non-child " &
- "package, parent is tagged record");
-
--- Call the class-wide operation for Remote_Camera'Class, which dispatches
--- to Set_Shutter_Speed:
-
- -- For an object of type Remote_Camera, the dispatching call should
- -- dispatch to the body declared for the root type:
-
- F392D00.Self_Test(Basic_Camera);
-
- if Basic_Camera.Shutter /= TC_Expected_Basic_Speed then
- Report.Failed ("Call dispatched incorrectly for root type");
- end if;
-
-
- -- C392D02_0.Set_Shutter_Speed should never be called by F392D00.Self_Test,
- -- since C392D02_0.Set_Shutter_Speed does not override
- -- F392D00.Set_Shutter_Speed.
-
- -- For an object of type Auto_Speed, the dispatching call should
- -- also dispatch to the body declared for the root type:
-
- F392D00.Self_Test(Auto_Camera1);
-
- if Auto_Camera1.Shutter /= TC_Expected_Basic_Speed then
- Report.Failed ("Call dispatched incorrectly for derived type");
- end if;
-
- -- Call to Self_Test from C392D02_0 invokes the dispatching call to
- -- Set_Shutter_Speed which should dispatch to the body explicitly declared
- -- for Auto_Speed:
-
- C392D02_0.Self_Test(Auto_Camera2);
-
- if Auto_Camera2.Shutter /= TC_Expected_Speed then
- Report.Failed ("Call to explicit subprogram executed the wrong body");
- end if;
-
- Report.Result;
-
-end C392D02;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c392d03.a b/gcc/testsuite/ada/acats/tests/c3/c392d03.a
deleted file mode 100644
index 3a488952e96..00000000000
--- a/gcc/testsuite/ada/acats/tests/c3/c392d03.a
+++ /dev/null
@@ -1,248 +0,0 @@
--- C392D03.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that, for an inherited dispatching operation that is overridden,
--- the body executed is the body of the overriding subprogram, even if
--- the overriding occurs in a private part.
---
--- Check for the case where the overriding operation is declared in a
--- separate (non-child) package from that declaring the parent type, and
--- the descendant type is a record extension.
---
--- Check for both dispatching and nondispatching calls.
---
--- TEST DESCRIPTION:
--- Consider:
---
--- package P is
--- type Root is tagged ...
--- procedure Op (A: Root);
--- end P;
---
--- with P;
--- package Q is
--- type Derived1 is new P.Root with record...
--- -- Implicit procedure Op (A: Derived1) declared here.
--- type Derived2 is new P.Root with private...
--- -- Implicit procedure Op (A: Derived2) declared here.
--- type New_Derived is new Derived1 with private...
--- -- Implicit procedure Op (A: New_Derived) declared here.
--- private
--- procedure Op (A: Derived1); -- Overrides parent's Op.
--- type Derived2 is new P.Root with record...
--- procedure Op (A: Derived2); -- Overrides parent's Op.
--- type New_Derived is new Derived1 with record...
--- ...
--- end Q;
---
--- Both type Derived1 and Derived2 inherit Op from the parent type Root.
--- Type New_Derived inherits (inherited) Op from Derived1. The inherited
--- operation is implicitly declared immediately after the type extension.
--- The inherited operation is overridden by an explicit declaration in
--- the private part. Even though the overriding operation is private,
--- calls to Op with an operand of tag Derived1, Derived2, or New_Derived
--- will execute the body of the overriding operation.
---
--- TEST FILES:
--- The following files comprise this test:
---
--- F392D00.A
--- C392D03.A
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
---
---!
-
-with F392D00;
-package C392D03_0 is
-
- type Aperture is (Eight, Sixteen);
-
- type Auto_Focus is new F392D00.Remote_Camera with record
- -- ...
- FStop : Aperture;
- end record;
-
- -- Implicit procedure Focus (C : in out Auto_Focus;
- -- Depth : in Depth_Of_Field) declared here.
-
- type Auto_Flashing is new F392D00.Remote_Camera with private;
-
- -- Implicit procedure Focus (C : in out Auto_Flashing;
- -- Depth : in Depth_Of_Field) declared here.
-
- type Special_Focus is new Auto_Focus with private;
-
- -- Implicit procedure Focus (C : in out Special_Focus;
- -- Depth : in Depth_Of_Field) declared here.
-
- -- ...Other operations.
-
-private
-
- procedure Focus (C : in out Auto_Focus; -- Overrides
- Depth : in F392D00.Depth_Of_Field); -- parent's op.
-
- -- For the improved remote camera, focus is set automatically, so it is
- -- declared as a private operation.
-
- type Auto_Flashing is new F392D00.Remote_Camera with null record;
-
- procedure Focus (C : in out Auto_Flashing; -- Overrides
- Depth : in F392D00.Depth_Of_Field); -- parent's op.
-
- type Special_Focus is new Auto_Focus with null record;
-
-end C392D03_0;
-
-
- --==================================================================--
-
-
-package body C392D03_0 is
-
- procedure Focus (C : in out Auto_Focus;
- Depth : in F392D00.Depth_Of_Field) is
- begin
- -- Artificial for testing purposes.
- C.DOF := 52;
- end Focus;
-
- -----------------------------------------------------------
- procedure Focus (C : in out Auto_Flashing;
- Depth : in F392D00.Depth_Of_Field) is
- begin
- -- Artificial for testing purposes.
- C.DOF := 91;
- end Focus;
-
-end C392D03_0;
-
-
- --==================================================================--
-
-
-with F392D00;
-with C392D03_0;
-
-with Report;
-
-procedure C392D03 is
-
- type Focus_Ptr is access procedure
- (P1 : in out C392D03_0.Auto_Focus;
- P2 : in F392D00.Depth_Of_Field);
-
- Basic_Camera : F392D00.Remote_Camera;
- Auto_Camera1 : C392D03_0.Auto_Focus;
- Auto_Camera2 : C392D03_0.Auto_Focus;
- Flash_Camera1 : C392D03_0.Auto_Flashing;
- Flash_Camera2 : C392D03_0.Auto_Flashing;
- Special_Camera : C392D03_0.Special_Focus;
- Auto_Depth : F392D00.Depth_Of_Field := 78;
-
- TC_Expected_Basic_Depth : constant F392D00.Depth_Of_Field := 46;
- TC_Expected_Auto_Depth : constant F392D00.Depth_Of_Field := 52;
- TC_Expected_Depth : constant F392D00.Depth_Of_Field := 91;
-
- FP : Focus_Ptr := C392D03_0.Focus'Access;
-
- use type F392D00.Depth_Of_Field;
-
-begin
- Report.Test ("C392D03", "Dispatching for overridden primitive " &
- "subprograms: record extension declared in non-child " &
- "package, parent is tagged record");
-
-
--- Call the class-wide operation for Remote_Camera'Class, which itself makes
--- a dispatching call to Focus:
-
- -- For an object of type Remote_Camera, the dispatching call should
- -- dispatch to the body declared for the root type:
-
- F392D00.Self_Test(Basic_Camera);
-
- if Basic_Camera.DOF /= TC_Expected_Basic_Depth then
- Report.Failed ("Call dispatched incorrectly for root type");
- end if;
-
-
- -- For an object of type Auto_Focus, the dispatching call should
- -- dispatch to the body declared for the derived type:
-
- F392D00.Self_Test(Auto_Camera1);
-
- if Auto_Camera1.DOF /= TC_Expected_Auto_Depth then
- Report.Failed ("Call dispatched incorrectly for Auto_Focus type");
- end if;
-
-
- -- For an object of type Auto_Flash, the dispatching call should
- -- also dispatch to the body declared for the derived type:
-
- F392D00.Self_Test(Flash_Camera1);
-
- if Flash_Camera1.DOF /= TC_Expected_Depth then
- Report.Failed ("Call dispatched incorrectly for Auto_Flash type");
- end if;
-
- -- For an object of Auto_Flash type, a non-dispatching call to Focus should
- -- execute the body declared for the derived type (even through it is
- -- declared in the private part).
-
- C392D03_0.Focus (Flash_Camera2, Auto_Depth);
-
- if Flash_Camera2.DOF /= TC_Expected_Depth then
- Report.Failed ("Non-dispatching call to privately overriding " &
- "subprogram executed the wrong body");
- end if;
-
- -- For an object of Auto_Focus type, a non-dispatching call to Focus should
- -- execute the body declared for the derived type (even through it is
- -- declared in the private part).
-
- FP.all (Auto_Camera2, Auto_Depth);
-
- if Auto_Camera2.DOF /= TC_Expected_Auto_Depth then
- Report.Failed ("Non-dispatching call by using access to overriding " &
- "subprogram executed the wrong body");
- end if;
-
- -- For an object of type Special_Camera, the dispatching call should
- -- also dispatch to the body declared for the derived type:
-
- F392D00.Self_Test(Special_Camera);
-
- if Special_Camera.DOF /= TC_Expected_Auto_Depth then
- Report.Failed ("Call dispatched incorrectly for Special_Camera type");
- end if;
-
- Report.Result;
-
-end C392D03;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c393001.a b/gcc/testsuite/ada/acats/tests/c3/c393001.a
deleted file mode 100644
index 9d6f85c6392..00000000000
--- a/gcc/testsuite/ada/acats/tests/c3/c393001.a
+++ /dev/null
@@ -1,407 +0,0 @@
--- C393001.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that an abstract type can be declared, and in turn concrete
--- types can be derived from it. Check that the definition of
--- actual subprograms associated with the derived types dispatch
--- correctly.
---
--- TEST DESCRIPTION:
--- This test declares an abstract type Breaker in a package, and
--- then derives from it. The type Basic_Breaker defines the least
--- possible in order to not be abstract. The type Ground_Fault is
--- defined to inherit as much as possible, whereas type Special_Breaker
--- overrides everything it can. The type Special_Breaker also includes
--- an embedded Basic_Breaker object. The main program then utilizes
--- each of the three types of breaker, and to ascertain that the
--- overloading and tagging resolution are correct, each "Create"
--- procedure is called with a unique value. The diagram below
--- illustrates the relationships. This test is derived from C3A2001.
---
--- Abstract type: Breaker
--- |
--- Basic_Breaker (Short)
--- / \
--- (Sharp) Ground_Fault Special_Breaker (Shock)
---
--- Test structure is an array of class-wide objects, modeling a circuit
--- as a list of components. The test then creates some values, and
--- traverses the list to determine correct operation.
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 13 Nov 95 SAIC Revised for 2.0.1
---
---!
-
------------------------------------------------------------------ C393001_1
-
-with Report;
-package C393001_1 is
-
- type Breaker is abstract tagged private;
- type Status is ( Power_Off, Power_On, Tripped, Failed );
-
- procedure Flip ( The_Breaker : in out Breaker ) is abstract;
- procedure Trip ( The_Breaker : in out Breaker ) is abstract;
- procedure Reset( The_Breaker : in out Breaker ) is abstract;
- procedure Fail ( The_Breaker : in out Breaker );
-
- procedure Set ( The_Breaker : in out Breaker'Class; To_State : Status );
-
- function Status_Of( The_Breaker : Breaker ) return Status;
-
-private
- type Breaker is abstract tagged record
- State : Status := Power_Off;
- end record;
-end C393001_1;
-
-with TCTouch;
-package body C393001_1 is
- procedure Fail( The_Breaker : in out Breaker ) is ------------------- a
- begin
- TCTouch.Touch( 'a' );
- The_Breaker.State := Failed;
- end Fail;
-
- procedure Set( The_Breaker : in out Breaker'Class; To_State : Status ) is
- begin
- The_Breaker.State := To_State;
- end Set;
-
- function Status_Of( The_Breaker : Breaker ) return Status is ------- b
- begin
- TCTouch.Touch( 'b' );
- return The_Breaker.State;
- end Status_Of;
-end C393001_1;
-
------------------------------------------------------------------ C393001_2
-
-with C393001_1;
-package C393001_2 is
-
- type Basic_Breaker is new C393001_1.Breaker with private;
-
- type Voltages is ( V12, V110, V220, V440 );
- type Amps is ( A1, A5, A10, A25, A100 );
-
- function Construct( Voltage : Voltages; Amperage : Amps )
- return Basic_Breaker;
-
- procedure Flip ( The_Breaker : in out Basic_Breaker );
- procedure Trip ( The_Breaker : in out Basic_Breaker );
- procedure Reset( The_Breaker : in out Basic_Breaker );
-private
- type Basic_Breaker is new C393001_1.Breaker with record
- Voltage_Level : Voltages := V110;
- Amperage : Amps;
- end record;
-end C393001_2;
-
-with TCTouch;
-package body C393001_2 is
- function Construct( Voltage : Voltages; Amperage : Amps ) ----------- c
- return Basic_Breaker is
- It : Basic_Breaker;
- begin
- TCTouch.Touch( 'c' );
- It.Amperage := Amperage;
- It.Voltage_Level := Voltage;
- C393001_1.Set( It, C393001_1.Power_Off );
- return It;
- end Construct;
-
- procedure Flip ( The_Breaker : in out Basic_Breaker ) is ------------ d
- begin
- TCTouch.Touch( 'd' );
- case Status_Of( The_Breaker ) is
- when C393001_1.Power_Off =>
- C393001_1.Set( The_Breaker, C393001_1.Power_On );
- when C393001_1.Power_On =>
- C393001_1.Set( The_Breaker, C393001_1.Power_Off );
- when C393001_1.Tripped | C393001_1.Failed => null;
- end case;
- end Flip;
-
- procedure Trip ( The_Breaker : in out Basic_Breaker ) is ------------ e
- begin
- TCTouch.Touch( 'e' );
- C393001_1.Set( The_Breaker, C393001_1.Tripped );
- end Trip;
-
- procedure Reset( The_Breaker : in out Basic_Breaker ) is ------------ f
- begin
- TCTouch.Touch( 'f' );
- case Status_Of( The_Breaker ) is
- when C393001_1.Power_Off | C393001_1.Tripped =>
- C393001_1.Set( The_Breaker, C393001_1.Power_On );
- when C393001_1.Power_On | C393001_1.Failed => null;
- end case;
- end Reset;
-
-end C393001_2;
-
-with C393001_1,C393001_2;
-package C393001_3 is
-
- type Ground_Fault is new C393001_2.Basic_Breaker with private;
-
- function Construct( Voltage : C393001_2.Voltages; Amperage : C393001_2.Amps
-)
- return Ground_Fault;
-
- procedure Set_Trip( The_Breaker : in out Ground_Fault;
- Capacitance : in Integer );
-
-private
- type Ground_Fault is new C393001_2.Basic_Breaker with record
- Capacitance : Integer;
- end record;
-end C393001_3;
-
------------------------------------------------------------------ C393001_3
-
-with TCTouch;
-package body C393001_3 is
-
- function Construct( Voltage : C393001_2.Voltages; ------------------ g
- Amperage : C393001_2.Amps )
- return Ground_Fault is
-
- It : Ground_Fault;
-
- procedure Set_Root( It: in out C393001_2.Basic_Breaker ) is
- begin
- It := C393001_2.Construct( Voltage, Amperage );
- end Set_Root;
-
- begin
- TCTouch.Touch( 'g' );
- Set_Root( C393001_2.Basic_Breaker( It ) );
- It.Capacitance := 0;
- return It;
- end Construct;
-
- procedure Set_Trip( The_Breaker : in out Ground_Fault; -------------- h
- Capacitance : in Integer ) is
- begin
- TCTouch.Touch( 'h' );
- The_Breaker.Capacitance := Capacitance;
- end Set_Trip;
-
-end C393001_3;
-
------------------------------------------------------------------ C393001_4
-
-with C393001_1, C393001_2;
-package C393001_4 is
-
- type Special_Breaker is new C393001_2.Basic_Breaker with private;
-
- function Construct( Voltage : C393001_2.Voltages;
- Amperage : C393001_2.Amps )
- return Special_Breaker;
-
- procedure Flip ( The_Breaker : in out Special_Breaker );
- procedure Trip ( The_Breaker : in out Special_Breaker );
- procedure Reset( The_Breaker : in out Special_Breaker );
- procedure Fail ( The_Breaker : in out Special_Breaker );
-
- function Status_Of( The_Breaker : Special_Breaker ) return C393001_1.Status;
- function On_Backup( The_Breaker : Special_Breaker ) return Boolean;
-
-private
- type Special_Breaker is new C393001_2.Basic_Breaker with record
- Backup : C393001_2.Basic_Breaker;
- end record;
-end C393001_4;
-
-with TCTouch;
-package body C393001_4 is
-
- function Construct( Voltage : C393001_2.Voltages; --------------- i
- Amperage : C393001_2.Amps )
- return Special_Breaker is
- It: Special_Breaker;
- procedure Set_Root( It: in out C393001_2.Basic_Breaker ) is
- begin
- It := C393001_2.Construct( Voltage, Amperage );
- end Set_Root;
- begin
- TCTouch.Touch( 'i' );
- Set_Root( C393001_2.Basic_Breaker( It ) );
- Set_Root( It.Backup );
- return It;
- end Construct;
-
- function Status_Of( It: C393001_1.Breaker ) return C393001_1.Status
- renames C393001_1.Status_Of;
-
- procedure Flip ( The_Breaker : in out Special_Breaker ) is ---------- j
- begin
- TCTouch.Touch( 'j' );
- case Status_Of( C393001_1.Breaker( The_Breaker )) is
- when C393001_1.Power_Off | C393001_1.Power_On =>
- C393001_2.Flip( C393001_2.Basic_Breaker( The_Breaker ) );
- when others =>
- C393001_2.Flip( The_Breaker.Backup );
- end case;
- end Flip;
-
- procedure Trip ( The_Breaker : in out Special_Breaker ) is ---------- k
- begin
- TCTouch.Touch( 'k' );
- case Status_Of( C393001_1.Breaker( The_Breaker )) is
- when C393001_1.Power_Off => null;
- when C393001_1.Power_On =>
- C393001_2.Reset( The_Breaker.Backup );
- C393001_2.Trip( C393001_2.Basic_Breaker( The_Breaker ) );
- when others =>
- C393001_2.Trip( The_Breaker.Backup );
- end case;
- end Trip;
-
- procedure Reset( The_Breaker : in out Special_Breaker ) is ---------- l
- begin
- TCTouch.Touch( 'l' );
- case Status_Of( C393001_1.Breaker( The_Breaker )) is
- when C393001_1.Tripped =>
- C393001_2.Reset( C393001_2.Basic_Breaker( The_Breaker ));
- when C393001_1.Failed =>
- C393001_2.Reset( The_Breaker.Backup );
- when C393001_1.Power_On | C393001_1.Power_Off =>
- null;
- end case;
- end Reset;
-
- procedure Fail ( The_Breaker : in out Special_Breaker ) is ---------- m
- begin
- TCTouch.Touch( 'm' );
- case Status_Of( C393001_1.Breaker( The_Breaker )) is
- when C393001_1.Failed =>
- C393001_2.Fail( The_Breaker.Backup );
- when others =>
- C393001_2.Fail( C393001_2.Basic_Breaker( The_Breaker ));
- C393001_2.Reset( The_Breaker.Backup );
- end case;
- end Fail;
-
- function Status_Of( The_Breaker : Special_Breaker ) ----------------- n
- return C393001_1.Status is
- begin
- TCTouch.Touch( 'n' );
- case Status_Of( C393001_1.Breaker( The_Breaker )) is
- when C393001_1.Power_On => return C393001_1.Power_On;
- when C393001_1.Power_Off => return C393001_1.Power_Off;
- when others =>
- return C393001_2.Status_Of( The_Breaker.Backup );
- end case;
- end Status_Of;
-
- function On_Backup( The_Breaker : Special_Breaker ) return Boolean is
- use C393001_2;
- use type C393001_1.Status;
- begin
- return Status_Of(Basic_Breaker(The_Breaker)) = C393001_1.Tripped
- or Status_Of(Basic_Breaker(The_Breaker)) = C393001_1.Failed;
- end On_Backup;
-
-end C393001_4;
-
-------------------------------------------------------------------- C393001
-
-with Report, TCTouch;
-with C393001_1, C393001_2, C393001_3, C393001_4;
-procedure C393001 is
-
- procedure Flipper( The_Circuit : in out C393001_1.Breaker'Class ) is
- begin
- C393001_1.Flip( The_Circuit );
- end Flipper;
-
- procedure Tripper( The_Circuit : in out C393001_1.Breaker'Class ) is
- begin
- C393001_1.Trip( The_Circuit );
- end Tripper;
-
- procedure Restore( The_Circuit : in out C393001_1.Breaker'Class ) is
- begin
- C393001_1.Reset( The_Circuit );
- end Restore;
-
- procedure Failure( The_Circuit : in out C393001_1.Breaker'Class ) is
- begin
- C393001_1.Fail( The_Circuit );
- end Failure;
-
- Short : C393001_1.Breaker'Class -- Basic_Breaker
- := C393001_2.Construct( C393001_2.V440, C393001_2.A5 );
- Sharp : C393001_1.Breaker'Class -- Ground_Fault
- := C393001_3.Construct( C393001_2.V110, C393001_2.A1 );
- Shock : C393001_1.Breaker'Class -- Special_Breaker
- := C393001_4.Construct( C393001_2.V12, C393001_2.A100 );
-
-begin -- Main test procedure.
-
- Report.Test ("C393001", "Check that an abstract type can be declared " &
- "and used. Check actual subprograms dispatch correctly" );
-
- TCTouch.Validate( "cgcicc", "Declaration" );
-
- Flipper( Short );
- TCTouch.Validate( "db", "Flipping Short" );
- Flipper( Sharp );
- TCTouch.Validate( "db", "Flipping Sharp" );
- Flipper( Shock );
- TCTouch.Validate( "jbdb", "Flipping Shock" );
-
- Tripper( Short );
- TCTouch.Validate( "e", "Tripping Short" );
- Tripper( Sharp );
- TCTouch.Validate( "e", "Tripping Sharp" );
- Tripper( Shock );
- TCTouch.Validate( "kbfbe", "Tripping Shock" );
-
- Restore( Short );
- TCTouch.Validate( "fb", "Restoring Short" );
- Restore( Sharp );
- TCTouch.Validate( "fb", "Restoring Sharp" );
- Restore( Shock );
- TCTouch.Validate( "lbfb", "Restoring Shock" );
-
- Failure( Short );
- TCTouch.Validate( "a", "Shock Failing" );
- Failure( Sharp );
- TCTouch.Validate( "a", "Shock Failing" );
- Failure( Shock );
- TCTouch.Validate( "mbafb", "Shock Failing" );
-
- Report.Result;
-
-end C393001;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c393007.a b/gcc/testsuite/ada/acats/tests/c3/c393007.a
deleted file mode 100644
index 93458eeffb8..00000000000
--- a/gcc/testsuite/ada/acats/tests/c3/c393007.a
+++ /dev/null
@@ -1,157 +0,0 @@
--- C393007.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- TEST OBJECTIVE:
--- Check that an extended type can be derived from an abstract type,
--- where the abstract type is defined in a package, and the type derived
--- from it is defined in a distinct library package.
---
--- TEST DESCRIPTION:
--- Declare an private (abstract) type; declare two primitive operations
--- of the type that are explicitly abstract.
--- Derive an extended type from the (private) abstract type, overriding
--- both of the primitive operations.
--- This test also checks to see that name overloading between abstract
--- and non-abstract functions is resolved correctly.
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
---
---!
-
- package C393007_0 is
- -- Alert_System
-
- type DT_Type is new Integer;
-
- type Alert_Type is abstract tagged record
- Time_Of_Arrival : DT_Type;
- end record;
-
- type Log_File_Type is range 0 .. 100;
-
- Procedure Handle (A : in out Alert_type) is abstract;
-
- procedure Log (A : Alert_Type;
- L : in out Log_File_Type) is abstract;
-
- procedure Set_Time (A : in out Alert_Type);
-
- function Correct_Time_Stamp (A : Alert_Type) return Boolean;
-
- Day_Time : DT_Type := 100;
-
- end C393007_0;
- -- Alert_System;
-
- --=======================================================================--
-
- package body C393007_0 is
- -- Alert_System
-
- function Time_Stamp return DT_Type is
- begin
- Day_Time := Day_Time + 1;
- return Day_Time;
- end Time_Stamp;
-
- procedure Set_Time (A : in out Alert_Type) is
- begin
- A.Time_Of_Arrival := Time_Stamp;
- end Set_time;
-
- function Correct_Time_Stamp ( A : Alert_Type) return Boolean is
- begin
- return (A.Time_Of_Arrival = Day_Time);
- end Correct_Time_Stamp;
-
- end C393007_0;
- -- Alert_System;
-
- --=======================================================================--
-
- with Report;
- with C393007_0;
- -- Alert_system;
-
- package C393007_1 is
-
- type Normal_Alert_Type is
- new C393007_0.Alert_Type
- with null record;
-
- Log_File: C393007_0.Log_File_Type := C393007_0.Log_File_Type'First;
-
- procedure Handle (A : in out Normal_Alert_Type); -- Override is required
-
- procedure Log (A : Normal_Alert_Type; -- Override is required
- L : in out C393007_0.Log_File_Type);
- end C393007_1;
-
- package body C393007_1 is
- use type C393007_0.Log_File_Type;
-
- procedure Handle (A : in out Normal_Alert_Type) is
- begin
- Set_Time (A);
- Log (A, Log_File);
- end Handle;
-
- procedure Log (A : Normal_Alert_Type;
- L : in out C393007_0.Log_File_Type) is
- begin
- L := C393007_0."+"(L, 1);
- end Log;
-
- end C393007_1;
-
- with Report;
- with C393007_0;
- with C393007_1;
- -- Alert_system;
-
- procedure C393007 is
- use C393007_0;
- use C393007_1;
-
- Alert_One : C393007_1.Normal_Alert_Type;
-
- begin
- Report.Test ("C393007", "Check that an extended type can be derived " &
- "from an abstract type");
-
- Handle (Alert_One);
- if not Correct_Time_Stamp (Alert_One) then
- Report.Failed ("Wrong results from procedure Handle");
- end if;
-
- if Log_File /=1 then
- Report.Failed ("Wrong results");
- end if;
-
- Report.Result;
-
- end C393007;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c393008.a b/gcc/testsuite/ada/acats/tests/c3/c393008.a
deleted file mode 100644
index d2d2aefed92..00000000000
--- a/gcc/testsuite/ada/acats/tests/c3/c393008.a
+++ /dev/null
@@ -1,204 +0,0 @@
--- C393008.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- TEST OBJECTIVE:
--- Check that an extended type can be derived from an abstract type.
---
--- TEST DESCRIPTION:
--- Declare a tagged record; declare an abstract
--- primitive operation and a non-abstract primitive operation of the
--- type. Derive an extended type from it, including a new component.
--- Use the derived type, the overriding operation and the inherited
--- operation to instantiate a generic package. The overriding operation
--- calls a new primitive operation and an inherited operation [so the
--- instantiation must get this sorted out correctly].
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
---
---!
-
-with Report;
-with TCTouch;
-procedure C393008 is
-
-package C393008_0 is
-
- type Status_Enum is (No_Status, Handled, Unhandled, Pending);
-
- type Alert_Type is abstract tagged record
- Status : Status_Enum;
- Reply : Boolean;
- Urgent : Boolean;
- end record;
-
- subtype Serial_Number is Integer range 0..Integer'last;
- Serial_Num : Serial_Number := 0;
-
- procedure Handle (A : in out Alert_Type) is abstract;
- -- abstract primitive operation
-
- -- the procedure Init would be _nice_ have this procedure be non_abstract
- -- and create a "base" object with a "null" constraint. The language
- -- will not allow this due to the restriction that an object of an
- -- abstract type cannot be created. Hence Init must be abstract,
- -- requiring any type derived directly from Alert_Type to declare
- -- an Init.
- --
- -- In light of this, I have changed init to a function to more closely
- -- model the typical usage of OO features...
-
- function Init return Alert_Type is abstract;
-
- procedure No_Reply (A : in out Alert_Type);
-
-end C393008_0;
-
---=======================================================================--
-
-package body C393008_0 is
-
- procedure No_Reply (A : in out Alert_Type) is
- begin -- primitive operation, not abstract
- TCTouch.Touch('A'); ------------------------------------------------- A
- if A.Status = Handled then
- A.Reply := False;
- end if;
- end No_Reply;
-
-end C393008_0;
-
---=======================================================================--
-
- generic
- -- pass in the Alert_Type object, including its
- -- operations
- type Data_Type is new C393008_0.Alert_Type with private;
- -- note that Alert_Type is abstract, so it may not be
- -- used as an actual parameter
- with procedure Update (P : in out Data_Type) is <>; -- generic formal
- with function Initialize return Data_Type is <>; -- generic formal
-
- package C393008_1 is
- -- Utilities
-
- procedure Modify (Item : in out Data_Type);
-
- end C393008_1;
- -- Utilities
-
---=======================================================================--
-
- package body C393008_1 is
- -- Utilities
-
- procedure Modify (Item : in out Data_Type) is
- begin
- TCTouch.Touch('B'); --------------------------------------------- B
- Item := Initialize;
- Update (Item);
- end Modify;
-
- end C393008_1;
-
---=======================================================================--
-
- package C393008_2 is
-
- type Low_Alert_Type is new C393008_0.Alert_Type with record
- Serial : C393008_0.Serial_Number;
- end record;
-
- procedure Serialize (LA : in out Low_Alert_Type);
-
- -- inherit No_Reply
-
- procedure Handle (LA : in out Low_Alert_Type);
-
- function Init return Low_Alert_Type;
- end C393008_2;
-
- package body C393008_2 is
- procedure Serialize (LA : in out Low_Alert_Type) is
- begin -- new primitive operation
- TCTouch.Touch('C'); ------------------------------------------------- C
- C393008_0.Serial_Num := C393008_0.Serial_Num + 1;
- LA.Serial := C393008_0.Serial_Num;
- end Serialize;
-
- -- inherit No_Reply
-
- function Init return Low_Alert_Type is
- TA: Low_Alert_Type;
- begin
- TCTouch.Touch('D'); ------------------------------------------------- D
- Serialize( TA );
- TA.Status := C393008_0.No_Status;
- return TA;
- end Init;
-
- procedure Handle (LA : in out Low_Alert_Type) is
- begin -- overrides abstract inherited Handle
- TCTouch.Touch('E'); ------------------------------------------------- E
- Serialize (LA);
- LA.Reply := False;
- LA.Status := C393008_0.Handled;
- No_Reply (LA);
- end Handle;
-
- end C393008_2;
-
- use C393008_2;
-
- package Alert_Utilities is new
- C393008_1 (Data_Type => Low_Alert_Type,
- Update => Handle, -- Low_Alert's Handle
- Initialize => Init); -- inherited from Alert
-
- Item : Low_Alert_Type;
-
- use type C393008_0.Status_Enum;
-
-begin
-
- Report.Test ("C393008", "Check that an extended type can be derived "&
- "from an abstract type");
-
- Item := Init;
- if (Item.Status /= C393008_0.No_Status) or (Item.Serial /=1) then
- Report.Failed ("Wrong initialization");
- end if;
- TCTouch.Validate("DC", "Initialization Call");
-
- Alert_Utilities.Modify (Item);
- if (Item.Status /= C393008_0.Handled) or (Item.Serial /= 3) then
- Report.Failed ("Wrong results from Modify");
- end if;
- TCTouch.Validate("BDCECA", "Generic Instance Call");
-
- Report.Result;
-
-end C393008;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c393009.a b/gcc/testsuite/ada/acats/tests/c3/c393009.a
deleted file mode 100644
index 1353f9c37d4..00000000000
--- a/gcc/testsuite/ada/acats/tests/c3/c393009.a
+++ /dev/null
@@ -1,170 +0,0 @@
--- C393009.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- TEST OBJECTIVE:
--- Check that an extended type can be derived from an abstract type.
---
--- TEST DESCRIPTION:
--- Declare an abstract type in the specification of a generic package.
--- Instantiate the package and derive an extended type from the abstract
--- (instantiated) type; override all abstract operations; use all
--- inherited operations;
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 14 Oct 95 SAIC Fixed for ACVC 2.0.1
---
---!
-
-with Report;
-procedure C393009 is
-
- package Display_Devices is
-
- type Display_Device_Enum is (None, TTY, Console, Big_Screen);
- Display : Display_Device_Enum := None;
-
- end Display_Devices;
-
---=======================================================================--
-
- generic
-
- type Generic_Status is (<>);
-
- type Serial_Type is (<>);
-
- package Alert_System is
-
- type Alert_Type (Serial : Serial_Type) is abstract tagged record
- Status : Generic_Status;
- end record;
-
- Next_Serial_Number : Serial_Type := Serial_Type'First;
-
- procedure Handle (A : in out Alert_Type) is abstract;
- -- abstract operation - must be overridden after instantiation
-
- procedure Display ( A : Alert_Type;
- On : Display_Devices.Display_Device_Enum);
- -- primitive operation of Alert_Type
- -- not required to be overridden
-
- function Get_Serial_Number (A : Alert_Type) return Serial_Type;
- -- primitive operation of Alert_Type
- -- not required to be overridden
-
- end Alert_System;
-
---=======================================================================--
-
- package body Alert_System is
-
- procedure Display ( A : in Alert_Type;
- On : Display_Devices.Display_Device_Enum) is
- begin
- Display_Devices.Display := On;
- end Display;
-
- function Get_Serial_Number (A : Alert_Type)
- return Serial_Type is
- begin
- return A.Serial;
- end Get_Serial_Number;
-
- end Alert_System;
-
---=======================================================================--
-
- package NCC_1701 is
-
- type Status_Kind is (Green, Yellow, Red);
- type Serial_Number_Type is new Integer range 1..Integer'Last;
-
- subtype Msg_Str is String (1..16);
- Alert_Msg : Msg_Str := "C393009 passed.";
- -- 123456789A123456
-
- package Alert_Pkg is new Alert_System (Status_Kind, Serial_Number_Type);
-
- type New_Alert_Type(Serial : Serial_Number_Type) is
- new Alert_Pkg.Alert_Type(Serial) with record
- Message : Msg_Str;
- end record;
-
- -- procedure Display is inherited by New_Alert_Type
-
- -- function Get_Serial_Number is inherited by New_Alert_Type
- procedure Handle (NA : in out New_Alert_Type); -- must be overridden
- procedure Init (NA : in out New_Alert_Type); -- new primitive
-
- NA : New_Alert_Type(Alert_Pkg.Next_Serial_Number);
- -- New_Alert_Type is not abstract, so an object of that
- -- type may be declared
-
- end NCC_1701;
-
- package body NCC_1701 is
-
- procedure Handle (NA : in out New_Alert_Type) is
- begin
- NA.Message := Alert_Msg;
- Display (NA, On => Display_Devices.TTY);
- end Handle;
-
- procedure Init (NA : in out New_Alert_Type) is -- new primitive operation
- begin -- for New_Alert_Type
- NA := (Serial=> NA.Serial, Status => Green, Message => (others => ' '));
- end Init;
-
- end NCC_1701;
-
- use NCC_1701;
- use type Display_Devices.Display_Device_Enum;
-
-begin
-
- Report.Test ("C393009", "Check that an extended type can be derived " &
- "from an abstract type");
-
- Init (NA);
- if (Get_Serial_Number (NA) /= 1)
- or (NA.Status /= Green)
- or (Display_Devices.Display /= Display_Devices.None) then
- Report.Failed ("Wrong Initialization");
- end if;
-
- Handle (NA);
- if (Get_Serial_Number (NA) /= 1)
- or (NA.Status /= Green)
- or (NA.Message /= Alert_Msg)
- or (Display_Devices.Display /= Display_Devices.TTY) then
- Report.Failed ("Wrong results from Handle");
- end if;
-
- Report.Result;
-
-end C393009;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c393010.a b/gcc/testsuite/ada/acats/tests/c3/c393010.a
deleted file mode 100644
index 6a52cf889a2..00000000000
--- a/gcc/testsuite/ada/acats/tests/c3/c393010.a
+++ /dev/null
@@ -1,306 +0,0 @@
--- C393010.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- TEST OBJECTIVE:
--- Check that an extended type can be derived from an abstract type and
--- that a call on an abstract operation is a dispatching operation.
--- Check that such a call can dispatch to an overriding operation
--- declared in the private part of a package.
---
--- TEST DESCRIPTION:
--- Taking from a classroom example of a typical usage: declare a basic
--- abstract type containing data germane to the entire class structure,
--- derive from that a type with specific data, and derive from that
--- another type merely providing a "secret" override. The abstract type
--- provides a concrete procedure that itself "redispatches" to an
--- abstract procedure; the abstract procedure must be provided by one or
--- more of the concrete types derived from the abstract type, and hence
--- upon re-evaluating the actual type of the operand should dispatch
--- accordingly.
---
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 15 Mar 96 SAIC ACVC 2.1
---
---!
-
------------------------------------------------------------------ C393010_0
-
-package C393010_0 is
-
- type Ticket is abstract tagged record
- Flight : Natural;
- Serial_Number : Natural;
- end record;
-
- function Issue return Ticket is abstract;
- procedure Label( T: Ticket ) is abstract;
-
- procedure Print( T: Ticket );
-
-end C393010_0;
-
-with TCTouch;
-package body C393010_0 is
-
- procedure Print( T: Ticket ) is
- begin
- -- Check that a call on an abstract operation is a dispatching operation
- Label( Ticket'Class( T ) );
- -- Appropriate_IO.Put( T.Flight & T.Serial_Number );
- TCTouch.Touch('P'); -------------------------------------------------- P
- end Print;
-
-end C393010_0;
-
------------------------------------------------------------------ C393010_1
-
-with C393010_0;
-package C393010_1 is
-
- type Service_Classes is (First, Business, Coach);
-
- type Menu is (Steak, Lobster, Fowl, Vegan);
-
- -- Check that an extended type can be derived from an abstract type.
- type Passenger_Ticket(Service : Service_Classes) is
- new C393010_0.Ticket with record
- Row_Seat : String(1..3);
- case Service is
- when First | Business => Meal : Menu;
- when Coach => null;
- end case;
- end record;
-
- function Issue return Passenger_Ticket;
- function Issue( Service : Service_Classes;
- Flight : Natural;
- Seat : String;
- Meal : Menu := Fowl ) return Passenger_Ticket;
-
- procedure Label( T: Passenger_Ticket );
-
- procedure Print( T: Passenger_Ticket );
-
-end C393010_1;
-
-with TCTouch;
-package body C393010_1 is
-
- procedure Label( T: Passenger_Ticket ) is
- begin
- -- Appropriate_IO.Put( T.Service );
- TCTouch.Touch('L'); -------------------------------------------------- L
- end Label;
-
- procedure Print( T: Passenger_Ticket ) is
- begin
- -- call parent print:
- C393010_0.Print( C393010_0.Ticket( T ) );
- case T.Service is
- when First => -- Appropriate_IO.Put( Meal );
- TCTouch.Touch('F'); ---------------------------------------------- F
- when Business => -- Appropriate_IO.Put( Meal );
- TCTouch.Touch('B'); ---------------------------------------------- B
- when Coach => -- Appropriate_IO.Put( "BYO" & " peanuts" );
- TCTouch.Touch('C'); ---------------------------------------------- C
- end case;
- end Print;
-
- Num : Natural := 1000;
-
- function Issue( Service : Service_Classes;
- Flight : Natural;
- Seat : String;
- Meal : Menu := Fowl ) return Passenger_Ticket is
- begin
- Num := Num +1;
- case Service is
- when First =>
- return Passenger_Ticket'(Service => First, Flight => Flight,
- Row_Seat => Seat, Meal => Meal, Serial_Number => Num );
- when Business =>
- return Passenger_Ticket'(Service => Business, Flight => Flight,
- Row_Seat => Seat, Meal => Meal, Serial_Number => Num );
- when Coach =>
- return Passenger_Ticket'(Service => Coach, Flight => Flight,
- Row_Seat => Seat, Serial_Number => Num );
- end case;
- end Issue;
-
- function Issue return Passenger_Ticket is
- begin
- return Issue( Coach, 0, "non" );
- end Issue;
-
-end C393010_1;
-
------------------------------------------------------------------ C393010_1
-
-with C393010_1;
-package C393010_2 is
-
- type Charter is new C393010_1.Passenger_Ticket( C393010_1.Coach )
- with private;
-
- function Issue return Charter;
-
- -- procedure Print( T: Passenger_Ticket );
-
-private
- type Charter is new C393010_1.Passenger_Ticket( C393010_1.Coach )
- with null record;
-
- -- Check that the dispatching call to the abstract operation will dispatch
- -- to a procedure defined in the private part of a package.
- procedure Label( T: Charter );
-
- -- an example of a required function the users shouldn't see:
- function Issue( Service : C393010_1.Service_Classes;
- Flight : Natural;
- Seat : String;
- Meal : C393010_1.Menu ) return Charter;
-
-end C393010_2;
-
-with TCTouch;
-package body C393010_2 is
-
- procedure Label( T: Charter ) is
- begin
- -- Appropriate_IO.Put( "Excursion Fare" );
- TCTouch.Touch('X'); -------------------------------------------------- X
- end Label;
-
- Num : Natural := 4000;
-
- function Issue return Charter is
- begin
- Num := Num +1;
- return Charter'(Service => C393010_1.Coach, Flight => 1001,
- Row_Seat => "OPN", Serial_Number => Num );
- end Issue;
-
- function Issue( Service : C393010_1.Service_Classes;
- Flight : Natural;
- Seat : String;
- Meal : C393010_1.Menu ) return Charter is
- begin
- return Issue;
- end Issue;
-
-end C393010_2;
-
------------------------------------------------------------------ C393010_1
-
-with Report;
-with TCTouch;
-with C393010_0;
-with C393010_1;
-with C393010_2; -- Charter Tours
-
-procedure C393010 is
-
- type Agents_Handle is access all C393010_0.Ticket'Class;
-
- type Itinerary;
-
- type Next_Leg is access Itinerary;
-
- type Itinerary is record
- Leg : Agents_Handle;
- Next : Next_Leg;
- end record;
-
- function Travel_Agent_1 return Next_Leg is
- begin
- -- ORL -> JFK -> LAX -> SAN -> DFW -> ORL
- return new Itinerary'(
- -- ORL -> JFK 01 12 2A First, Lobster
- new C393010_1.Passenger_Ticket'(
- C393010_1.Issue(C393010_1.First, 12, " 2A", C393010_1.Lobster )),
- new Itinerary'(
- -- JFK -> LAX 02 18 2B First, Steak
- new C393010_1.Passenger_Ticket'(
- C393010_1.Issue(C393010_1.First, 18, " 2B", C393010_1.Steak )),
- new Itinerary'(
- -- LAX -> SAN 03 5225 34H Coach
- new C393010_1.Passenger_Ticket'(
- C393010_1.Issue(C393010_1.Coach, 5225, "34H")),
- new Itinerary'(
- -- SAN -> DFW 04 25 13A Business, Fowl
- new C393010_1.Passenger_Ticket'(
- C393010_1.Issue(C393010_1.Business, 25, "13A")),
- new Itinerary'(
- -- DFW -> ORL 05 15 1D First, Lobster
- new C393010_1.Passenger_Ticket'(
- C393010_1.Issue(C393010_1.First, 15, " 1D", C393010_1.Lobster )),
- null )))));
- end Travel_Agent_1;
-
- function Travel_Agent_2 return Next_Leg is
- begin
- -- LAX -> NRT -> SYD -> LAX
- return new Itinerary'(
- new C393010_2.Charter'( C393010_2.Issue ),
- new Itinerary'(
- new C393010_2.Charter'( C393010_2.Issue ),
- new Itinerary'(
- new C393010_2.Charter'( C393010_2.Issue ),
- new Itinerary'(
- new C393010_2.Charter'( C393010_2.Issue ),
- null ))));
- end Travel_Agent_2;
-
- procedure Traveler( Pax_Tix : in Next_Leg ) is
- Fly_Me : Next_Leg := Pax_Tix;
- begin
- -- a particularly consumptive process...
- while Fly_Me /= null loop
- C393010_0.Print( Fly_Me.Leg.all ); -- herein lies the test.
- Fly_Me := Fly_Me.Next;
- end loop;
- end Traveler;
-
-begin
-
- Report.Test ("C393010", "Check that an extended type can be derived from "
- & "an abstract type and that a call on an abstract "
- & "operation is a dispatching operation. Check "
- & "that such a call can dispatch to an overriding "
- & "operation declared in the private part of a "
- & "package" );
-
- Traveler( Travel_Agent_1 );
- TCTouch.Validate("LPFLPFLPCLPBLPF","First Trip");
-
- Traveler( Travel_Agent_2 );
- TCTouch.Validate("XPCXPCXPCXPC","Second Trip");
-
- Report.Result;
-
-end C393010;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c393011.a b/gcc/testsuite/ada/acats/tests/c3/c393011.a
deleted file mode 100644
index 8741e87c1c4..00000000000
--- a/gcc/testsuite/ada/acats/tests/c3/c393011.a
+++ /dev/null
@@ -1,220 +0,0 @@
--- C393011.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- TEST OBJECTIVE:
--- Check that an abstract extended type can be derived from an abstract
--- type, and that a a non-abstract type may then be derived from the
--- second abstract type.
---
--- TEST DESCRIPTION:
--- Define an abstract type with three primitive operations, two of them
--- abstract. Derive an extended type from it, inheriting the non-
--- abstract operation, overriding one of the abstract operations with
--- a non-abstract operation, and overriding the other abstract operation
--- with an abstract operation. The extended type is therefore abstract;
--- derive an extended type from it. Override the abstract operation with
--- a non-abstract operation; inherit one operation from the original
--- abstract type, and inherit one operation from the intermediate
--- abstract type.
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
---
---!
-
- Package C393011_0 is
- -- Definitions
-
- type Status_Enum is (None, Unhandled, Pending, Handled);
- type Serial_Type is new Integer range 0 .. Integer'Last;
- subtype Priority_Type is Integer range 0..10;
-
- type Display_Enum is (Bit_Bucket, TTY, Console, Big_Screen);
-
- Next : Serial_Type := 1;
- Display_Device : Display_Enum := Bit_Bucket;
-
- end C393011_0;
- -- Definitions;
-
- --=======================================================================--
-
- with C393011_0;
- -- Definitions
-
- Package C393011_1 is
- -- Alert
-
- package Definitions renames C393011_0;
-
- type Alert_Type is abstract tagged record
- Status : Definitions.Status_Enum := Definitions.None;
- Serial_Num : Definitions.Serial_Type := 0;
- Priority : Definitions.Priority_Type;
- end record;
- -- Alert_Type is an abstract type with
- -- two operations to be overridden
-
- procedure Set_Status ( A : in out Alert_Type; -- not abstract
- To : Definitions.Status_Enum);
-
- procedure Set_Serial ( A : in out Alert_Type) is abstract;
- procedure Display ( A : Alert_Type) is abstract;
-
- end C393011_1;
- -- Alert
-
- --=======================================================================--
-
- with C393011_0;
- package body C393011_1 is
- -- Alert
- procedure Set_Status ( A : in out Alert_Type;
- To : Definitions.Status_Enum) is
- begin
- A.Status := To;
- end Set_Status;
-
- end C393011_1;
- -- Alert;
-
- --=======================================================================--
-
- with C393011_0,
- -- Definitions,
- C393011_1,
- -- Alert,
- Calendar;
-
- Package C393011_3 is
- -- New_Alert
-
- type New_Alert_Type is abstract new C393011_1.Alert_Type with record
- Display_Dev : C393011_0.Display_Enum := C393011_0.TTY;
- end record;
-
- -- procedure Set_Status is inherited
-
- procedure Set_Serial ( A : in out New_Alert_Type); -- override/see body
-
- procedure Display ( A : New_Alert_Type) is abstract;
- -- override is abstract
- -- still can't declare objects of New_Alert_Type
-
- end C393011_3;
- -- New_Alert
-
- --=======================================================================--
-
- with C393011_0;
- Package Body C393011_3 is
- -- New_Alert
-
- package Definitions renames C393011_0;
-
- procedure Set_Serial (A : in out New_Alert_Type) is
- use type Definitions.Serial_Type;
- begin
- A.Serial_Num := Definitions.Next;
- Definitions.Next := Definitions."+"( Definitions.Next, 1);
- end Set_Serial;
-
- End C393011_3;
- -- New_Alert;
-
- --=======================================================================--
-
- with C393011_0,
- -- Definitions
- C393011_3;
- -- New_Alert -- package Alert is not visible
- package C393011_4 is
-
- package New_Alert renames C393011_3;
- package Definitions renames C393011_0;
-
- type Final_Alert_Type is new New_Alert.New_Alert_Type with null record;
- -- inherits Set_Status including body
- -- inherits Set_Serial including body
- -- must override Display since inherited Display is abstract
- procedure Display(FA : in Final_Alert_Type);
- procedure Handle (FA : in out Final_Alert_Type);
-
- end C393011_4;
-
- package body C393011_4 is
-
- procedure Display (FA : in Final_Alert_Type) is
- begin
- Definitions.Display_Device := FA.Display_Dev;
- end Display;
-
- procedure Handle (FA : in out Final_Alert_Type) is
- begin
- Set_Status (FA, Definitions.Handled);
- Set_Serial (FA);
- Display (FA);
- end Handle;
- end C393011_4;
-
- with C393011_0,
- -- Definitions
- C393011_3;
- -- New_Alert -- package Alert is not visible
- with C393011_4;
- with Report;
- procedure C393011 is
- use C393011_4;
- use Definitions;
-
- FA : Final_Alert_Type;
-
- begin
-
- Report.Test ("C393011", "Check that an extended type can be derived " &
- "from an abstract type");
-
- if (Definitions.Display_Device /= Definitions.Bit_Bucket)
- or (Definitions.Next /= 1)
- or (FA.Status /= Definitions.None)
- or (FA.Serial_Num /= 0)
- or (FA.Display_Dev /= TTY) then
- Report.Failed ("Incorrect initial conditions");
- end if;
-
- Handle (FA);
- if (Definitions.Display_Device /= Definitions.TTY)
- or (Definitions.Next /= 2)
- or (FA.Status /= Definitions.Handled)
- or (FA.Serial_Num /= 1)
- or (FA.Display_Dev /= TTY) then
- Report.Failed ("Incorrect results from Handle");
- end if;
-
- Report.Result;
-
- end C393011;
-
diff --git a/gcc/testsuite/ada/acats/tests/c3/c393012.a b/gcc/testsuite/ada/acats/tests/c3/c393012.a
deleted file mode 100644
index 16bf6ddccf8..00000000000
--- a/gcc/testsuite/ada/acats/tests/c3/c393012.a
+++ /dev/null
@@ -1,221 +0,0 @@
--- C393012.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that a non-abstract subprogram of an abstract type can be
--- called with a controlling operand that is a type conversion to
--- the abstract type.
---
--- Check that converting to the class-wide type of an abstract type
--- inside an operation of that type causes a "redispatch" of the
--- called operation.
---
--- TEST DESCRIPTION:
--- This test defines an abstract type, and further derives types from it.
--- The key feature of this test is in the "Display" procedures where
--- the bodies of these procedures convert an object to the class-wide
--- type of the root abstract type, causing a "redispatch".
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 16 Dec 94 SAIC Add allocation to the object initializations
---
---!
-
-package C393012_0 is
-
- subtype Row_Number is Positive range 1..120;
- subtype Seat_Letter is Character range 'A'..'M';
-
- type Ticket is abstract tagged
- record
- Flight : Natural;
- Row : Row_Number;
- Seat : Seat_Letter;
- end record;
-
- function Display( T: Ticket ) return String;
- function Service( T: Ticket ) return String is abstract;
-
-end C393012_0;
-
-with TCTouch;
-package body C393012_0 is
- function Display( T: Ticket ) return String is
- begin
- TCTouch.Touch('T'); --------------------------------------------------- T
- return "Fl:" & Natural'Image(T.Flight)
- & Service( Ticket'Class( T ) )
- & " Seat:" & Row_Number'Image(T.Row) & T.Seat;
- end Display;
-end C393012_0;
-
-with C393012_0;
-package C393012_1 is
- type Economy is new C393012_0.Ticket with null record;
- function Display( T: Economy ) return String;
- function Service( T: Economy ) return String;
-
- type Meal_Designator is ( B, L, D, V, SN );
-
- type First is new C393012_0.Ticket with
- record
- Meal : Meal_Designator;
- end record;
- function Display( T: First ) return String;
- function Service( T: First ) return String;
- procedure Set_Meal( T: in out First; To_Meal : Meal_Designator );
-
-end C393012_1;
-
-with TCTouch;
-package body C393012_1 is
- function Display( T: Economy ) return String is
- begin
- TCTouch.Touch('E'); --------------------------------------------------- E
- return C393012_0.Display( C393012_0.Ticket( T ) );
- end Display; -- conversion to abstract type
-
- function Service( T: Economy ) return String is
- begin
- TCTouch.Touch('e'); --------------------------------------------------- e
- return " K";
- end Service;
-
- function Display( T: First ) return String is
- begin
- TCTouch.Touch('F'); --------------------------------------------------- F
- return C393012_0.Display( C393012_0.Ticket( T ) );
- end Display; -- conversion to abstract type
-
- function Service( T: First ) return String is
- begin
- TCTouch.Touch('f'); --------------------------------------------------- f
- return " F" & Meal_Designator'Image(T.Meal);
- end Service;
-
- procedure Set_Meal( T: in out First; To_Meal : Meal_Designator ) is
- begin
- T.Meal := To_Meal;
- end Set_Meal;
-
-end C393012_1;
-
-with Report;
-with TCTouch;
-with C393012_0;
-with C393012_1;
-procedure C393012 is
-
- package Rt renames C393012_0;
- package Tx renames C393012_1;
-
- type Tix is access Rt.Ticket'Class;
- type Itinerary is array(Positive range 1..3) of Tix;
-
--- Outbound and Inbound itineraries provide different orderings of mixtures
--- of Economy and First_Class. Not that that should make any difference...
-
- Outbound : Itinerary := ( 1 => new Tx.Economy'( 5335, 5, 'B' ),
- 2 => new Tx.First' ( 67, 1, 'J', Tx.L ),
- 3 => new Tx.Economy'( 345, 37, 'C' ) );
-
- Inbound : Itinerary := ( 1 => new Tx.First' ( 456, 4, 'F', Tx.SN ),
- 2 => new Tx.Economy'( 68, 12, 'D' ),
- 3 => new Tx.Economy'( 5336, 6, 'A' ) );
-
--- Each call to Display uses a parameter that is a type conversion
--- to the abstract type Ticket.
-
- procedure TC_Convert( I: Itinerary; Leg1,Leg2,Leg3: String ) is
- begin
- if Rt.Display( Rt.Ticket( I(1).all ) ) /= Leg1 then
- Report.Failed( Rt.Display( Rt.Ticket( I(1).all ) ) & " /= " & Leg1 );
- end if;
- if Rt.Display( Rt.Ticket( I(2).all ) ) /= Leg2 then
- Report.Failed( Rt.Display( Rt.Ticket( I(2).all ) ) & " /= " & Leg2 );
- end if;
- if Rt.Display( Rt.Ticket( I(3).all ) ) /= Leg3 then
- Report.Failed( Rt.Display( Rt.Ticket( I(3).all ) ) & " /= " & Leg3 );
- end if;
- end TC_Convert;
-
--- Each call to Display uses a parameter that is not a type conversion
-
- procedure TC_Match( I: Itinerary; Leg1,Leg2,Leg3: String ) is
- begin
- if Rt.Display( I(1).all ) /= Leg1 then
- Report.Failed( Rt.Display( I(1).all ) & " /= " & Leg1 );
- end if;
- if Rt.Display( I(2).all ) /= Leg2 then
- Report.Failed( Rt.Display( I(2).all ) & " /= " & Leg2 );
- end if;
- if Rt.Display( I(3).all ) /= Leg3 then
- Report.Failed( Rt.Display( I(3).all ) & " /= " & Leg3 );
- end if;
- end TC_Match;
-
-begin -- Main test procedure.
-
- Report.Test ("C393012", "Check that a non-abstract subprogram of an "
- & "abstract type can be called with a "
- & "controlling operand that is a type "
- & "conversion to the abstract type. "
- & "Check that converting to the class-wide type "
- & "of an abstract type inside an operation of "
- & "that type causes a redispatch" );
-
- -- Test conversions to abstract type
-
- TC_Convert( Outbound, "Fl: 5335 K Seat: 5B",
- "Fl: 67 FL Seat: 1J",
- "Fl: 345 K Seat: 37C" );
-
- TCTouch.Validate( "TeTfTe", "Outbound flight (converted)" );
-
- TC_Convert( Inbound, "Fl: 456 FSN Seat: 4F",
- "Fl: 68 K Seat: 12D",
- "Fl: 5336 K Seat: 6A" );
-
- TCTouch.Validate( "TfTeTe", "Inbound flight (converted)" );
-
- -- Test without conversions to abstract type
-
- TC_Match( Outbound, "Fl: 5335 K Seat: 5B",
- "Fl: 67 FL Seat: 1J",
- "Fl: 345 K Seat: 37C" );
-
- TCTouch.Validate( "ETeFTfETe", "Outbound flight" );
-
- TC_Match( Inbound, "Fl: 456 FSN Seat: 4F",
- "Fl: 68 K Seat: 12D",
- "Fl: 5336 K Seat: 6A" );
-
- TCTouch.Validate( "FTfETeETe", "Inbound flight" );
-
- Report.Result;
-
-end C393012;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c393a02.a b/gcc/testsuite/ada/acats/tests/c3/c393a02.a
deleted file mode 100644
index 177bd34b87e..00000000000
--- a/gcc/testsuite/ada/acats/tests/c3/c393a02.a
+++ /dev/null
@@ -1,213 +0,0 @@
--- C393A02.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that a dispatching call to an abstract subprogram invokes
--- the correct subprogram body of a descendant type according to
--- the controlling tag.
--- Check that a subprogram can be declared with formal parameters
--- and result that are of an abstract type's associated class-wide
--- type and that such subprograms can be called. 3.4.1(4)
---
--- TEST DESCRIPTION:
--- This test declares several objects of types derived from the
--- abstract type as defined in the foundation F393A00. It then calls
--- various dispatching and class-wide subprograms using those objects.
--- The packages in F393A00 are instrumented to trace the flow of
--- execution.
--- The test checks for the correct order of execution, as expected
--- by the various calls.
---
--- TEST FILES:
--- The following files comprise this test:
---
--- F393A00.A (foundation code)
--- C393A02.A
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 19 Dec 94 SAIC Removed RM references from objective text.
--- 05 APR 96 SAIC Update RM references for 2.1
---
---!
-
-with Report;
-with F393A00_0;
-with F393A00_1;
-with F393A00_2;
-with F393A00_3;
-with F393A00_4;
-procedure C393A02 is
-
- A_Windmill : F393A00_2.Windmill;
- A_Pump : F393A00_3.Pump;
- A_Mill : F393A00_4.Mill;
-
- A_Windmill_2 : F393A00_2.Windmill;
- A_Pump_2 : F393A00_3.Pump;
- A_Mill_2 : F393A00_4.Mill;
-
- B_Windmill : F393A00_2.Windmill;
- B_Pump : F393A00_3.Pump;
- B_Mill : F393A00_4.Mill;
-
- procedure Swapem( A,B: in out F393A00_2.Windmill'Class ) is
- begin
- F393A00_0.TC_Touch('x');
- F393A00_2.Swap( A,B );
- end Swapem;
-
- function Zephyr( A: F393A00_2.Windmill'Class )
- return F393A00_2.Windmill'Class is
- Item : F393A00_2.Windmill'Class := A;
- begin
- F393A00_0.TC_Touch('y');
- if not F393A00_1.Initialized( Item ) then -- b
- F393A00_2.Initialize( Item ); -- a
- end if;
- F393A00_2.Stop( Item ); -- f / mff
- F393A00_2.Add_Spin( Item, 10 ); -- e
- return Item;
- end Zephyr;
-
- function Gale( It: F393A00_2.Windmill ) return F393A00_2.Windmill'Class is
- Item : F393A00_2.Windmill'Class := It;
- begin
- F393A00_2.Stop( Item ); -- f
- F393A00_2.Add_Spin( Item, 40 ); -- e
- return Item;
- end Gale;
-
- function Gale( It: F393A00_3.Pump ) return F393A00_2.Windmill'Class is
- Item : F393A00_2.Windmill'Class := It;
- begin
- F393A00_2.Stop( Item ); -- f
- F393A00_2.Add_Spin( Item, 50 ); -- e
- return Item;
- end Gale;
-
- function Gale( It: F393A00_4.Mill ) return F393A00_2.Windmill'Class is
- Item : F393A00_2.Windmill'Class := It;
- begin
- F393A00_2.Stop( Item ); -- mff
- F393A00_2.Add_Spin( Item, 60 ); -- e
- return Item;
- end Gale;
-
-begin -- Main test procedure.
-
- Report.Test ("C393A02", "Check that a dispatching call to an abstract "
- & "subprogram invokes the correct subprogram body. "
- & "Check that a subprogram declared with formal "
- & "parameters/result of an abstract type's "
- & "associated class-wide can be called" );
-
- F393A00_0.TC_Validate( "hhh", "Mill declarations" );
- A_Windmill := F393A00_2.Create;
- F393A00_0.TC_Validate( "d", "Create A_Windmill" );
-
- A_Pump := F393A00_3.Create;
- F393A00_0.TC_Validate( "h", "Create A_Pump" );
-
- A_Mill := F393A00_4.Create;
- F393A00_0.TC_Validate( "hl", "Create A_Mill" );
-
- --------------
-
- Swapem( A_Windmill, A_Windmill_2 );
- F393A00_0.TC_Validate( "xc", "Windmill Swap" );
-
- Swapem( A_Pump, A_Pump_2 );
- F393A00_0.TC_Validate( "xc", "Pump Swap" );
-
- Swapem( A_Mill, A_Mill_2 );
- F393A00_0.TC_Validate( "xk", "Pump Swap" );
-
- F393A00_2.Initialize( A_Windmill_2 );
- F393A00_3.Initialize( A_Pump_2 );
- F393A00_4.Initialize( A_Mill_2 );
- B_Windmill := A_Windmill_2;
- B_Pump := A_Pump_2;
- B_Mill := A_Mill_2;
- F393A00_2.Add_Spin( B_Windmill, 123 );
- F393A00_3.Set_Rate( B_Pump, 12.34 );
- F393A00_4.Add_Spin( B_Mill, 321 );
- F393A00_0.TC_Validate( "aaaeie", "Setting Values" );
-
- declare
- It : F393A00_2.Windmill'Class := Zephyr( B_Windmill ); -- ybfe
- XX : F393A00_2.Windmill'Class := Gale( B_Windmill ); -- fe
- use type F393A00_2.Rotational_Measurement;
- begin
- if not F393A00_1.Initialized( It ) or not F393A00_1.Initialized( XX )
-then
- Report.Failed( "Copy to class-wide variable" );
- end if; -- bb
- if F393A00_2.Spin( It ) /= 10 -- g
- or F393A00_2.Spin( XX ) /= 40 then -- g
- Report.Failed( "Call to class-wide operation" );
- end if;
-
- F393A00_0.TC_Validate( "ybfefebbgg", "Windmill Zephyr" );
- end;
-
- declare
- It : F393A00_2.Windmill'Class := Zephyr( B_Pump ); -- ybfe
- XX : F393A00_2.Windmill'Class := Gale( B_Pump ); -- fe
- use type F393A00_2.Rotational_Measurement;
- begin
- if not F393A00_1.Initialized( It ) or not F393A00_1.Initialized( XX )
-then
- Report.Failed( "Bad copy to class-wide variable" );
- end if; -- bb
- if F393A00_2.Spin( It ) /= 10 -- g
- or F393A00_2.Spin( XX ) /= 50 then -- g
- Report.Failed( "Call to class-wide operation" );
- end if;
-
- F393A00_0.TC_Validate( "ybfefebbgg", "Pump Zephyr" );
- end;
-
- declare
- It : F393A00_2.Windmill'Class := Zephyr( B_Mill ); -- ybmffe
- XX : F393A00_2.Windmill'Class := Gale( B_Mill ); -- mffe
- use type F393A00_2.Rotational_Measurement;
- begin
- if not F393A00_1.Initialized( It ) or not F393A00_1.Initialized( XX )
-then
- Report.Failed( "Bad copy to class-wide variable" );
- end if; -- bb
- if F393A00_2.Spin( It ) /= 10 -- g
- or F393A00_2.Spin( XX ) /= 60 then -- g
- Report.Failed( "Call to class-wide operation" );
- end if;
-
- F393A00_0.TC_Validate( "ybmffemffebbgg", "Mill Zephyr" );
- end;
-
- Report.Result;
-
-end C393A02;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c393a03.a b/gcc/testsuite/ada/acats/tests/c3/c393a03.a
deleted file mode 100644
index 90106f4bf44..00000000000
--- a/gcc/testsuite/ada/acats/tests/c3/c393a03.a
+++ /dev/null
@@ -1,242 +0,0 @@
--- C393A03.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that a non-abstract primitive subprogram of an abstract
--- type can be called as a dispatching operation and that the body
--- of this subprogram can make a dispatching call to an abstract
--- operation of the corresponding abstract type.
---
--- TEST DESCRIPTION:
--- This test expands on the class family defined in foundation F393A00
--- by deriving a new abstract type from the root abstract type "Object".
--- The subprograms defined for the new abstract type are then
--- appropriately overridden, and the test ultimately calls various
--- mixtures of these subprograms to check that the dispatching occurs
--- correctly.
---
--- TEST FILES:
--- The following files comprise this test:
---
--- F393A00.A (foundation code)
--- C393A03.A
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 19 Dec 94 SAIC Removed ARM references from objective text.
--- 23 Oct 95 SAIC Fixed bugs for ACVC 2.0.1
---
---!
-
-------------------------------------------------------------------- C393A03_0
-
-with F393A00_1;
-package C393A03_0 is
-
- type Counting_Object is abstract new F393A00_1.Object with private;
- -- inherits Initialize, Swap (abstract) and Create (abstract)
-
- procedure Bump ( A_Counter: in out Counting_Object );
- procedure Clear( A_Counter: in out Counting_Object ) is abstract;
- procedure Zero ( A_Counter: in out Counting_Object );
- function Value( A_Counter: Counting_Object'Class ) return Natural;
-
-private
-
- type Counting_Object is abstract new F393A00_1.Object with
- record
- Tally : Natural :=0;
- end record;
-
-end C393A03_0;
-
------------------------------------------------------------------------------
-
-with F393A00_0;
-package body C393A03_0 is
-
- procedure Bump ( A_Counter: in out Counting_Object ) is
- begin
- F393A00_0.TC_Touch('A');
- A_Counter.Tally := A_Counter.Tally +1;
- end Bump;
-
- procedure Zero ( A_Counter: in out Counting_Object ) is
- begin
- F393A00_0.TC_Touch('B');
-
- -- dispatching call to abstract operation of Counting_Object
- Clear( Counting_Object'Class(A_Counter) );
-
- A_Counter.Tally := 0;
-
- end Zero;
-
- function Value( A_Counter: Counting_Object'Class ) return Natural is
- begin
- F393A00_0.TC_Touch('C');
- return A_Counter.Tally;
- end Value;
-
-end C393A03_0;
-
-------------------------------------------------------------------- C393A03_1
-
-with C393A03_0;
-package C393A03_1 is
-
- type Modular_Object is new C393A03_0.Counting_Object with private;
- -- inherits Initialize, Bump, Zero and Value,
- -- inherits abstract Swap, Create and Clear
-
- procedure Swap( A,B: in out Modular_Object );
- procedure Clear( It: in out Modular_Object );
- procedure Set_Max( It : in out Modular_Object; Value : Natural );
- function Create return Modular_Object;
-
-private
-
- type Modular_Object is new C393A03_0.Counting_Object with
- record
- Max_Value : Natural;
- end record;
-
-end C393A03_1;
-
------------------------------------------------------------------------------
-
-with F393A00_0;
-package body C393A03_1 is
-
- procedure Swap( A,B: in out Modular_Object ) is
- T : constant Modular_Object := B;
- begin
- F393A00_0.TC_Touch('1');
- B := A;
- A := T;
- end Swap;
-
- procedure Clear( It: in out Modular_Object ) is
- begin
- F393A00_0.TC_Touch('2');
- null;
- end Clear;
-
- procedure Set_Max( It : in out Modular_Object; Value : Natural ) is
- begin
- F393A00_0.TC_Touch('3');
- It.Max_Value := Value;
- end Set_Max;
-
- function Create return Modular_Object is
- AMO : Modular_Object;
- begin
- F393A00_0.TC_Touch('4');
- AMO.Max_Value := Natural'Last;
- return AMO;
- end Create;
-
-end C393A03_1;
-
---------------------------------------------------------------------- C393A03
-
-with Report;
-with F393A00_0;
-with F393A00_1;
-with C393A03_0;
-with C393A03_1;
-procedure C393A03 is
-
- A_Thing : C393A03_1.Modular_Object;
- Another_Thing : C393A03_1.Modular_Object;
-
- procedure Initialize( It: in out C393A03_0.Counting_Object'Class ) is
- begin
- C393A03_0.Initialize( It ); -- dispatch to inherited procedure
- end Initialize;
-
- procedure Bump( It: in out C393A03_0.Counting_Object'Class ) is
- begin
- C393A03_0.Bump( It ); -- dispatch to non-abstract procedure
- end Bump;
-
- procedure Set_Max( It : in out C393A03_1.Modular_Object'Class;
- Val : Natural) is
- begin
- C393A03_1.Set_Max( It, Val ); -- dispatch to non-abstract procedure
- end Set_Max;
-
- procedure Swap( A, B : in out C393A03_0.Counting_Object'Class ) is
- begin
- C393A03_0.Swap( A, B ); -- dispatch to inherited abstract procedure
- end Swap;
-
- procedure Zero( It: in out C393A03_0.Counting_Object'Class ) is
- begin
- C393A03_0.Zero( It ); -- dispatch to non-abstract procedure
- end Zero;
-
-begin -- Main test procedure.
-
- Report.Test ("C393A03", "Check that a non-abstract primitive subprogram "
- & "of an abstract type can be called as a "
- & "dispatching operation and that the body of this "
- & "subprogram can make a dispatching call to an "
- & "abstract operation of the corresponding "
- & "abstract type" );
-
- A_Thing := C393A03_1.Create; -- Max_Value = Natural'Last
- F393A00_0.TC_Validate( "4", "Overridden primitive layer 2");
-
- Initialize( A_Thing );
- Initialize( Another_Thing );
- F393A00_0.TC_Validate( "aa", "Non-abstract primitive layer 0");
-
- Bump( A_Thing ); -- Tally = 1
- F393A00_0.TC_Validate( "A", "Non-abstract primitive layer 1");
-
- Set_Max( A_Thing, 42 ); -- Max_Value = 42
- F393A00_0.TC_Validate( "3", "Non-abstract normal layer 2");
-
- if not F393A00_1.Initialized( A_Thing ) then
- Report.Failed("Initialize didn't");
- end if;
- F393A00_0.TC_Validate( "b", "Class-wide layer 0");
-
- Swap( A_Thing, Another_Thing );
- F393A00_0.TC_Validate( "1", "Overridden abstract layer 2");
-
- Zero( A_Thing );
- F393A00_0.TC_Validate( "B2", "Non-abstract layer 0, calls dispatch");
-
- if C393A03_0.Value( A_Thing ) /= 0 then
- Report.Failed("Zero didn't");
- end if;
- F393A00_0.TC_Validate( "C", "Class-wide normal layer 2");
-
- Report.Result;
-
-end C393A03;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c393a05.a b/gcc/testsuite/ada/acats/tests/c3/c393a05.a
deleted file mode 100644
index b404559cc83..00000000000
--- a/gcc/testsuite/ada/acats/tests/c3/c393a05.a
+++ /dev/null
@@ -1,166 +0,0 @@
--- C393A05.A
- --
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
- --
- -- OBJECTIVE:
- -- Check that for a nonabstract private extension, any inherited
- -- abstract subprograms can be overridden in the private part of
- -- the immediately enclosing package and that calls can be made to
- -- private dispatching operations.
- --
- -- TEST DESCRIPTION:
- -- This test builds an additional layer upon the foundation code to
- -- provide the required "hidden" dispatching operation. The procedure
- -- Swap, a private subprogram, should be called by dispatch.
- --
- -- TEST FILES:
- -- The following files comprise this test:
- --
- -- F393A00.A (foundation code)
- -- C393A05.A
- --
- --
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
---
- --!
-
- with F393A00_4;
- package C393A05_0 is
- type Grinder is new F393A00_4.Mill with private;
- type Coarseness is (Whole_Bean, Coarse, Medium, Fine, Espresso);
-
- procedure Set_Grind( It: in out Grinder; The_Grind: Coarseness );
- function Grind( It: Grinder ) return Coarseness;
-
- function Create return Grinder;
- private
- procedure Swap( A,B: in out Grinder );
- type Grinder is new F393A00_4.Mill with
- record
- Grind : Coarseness := Whole_Bean;
- end record;
- end C393A05_0;
-
- with F393A00_0;
- package body C393A05_0 is
- procedure Set_Grind( It: in out Grinder; The_Grind: Coarseness ) is
- begin
- F393A00_0.TC_Touch( 'A' );
- It.Grind := The_Grind;
- end Set_Grind;
-
- function Grind( It: Grinder ) return Coarseness is
- begin
- F393A00_0.TC_Touch( 'B' );
- return It.Grind;
- end Grind;
-
- procedure Swap( A,B: in out Grinder ) is
- T : constant Grinder := A;
- begin
- F393A00_0.TC_Touch( 'C' );
- A := B;
- B := T;
- end Swap;
-
- function Create return Grinder is
- One: Grinder;
- begin
- F393A00_0.TC_Touch( 'D' );
- F393A00_4.Initialize( F393A00_4.Mill( One ) );
- One.Grind := Fine;
- return One;
- end Create;
- end C393A05_0;
-
- with Report;
- with F393A00_0;
- with C393A05_0;
- procedure C393A05 is
-
- package Tracer renames F393A00_0;
- package Coffee renames C393A05_0;
- use type Coffee.Coarseness;
-
- Morning : Coffee.Grinder;
- Afternoon : Coffee.Grinder;
-
- Gritty : Coffee.Coarseness;
-
- procedure Class_Swap( A, B: in out Coffee.Grinder'Class ) is
- begin
- Coffee.Swap( A, B ); -- dispatch
- end Class_Swap;
-
- begin -- Main test procedure.
-
- Report.Test ("C393A05", "Check that nonabstract private extensions, "
- & "inherited abstract subprograms overridden "
- & "in the private part can be dispatched from "
- & "outside the package" );
-
- Tracer.TC_Validate( "hh", "Declarations" );
-
- Morning := Coffee.Create;
- Tracer.TC_Validate( "hDa", "Creating Morning Coffee" );
- Gritty := Coffee.Grind( Morning );
- Tracer.TC_Validate( "B", "Finding Morning Grind" );
-
- Afternoon := Coffee.Create;
- Tracer.TC_Validate( "hDa", "Creating Afternoon Coffee" );
- Coffee.Set_Grind( Afternoon, Coffee.Medium );
- Tracer.TC_Validate( "A", "Setting Afternoon Grind" );
-
- Coffee.Swap( Morning, Afternoon );
- Tracer.TC_Validate( "C", "Dispatching Swapping Coffees" );
-
- if Gritty /= Coffee.Grind( Afternoon )
- or Coffee.Grind ( Afternoon ) /= Coffee.Fine then
- Report.Failed ("Result of Swap");
- end if;
- Tracer.TC_Validate( "BB", "Finding Afternoon Grind" );
-
- Sunset: declare
- Evening : Coffee.Grinder'Class := Coffee.Create;
- begin
- Tracer.TC_Validate( "hDa", "Creating Evening Coffee" );
-
- Coffee.Set_Grind( Evening, Coffee.Espresso );
- Tracer.TC_Validate( "A", "Setting Evening Grind" );
-
- Morning := Coffee.Grinder( Evening );
- Class_Swap( Morning, Evening );
- Tracer.TC_Validate( "C", "Swapping Coffees" );
- if Coffee.Grind( Morning ) /= Coffee.Espresso then
- Report.Failed ("Result of Assignment");
- end if;
- end Sunset;
-
- Report.Result;
-
- end C393A05;
-
-
-
diff --git a/gcc/testsuite/ada/acats/tests/c3/c393a06.a b/gcc/testsuite/ada/acats/tests/c3/c393a06.a
deleted file mode 100644
index c257d5fa0a0..00000000000
--- a/gcc/testsuite/ada/acats/tests/c3/c393a06.a
+++ /dev/null
@@ -1,201 +0,0 @@
--- C393A06.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that a type that inherits abstract operations but
--- overrides each of these operations is not required to be
--- abstract, and that objects of the type and its class-wide type
--- may be declared and passed in calls to the overriding
--- subprograms.
---
--- TEST DESCRIPTION:
--- This test derives a type from the root abstract type available
--- in foundation F393A00. It declares subprograms as required by
--- the language to override the abstract subprograms, allowing the
--- derived type itself to be not abstract. It also declares
--- operations on the new type, as well as on the associated class-
--- wide type. The main program then uses two objects of the type
--- and two objects of the class-wide type as parameters for each of
--- the subprograms. Correct execution is determined by path
--- analysis and value checking.
---
--- TEST FILES:
--- The following files comprise this test:
---
--- F393A00.A (foundation code)
--- C393A06.A
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 19 Dec 94 SAIC Removed RM references from objective text.
---
---!
-
- with F393A00_1;
- package C393A06_0 is
- type Organism is new F393A00_1.Object with private;
- type Kingdoms is ( Animal, Vegetable, Unspecified );
-
- procedure Swap( A,B: in out Organism );
- function Create return Organism;
-
- procedure Initialize( The_Entity : in out Organism;
- In_The_Kingdom : Kingdoms );
- function Kingdom( Of_The_Entity : Organism ) return Kingdoms;
-
- procedure TC_Check( An_Entity : Organism'Class;
- In_Kingdom : Kingdoms;
- Initialized : Boolean );
-
- Incompatible : exception;
-
- private
- type Organism is new F393A00_1.Object with
- record
- In_Kingdom : Kingdoms;
- end record;
- end C393A06_0;
-
- with F393A00_0;
- package body C393A06_0 is
-
- procedure Swap( A,B: in out Organism ) is
- begin
- F393A00_0.TC_Touch( 'A' ); ------------------------------------------- A
- if A.In_Kingdom /= B.In_Kingdom then
- F393A00_0.TC_Touch( 'X' );
- raise Incompatible;
- else
- declare
- T: constant Organism := A;
- begin
- A := B;
- B := T;
- end;
- end if;
- end Swap;
-
- function Create return Organism is
- Widget : Organism;
- begin
- F393A00_0.TC_Touch( 'B' ); ------------------------------------------- B
- Initialize( Widget );
- Widget.In_Kingdom := Unspecified;
- return Widget;
- end Create;
-
- procedure Initialize( The_Entity : in out Organism;
- In_The_Kingdom : Kingdoms ) is
- begin
- F393A00_0.TC_Touch( 'C' ); ------------------------------------------- C
- F393A00_1.Initialize( F393A00_1.Object( The_Entity ) );
- The_Entity.In_Kingdom := In_The_Kingdom;
- end Initialize;
-
- function Kingdom( Of_The_Entity : Organism ) return Kingdoms is
- begin
- F393A00_0.TC_Touch( 'D' ); ------------------------------------------- D
- return Of_The_Entity.In_Kingdom;
- end Kingdom;
-
- procedure TC_Check( An_Entity : Organism'Class;
- In_Kingdom : Kingdoms;
- Initialized : Boolean ) is
- begin
- if F393A00_1.Initialized( An_Entity ) /= Initialized then
- F393A00_0.TC_Touch( '-' ); ------------------------------------------- -
- elsif An_Entity.In_Kingdom /= In_Kingdom then
- F393A00_0.TC_Touch( '!' ); ------------------------------------------- !
- else
- F393A00_0.TC_Touch( '+' ); ------------------------------------------- +
- end if;
- end TC_Check;
-
- end C393A06_0;
-
- with Report;
-
- with C393A06_0;
- with F393A00_0;
- with F393A00_1;
- procedure C393A06 is
-
- package Darwin renames C393A06_0;
- package Tagger renames F393A00_0;
- package Objects renames F393A00_1;
-
- Lion : Darwin.Organism;
- Tigerlily : Darwin.Organism;
- Bear : Darwin.Organism'Class := Darwin.Create;
- Sunflower : Darwin.Organism'Class := Darwin.Create;
-
- use type Darwin.Kingdoms;
-
- begin -- Main test procedure.
-
- Report.Test ("C393A06", "Check that a type that inherits abstract "
- & "operations but overrides each of these "
- & "operations is not required to be abstract. "
- & "Check that objects of the type and its "
- & "class-wide type may be declared and passed "
- & "in calls to the overriding subprograms" );
-
- Tagger.TC_Validate( "BaBa", "Declaration Initializations" );
-
- Darwin.Initialize( Lion, Darwin.Animal );
- Darwin.Initialize( Tigerlily, Darwin.Vegetable );
- Darwin.Initialize( Bear, Darwin.Animal );
- Darwin.Initialize( Sunflower, Darwin.Vegetable );
-
- Tagger.TC_Validate( "CaCaCaCa", "Initialization sequence" );
-
- Oh_My: begin
- Darwin.Swap( Lion, Darwin.Organism( Bear ) );
- Darwin.Swap( Lion, Tigerlily );
- Report.Failed("Exception not raised");
- exception
- when Darwin.Incompatible => null;
- end Oh_My;
-
- Tagger.TC_Validate( "AAX", "Swap sequence" );
-
- if Darwin.Kingdom( Darwin.Create ) = Darwin.Unspecified then
- Darwin.Swap( Sunflower, Darwin.Organism'Class( Tigerlily ) );
- end if;
-
- Tagger.TC_Validate( "BaDA", "Vegetable swap sequence" );
-
- Darwin.TC_Check( Lion, Darwin.Animal, True );
- Darwin.TC_Check( Tigerlily, Darwin.Vegetable, True );
- Darwin.TC_Check( Bear, Darwin.Animal, True );
- Darwin.TC_Check( Sunflower, Darwin.Vegetable, True );
-
- Tagger.TC_Validate( "b+b+b+b+", "Final sequence" );
-
- Report.Result;
-
- end C393A06;
-
diff --git a/gcc/testsuite/ada/acats/tests/c3/c393b12.a b/gcc/testsuite/ada/acats/tests/c3/c393b12.a
deleted file mode 100644
index 5d1b46daa74..00000000000
--- a/gcc/testsuite/ada/acats/tests/c3/c393b12.a
+++ /dev/null
@@ -1,131 +0,0 @@
--- C393B12.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- TEST OBJECTIVE:
--- Check that an extended type can be derived in the specification of a
--- generic package when the parent is an abstract type in a library
--- package.
---
--- TEST DESCRIPTION:
--- Extend an abstract type in the visible part of a generic package.
--- Make all of the procedures which override abstract procedures
--- available as part of the generic interface. Instantiate the generic.
---
--- TEST FILES:
--- This test depends on the following foundation code:
---
--- F393B00.A Package Alert_Foundation
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 14 Oct 95 SAIC Update and repair for ACVC 2.0.1
--- 27 Feb 97 PWB.CTA Add pragma Elaborate for C393B12_0.
---!
-
------------------------------------------------------------------ C393B12_0
-
-with F393B00;
- -- Alert_Foundation
-generic
- type Generic_Status_Enum is (<>);
-
-package C393B12_0 is
- -- Alert_Functions
-
- type Generic_Alert_Type is new F393B00.Alert with record
- Status : Generic_Status_Enum := Generic_Status_Enum'First;
- end record;
- -- extension of an abstract type
-
- procedure Handle (GA : in out Generic_Alert_Type);
- -- override of abstract procedure
-
- function Query_Status (GA : Generic_Alert_Type)
- return Generic_Status_Enum; -- new primitive operation for
- -- Generic_Alert_Type
-end C393B12_0;
- -- Alert_Functions
-
--- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
-
-package body C393B12_0 is
- -- Alert_Functions
-
- procedure Handle (GA : in out Generic_Alert_Type) is
- begin
- GA.Status := Generic_Status_Enum'Last;
- end Handle;
-
- function Query_Status (GA : Generic_Alert_Type)
- return Generic_Status_Enum is
- begin
- return GA.Status;
- end Query_Status;
-
-end C393B12_0;
-
------------------------------------------------------------------ C393B12_1
-
-package C393B12_1 is
- type Status is (Low, Medium, High);
-end C393B12_1;
-
-------------------------------------------------------- C393B12_1.C393B12_2
-
-with C393B12_0;
-pragma Elaborate (C393B12_0);
-package C393B12_1.C393B12_2 is new C393B12_0
- -- Alert_Functions
- (Generic_Status_Enum => Status);
-
-------------------------------------------------------------------- C393B12
-
-with C393B12_1.C393B12_2;
-with Report;
-procedure C393B12 is
-
- use type C393B12_1.Status;
-
- package Alt_Alert renames C393B12_1.C393B12_2;
-
- GA : Alt_Alert.Generic_Alert_Type;
-
-begin
- Report.Test ("C393B12", "Check that an extended type can be derived " &
- "from an abstract type");
-
- if Alt_Alert.Query_Status (GA) /= C393B12_1.Low then
- Report.Failed ("Wrong initialization");
- end if;
-
- Alt_Alert.Handle (GA);
- if Alt_Alert.Query_Status (GA) /= C393B12_1.High then
- Report.Failed ("Wrong results from Handle");
- end if;
-
- Report.Result;
-
-end C393B12;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c393b13.a b/gcc/testsuite/ada/acats/tests/c3/c393b13.a
deleted file mode 100644
index c533badbe04..00000000000
--- a/gcc/testsuite/ada/acats/tests/c3/c393b13.a
+++ /dev/null
@@ -1,105 +0,0 @@
--- C393B13.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- TEST OBJECTIVE:
--- Check that an extended type can be derived from an abstract type
--- when that derivation is declared in a child package.
---
--- TEST DESCRIPTION:
--- Add a visible child to Alert_Foundation. Using the abstract type
--- Alert as parent, declare an extended type with discriminant and new
--- record components. Override the Handle procedure.
---
--- TEST FILES:
--- This test depends on the following foundation code:
---
--- F393B00.A Package Alert_Foundation
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 15 Oct 95 SAIC Fixed bugs for ACVC 2.0.1
---
---!
-
-package F393B00.C393B13_0 is
- -- Alert_Foundation.Public_Child
-
- subtype Msg_Length_Range is integer range 0 .. 240;
- Max_Msg_Length : constant Msg_Length_Range := 80;
- Message : String := "Test Passed";
-
- type Child_Alert (Length : Msg_Length_Range)
- is new Alert with record -- abstract type is in parent package
- Times_Handled : Natural := 0;
- Msg : String (1..Length);
- end record;
-
- procedure Handle (CA : in out Child_Alert); -- required override
-
-end F393B00.C393B13_0;
- -- Alert_Foundation.Public_Child;
-
---=======================================================================--
-
-package body F393B00.C393B13_0 is
- -- Alert_Foundation.Public_Child
-
- procedure Handle (CA : in out Child_Alert) is
- begin
- CA.Msg(1..Message'Length) := Message;
- CA.Times_Handled := CA.Times_Handled + 1;
- end;
-
-end F393B00.C393B13_0;
- -- Alert_Foundation.Public_Child
-
---=======================================================================--
-
-with Report;
-with F393B00.C393B13_0;
- -- Alert_foundation.Public_Child;
-procedure C393B13 is
- package Child renames F393B00.C393B13_0;
- CA : Child.Child_Alert(Child.Message'Length);
-
-begin
-
- Report.Test ("C393B13", "Check that an extended type can be derived " &
- "from an abstract type");
-
- if CA.Times_Handled /= 0 then
- Report.Failed ("Wrong initialization");
- end if;
-
- Child.Handle (CA);
- if (CA.Times_Handled /= 1)
- or (CA.Msg /= Child.Message) then
- Report.Failed ("Wrong results from Handle");
- end if;
-
- Report.Result;
-
-end C393B13;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c393b14.a b/gcc/testsuite/ada/acats/tests/c3/c393b14.a
deleted file mode 100644
index f100377aa04..00000000000
--- a/gcc/testsuite/ada/acats/tests/c3/c393b14.a
+++ /dev/null
@@ -1,147 +0,0 @@
--- C393B14.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- TEST OBJECTIVE:
--- Check that an extended type can be derived in a private child package
--- from an abstract type defined in a library package.
---
--- TEST DESCRIPTION:
--- Add a private child package to Alert_Foundation. Using Private_Alert
--- as parent type, declare an extended type adding a new record component.
--- Override procedure Handle. Declare an object of the new type in the
--- child specification. Use type definitions from the private part of the
--- parent in the body of the child.
---
--- TEST FILES:
--- This test depends on the following foundation code:
---
--- F393B00.A Package Alert_Foundation
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
---
---!
-
-private package F393B00.C393B14_0 is
- -- Alert_Foundation.Private_Child
-
- type Implementation_Specific_Alert_Type is new Private_Alert with record
- New_Private_Field : Implementation_Detail
- := Implementation_Detail'Last;
- end record;
-
- procedure Handle (PA : in out Implementation_Specific_Alert_Type);
- -- overrides abstract Handle, as required
- PA : Implementation_Specific_Alert_Type;
-
-end F393B00.C393B14_0;
- -- Alert_Foundation.Private_Child
-
---=======================================================================--
-
-package body F393B00.C393B14_0 is
- -- Alert_Foundation.Private_Child
-
- procedure Handle (PA : in out Implementation_Specific_Alert_Type) is
- begin
- PA.Private_Field := 1;
- PA.New_Private_Field := PA.Private_Field + 1;
- end;
-
-end F393B00.C393B14_0;
- -- Alert_Foundation.Private_Child
-
---=======================================================================--
-
-package F393B00.C393B14_1 is
- -- Alert_Foundation.Public_Child
-
- type Timing is (Before, After);
- procedure Init;
- procedure Modify;
- function Check_Before return Boolean;
- function Check_After return Boolean;
-
-end F393B00.C393B14_1;
- -- Alert_Foundation.Public_Child
-
---=======================================================================--
-
-with F393B00.C393B14_0; -- private sibling is visible in the
- -- Alert_Foundation.Private_Child -- body of a public sibling
-package body F393B00.C393B14_1 is
- -- Alert_Foundation.Public_Child
- package Priv renames F393B00.C393B14_0;
-
- procedure Init is
- begin
- Priv.PA.Private_Field := 5;
- Priv.PA.New_Private_Field := 10;
- end Init;
-
- procedure Modify is
- begin
- Priv.Handle (Priv.PA);
- end Modify;
-
- function Check_Before return Boolean is
- begin
- return ((Priv.PA.Private_Field = 5)
- and (Priv.PA.New_Private_Field =10));
- end Check_Before;
-
- function Check_After return Boolean is
- begin
- return ((Priv.PA.Private_Field = 1)
- and (Priv.PA.New_Private_Field = 2));
- end Check_After;
-
-end F393B00.C393B14_1;
- -- Alert_Foundation.Public_Child
-
---=======================================================================--
-
-with Report;
-with F393B00.C393B14_1;
-procedure C393B14 is
- -- Alert_Foundation.Public_Child;
-
-begin
- Report.Test ("C393B14", "Check that an extended type can be derived " &
- "from an abstract type");
-
- F393B00.C393B14_1.Init;
- if not F393B00.C393B14_1.Check_Before then
- Report.Failed ("Wrong initialization");
- end if;
-
- F393B00.C393B14_1.Modify;
- if not F393B00.C393B14_1.Check_After then
- Report.Failed ("Wrong results from Handle");
- end if;
-
- Report.Result;
-end C393B14;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c3a0001.a b/gcc/testsuite/ada/acats/tests/c3/c3a0001.a
deleted file mode 100644
index f8a0681e78f..00000000000
--- a/gcc/testsuite/ada/acats/tests/c3/c3a0001.a
+++ /dev/null
@@ -1,138 +0,0 @@
--- C3A0001.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that access to subprogram type can be used to select and
--- invoke functions with appropriate arguments dynamically.
---
--- TEST DESCRIPTION:
--- Declare an access to function type in a package specification.
--- Declare three different sine functions that can be referred to by
--- the access to function type.
---
--- In the main program, call each function indirectly by dereferencing
--- the access value.
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
---
---!
-
-package C3A0001_0 is
-
- TC_Call_Tag : Natural := 0;
-
- -- Type accesses to any sine function
- type Sine_Function_Ptr is access function
- (Angle : in Float) return Float;
-
--- Three 'Sine' functions that model an application situation in which
--- one function might be chosen when speed is important, another (using
--- a different algorithm) might be chosen when accuracy is important,
--- and so on.
-
- function Sine_Calc_Fast (Angle : in Float) return Float;
-
- function Sine_Calc_Acc (Angle : in Float) return Float;
-
- function Sine_Calc_Table (Angle : in Float) return Float;
-
-end C3A0001_0;
-
-
------------------------------------------------------------------------------
-
-
-package body C3A0001_0 is
-
- function Sine_Calc_Fast (Angle : in Float) return Float is
- begin
- TC_Call_Tag := 1;
- return 1.0;
- end Sine_Calc_Fast;
-
-
- function Sine_Calc_Acc (Angle : in Float) return Float is
- begin
- TC_Call_Tag := 2;
- return 0.0;
- end Sine_Calc_Acc;
-
-
- function Sine_Calc_Table (Angle : in Float) return Float is
- begin
- TC_Call_Tag := 3;
- return -1.0;
- end Sine_Calc_Table;
-
-end C3A0001_0;
-
------------------------------------------------------------------------------
-
-with Report;
-with C3A0001_0;
-
-procedure C3A0001 is
-
- Sine_Access : C3A0001_0.Sine_Function_Ptr;
- X, Theta : Float := 0.0;
-
-begin
-
- Report.Test ("C3A0001", "Check that access to subprogram can be " &
- "used to select and invoke an operation with " &
- "appropriate arguments dynamically");
-
- Sine_Access := C3A0001_0.Sine_Calc_Fast'Access;
-
- -- Invoking Sine function designated by access value
- X := Sine_Access(Theta);
-
- If C3A0001_0.TC_Call_Tag /= 1 then
- Report.Failed ("Incorrect Sine_Calc_Fast result");
- end if;
-
- Sine_Access := C3A0001_0.Sine_Calc_Acc'Access;
-
- -- Invoking Sine function designated by access value
- X := Sine_Access(Theta);
-
- If C3A0001_0.TC_Call_Tag /= 2 then
- Report.Failed ("Incorrect Sine_Calc_Acc result");
- end if;
-
- Sine_Access := C3A0001_0.Sine_Calc_Table'Access;
-
- -- Invoking Sine function designated by access value
- X := Sine_Access(Theta);
-
- If C3A0001_0.TC_Call_Tag /= 3 then
- Report.Failed ("Incorrect Sine_Calc_Table result");
- end if;
-
- Report.Result;
-
-end C3A0001;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c3a0002.a b/gcc/testsuite/ada/acats/tests/c3/c3a0002.a
deleted file mode 100644
index 5c05d43fb6a..00000000000
--- a/gcc/testsuite/ada/acats/tests/c3/c3a0002.a
+++ /dev/null
@@ -1,142 +0,0 @@
--- C3A0002.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that access to subprogram type can be used to select and
--- invoke procedures with appropriate arguments dynamically.
---
--- TEST DESCRIPTION:
--- Declare an access to procedure type in a package specification.
--- Declare three different log procedures that can be referred to by
--- the access to procedure type.
---
--- In the main program, call each procedure indirectly by dereferencing
--- the access value.
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 05 APR 96 SAIC RM reference change for 2.1
---
---
---!
-
-
-package C3A0002_0 is
-
- TC_Call_Tag : Natural := 0;
-
- Return_Num : Float := 0.0;
-
- -- Type accesses to any log procedure
- type Log_Procedure_Ptr is access procedure
- (Angle : in Float);
-
- procedure Log_Calc_Fast (Angle : in Float);
-
- procedure Log_Calc_Acc (Angle : in Float);
-
- procedure Log_Calc_Table (Angle : in Float);
-
-end C3A0002_0;
-
-
------------------------------------------------------------------------------
-
-
-package body C3A0002_0 is
-
- procedure Log_Calc_Fast (Angle : in Float) is
- begin
- TC_Call_Tag := 1;
- Return_Num := Angle;
- end Log_Calc_Fast;
-
-
- procedure Log_Calc_Acc (Angle : in Float) is
- begin
- TC_Call_Tag := 2;
- Return_Num := Angle;
- end Log_Calc_Acc;
-
-
- procedure Log_Calc_Table (Angle : in Float) is
- begin
- TC_Call_Tag := 3;
- Return_Num := Angle;
- end Log_Calc_Table;
-
-end C3A0002_0;
-
------------------------------------------------------------------------------
-
-with Report;
-with C3A0002_0;
-
-procedure C3A0002 is
-
- Log_Access : C3A0002_0.Log_Procedure_Ptr;
- Theta : Float := 0.0;
-
-begin
-
- Report.Test ("C3A0002", "Check that access to subprogram type can be "
- & "used to select and invoke procedures with "
- & "appropriate arguments dynamically" );
-
- Log_Access := C3A0002_0.Log_Calc_Fast'Access;
-
- -- Invoking Log procedure designated by access value
- Log_Access (Theta);
-
- If C3A0002_0.TC_Call_Tag /= 1 or C3A0002_0.Return_Num /= 0.0 then
- Report.Failed ("Incorrect Log_Calc_Fast result");
- end if;
-
- Theta := 1.0;
-
- Log_Access := C3A0002_0.Log_Calc_Acc'Access;
-
- -- Invoking Log procedure designated by access value
- Log_Access (Theta);
-
- If C3A0002_0.TC_Call_Tag /= 2 or C3A0002_0.Return_Num /= 1.0 then
- Report.Failed ("Incorrect Log_Calc_Acc result");
- end if;
-
- Theta := -1.0;
-
- Log_Access := C3A0002_0.Log_Calc_Table'Access;
-
- -- Invoking Log procedure designated by access value
- Log_Access (Theta);
-
- If C3A0002_0.TC_Call_Tag /= 3 or C3A0002_0.Return_Num /= -1.0 then
- Report.Failed ("Incorrect Log_Calc_Table result");
- end if;
-
- Report.Result;
-
-end C3A0002;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c3a0003.a b/gcc/testsuite/ada/acats/tests/c3/c3a0003.a
deleted file mode 100644
index 4f9fdbe29f8..00000000000
--- a/gcc/testsuite/ada/acats/tests/c3/c3a0003.a
+++ /dev/null
@@ -1,144 +0,0 @@
--- C3A0003.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that a function in a generic instance can be called using
--- an access-to-subprogram value.
---
--- TEST DESCRIPTION:
--- Declare a numeric type in the visible part of a generic package.
--- Declare an access to function type. Declare three different sine
--- functions that can be referred to by the access to function type.
---
--- In the main program, instantiate the generic. Call each function
--- indirectly by dereferencing the access value.
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
---
---!
-
-generic
- type Real_Num is digits <>;
-
-package C3A0003_0 is
-
- TC_Call_Tag : Natural := 0;
-
- -- Type accesses to any sine function
- type Sine_Function_Ptr is access function
- (Angle : in Real_Num) return Real_Num;
-
- function Sine_Calc_Fast (Angle : in Real_Num) return Real_Num;
-
- function Sine_Calc_Acc (Angle : in Real_Num) return Real_Num;
-
- function Sine_Calc_Table (Angle : in Real_Num) return Real_Num;
-
-end C3A0003_0;
-
-
------------------------------------------------------------------------------
-
-
-package body C3A0003_0 is
-
- function Sine_Calc_Fast (Angle : in Real_Num) return Real_Num is
- Sine_Num : Real_Num := 1.0;
- begin
- TC_Call_Tag := 1;
- return Sine_Num;
- end Sine_Calc_Fast;
-
-
- function Sine_Calc_Acc (Angle : in Real_Num) return Real_Num is
- Sine_Num : Real_Num := 0.0;
- begin
- TC_Call_Tag := 2;
- return Sine_Num;
- end Sine_Calc_Acc;
-
-
- function Sine_Calc_Table (Angle : in Real_Num) return Real_Num is
- Sine_Num : Real_Num := -1.0;
- begin
- TC_Call_Tag := 3;
- return Sine_Num;
- end Sine_Calc_Table;
-
-end C3A0003_0;
-
------------------------------------------------------------------------------
-
-with Report;
-with C3A0003_0;
-
-procedure C3A0003 is
-
- type Real is digits 5;
-
- Subtype Trig_Float is Real range -1.0 .. 1.0;
-
- package Trig is new C3A0003_0 (Real_Num => Trig_Float);
-
- Sine_Access : Trig.Sine_Function_Ptr;
- X, Theta : Trig_Float := 0.0;
-
-begin
-
- Report.Test ("C3A0003", "Check that a function in a generic instance can "
- & "be called using an access-to-subprogram value");
-
- Sine_Access := Trig.Sine_Calc_Fast'Access;
-
- -- Invoking Sine function designated by access value
- X := Sine_Access.all(Theta);
-
- If Trig.TC_Call_Tag /= 1 then
- Report.Failed ("Incorrect Sine_Calc_Fast result");
- end if;
-
- Sine_Access := Trig.Sine_Calc_Acc'Access;
-
- -- Invoking Sine function designated by access value
- X := Sine_Access.all(Theta);
-
- If Trig.TC_Call_Tag /= 2 then
- Report.Failed ("Incorrect Sine_Calc_Acc result");
- end if;
-
- Sine_Access := Trig.Sine_Calc_Table'Access;
-
- -- Invoking Sine function designated by access value
- X := Sine_Access.all(Theta);
-
- If Trig.TC_Call_Tag /= 3 then
- Report.Failed ("Incorrect Sine_Calc_Table result");
- end if;
-
- Report.Result;
-
-end C3A0003;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c3a0004.a b/gcc/testsuite/ada/acats/tests/c3/c3a0004.a
deleted file mode 100644
index 2557546c2e4..00000000000
--- a/gcc/testsuite/ada/acats/tests/c3/c3a0004.a
+++ /dev/null
@@ -1,115 +0,0 @@
--- C3A0004.A
- --
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
- --
- -- OBJECTIVE:
- -- Check that access to subprogram may be stored within array
- -- objects, and that the access to subprogram can subsequently
- -- be called.
- --
- -- TEST DESCRIPTION:
- -- Declare an access to procedure type in a package specification.
- -- Declare an array of the access type. Declare three different
- -- procedures that can be referred to by the access to procedure type.
- --
- -- In the main program, build the array by dereferencing the access
- -- value.
- --
- --
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
---
- --!
-
- with Report;
-
- procedure C3A0004 is
-
- Left_Turn : Integer := 1;
-
- Right_Turn : Integer := 1;
-
- Center_Turn : Integer := 1;
-
- -- Type accesses to any procedure
- type Action_Ptr is access procedure;
-
- -- Array of access to procedure
- type Action_Array is array (Integer range <>) of Action_Ptr;
-
-
- procedure Rotate_Left is
- begin
- Left_Turn := 2;
- end Rotate_Left;
-
-
- procedure Rotate_Right is
- begin
- Right_Turn := 3;
- end Rotate_Right;
-
-
- procedure Center is
- begin
- Center_Turn := 0;
- end Center;
-
-
- begin
-
- Report.Test ("C3A0004", "Check that access to subprogram may be "
- & "stored within data structures, and that the "
- & "access to subprogram can subsequently be called");
-
- ------------------------------------------------------------------------
-
- declare
- Total_Actions : constant := 3;
- Action_Sequence : Action_Array (1 .. Total_Actions);
-
- begin
-
- -- Build the action sequence
- Action_Sequence := (Rotate_Left'Access, Center'Access,
- Rotate_Right'Access);
-
- -- Assign actions by invoking subprogram designated by access value
- for I in Action_Sequence'Range loop
- Action_Sequence(I).all;
- end loop;
-
- If Left_Turn /= 2 or Right_Turn /= 3
- or Center_Turn /= 0 then
- Report.Failed ("Incorrect Action sequence result");
- end if;
-
- end;
-
- ------------------------------------------------------------------------
-
- Report.Result;
-
- end C3A0004;
-
diff --git a/gcc/testsuite/ada/acats/tests/c3/c3a0005.a b/gcc/testsuite/ada/acats/tests/c3/c3a0005.a
deleted file mode 100644
index 1f23689579f..00000000000
--- a/gcc/testsuite/ada/acats/tests/c3/c3a0005.a
+++ /dev/null
@@ -1,147 +0,0 @@
--- C3A0005.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that access to subprogram may be stored within record
--- objects, and that the access to subprogram can subsequently
--- be called.
---
--- TEST DESCRIPTION:
--- Declare an access to procedure type in a package specification.
--- Declare two different procedures that can be referred to by the
--- access to procedure type. Declare a record with the access to
--- procedure type as a component. Use the access to procedure type to
--- initialize the component of a record.
---
--- In the main program, declare an operation. An access value
--- designating this operation is passed as a parameter to be
--- stored in the record.
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
---
---!
-
-package C3A0005_0 is
-
- Default_Call : Boolean := False;
-
- type Button;
-
-
- -- Type accesses to procedures Push and Default_Response
- type Button_Response_Ptr is access procedure
- (B : access Button);
-
- procedure Push (B : access Button);
-
- procedure Set_Response (B : access Button;
- R : in Button_Response_Ptr);
-
- procedure Default_Response (B : access Button);
-
- Emergency_Call : Boolean := False;
-
- procedure Emergency (B : access C3A0005_0.Button);
-
- type Button is
- record
- Response : Button_Response_Ptr
- := Default_Response'Access;
- end record;
-
-end C3A0005_0;
-
-
------------------------------------------------------------------------------
-
-with TCTouch;
-package body C3A0005_0 is
-
- procedure Push (B : access Button) is
- begin
- TCTouch.Touch( 'P' ); --------------------------------------------- P
- -- Invoking subprogram designated by access value
- B.Response (B);
- end Push;
-
-
- procedure Set_Response (B : access Button;
- R : in Button_Response_Ptr) is
- begin
- TCTouch.Touch( 'S' ); --------------------------------------------- S
- -- Set procedure value in record
- B.Response := R;
- end Set_Response;
-
-
- procedure Default_Response (B : access Button) is
- begin
- TCTouch.Touch( 'D' ); --------------------------------------------- D
- Default_Call := True;
- end Default_Response;
-
-
- procedure Emergency (B : access C3A0005_0.Button) is
- begin
- TCTouch.Touch( 'E' ); --------------------------------------------- E
- Emergency_Call := True;
- end Emergency;
-
-end C3A0005_0;
-
-
------------------------------------------------------------------------------
-
-with TCTouch;
-with Report;
-
-with C3A0005_0;
-
-procedure C3A0005 is
-
- Big_Red_Button : aliased C3A0005_0.Button;
-
-begin
-
- Report.Test ("C3A0005", "Check that access to subprogram may be "
- & "stored within data structures, and that the "
- & "access to subprogram can subsequently be called");
-
- C3A0005_0.Push (Big_Red_Button'Access);
- TCTouch.Validate("PD", "Using default value");
- TCTouch.Assert( C3A0005_0.Default_Call, "Default Call" );
-
- -- set Emergency value in Button.Response
- C3A0005_0.Set_Response(Big_Red_Button'Access, C3A0005_0.Emergency'Access);
-
- C3A0005_0.Push (Big_Red_Button'Access);
- TCTouch.Validate("SPE", "After set to Emergency value");
- TCTouch.Assert( C3A0005_0.Emergency_Call, "Emergency Call");
-
- Report.Result;
-
-end C3A0005;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c3a0006.a b/gcc/testsuite/ada/acats/tests/c3/c3a0006.a
deleted file mode 100644
index effab346581..00000000000
--- a/gcc/testsuite/ada/acats/tests/c3/c3a0006.a
+++ /dev/null
@@ -1,163 +0,0 @@
--- C3A0006.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that access to subprogram may be stored within data
--- structures, and that the access to subprogram can subsequently
--- be called.
---
--- TEST DESCRIPTION:
--- Declare an access to function type in a package specification.
--- Declare an array of the access type. Declare three different
--- functions that can be referred to by the access to function type.
---
--- In the main program, declare a key function that builds the array
--- by calling each function indirectly through the access value.
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
---
---!
-
-
-package C3A0006_0 is
-
- TC_Sine_Call : Integer := 0;
- TC_Cos_Call : Integer := 0;
- TC_Tan_Call : Integer := 0;
-
- Sine_Value : Float := 4.0;
- Cos_Value : Float := 8.0;
- Tan_Value : Float := 10.0;
-
- -- Type accesses to any function
- type Trig_Function_Ptr is access function
- (Angle : in Float) return Float;
-
- function Sine (Angle : in Float) return Float;
-
- function Cos (Angle : in Float) return Float;
-
- function Tan (Angle : in Float) return Float;
-
-end C3A0006_0;
-
-
------------------------------------------------------------------------------
-
-
-package body C3A0006_0 is
-
- function Sine (Angle : in Float) return Float is
- begin
- TC_Sine_Call := TC_Sine_Call + 1;
- Sine_Value := Sine_Value + Angle;
- return Sine_Value;
- end Sine;
-
-
- function Cos (Angle: in Float) return Float is
- begin
- TC_Cos_Call := TC_Cos_Call + 1;
- Cos_Value := Cos_Value - Angle;
- return Cos_Value;
- end Cos;
-
-
- function Tan (Angle : in Float) return Float is
- begin
- TC_Tan_Call := TC_Tan_Call + 1;
- Tan_Value := (Tan_Value + (Tan_Value * Angle));
- return Tan_Value;
- end Tan;
-
-
-end C3A0006_0;
-
------------------------------------------------------------------------------
-
-
-with Report;
-
-with C3A0006_0;
-
-procedure C3A0006 is
-
- Trig_Value, Theta : Float := 0.0;
-
- Total_Routines : constant := 3;
-
- Sine_Total : constant := 7.0;
- Cos_Total : constant := 5.0;
- Tan_Total : constant := 75.0;
-
- Trig_Table : array (1 .. Total_Routines) of C3A0006_0.Trig_Function_Ptr;
-
-
- -- Key function to build the table
- function Call_Trig_Func (Func : C3A0006_0.Trig_Function_Ptr;
- Operand : Float) return Float is
- begin
- return (Func(Operand));
- end Call_Trig_Func;
-
-
-begin
-
- Report.Test ("C3A0006", "Check that access to subprogram may be " &
- "stored within data structures, and that the access " &
- "to subprogram can subsequently be called");
-
- Trig_Table := (C3A0006_0.Sine'Access, C3A0006_0.Cos'Access,
- C3A0006_0.Tan'Access);
-
- -- increase the value of Theta to build the table
- for I in 1 .. Total_Routines loop
- Theta := Theta + 0.5;
- for J in 1 .. Total_Routines loop
- Trig_Value := Call_Trig_Func (Trig_Table(J), Theta);
- end loop;
- end loop;
-
- if C3A0006_0.TC_Sine_Call /= Total_Routines
- or C3A0006_0.TC_Cos_Call /= Total_Routines
- or C3A0006_0.TC_Tan_Call /= Total_Routines then
- Report.Failed ("Incorrect subprograms result");
- end if;
-
- if C3A0006_0.Sine_Value /= Sine_Total
- or C3A0006_0.Cos_Value /= Cos_Total
- or C3A0006_0.Tan_Value /= Tan_Total then
- Report.Failed ("Incorrect values returned from subprograms");
- end if;
-
- if Trig_Value /= Tan_Total then
- Report.Failed ("Incorrect call order.");
- end if;
-
- Report.Result;
-
-end C3A0006;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c3a0007.a b/gcc/testsuite/ada/acats/tests/c3/c3a0007.a
deleted file mode 100644
index ff18d2f9e1d..00000000000
--- a/gcc/testsuite/ada/acats/tests/c3/c3a0007.a
+++ /dev/null
@@ -1,234 +0,0 @@
--- C3A0007.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that a call to a subprogram via an access-to-subprogram value
--- stored in a data structure will correctly dispatch according to the
--- tag of the class-wide parameter passed via that call.
---
--- TEST DESCRIPTION:
--- Declare an access to procedure type in a package specification.
--- Declare a root tagged type with the access to procedure type as a
--- component. Declare three primitive procedures for the type that
--- can be referred to by the access to procedure type. Use the access
--- to procedure type to initialize the component of a record.
---
--- Extend the root type with a record extension in another package
--- specification. Declare a new primitive procedure for the extension
--- (in addition to its three inherited subprograms).
---
--- In the main program, declare an operation for the root tagged type
--- which can be passed as an access value to change the initial value
--- of the component. Call the inherited operation indirectly by
--- dereferencing the access value to check on the initial value of the
--- extension. Call inherited operations indirectly by dereferencing
--- the access value to replace the initial value. Call the primitive
--- procedure indirectly by dereferencing the access value to modify the
--- extension.
---
--- type Button
--- procedure Push(Button)
--- procedure Set_Response(Button,Button_Response_Ptr)
--- procedure Default_Response(Button)
---
--- type Priority_Button (new Button)
--- procedures Push, Set_Response inherited
--- procedure Default_Response
--- procedure Set_Priority
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
---
---!
-
-package C3A0007_0 is
-
- Default_Call : Boolean := False;
-
- type Button is tagged private;
-
- type Button_Response_Ptr is access procedure
- (B : in out Button'Class);
-
- procedure Push (B : in out Button); -- to be inherited
-
- procedure Set_Response (B : in out Button; -- to be inherited
- R : in Button_Response_Ptr);
-
- procedure Response (B : in out Button); -- to be inherited
-
-private
- procedure Default_Response(B: in out Button'Class);
- type Button is tagged -- root tagged type
- record
- Action : Button_Response_Ptr
- := Default_Response'Access;
- end record;
-end C3A0007_0;
-
-with C3A0007_0;
-package C3A0007_1 is
-
- type Priority_Button is new C3A0007_0.Button
- with record
- Priority : Integer := 0;
- end record;
-
- -- Inherits procedure Push from Button
- -- Inherits procedure Set_Response from Button
-
- -- Override procedure Response from Button
- procedure Response (B : in out Priority_Button);
-
- -- Primitive operation of the extension
- procedure Set_Priority (B : in out Priority_Button);
-
-end C3A0007_1;
-
-with C3A0007_0;
-package C3A0007_2 is
-
- Emergency_Call : Boolean := False;
-
- procedure Emergency (B : in out C3A0007_0.Button'Class);
-end C3A0007_2;
-
------------------------------------------------------------------------------
-
-with TCTouch;
-package body C3A0007_0 is
-
- procedure Push (B : in out Button) is
- begin
- TCTouch.Touch( 'P' ); --------------------------------------------- P
- -- Invoking subprogram designated by access value
- B.Action (B);
- end Push;
-
-
- procedure Set_Response (B : in out Button;
- R : in Button_Response_Ptr) is
- begin
- TCTouch.Touch( 'S' ); --------------------------------------------- S
- -- Set procedure value in record
- B.Action := R;
- end Set_Response;
-
-
- procedure Response (B : in out Button) is
- begin
- TCTouch.Touch( 'D' ); --------------------------------------------- D
- Default_Call := True;
- end Response;
-
- procedure Default_Response (B : in out Button'Class) is
- begin
- TCTouch.Touch( 'C' ); --------------------------------------------- C
- Response(B);
- end Default_Response;
-
-end C3A0007_0;
-
-with TCTouch;
-package body C3A0007_1 is
-
- procedure Set_Priority (B : in out Priority_Button) is
- begin
- TCTouch.Touch( 's' ); --------------------------------------------- s
- B.Priority := 1;
- end Set_Priority;
-
- procedure Response (B : in out Priority_Button) is
- begin
- TCTouch.Touch( 'd' ); --------------------------------------------- d
- end Response;
-
-end C3A0007_1;
-
-with TCTouch;
-package body C3A0007_2 is
- procedure Emergency (B : in out C3A0007_0.Button'Class) is
- begin
- TCTouch.Touch( 'E' ); ------------------------------------------- E
- Emergency_Call := True;
- end Emergency;
-end C3A0007_2;
-
------------------------------------------------------------------------------
-
-with Report;
-with TCTouch;
-
-with C3A0007_0;
-with C3A0007_1;
-with C3A0007_2;
-procedure C3A0007 is
-
- Pink_Button : C3A0007_0.Button;
- Green_Button : C3A0007_1.Priority_Button;
-
-begin
-
- Report.Test ("C3A0007", "Check that a call to a subprogram via an "
- & "access-to-subprogram value stored in a data "
- & "structure will correctly dispatch according to "
- & "the tag of the class-wide parameter passed "
- & "via that call" );
-
- -- Call inherited operation Push to set Default_Response value
- -- in the extension.
-
- C3A0007_1.Push (Green_Button);
- TCTouch.Validate("PCd", "First Green Button Push");
-
- TCTouch.Assert_Not(C3A0007_0.Default_Call,
- "Incorrect Green Default_Response");
-
- C3A0007_0.Push (Pink_Button);
- TCTouch.Validate("PCD", "First Pink Button Push");
-
- -- Call inherited operations Set_Response and Push to set
- -- Emergency value in the extension.
- C3A0007_1.Set_Response (Green_Button, C3A0007_2.Emergency'Access);
- C3A0007_1.Push (Green_Button);
- TCTouch.Validate("SPE", "Second Green Button Push");
-
- TCTouch.Assert(C3A0007_2.Emergency_Call, "Incorrect Green Emergency");
-
- C3A0007_0.Set_Response (Pink_Button, C3A0007_2.Emergency'Access);
- C3A0007_0.Push (Pink_Button);
- TCTouch.Validate("SPE", "Second Pink Button Push");
-
- -- Call primitive operation to set priority value
- -- in the extension.
- C3A0007_1.Set_Priority (Green_Button);
- TCTouch.Validate("s", "Green Button Priority");
-
- TCTouch.Assert(Green_Button.Priority = 1, "Incorrect Set_Priority");
-
- Report.Result;
-
-end C3A0007;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c3a0008.a b/gcc/testsuite/ada/acats/tests/c3/c3a0008.a
deleted file mode 100644
index 6cd9ce3ddf0..00000000000
--- a/gcc/testsuite/ada/acats/tests/c3/c3a0008.a
+++ /dev/null
@@ -1,150 +0,0 @@
--- C3A0008.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that subprogram references may be passed as parameters using
--- access-to-subprogram types. Check that the passed subprograms may
--- be invoked from within the called subprogram.
---
--- TEST DESCRIPTION:
--- Declare an access to function type in a package specification.
--- Declare three different trig functions that can be referred to by
--- the access to function type.
---
--- In the main program, call each function indirectly by passing the
--- access to subprogram value as parameter.
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
---
---!
-
-
-package Integrate_Lookup is
-
- TC_Log_Call : Boolean := False;
-
- TC_Cos_Call : Boolean := False;
-
- TC_Sine_Call : Boolean := False;
-
- -- Type accesses to functions Log, Sine, or Cos
- type Integrand_Ptr is access function
- (Angle : Float) return Float;
-
- function Log (Angle : in Float) return Float;
-
- function Sine (Angle : in Float) return Float;
-
- function Cos (Angle : in Float) return Float;
-
- function Integrate (Func : Integrand_Ptr; From, To: Float)
- return Float;
-
-end Integrate_Lookup;
-
-
------------------------------------------------------------------------------
-
-
-package body Integrate_Lookup is
-
-
- function Log (Angle : in Float) return Float is
- begin
- TC_Log_Call := True;
- return 0.1;
- end Log;
-
-
- function Sine (Angle : in Float) return Float is
- begin
- TC_Sine_Call := True;
- return 0.0;
- end Sine;
-
-
- function Cos (Angle : in Float) return Float is
- begin
- TC_Cos_Call := True;
- return 1.0;
- end Cos;
-
-
- function Integrate (Func : Integrand_Ptr; From, To: Float)
- return Float is
- Theta : Float;
- begin
- -- calls the actual subprogram passed as parameter
- Theta := Func (From) + Func (To);
- return Theta;
- end Integrate;
-
-end Integrate_Lookup;
-
-
------------------------------------------------------------------------------
-
-
-with Report;
-
-with Integrate_Lookup;
-
-procedure C3A0008 is
-
- Area : Float := 0.0;
-
-begin
-
- Report.Test ("C3A0008", "Check that subprogram references may be passed "
- & "as parameters using access-to-subprogram types. "
- & "Check that the passed subprograms may be invoked "
- & "from within the called subprogram");
-
- Area := Integrate_Lookup.Integrate
- (Integrate_Lookup.Log'Access, 1.0, 2.0);
-
- If not Integrate_Lookup.TC_Log_Call or Area /= 0.2 then
- Report.Failed ("Incorrect Log result");
- end if;
-
- Area := Integrate_Lookup.Integrate
- (Integrate_Lookup.Sine'Access, 1.0, 2.0);
-
- If not Integrate_Lookup.TC_Sine_Call or Area /= 0.0 then
- Report.Failed ("Incorrect Sine result");
- end if;
-
- Area := Integrate_Lookup.Integrate
- (Integrate_Lookup.Cos'Access, 1.0, 2.0);
-
- If not Integrate_Lookup.TC_Cos_Call or Area /= 2.0 then
- Report.Failed ("Incorrect Cos result");
- end if;
-
- Report.Result;
-
-end C3A0008;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c3a0009.a b/gcc/testsuite/ada/acats/tests/c3/c3a0009.a
deleted file mode 100644
index ba3f2f6e1e7..00000000000
--- a/gcc/testsuite/ada/acats/tests/c3/c3a0009.a
+++ /dev/null
@@ -1,219 +0,0 @@
--- C3A0009.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that subprogram references may be passed as parameters using
--- access-to-subprogram types. Check that the passed subprograms may
--- be invoked from within the called subprogram.
---
--- TEST DESCRIPTION:
--- Declare an access to procedure type in a package specification.
--- Declare a root tagged type with the access to procedure type as a
--- component. Declare three primitive procedures for the type that
--- can be referred to by the access to procedure type. Use the access
--- to procedure type to initialize the component of a record.
---
--- Extend the root type with a private extension in the same package
--- specification. Declare two new primitive subprograms for the extension
--- (in addition to its three inherited subprograms).
---
--- In the main program, declare an operation for the root tagged type
--- which can be passed as an access value to change the initial value
--- of the component. Call the inherited operations indirectly by
--- de-referencing the access value to set value in the extension.
--- Call the primitive function to modify the extension by passing
--- the access value designating the primitive procedure as a parameter.
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
---
---!
-
-package C3A0009_0 is -- Push_Buttons
-
- type Button is tagged private;
-
- -- Type accesses to procedures Push and Default_Response
- type Button_Response_Ptr is access procedure
- (B : in out Button);
-
- procedure Push (B : in out Button); -- to be inherited
-
- procedure Set_Response (B : in out Button; -- to be inherited
- R : in Button_Response_Ptr);
-
- procedure Default_Response (B : in out Button); -- to be inherited
-
- type Alert_Button is new Button with private; -- private extension of
- -- root tagged type
- -- Inherits procedure Push from Button
- -- Inherits procedure Set_Response from Button
- -- Inherits procedure Default_Response from Button
-
- procedure Replace_Action( B: in out Alert_Button );
-
- -- type accesses to procedure Default_Action
- type Button_Action_Ptr is access procedure;
-
- -- The following function is needed to set value in the
- -- extension's private component.
- function Alert (B : in Alert_Button) return Button_Action_Ptr;
-
-private
-
- type Button is tagged -- root tagged type
- record
- Response : Button_Response_Ptr
- := Default_Response'Access;
- end record;
-
- procedure Default_Action;
-
- type Alert_Button is new Button with record
- Action : Button_Action_Ptr
- := Default_Action'Access;
- end record;
-
-end C3A0009_0;
-
-
------------------------------------------------------------------------------
-
-
-with TCTouch;
-package body C3A0009_0 is
-
- procedure Push (B : in out Button) is
- begin
- TCTouch.Touch( 'P' ); --------------------------------------------- P
- -- Invoking subprogram designated by access value
- B.Response (B);
- end Push;
-
-
- procedure Set_Response (B : in out Button;
- R : in Button_Response_Ptr) is
- begin
- TCTouch.Touch( 'S' ); --------------------------------------------- S
- -- Set procedure value in record
- B.Response := R;
- end Set_Response;
-
-
- procedure Default_Response (B : in out Button) is
- begin
- TCTouch.Touch( 'D' ); --------------------------------------------- D
- end Default_Response;
-
-
- procedure Default_Action is
- begin
- TCTouch.Touch( 'd' ); --------------------------------------------- d
- end Default_Action;
-
- procedure Replacement_Action is
- begin
- TCTouch.Touch( 'r' ); --------------------------------------------- r
- end Replacement_Action;
-
- procedure Replace_Action( B: in out Alert_Button ) is
- begin
- TCTouch.Touch( 'R' ); --------------------------------------------- R
- B.Action := Replacement_Action'Access;
- end Replace_Action;
-
- function Alert (B : in Alert_Button) return Button_Action_Ptr is
- begin
- TCTouch.Touch( 'A' ); --------------------------------------------- A
- return (B.Action);
- end Alert;
-
-end C3A0009_0;
-
------------------------------------------------------------------------------
-
-with C3A0009_0;
-package C3A0009_1 is -- Emergency_Items
- package Push_Buttons renames C3A0009_0;
-
- procedure Emergency (B : in out Push_Buttons.Button);
-end C3A0009_1;
-
-with TCTouch;
-package body C3A0009_1 is -- Emergency_Items
- procedure Emergency (B : in out Push_Buttons.Button) is
- begin
- TCTouch.Touch( 'E' ); ------------------------------------------- E
- end Emergency;
-end C3A0009_1;
------------------------------------------------------------------------------
-
-with Report;
-
-with C3A0009_0, C3A0009_1;
-with TCTouch;
-procedure C3A0009 is
-
- package Push_Buttons renames C3A0009_0;
- package Emergency_Items renames C3A0009_1;
-
- Black_Button : Push_Buttons.Alert_Button;
- Alert_Ptr : Push_Buttons.Button_Action_Ptr;
-
-begin
-
- Report.Test ("C3A0009", "Check that subprogram references may be passed "
- & "as parameters using access-to-subprogram types. "
- & "Check that the passed subprograms may be "
- & "invoked from within the called subprogram");
-
-
- Push_Buttons.Push( Black_Button );
- Push_Buttons.Alert( Black_Button ).all;
-
- TCTouch.Validate( "PDAd", "Default operation set" );
-
- -- Call inherited operations Set_Response and Push to set
- -- Emergency value in the extension.
- Push_Buttons.Set_Response (Black_Button, Emergency_Items.Emergency'Access);
-
-
- Push_Buttons.Push( Black_Button );
- Push_Buttons.Alert( Black_Button ).all;
-
- TCTouch.Validate( "SPEAd", "Altered Response set" );
-
- -- Call primitive operation to set action value in the extension.
- Push_Buttons.Replace_Action( Black_Button );
-
-
- Push_Buttons.Push( Black_Button );
- Push_Buttons.Alert( Black_Button ).all;
-
- TCTouch.Validate( "RPEAr", "Altered Action set" );
-
- Report.Result;
-end C3A0009;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c3a0010.a b/gcc/testsuite/ada/acats/tests/c3/c3a0010.a
deleted file mode 100644
index 5628c9518de..00000000000
--- a/gcc/testsuite/ada/acats/tests/c3/c3a0010.a
+++ /dev/null
@@ -1,158 +0,0 @@
--- C3A0010.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that an access-to-subprogram type in a generic instance may be
--- used to declare access-to-subprogram objects which invoke subprograms
--- in the instance.
---
--- TEST DESCRIPTION:
--- Declare a numeric type in the visible part of a generic package.
--- Declare two different math procedures that can be referred to by
--- the access to procedure type.
---
--- In the main program, instantiate the generic. Declare an access
--- to procedure type. Call each procedure indirectly by dereferencing
--- the access value.
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 05 APR 96 SAIC Header correction for 2.1
---
---!
-
-generic
- type Real_Num is digits <>;
-
-package C3A0010_0 is
-
- -- Type accesses to any math procedure
- type Math_Procedure_Ptr is access procedure
- (First_Num, Second_Num : in Real_Num;
- Result_Num : out Real_Num);
-
- procedure Add (First_Num, Second_Num : in Real_Num;
- Result_Num : out Real_Num);
-
- procedure Subtract (First_Num, Second_Num : in Real_Num;
- Result_Num : out Real_Num);
-
-end C3A0010_0;
-
-
------------------------------------------------------------------------------
-
-
-package body C3A0010_0 is
-
- procedure Add (First_Num, Second_Num : in Real_Num;
- Result_Num : out Real_Num) is
- begin
- Result_Num := First_Num + Second_Num;
- end Add;
-
-
- procedure Subtract (First_Num, Second_Num : in Real_Num;
- Result_Num : out Real_Num) is
- begin
- Result_Num := First_Num - Second_Num;
- end Subtract;
-
-end C3A0010_0;
-
------------------------------------------------------------------------------
-
-with Report;
-with C3A0010_0;
-
-procedure C3A0010 is
-
- type Real is digits 2;
-
- subtype Math_Float is Real range -10.0 .. 10.0;
-
- package Math_Pk is new C3A0010_0 (Real_Num => Math_Float);
-
- Math_Access : Math_Pk.Math_Procedure_Ptr;
-
- Total_Num : Math_Float := 0.0;
- First_Num : Math_Float := 1.0;
- Second_Num : Math_Float := 2.0;
-
- procedure Max( A_Num, B_Num: in Math_Float; Result : out Math_Float ) is
- begin
- if A_Num > B_Num then
- Result := A_Num;
- else
- Result := B_Num;
- end if;
- end Max;
-
- procedure Due_Process( Process: Math_Pk.Math_Procedure_Ptr ) is
- begin
- Process(First_Num, Second_Num, Total_Num);
- end Due_Process;
-
-begin
-
- Report.Test ("C3A0010", "Check that an access-to-subprogram type in a "
- & "generic instance may be used to declare "
- & "access-to-subprogram objects which invoke "
- & "subprograms in the instance");
-
--- Check for correct defaulting
- if Math_Pk."/="( Math_Access, null) then
- Report.Failed("subprogram access type object not initialized to null");
- end if;
-
- Math_Access := Math_Pk.Add'Access;
-
- -- Invoking Add procedure designated by access value
- Due_Process( Math_Access );
-
- If Total_Num /= 3.0 then
- Report.Failed ("Incorrect Add result");
- end if;
-
- Math_Access := Math_Pk.Subtract'Access;
-
- Due_Process( Math_Access );
-
- If Total_Num /= -1.0 then
- Report.Failed ("Incorrect Subtract result");
- end if;
-
- Math_Access := Max'Access;
-
- Due_Process( Math_Access );
-
- If Total_Num /= 2.0 then
- Report.Failed ("Incorrect Max result");
- end if;
-
- Report.Result;
-
-end C3A0010;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c3a0011.a b/gcc/testsuite/ada/acats/tests/c3/c3a0011.a
deleted file mode 100644
index 985080659a1..00000000000
--- a/gcc/testsuite/ada/acats/tests/c3/c3a0011.a
+++ /dev/null
@@ -1,186 +0,0 @@
--- C3A0011.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that an access-to-subprogram object whose type is declared in a
--- parent package, may be used to invoke subprograms in a child package.
--- Check that such access objects may be stored in a data structure and
--- that subprograms may be called by walking the data structure.
---
--- TEST DESCRIPTION:
--- In the package, declare an access to procedure type. Declare an
--- array of the access type. Declare three different procedures that
--- can be referred to by the access to procedure type.
---
--- In the visible child package, declare two procedures that can be
--- referred to by the access to procedure type of the parent. Build
--- the array by calling each procedure indirectly through the access
--- value.
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 16 Dec 94 SAIC Improved visibility of "/=" in main body
---
---!
-
-package C3A0011_0 is -- Interpreter
-
- type Compass_Point is mod 360;
-
- function Heading return Compass_Point;
-
- -- Type accesses to any procedure
- type Action_Ptr is access procedure;
-
- -- Array of access to procedure
- type Action_Array is array (Natural range <>) of Action_Ptr;
-
- procedure Rotate_Left;
-
- procedure Rotate_Right;
-
- procedure Center;
-
-private
- The_Heading : Compass_Point := Compass_Point'First;
-
-end C3A0011_0;
-
-
------------------------------------------------------------------------------
-
-
-package body C3A0011_0 is
-
- function Heading return Compass_Point is
- begin
- return The_Heading;
- end Heading;
-
- procedure Rotate_Left is
- begin
- The_Heading := The_Heading - 90;
- end Rotate_Left;
-
-
- procedure Rotate_Right is
- begin
- The_Heading := The_Heading + 90;
- end Rotate_Right;
-
-
- procedure Center is
- begin
- The_Heading := 0;
- end Center;
-
-end C3A0011_0;
-
-
------------------------------------------------------------------------------
-
-
-package C3A0011_0.Action is
-
- procedure Rotate_Front;
-
- procedure Rotate_Back;
-
-end C3A0011_0.Action;
-
-
------------------------------------------------------------------------------
-
-
-package body C3A0011_0.Action is
-
- procedure Rotate_Front is
- begin
- The_Heading := The_Heading + 5;
- end Rotate_Front;
-
-
- procedure Rotate_Back is
- begin
- The_Heading := The_Heading - 5;
- end Rotate_Back;
-
-end C3A0011_0.Action;
-
-
------------------------------------------------------------------------------
-
-
-with C3A0011_0.Action;
-
-with Report;
-
-procedure C3A0011 is
-
- Total_Actions : constant := 6;
-
- Action_Sequence : C3A0011_0.Action_Array (1 .. Total_Actions);
-
- type Result_Array is array (Natural range <>) of C3A0011_0.Compass_Point;
-
- Action_Results : Result_Array(1 .. Total_Actions);
-
- package IA renames C3A0011_0.Action;
-
-begin
-
- Report.Test ("C3A0011", "Check that an access-to-subprogram object whose "
- & "type is declared in a parent package, may be "
- & "used to invoke subprograms in a child package. "
- & "Check that such access objects may be stored in "
- & "a data structure and that subprograms may be "
- & "called by walking the data structure");
-
- -- Build the action sequence
- Action_Sequence := (C3A0011_0.Rotate_Left'Access,
- C3A0011_0.Center'Access,
- C3A0011_0.Rotate_Right'Access,
- IA.Rotate_Front'Access,
- C3A0011_0.Center'Access,
- IA.Rotate_Back'Access);
-
- -- Build the expected result
- Action_Results := ( 270, 0, 90, 95, 0, 355 );
-
- -- Assign actions by invoking subprogram designated by access value
- for I in Action_Sequence'Range loop
- Action_Sequence(I).all;
- if C3A0011_0."/="( C3A0011_0.Heading, Action_Results(I) ) then
- Report.Failed ("Expecting "
- & C3A0011_0.Compass_Point'Image(Action_Results(I))
- & " Got"
- & C3A0011_0.Compass_Point'Image(C3A0011_0.Heading));
- end if;
- end loop;
-
- Report.Result;
-
-end C3A0011;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c3a00120.a b/gcc/testsuite/ada/acats/tests/c3/c3a00120.a
deleted file mode 100644
index 5ce7b6175d5..00000000000
--- a/gcc/testsuite/ada/acats/tests/c3/c3a00120.a
+++ /dev/null
@@ -1,83 +0,0 @@
--- C3A00120.A
- --
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
- --
- -- OBJECTIVE:
- -- See file C3A00122.AM
- --
- -- TEST DESCRIPTION:
- -- See file C3A00122.AM
- --
- -- TEST FILES:
- -- The following files comprise this test:
- --
- -- => C3A00120.A
- -- C3A00121.A
- -- C3A00122.AM
- --
- --
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
---
- --!
-
- package C3A0012_0 is
-
- type Call_Kind is (No_Call_Made, Fast_Call, Accurate_Call,
- Table_Lookup_Call);
-
- Log_Result : Float := 0.0;
-
- -- Type accesses to any log procedure
- type Log_Procedure_Ptr is access procedure
- (Angle : in Float; Log_Call : out Call_Kind);
-
- procedure Log_Calc_Fast (Angle : in Float;
- Method : out Call_Kind);
-
- procedure Log_Calc_Acc (Angle : in Float;
- Method : out Call_Kind);
-
- procedure Log_Calc_Table (Angle : in Float;
- Method : out Call_Kind);
-
- end C3A0012_0;
-
-
- --=======================================================================--
-
-
- package body C3A0012_0 is
-
- procedure Log_Calc_Fast (Angle : in Float;
- Method : out Call_Kind) is separate;
-
- procedure Log_Calc_Acc (Angle : in Float;
- Method : out Call_Kind) is separate;
-
- procedure Log_Calc_Table (Angle : in Float;
- Method : out Call_Kind) is separate;
-
- end C3A0012_0;
-
diff --git a/gcc/testsuite/ada/acats/tests/c3/c3a00121.a b/gcc/testsuite/ada/acats/tests/c3/c3a00121.a
deleted file mode 100644
index acb1dab99aa..00000000000
--- a/gcc/testsuite/ada/acats/tests/c3/c3a00121.a
+++ /dev/null
@@ -1,76 +0,0 @@
--- C3A00121.A
- --
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
- --
- -- OBJECTIVE:
- -- See file C3A00122.AM
- --
- -- TEST DESCRIPTION:
- -- See file C3A00122.AM
- --
- -- TEST FILES:
- -- The following files comprise this test:
- --
- -- C3A00120.A
- -- => C3A00121.A
- -- C3A00122.AM
- --
- --
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
---
- --!
-
- Separate (C3A0012_0)
- procedure Log_Calc_Fast (Angle : in Float;
- Method : out Call_Kind) is
- begin
- C3A0012_0.Log_Result := Angle;
- Method := Fast_Call;
- end Log_Calc_Fast;
-
-
- --=======================================================================--
-
-
- Separate (C3A0012_0)
- procedure Log_Calc_Acc (Angle : in Float;
- Method : out Call_Kind) is
- begin
- C3A0012_0.Log_Result := Angle;
- Method := Accurate_Call;
- end Log_Calc_Acc;
-
-
- --=======================================================================--
-
-
- Separate (C3A0012_0)
- procedure Log_Calc_Table (Angle : in Float;
- Method : out Call_Kind) is
- begin
- C3A0012_0.Log_Result := Angle;
- Method := Table_Lookup_Call;
- end Log_Calc_Table;
-
diff --git a/gcc/testsuite/ada/acats/tests/c3/c3a0013.a b/gcc/testsuite/ada/acats/tests/c3/c3a0013.a
deleted file mode 100644
index b23d4ee1151..00000000000
--- a/gcc/testsuite/ada/acats/tests/c3/c3a0013.a
+++ /dev/null
@@ -1,347 +0,0 @@
--- C3A0013.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that a general access type object may reference allocated
--- pool objects as well as aliased objects. (3,4)
--- Check that formal parameters of tagged types are implicitly
--- defined as aliased; check that the 'Access of these formal
--- parameters designates the correct object with the correct
--- tag. (5)
--- Check that the current instance of a limited type is defined as
--- aliased. (5)
---
--- TEST DESCRIPTION:
--- This test takes from the hierarchy defined in C390003; making
--- the root type Vehicle limited private. It also shifts the
--- abstraction to include the notion of a transmission, an object
--- which is contained within any vehicle. Using an access
--- discriminant, any subprogram which operates on a transmission
--- may also reference the vehicle in which it is installed.
---
--- Class Hierarchy:
--- Vehicle Transmission
--- / \
--- Truck Car
---
--- Contains:
--- Vehicle( Transmission )
---
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 16 Dec 94 SAIC Fixed accessibility problems
---
---!
-
-package C3A0013_1 is
- type Vehicle is tagged limited private;
- type Vehicle_ID is access all Vehicle'Class;
-
- -- Constructors
- procedure Create ( It : in out Vehicle;
- Wheels : Natural := 4 );
- -- Modifiers
- procedure Accelerate ( It : in out Vehicle );
- procedure Decelerate ( It : in out Vehicle );
- procedure Up_Shift ( It : in out Vehicle );
- procedure Stop ( It : in out Vehicle );
-
- -- Selectors
- function Speed ( It : Vehicle ) return Natural;
- function Wheels ( It : Vehicle ) return Natural;
- function Gear_Factor( It : Vehicle ) return Natural;
-
- -- TC_Ops
- procedure TC_Validate( It : in out Vehicle; Speed_Trap : Natural );
-
- -- dispatching procedure used to check tag correctness
- procedure TC_Validate( It : Vehicle;
- TC_ID : Character);
-
-private
-
- type Transmission(Within: access Vehicle'Class) is limited record
- Engaged : Boolean := False;
- Gear : Integer range -1..5 := 0;
- end record;
-
- -- Current instance of a limited type is defined as aliased
-
- type Vehicle is tagged limited record
- Wheels: Natural;
- Speed : Natural;
- Power_Train: Transmission( Vehicle'Access );
- end record;
-end C3A0013_1;
-
-with C3A0013_1;
-package C3A0013_2 is
- type Car is new C3A0013_1.Vehicle with private;
- procedure TC_Validate( It : Car;
- TC_ID : Character);
- function Gear_Factor( It : Car ) return Natural;
-private
- type Car is new C3A0013_1.Vehicle with record
- Displacement : Natural;
- end record;
-end C3A0013_2;
-
-with C3A0013_1;
-package C3A0013_3 is
- type Truck is new C3A0013_1.Vehicle with private;
- procedure TC_Validate( It : Truck;
- TC_ID : Character);
- function Gear_Factor( It : Truck ) return Natural;
-private
- type Truck is new C3A0013_1.Vehicle with record
- Displacement : Natural;
- end record;
-end C3A0013_3;
-
-with Report;
-package body C3A0013_1 is
-
- procedure Create ( It : in out Vehicle;
- Wheels : Natural := 4 ) is
- begin
- It.Wheels := Wheels;
- It.Speed := 0;
- end Create;
-
- procedure Accelerate( It : in out Vehicle ) is
- begin
- It.Speed := It.Speed + Gear_Factor( It.Power_Train.Within.all );
- end Accelerate;
-
- procedure Decelerate( It : in out Vehicle ) is
- begin
- It.Speed := It.Speed - Gear_Factor( It.Power_Train.Within.all );
- end Decelerate;
-
- procedure Stop ( It : in out Vehicle ) is
- begin
- It.Speed := 0;
- It.Power_Train.Engaged := False;
- end Stop;
-
- function Gear_Factor( It : Vehicle ) return Natural is
- begin
- return It.Power_Train.Gear;
- end Gear_Factor;
-
- function Speed ( It : Vehicle ) return Natural is
- begin
- return It.Speed;
- end Speed;
-
- function Wheels ( It : Vehicle ) return Natural is
- begin
- return It.Wheels;
- end Wheels;
-
- -- formal tagged parameters are implicitly aliased
-
- procedure TC_Validate( It : in out Vehicle; Speed_Trap : Natural ) is
- License: Vehicle_ID := It'Unchecked_Access;
- begin
- if Speed( License.all ) /= Speed_Trap then
- Report.Failed("Speed Trap: expected: " & Natural'Image(Speed_Trap));
- end if;
- end TC_Validate;
-
- procedure TC_Validate( It : Vehicle;
- TC_ID : Character) is
- begin
- if TC_ID /= 'V' then
- Report.Failed("Dispatched to Vehicle");
- end if;
- if Wheels( It ) /= 1 then
- Report.Failed("Not a Vehicle");
- end if;
- end TC_Validate;
-
- procedure Up_Shift( It: in out Vehicle ) is
- begin
- It.Power_Train.Gear := It.Power_Train.Gear +1;
- It.Power_Train.Engaged := True;
- Accelerate( It );
- end Up_Shift;
-end C3A0013_1;
-
-with Report;
-package body C3A0013_2 is
-
- procedure TC_Validate( It : Car;
- TC_ID : Character ) is
- begin
- if TC_ID /= 'C' then
- Report.Failed("Dispatched to Car");
- end if;
- if Wheels( It ) /= 4 then
- Report.Failed("Not a Car");
- end if;
- end TC_Validate;
-
- function Gear_Factor( It : Car ) return Natural is
- begin
- return C3A0013_1.Gear_Factor( C3A0013_1.Vehicle( It ) )*2;
- end Gear_Factor;
-
-end C3A0013_2;
-
-with Report;
-package body C3A0013_3 is
-
- procedure TC_Validate( It : Truck;
- TC_ID : Character) is
- begin
- if TC_ID /= 'T' then
- Report.Failed("Dispatched to Truck");
- end if;
- if Wheels( It ) /= 3 then
- Report.Failed("Not a Truck");
- end if;
- end TC_Validate;
-
- function Gear_Factor( It : Truck ) return Natural is
- begin
- return C3A0013_1.Gear_Factor( C3A0013_1.Vehicle( It ) )*3;
- end Gear_Factor;
-
-end C3A0013_3;
-
-package C3A0013_4 is
- procedure Perform_Tests;
-end C3A0013_4;
-
-with Report;
-with C3A0013_1;
-with C3A0013_2;
-with C3A0013_3;
-package body C3A0013_4 is
- package Root renames C3A0013_1;
- package Cars renames C3A0013_2;
- package Trucks renames C3A0013_3;
-
- type Car_Pool is array(1..4) of aliased Cars.Car;
- Commuters : Car_Pool;
-
- My_Car : aliased Cars.Car;
- Company_Car : Root.Vehicle_ID;
- Repair_Shop : Root.Vehicle_ID;
-
- The_Vehicle : Root.Vehicle;
- The_Car : Cars.Car;
- The_Truck : Trucks.Truck;
-
- procedure TC_Dispatch( Ptr : Root.Vehicle_ID;
- Char : Character ) is
- begin
- Root.TC_Validate( Ptr.all, Char );
- end TC_Dispatch;
-
- procedure TC_Check_Formal_Access( Item: in out Root.Vehicle'Class;
- Char: Character) is
- begin
- TC_Dispatch( Item'Unchecked_Access, Char );
- end TC_Check_Formal_Access;
-
- procedure Perform_Tests is
- begin -- Main test procedure.
-
- for Lane in Commuters'Range loop
- Cars.Create( Commuters(Lane) );
- for Excitement in 1..Lane loop
- Cars.Up_Shift( Commuters(Lane) );
- end loop;
- end loop;
-
- Cars.Create( My_Car );
- Cars.Up_Shift( My_Car );
- Cars.TC_Validate( My_Car, 2 );
-
- Root.Create( The_Vehicle, 1 );
- Cars.Create( The_Car , 4 );
- Trucks.Create( The_Truck, 3 );
-
- TC_Check_Formal_Access( The_Vehicle, 'V' );
- TC_Check_Formal_Access( The_Car, 'C' );
- TC_Check_Formal_Access( The_Truck, 'T' );
-
- Root.Up_Shift( The_Vehicle );
- Cars.Up_Shift( The_Car );
- Trucks.Up_Shift( The_Truck );
-
- Root.TC_Validate( The_Vehicle, 1 );
- Cars.TC_Validate( The_Car, 2 );
- Trucks.TC_Validate( The_Truck, 3 );
-
- -- general access type may reference allocated objects
-
- Company_Car := new Cars.Car;
- Root.Create( Company_Car.all );
- Root.Up_Shift( Company_Car.all );
- Root.Up_Shift( Company_Car.all );
- Root.TC_Validate( Company_Car.all, 6 );
-
- -- general access type may reference aliased objects
-
- Repair_Shop := My_Car'Access;
- Root.TC_Validate( Repair_Shop.all, 2 );
-
- -- general access type may reference aliased objects
-
- Construction: declare
- type Speed_List is array(Commuters'Range) of Natural;
- Accelerations : constant Speed_List := (2, 6, 12, 20);
- begin
- for Rotation in Commuters'Range loop
- Repair_Shop := Commuters(Rotation)'Access;
- Root.TC_Validate( Repair_Shop.all, Accelerations(Rotation) );
- end loop;
- end Construction;
-
-end Perform_Tests;
-
-end C3A0013_4;
-
-with C3A0013_4;
-with Report;
-procedure C3A0013 is
-begin
-
- Report.Test ("C3A0013", "Check general access types. Check aliased "
- & "nature of formal tagged type parameters. "
- & "Check aliased nature of the current "
- & "instance of a limited type. Check the "
- & "constraining of actual subtypes for "
- & "discriminated objects" );
-
- C3A0013_4.Perform_Tests;
-
- Report.Result;
-end C3A0013;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c3a0014.a b/gcc/testsuite/ada/acats/tests/c3/c3a0014.a
deleted file mode 100644
index c83ab4f5e28..00000000000
--- a/gcc/testsuite/ada/acats/tests/c3/c3a0014.a
+++ /dev/null
@@ -1,453 +0,0 @@
--- C3A0014.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that if the view defined by an object declaration is aliased,
--- and the type of the object has discriminants, then the object is
--- constrained by its initial value even if its nominal subtype is
--- unconstrained.
---
--- Check that the attribute A'Constrained returns True if A is a formal
--- out or in out parameter, or dereference thereof, and A denotes an
--- aliased view of an object.
---
--- TEST DESCRIPTION:
--- These rules apply to objects of a record type with defaulted
--- discriminants, which may be unconstrained variables. If such a
--- variable is declared to be aliased, then it is constrained by its
--- initial value, and the value of the discriminant cannot be changed
--- for the life of the variable.
---
--- The rules do not apply to aliased component types because if such
--- types are discriminated they must be constrained.
---
--- A'Constrained returns True if A denotes a constant, value, or
--- constrained variable. Since aliased objects are constrained, it must
--- return True if the actual parameter corresponding to a formal
--- parameter A is an aliased object. The objective only mentions formal
--- parameters of mode out and in out, since parameters of mode in are
--- by definition constant, and would result in True anyway.
---
--- This test declares aliased objects of a nominally unconstrained
--- record subtype, both with and without initialization expressions.
--- It also declares access values which point to such objects. It then
--- checks that Constraint_Error is raised if an attempt is made to
--- change the discriminant value of an aliased object, either directly
--- or via a dereference of an access value. For aliased objects, this
--- check is also performed for subprogram parameters of mode out.
---
--- The test also passes aliased objects and access values which point
--- to such objects as actuals to subprograms and verifies, for parameter
--- modes out and in out, that P'Constrained returns true if P is the
--- corresponding formal parameter or a dereference thereof.
---
--- Additionally, the test declares a generic package which declares a
--- an aliased object of a formal derived unconstrained type, which is
--- is initialized with the value of a formal object of that type.
--- procedure declared within the generic assigns a value to the object
--- which has the same discriminant value as the formal derived type's
--- ancestor type. The generic is instantiated with various actuals
--- for the formal object, and the procedure is called. The test verifies
--- that Constraint_Error is raised if the discriminant values of the
--- actual corresponding to the formal object and the value assigned
--- by the procedure are not equal.
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 16 Nov 95 SAIC ACVC 2.0.1 fixes: Corrected numerous errors.
---
---!
-
-package C3A0014_0 is
-
- subtype Reasonable is Integer range 1..10;
- -- Unconstrained (sub)type.
- type UC (D: Reasonable := 2) is record -- Discriminant default.
- S: String (1 .. D) := "Hi"; -- Default value.
- end record;
-
- type AUC is access all UC;
-
- -- Nominal subtype is unconstrained for the following:
-
- Obj0 : UC; -- An unconstrained object.
-
- Obj1 : UC := (5, "Hello"); -- Non-aliased with initialization,
- -- an unconstrained object.
-
- Obj2 : aliased UC := (5, "Hello"); -- Aliased with initialization,
- -- a constrained object.
-
- Obj3 : UC renames Obj2; -- Aliased (renaming of aliased view),
- -- a constrained object.
- Obj4 : aliased UC; -- Aliased without initialization, Obj4
- -- constrained here to initial value
- -- taken from default for type.
-
- Ptr1 : AUC := new UC'(Obj1);
- Ptr2 : AUC := new UC;
- Ptr3 : AUC := Obj3'Access;
- Ptr4 : AUC := Obj4'Access;
-
-
- procedure NP_Proc (A: out UC);
- procedure NP_Cons (A: in out UC; B: out Boolean);
- procedure P_Cons (A: out AUC; B: out Boolean);
-
-
- generic
- type FT is new UC;
- FObj : in out FT;
- package Gen is
- F : aliased FT := FObj; -- Constrained if FT has discriminants.
- procedure Proc;
- end Gen;
-
-
- procedure Avoid_Optimization_and_Fail ( P : UC; Msg : String );
-
-
-end C3A0014_0;
-
-
- --=======================================================================--
-
-with Report;
-
-package body C3A0014_0 is
-
- procedure NP_Proc (A: out UC) is
- begin
- A := (3, "Bye");
- end NP_Proc;
-
- procedure NP_Cons (A: in out UC; B: out Boolean) is
- begin
- B := A'Constrained;
- end NP_Cons;
-
- procedure P_Cons (A: out AUC; B: out Boolean) is
- begin
- B := A.all'Constrained;
- end P_Cons;
-
-
- package body Gen is
-
- procedure Proc is
- begin
- F := (2, "Fi");
- end Proc;
-
- end Gen;
-
-
- procedure Avoid_Optimization_and_Fail ( P : UC; Msg : String ) is
- Default : UC := (1, "!"); -- Unique value.
- begin
- if P = Default then -- Both If branches can't do the same thing.
- Report.Failed (Msg & ": Constraint_Error not raised");
- else -- Subtests should always select this path.
- Report.Failed ("Constraint_Error not raised " & Msg);
- end if;
- end Avoid_Optimization_and_Fail;
-
-
-end C3A0014_0;
-
-
- --=======================================================================--
-
-
-with C3A0014_0; use C3A0014_0;
-with Report;
-
-procedure C3A0014 is
-begin
-
- Report.Test("C3A0014", "Check that if the view defined by an object " &
- "declaration is aliased, and the type of the " &
- "object has discriminants, then the object is " &
- "constrained by its initial value even if its " &
- "nominal subtype is unconstrained. Check that " &
- "the attribute A'Constrained returns True if A " &
- "is a formal out or in out parameter, or " &
- "dereference thereof, and A denotes an aliased " &
- "view of an object");
-
- Non_Pointer_Block:
- begin
-
- begin
- Obj0 := (3, "Bye"); -- OK: Obj0 not constrained.
- if Obj0 /= (3, "Bye") then
- Report.Failed
- ("Wrong value after aggregate assignment - Subtest 1");
- end if;
- exception
- when others =>
- Report.Failed ("Unexpected exception raised - Subtest 1");
- end;
-
-
- begin
- Obj1 := (3, "Bye"); -- OK: Obj1 not constrained.
- if Obj1 /= (3, "Bye") then
- Report.Failed
- ("Wrong value after aggregate assignment - Subtest 2");
- end if;
- exception
- when others =>
- Report.Failed ("Unexpected exception raised - Subtest 2");
- end;
-
-
- begin
- Obj2 := (3, "Bye"); -- C_E: Obj2 is constrained (D=>5).
- Avoid_Optimization_and_Fail (Obj2, "Subtest 3");
- exception
- when Constraint_Error => null; -- Exception is expected.
- end;
-
-
- begin
- Obj3 := (3, "Bye"); -- C_E: Obj3 is constrained (D=>5).
- Avoid_Optimization_and_Fail (Obj3, "Subtest 4");
- exception
- when Constraint_Error => null; -- Exception is expected.
- end;
-
-
- begin
- Obj4 := (3, "Bye"); -- C_E: Obj4 is constrained (D=>2).
- Avoid_Optimization_and_Fail (Obj4, "Subtest 5");
- exception
- when Constraint_Error => null; -- Exception is expected.
- end;
-
- exception
- when others => Report.Failed("Unexpected exception: Non_Pointer_Block");
- end Non_Pointer_Block;
-
-
- Pointer_Block:
- begin
-
- begin
- Ptr1.all := (3, "Bye"); -- C_E: Ptr1.all is constrained (D=>5).
- Avoid_Optimization_and_Fail (Ptr1.all, "Subtest 6");
- exception
- when Constraint_Error => null; -- Exception is expected.
- end;
-
-
- begin
- Ptr2.all := (3, "Bye"); -- C_E: Ptr2.all is constrained (D=>2).
- Avoid_Optimization_and_Fail (Ptr2.all, "Subtest 7");
- exception
- when Constraint_Error => null; -- Exception is expected.
- end;
-
-
- begin
- Ptr3.all := (3, "Bye"); -- C_E: Ptr3.all is constrained (D=>5).
- Avoid_Optimization_and_Fail (Ptr3.all, "Subtest 8");
- exception
- when Constraint_Error => null; -- Exception is expected.
- end;
-
-
- begin
- Ptr4.all := (3, "Bye"); -- C_E: Ptr4.all is constrained (D=>2).
- Avoid_Optimization_and_Fail (Ptr4.all, "Subtest 9");
- exception
- when Constraint_Error => null; -- Exception is expected.
- end;
-
- exception
- when others => Report.Failed("Unexpected exception: Pointer_Block");
- end Pointer_Block;
-
-
- Subprogram_Block:
- declare
- Is_Constrained : Boolean;
- begin
-
- begin
- NP_Proc (Obj0); -- OK: Obj0 not constrained, can
- if Obj0 /= (3, "Bye") then -- change discriminant value.
- Report.Failed
- ("Wrong value after aggregate assignment - Subtest 10");
- end if;
- exception
- when others =>
- Report.Failed ("Unexpected exception raised - Subtest 10");
- end;
-
-
- begin
- NP_Proc (Obj2); -- C_E: Obj2 is constrained (D=>5).
- Avoid_Optimization_and_Fail (Obj2, "Subtest 11");
- exception
- when Constraint_Error => null; -- Exception is expected.
- end;
-
-
- begin
- NP_Proc (Obj3); -- C_E: Obj3 is constrained (D=>5).
- Avoid_Optimization_and_Fail (Obj3, "Subtest 12");
- exception
- when Constraint_Error => null; -- Exception is expected.
- end;
-
-
- begin
- NP_Proc (Obj4); -- C_E: Obj4 is constrained (D=>2).
- Avoid_Optimization_and_Fail (Obj4, "Subtest 13");
- exception
- when Constraint_Error => null; -- Exception is expected.
- end;
-
-
-
- begin
- Is_Constrained := True;
- NP_Cons (Obj1, Is_Constrained); -- Should return False, since Obj1
- if Is_Constrained then -- is not constrained.
- Report.Failed ("Wrong result from 'Constrained - Subtest 14");
- end if;
- exception
- when others =>
- Report.Failed ("Unexpected exception raised - Subtest 14");
- end;
-
-
- begin
- Is_Constrained := False;
- NP_Cons (Obj2, Is_Constrained); -- Should return True, Obj2 is
- if not Is_Constrained then -- constrained.
- Report.Failed ("Wrong result from 'Constrained - Subtest 15");
- end if;
- exception
- when others =>
- Report.Failed ("Unexpected exception raised - Subtest 15");
- end;
-
-
-
-
- begin
- Is_Constrained := False;
- P_Cons (Ptr2, Is_Constrained); -- Should return True, Ptr2.all
- if not Is_Constrained then -- is constrained.
- Report.Failed ("Wrong result from 'Constrained - Subtest 16");
- end if;
- exception
- when others =>
- Report.Failed ("Unexpected exception raised - Subtest 16");
- end;
-
-
- begin
- Is_Constrained := False;
- P_Cons (Ptr3, Is_Constrained); -- Should return True, Ptr3.all
- if not Is_Constrained then -- is constrained.
- Report.Failed ("Wrong result from 'Constrained - Subtest 17");
- end if;
- exception
- when others =>
- Report.Failed ("Unexpected exception raised - Subtest 17");
- end;
-
-
- exception
- when others => Report.Failed("Exception raised in Subprogram_Block");
- end Subprogram_Block;
-
-
- Generic_Block:
- declare
-
- type NUC is new UC;
-
- Obj : NUC;
-
-
- package Instance_A is new Gen (NUC, Obj);
- package Instance_B is new Gen (UC, Obj2);
- package Instance_C is new Gen (UC, Obj3);
- package Instance_D is new Gen (UC, Obj4);
-
- begin
-
- begin
- Instance_A.Proc; -- OK: Obj.D = 2.
- if Instance_A.F /= (2, "Fi") then
- Report.Failed
- ("Wrong value after aggregate assignment - Subtest 18");
- end if;
- exception
- when others =>
- Report.Failed ("Unexpected exception raised - Subtest 18");
- end;
-
-
- begin
- Instance_B.Proc; -- C_E: Obj2.D = 5.
- Avoid_Optimization_and_Fail (Obj2, "Subtest 19");
- exception
- when Constraint_Error => null; -- Exception is expected.
- end;
-
-
- begin
- Instance_C.Proc; -- C_E: Obj3.D = 5.
- Avoid_Optimization_and_Fail (Obj3, "Subtest 20");
- exception
- when Constraint_Error => null; -- Exception is expected.
- end;
-
-
- begin
- Instance_D.Proc; -- OK: Obj4.D = 2.
- if Instance_D.F /= (2, "Fi") then
- Report.Failed
- ("Wrong value after aggregate assignment - Subtest 21");
- end if;
- exception
- when others =>
- Report.Failed ("Unexpected exception raised - Subtest 21");
- end;
-
- exception
- when others => Report.Failed("Exception raised in Generic_Block");
- end Generic_Block;
-
-
- Report.Result;
-
-end C3A0014;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c3a0015.a b/gcc/testsuite/ada/acats/tests/c3/c3a0015.a
deleted file mode 100644
index 856c910f92d..00000000000
--- a/gcc/testsuite/ada/acats/tests/c3/c3a0015.a
+++ /dev/null
@@ -1,267 +0,0 @@
--- C3A0015.A
---
--- Grant of Unlimited Rights
---
--- The Ada Conformity Assessment Authority (ACAA) holds unlimited
--- rights in the software and documentation contained herein. Unlimited
--- rights are the same as those granted by the U.S. Government for older
--- parts of the Ada Conformity Assessment Test Suite, and are defined
--- in DFAR 252.227-7013(a)(19). By making this public release, the ACAA
--- intends to confer upon all recipients unlimited rights equal to those
--- held by the ACAA. These rights include rights to use, duplicate,
--- release or disclose the released technical data and computer software
--- in whole or in part, in any manner and for any purpose whatsoever, and
--- to have or permit others to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that a derived access type has the same storage pool as its
--- parent. (Defect Report 8652/0012, Technical Corrigendum 3.10(7/1)).
---
--- CHANGE HISTORY:
--- 24 JAN 2001 PHL Initial version.
--- 29 JUN 2001 RLB Reformatted for ACATS.
---
---!
-with System.Storage_Elements;
-use System.Storage_Elements;
-with System.Storage_Pools;
-use System.Storage_Pools;
-package C3A0015_0 is
-
- type Pool (Storage_Size : Storage_Count) is new Root_Storage_Pool with
- record
- First_Free : Storage_Count := 1;
- Contents : Storage_Array (1 .. Storage_Size);
- end record;
-
- procedure Allocate (Pool : in out C3A0015_0.Pool;
- Storage_Address : out System.Address;
- Size_In_Storage_Elements : in Storage_Count;
- Alignment : in Storage_Count);
-
- procedure Deallocate (Pool : in out C3A0015_0.Pool;
- Storage_Address : in System.Address;
- Size_In_Storage_Elements : in Storage_Count;
- Alignment : in Storage_Count);
-
- function Storage_Size (Pool : in C3A0015_0.Pool) return Storage_Count;
-
-end C3A0015_0;
-
-package body C3A0015_0 is
-
- use System;
-
- procedure Allocate (Pool : in out C3A0015_0.Pool;
- Storage_Address : out System.Address;
- Size_In_Storage_Elements : in Storage_Count;
- Alignment : in Storage_Count) is
- Unaligned_Address : constant System.Address :=
- Pool.Contents (Pool.First_Free)'Address;
- Unalignment : Storage_Count;
- begin
- Unalignment := Unaligned_Address mod Alignment;
- if Unalignment = 0 then
- Storage_Address := Unaligned_Address;
- Pool.First_Free := Pool.First_Free + Size_In_Storage_Elements;
- else
- Storage_Address :=
- Pool.Contents (Pool.First_Free + Alignment - Unalignment)'
- Address;
- Pool.First_Free := Pool.First_Free + Size_In_Storage_Elements +
- Alignment - Unalignment;
- end if;
- end Allocate;
-
- procedure Deallocate (Pool : in out C3A0015_0.Pool;
- Storage_Address : in System.Address;
- Size_In_Storage_Elements : in Storage_Count;
- Alignment : in Storage_Count) is
- begin
- if Storage_Address + Size_In_Storage_Elements =
- Pool.Contents (Pool.First_Free)'Address then
- -- Only deallocate if the block is at the end.
- Pool.First_Free := Pool.First_Free - Size_In_Storage_Elements;
- end if;
- end Deallocate;
-
- function Storage_Size (Pool : in C3A0015_0.Pool) return Storage_Count is
- begin
- return Pool.Storage_Size;
- end Storage_Size;
-
-end C3A0015_0;
-
-with Ada.Exceptions;
-use Ada.Exceptions;
-with Ada.Unchecked_Deallocation;
-with Report;
-use Report;
-with System.Storage_Elements;
-use System.Storage_Elements;
-with C3A0015_0;
-procedure C3A0015 is
-
- type Standard_Pool is access Float;
- type Derived_Standard_Pool is new Standard_Pool;
- type Derived_Derived_Standard_Pool is new Derived_Standard_Pool;
-
- type User_Defined_Pool is access Integer;
- type Derived_User_Defined_Pool is new User_Defined_Pool;
- type Derived_Derived_User_Defined_Pool is new Derived_User_Defined_Pool;
-
- My_Pool : C3A0015_0.Pool (1024);
- for User_Defined_Pool'Storage_Pool use My_Pool;
-
- generic
- type Designated is private;
- Value : Designated;
- type Acc is access Designated;
- type Derived_Acc is new Acc;
- procedure Check (Subtest : String; User_Defined_Pool : Boolean);
-
- procedure Check (Subtest : String; User_Defined_Pool : Boolean) is
-
- procedure Deallocate is
- new Ada.Unchecked_Deallocation (Object => Designated,
- Name => Acc);
- procedure Deallocate is
- new Ada.Unchecked_Deallocation (Object => Designated,
- Name => Derived_Acc);
-
- First_Free : Storage_Count;
- X : Acc;
- Y : Derived_Acc;
- begin
- if User_Defined_Pool then
- First_Free := My_Pool.First_Free;
- end if;
- X := new Designated'(Value);
- if User_Defined_Pool and then First_Free >= My_Pool.First_Free then
- Failed (Subtest &
- " - Allocation didn't consume storage in the pool - 1");
- else
- First_Free := My_Pool.First_Free;
- end if;
-
- Y := Derived_Acc (X);
- if User_Defined_Pool and then First_Free /= My_Pool.First_Free then
- Failed (Subtest &
- " - Conversion did consume storage in the pool - 1");
- end if;
- if Y.all /= Value then
- Failed (Subtest &
- " - Incorrect allocation/conversion of access values - 1");
- end if;
-
- Deallocate (Y);
- if User_Defined_Pool and then First_Free <= My_Pool.First_Free then
- Failed (Subtest &
- " - Deallocation didn't release storage from the pool - 1");
- else
- First_Free := My_Pool.First_Free;
- end if;
-
- Y := new Designated'(Value);
- if User_Defined_Pool and then First_Free >= My_Pool.First_Free then
- Failed (Subtest &
- " - Allocation didn't consume storage in the pool - 2");
- else
- First_Free := My_Pool.First_Free;
- end if;
-
- X := Acc (Y);
- if User_Defined_Pool and then First_Free /= My_Pool.First_Free then
- Failed (Subtest &
- " - Conversion did consume storage in the pool - 2");
- end if;
- if X.all /= Value then
- Failed (Subtest &
- " - Incorrect allocation/conversion of access values - 2");
- end if;
-
- Deallocate (X);
- if User_Defined_Pool and then First_Free <= My_Pool.First_Free then
- Failed (Subtest &
- " - Deallocation didn't release storage from the pool - 2");
- end if;
- exception
- when E: others =>
- Failed (Subtest & " - Exception " & Exception_Name (E) &
- " raised - " & Exception_Message (E));
- end Check;
-
-
-begin
- Test ("C3A0015", "Check that a dervied access type has the same " &
- "storage pool as its parent");
-
- Comment ("Access types using the standard storage pool");
-
- Std:
- declare
- procedure Check1 is
- new Check (Designated => Float,
- Value => 3.0,
- Acc => Standard_Pool,
- Derived_Acc => Derived_Standard_Pool);
- procedure Check2 is
- new Check (Designated => Float,
- Value => 4.0,
- Acc => Standard_Pool,
- Derived_Acc => Derived_Derived_Standard_Pool);
- procedure Check3 is
- new Check (Designated => Float,
- Value => 5.0,
- Acc => Derived_Standard_Pool,
- Derived_Acc => Derived_Derived_Standard_Pool);
- begin
- Check1 ("Standard_Pool/Derived_Standard_Pool",
- User_Defined_Pool => False);
- Check2 ("Standard_Pool/Derived_Derived_Standard_Pool",
- User_Defined_Pool => False);
- Check3 ("Derived_Standard_Pool/Derived_Derived_Standard_Pool",
- User_Defined_Pool => False);
- end Std;
-
- Comment ("Access types using a user-defined storage pool");
-
- User:
- declare
- procedure Check1 is
- new Check (Designated => Integer,
- Value => 17,
- Acc => User_Defined_Pool,
- Derived_Acc => Derived_User_Defined_Pool);
- procedure Check2 is
- new Check (Designated => Integer,
- Value => 18,
- Acc => User_Defined_Pool,
- Derived_Acc => Derived_Derived_User_Defined_Pool);
- procedure Check3 is
- new Check (Designated => Integer,
- Value => 19,
- Acc => Derived_User_Defined_Pool,
- Derived_Acc => Derived_Derived_User_Defined_Pool);
- begin
- Check1 ("User_Defined_Pool/Derived_User_Defined_Pool",
- User_Defined_Pool => True);
- Check2 ("User_Defined_Pool/Derived_Derived_User_Defined_Pool",
- User_Defined_Pool => True);
- Check3
- ("Derived_User_Defined_Pool/Derived_Derived_User_Defined_Pool",
- User_Defined_Pool => True);
- end User;
-
- Result;
-end C3A0015;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c3a1001.a b/gcc/testsuite/ada/acats/tests/c3/c3a1001.a
deleted file mode 100644
index 9b05b5da254..00000000000
--- a/gcc/testsuite/ada/acats/tests/c3/c3a1001.a
+++ /dev/null
@@ -1,315 +0,0 @@
--- C3A1001.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that the full type completing a type with no discriminant part
--- or an unknown discriminant part may have explicitly declared or
--- inherited discriminants.
--- Check for cases where the types are records and protected types.
---
--- TEST DESCRIPTION:
--- Declare two groups of incomplete types: one group with no discriminant
--- part and one group with unknown discriminant part. Both groups of
--- incomplete types are completed with both explicit and inherited
--- discriminants. Discriminants for record and protected types are
--- declared with default and non default values.
--- In the main program, verify that objects of both groups of incomplete
--- types can be created by default values or by assignments.
---
---
--- CHANGE HISTORY:
--- 11 Oct 95 SAIC Initial prerelease version.
--- 11 Nov 96 SAIC Revised for version 2.1.
---
---!
-
-package C3A1001_0 is
-
- type Incomplete1 (<>); -- unknown discriminant
-
- type Incomplete2; -- no discriminant
-
- type Incomplete3 (<>); -- unknown discriminant
-
- type Incomplete4; -- no discriminant
-
- type Incomplete5 (<>); -- unknown discriminant
-
- type Incomplete6; -- no discriminant
-
- type Incomplete8; -- no discriminant
-
- subtype Small_Int is Integer range 1 .. 10;
-
- type Enu_Type is (M, F);
-
- type Incomplete1 (Disc : Enu_Type) is -- unknown discriminant/
- record -- explicit discriminant
- case Disc is
- when M => MInteger : Small_Int := 3;
- when F => FInteger : Small_Int := 8;
- end case;
- end record;
-
- type Incomplete2 (Disc : Small_Int := 8) is -- no discriminant/
- record -- explicit discriminant
- ID : String (1 .. Disc) := "Plymouth";
- end record;
-
- type Incomplete3 is new Incomplete2; -- unknown discriminant/
- -- inherited discriminant
-
- type Incomplete4 is new Incomplete2; -- no discriminant/
- -- inherited discriminant
-
- protected type Incomplete5 -- unknown discriminant/
- (Disc : Enu_Type) is -- explicit discriminant
- function Get_Priv_Val return Enu_Type;
- private
- Enu_Obj : Enu_Type := Disc;
- end Incomplete5;
-
- protected type Incomplete6 -- no discriminant/
- (Disc : Small_Int := 1) is -- explicit discriminant
- function Get_Priv_Val return Small_Int; -- with default
- private
- Num : Small_Int := Disc;
- end Incomplete6;
-
- type Incomplete8 (Disc : Small_Int) is -- no discriminant/
- record -- explicit discriminant
- Str : String (1 .. Disc); -- no default
- end record;
-
- type Incomplete9 is new Incomplete8;
-
- function Return_String (S : String) return String;
-
-end C3A1001_0;
-
- --==================================================================--
-
-with Report;
-
-package body C3A1001_0 is
-
- protected body Incomplete5 is
-
- function Get_Priv_Val return Enu_Type is
- begin
- return Enu_Obj;
- end Get_Priv_Val;
-
- end Incomplete5;
-
- ----------------------------------------------------------------------
- protected body Incomplete6 is
-
- function Get_Priv_Val return Small_Int is
- begin
- return Num;
- end Get_Priv_Val;
-
- end Incomplete6;
-
- ----------------------------------------------------------------------
- function Return_String (S : String) return String is
- begin
- if Report.Ident_Bool(True) = True then
- return S;
- end if;
-
- return S;
- end Return_String;
-
-end C3A1001_0;
-
- --==================================================================--
-
-with Report;
-
-with C3A1001_0;
-use C3A1001_0;
-
-procedure C3A1001 is
-
- -- Discriminant value comes from default.
-
- Incomplete2_Obj_1 : Incomplete2;
-
- Incomplete4_Obj_1 : Incomplete4;
-
- Incomplete6_Obj_1 : Incomplete6;
-
- -- Discriminant value comes from explicit constraint.
-
- Incomplete1_Obj_1 : Incomplete1 (F);
-
- Incomplete5_Obj_1 : Incomplete5 (M);
-
- Incomplete6_Obj_2 : Incomplete6 (2);
-
- -- Discriminant value comes from assignment.
-
- Incomplete3_Obj_1 : Incomplete3 := (Disc => 6, ID => "Sentra");
-
- Incomplete1_Obj_2 : Incomplete1 := (Disc => M, MInteger => 9);
-
- Incomplete2_Obj_2 : Incomplete2 := (Disc => 5, ID => "Buick");
-
-begin
-
- Report.Test ("C3A1001", "Check that the full type completing a type " &
- "with no discriminant part or an unknown discriminant " &
- "part may have explicitly declared or inherited " &
- "discriminants. Check for cases where the types are " &
- "records and protected types");
-
- -- Check the initial values.
-
- if (Incomplete2_Obj_1.Disc /= 8) or
- (Incomplete2_Obj_1.ID /= "Plymouth") then
- Report.Failed ("Wrong initial values for Incomplete2_Obj_1");
- end if;
-
- if (Incomplete4_Obj_1.Disc /= 8) or
- (Incomplete4_Obj_1.ID /= "Plymouth") then
- Report.Failed ("Wrong initial values for Incomplete4_Obj_1");
- end if;
-
- if (Incomplete6_Obj_1.Disc /= 1) or
- (Incomplete6_Obj_1.Get_Priv_Val /= 1) then
- Report.Failed ("Wrong initial value for Incomplete6_Obj_1");
- end if;
-
- -- Check the explicit values.
-
- if (Incomplete1_Obj_1.Disc /= F) or
- (Incomplete1_Obj_1.FInteger /= 8) then
- Report.Failed ("Wrong values for Incomplete1_Obj_1");
- end if;
-
- if (Incomplete5_Obj_1.Disc /= M) or
- (Incomplete5_Obj_1.Get_Priv_Val /= M) then
- Report.Failed ("Wrong value for Incomplete5_Obj_1");
- end if;
-
- if (Incomplete6_Obj_2.Disc /= 2) or
- (Incomplete6_Obj_2.Get_Priv_Val /= 2) then
- Report.Failed ("Wrong value for Incomplete6_Obj_2");
- end if;
-
- -- Check the assigned values.
-
- if (Incomplete3_Obj_1.Disc /= 6) or
- (Incomplete3_Obj_1.ID /= "Sentra") then
- Report.Failed ("Wrong values for Incomplete3_Obj_1");
- end if;
-
- if (Incomplete1_Obj_2.Disc /= M) or
- (Incomplete1_Obj_2.MInteger /= 9) then
- Report.Failed ("Wrong values for Incomplete1_Obj_2");
- end if;
-
- if (Incomplete2_Obj_2.Disc /= 5) or
- (Incomplete2_Obj_2.ID /= "Buick") then
- Report.Failed ("Wrong values for Incomplete2_Obj_2");
- end if;
-
- -- Make sure that assignments work without problems.
-
- Incomplete1_Obj_1.FInteger := 1;
-
- -- Avoid optimization (dead variable removal of FInteger):
-
- if Incomplete1_Obj_1.FInteger /= Report.Ident_Int(1)
- then
- Report.Failed ("Wrong value stored in Incomplete1_Obj_1.FInteger");
- end if;
-
- Incomplete2_Obj_1.ID := Return_String ("12345678");
-
- -- Avoid optimization (dead variable removal of ID)
-
- if Incomplete2_Obj_1.ID /= Return_String ("12345678")
- then
- Report.Failed ("Wrong values for Incomplete8_Obj_1.ID");
- end if;
-
- Incomplete4_Obj_1.ID := Return_String ("87654321");
-
- -- Avoid optimization (dead variable removal of ID)
-
- if Incomplete4_Obj_1.ID /= Return_String ("87654321")
- then
- Report.Failed ("Wrong values for Incomplete4_Obj_1.ID");
- end if;
-
-
- Test1:
- declare
-
- Incomplete8_Obj_1 : Incomplete8 (10);
-
- begin
- Incomplete8_Obj_1.Str := "Merry Xmas";
-
- -- Avoid optimization (dead variable removal of Str):
-
- if Return_String (Incomplete8_Obj_1.Str) /= "Merry Xmas"
- then
- Report.Failed ("Wrong values for Incomplete8_Obj_1.Str");
- end if;
-
- exception
- when Constraint_Error =>
- Report.Failed ("Constraint_Error raised in Incomplete8_Obj_1");
-
- end Test1;
-
- Test2:
- declare
-
- Incomplete8_Obj_2 : Incomplete8 (5);
-
- begin
- Incomplete8_Obj_2.Str := "Happy";
-
- -- Avoid optimization (dead variable removal of Str):
-
- if Return_String (Incomplete8_Obj_2.Str) /= "Happy"
- then
- Report.Failed ("Wrong values for Incomplete8_Obj_1.Str");
- end if;
-
- exception
- when Constraint_Error =>
- Report.Failed ("Constraint_Error raised in Incomplete8_Obj_2");
-
- end Test2;
-
- Report.Result;
-
-end C3A1001;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c3a1002.a b/gcc/testsuite/ada/acats/tests/c3/c3a1002.a
deleted file mode 100644
index 27d1f843c30..00000000000
--- a/gcc/testsuite/ada/acats/tests/c3/c3a1002.a
+++ /dev/null
@@ -1,251 +0,0 @@
--- C3A1002.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that the full type completing a type with no discriminant part
--- or an unknown discriminant part may have explicitly declared or
--- inherited discriminants.
--- Check for cases where the types are tagged records and task types.
---
--- TEST DESCRIPTION:
--- Declare two groups of incomplete types: one group with no discriminant
--- part and one group with unknown discriminant part. Both groups of
--- incomplete types are completed with both explicit and inherited
--- discriminants. Discriminants for task types are declared with both
--- default and non default values. Discriminants for tagged types are
--- only declared without default values.
--- In the main program, verify that objects of both groups of incomplete
--- types can be created by default values or by assignments.
---
---
--- CHANGE HISTORY:
--- 23 Oct 95 SAIC Initial prerelease version.
--- 19 Oct 96 SAIC ACVC 2.1: modified test description. Initialized
--- Int_Val.
---
---!
-
-package C3A1002_0 is
-
- subtype Small_Int is Integer range 1 .. 15;
-
- type Enu_Type is (M, F);
-
- type Tag_Type is tagged
- record
- I : Small_Int := 1;
- end record;
-
- type NTag_Type (D : Small_Int) is new Tag_Type with
- record
- S : String (1 .. D) := "Aloha";
- end record;
-
- type Incomplete1; -- no discriminant
-
- type Incomplete2 (<>); -- unknown discriminant
-
- type Incomplete3; -- no discriminant
-
- type Incomplete4 (<>); -- unknown discriminant
-
- type Incomplete5; -- no discriminant
-
- type Incomplete6 (<>); -- unknown discriminant
-
- type Incomplete1 (D1 : Enu_Type) is tagged -- no discriminant/
- record -- explicit discriminant
- case D1 is
- when M => MInteger : Small_Int := 9;
- when F => FInteger : Small_Int := 8;
- end case;
- end record;
-
- type Incomplete2 (D2 : Small_Int) is new -- unknown discriminant/
- Incomplete1 (D1 => F) with record -- explicit discriminant
- ID : String (1 .. D2) := "ACVC95";
- end record;
-
- type Incomplete3 is new -- no discriminant/
- NTag_Type with record -- inherited discriminant
- E : Enu_Type := M;
- end record;
-
- type Incomplete4 is new -- unknown discriminant/
- NTag_Type (D => 3) with record -- inherited discriminant
- E : Enu_Type := F;
- end record;
-
- task type Incomplete5 (D5 : Enu_Type) is -- no discriminant/
- entry Read_Disc (P : out Enu_Type); -- explicit discriminant
- end Incomplete5;
-
- task type Incomplete6
- (D6 : Small_Int := 4) is -- unknown discriminant/
- entry Read_Int (P : out Small_Int); -- explicit discriminant
- end Incomplete6;
-
-end C3A1002_0;
-
- --==================================================================--
-
-package body C3A1002_0 is
-
- task body Incomplete5 is
- begin
- select
- accept Read_Disc (P : out Enu_Type) do
- P := D5;
- end Read_Disc;
- or
- terminate;
- end select;
-
- end Incomplete5;
-
- ----------------------------------------------------------------------
- task body Incomplete6 is
- begin
- select
- accept Read_Int (P : out Small_Int) do
- P := D6;
- end Read_Int;
- or
- terminate;
- end select;
-
- end Incomplete6;
-
-end C3A1002_0;
-
- --==================================================================--
-
-with Report;
-
-with C3A1002_0;
-use C3A1002_0;
-
-procedure C3A1002 is
-
- Enum_Val : Enu_Type := M;
-
- Int_Val : Small_Int := 15;
-
- -- Discriminant value comes from default.
-
- Incomplete6_Obj_1 : Incomplete6;
-
- -- Discriminant value comes from explicit constraint.
-
- Incomplete1_Obj_1 : Incomplete1 (M);
-
- Incomplete2_Obj_1 : Incomplete2 (6);
-
- Incomplete5_Obj_1 : Incomplete5 (F);
-
- Incomplete6_Obj_2 : Incomplete6 (7);
-
- -- Discriminant value comes from assignment.
-
- Incomplete1_Obj_2 : Incomplete1
- := (F, 12);
-
- Incomplete3_Obj_1 : Incomplete3
- := (D => 2, S => "Hi", I => 10, E => F);
-
- Incomplete4_Obj_1 : Incomplete4
- := (E => M, D => 3, S => "Bye", I => 14);
-
-begin
-
- Report.Test ("C3A1002", "Check that the full type completing a type " &
- "with no discriminant part or an unknown discriminant " &
- "part may have explicitly declared or inherited " &
- "discriminants. Check for cases where the types are " &
- "tagged records and task types");
-
- -- Check the initial values.
-
- if (Incomplete6_Obj_1.D6 /= 4) then
- Report.Failed ("Wrong initial value for Incomplete6_Obj_1");
- end if;
-
- -- Check the explicit values.
-
- if (Incomplete1_Obj_1.D1 /= M) or
- (Incomplete1_Obj_1.MInteger /= 9) then
- Report.Failed ("Wrong values for Incomplete1_Obj_1");
- end if;
-
- if (Incomplete2_Obj_1.D2 /= 6) or
- (Incomplete2_Obj_1.FInteger /= 8) or
- (Incomplete2_Obj_1.ID /= "ACVC95") then
- Report.Failed ("Wrong values for Incomplete2_Obj_1");
- end if;
-
- if (Incomplete5_Obj_1.D5 /= F) then
- Report.Failed ("Wrong value for Incomplete5_Obj_1");
- end if;
-
- Incomplete5_Obj_1.Read_Disc (Enum_Val);
-
- if (Enum_Val /= F) then
- Report.Failed ("Wrong value for Enum_Val");
- end if;
-
- if (Incomplete6_Obj_2.D6 /= 7) then
- Report.Failed ("Wrong value for Incomplete6_Obj_2");
- end if;
-
- Incomplete6_Obj_1.Read_Int (Int_Val);
-
- if (Int_Val /= 4) then
- Report.Failed ("Wrong value for Int_Val");
- end if;
-
- -- Check the assigned values.
-
- if (Incomplete1_Obj_2.D1 /= F) or
- (Incomplete1_Obj_2.FInteger /= 12) then
- Report.Failed ("Wrong values for Incomplete1_Obj_2");
- end if;
-
- if (Incomplete3_Obj_1.D /= 2 ) or
- (Incomplete3_Obj_1.I /= 10) or
- (Incomplete3_Obj_1.E /= F ) or
- (Incomplete3_Obj_1.S /= "Hi") then
- Report.Failed ("Wrong values for Incomplete3_Obj_1");
- end if;
-
- if (Incomplete4_Obj_1.E /= M ) or
- (Incomplete4_Obj_1.D /= 3) or
- (Incomplete4_Obj_1.S /= "Bye") or
- (Incomplete4_Obj_1.I /= 14) then
- Report.Failed ("Wrong values for Incomplete4_Obj_1");
- end if;
-
- Report.Result;
-
-end C3A1002;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c3a2001.a b/gcc/testsuite/ada/acats/tests/c3/c3a2001.a
deleted file mode 100644
index c3c7f441062..00000000000
--- a/gcc/testsuite/ada/acats/tests/c3/c3a2001.a
+++ /dev/null
@@ -1,460 +0,0 @@
--- C3A2001.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that an access type may be defined to designate the
--- class-wide type of an abstract type. Check that the access type
--- may then be used subsequently with types derived from the abstract
--- type. Check that dispatching operations dispatch correctly, when
--- called using values designated by objects of the access type.
---
--- TEST DESCRIPTION:
--- This test declares an abstract type Breaker in a package, and
--- then derives from it. The type Basic_Breaker defines the least
--- possible in order to not be abstract. The type Ground_Fault is
--- defined to inherit as much as possible, whereas type Special_Breaker
--- overrides everything it can. The type Special_Breaker also includes
--- an embedded Basic_Breaker object. The main program then utilizes
--- each of the three types of breaker, and to ascertain that the
--- overloading and tagging resolution are correct, each "Create"
--- procedure is called with a unique value. The diagram below
--- illustrates the relationships.
---
--- Abstract type: Breaker(1)
--- |
--- Basic_Breaker(2)
--- / \
--- Ground_Fault(3) Special_Breaker(4)
---
--- Test structure is a polymorphic linked list, modeling a circuit
--- as a list of components. The type component is the access type
--- defined to designate Breaker'Class values. The test then creates
--- some values, and traverses the list to determine correct operation.
--- This test is instrumented with a the trace facility found in
--- foundation F392C00 to simplify the verification process.
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 10 Nov 95 SAIC Checked compilation for ACVC 2.0.1
--- 23 APR 96 SAIC Added pragma Elaborate_All
--- 26 NOV 96 SAIC Elaborate_Body changed to Elaborate_All
---
---!
-
-with Report;
-with TCTouch;
-package C3A2001_1 is
-
- type Breaker is abstract tagged private;
- type Status is ( Power_Off, Power_On, Tripped, Failed );
-
- procedure Flip ( The_Breaker : in out Breaker ) is abstract;
- procedure Trip ( The_Breaker : in out Breaker ) is abstract;
- procedure Reset( The_Breaker : in out Breaker ) is abstract;
- procedure Fail ( The_Breaker : in out Breaker );
-
- procedure Set ( The_Breaker : in out Breaker'Class; To_State : Status );
-
- function Status_Of( The_Breaker : Breaker ) return Status;
-
-private
- type Breaker is abstract tagged record
- State : Status := Power_Off;
- end record;
-end C3A2001_1;
-
-----------------------------------------------------------------------------
-
-with TCTouch;
-package body C3A2001_1 is
- procedure Fail( The_Breaker : in out Breaker ) is
- begin
- TCTouch.Touch( 'a' ); --------------------------------------------- a
- The_Breaker.State := Failed;
- end Fail;
-
- procedure Set( The_Breaker : in out Breaker'Class; To_State : Status ) is
- begin
- The_Breaker.State := To_State;
- end Set;
-
- function Status_Of( The_Breaker : Breaker ) return Status is
- begin
- TCTouch.Touch( 'b' ); --------------------------------------------- b
- return The_Breaker.State;
- end Status_Of;
-end C3A2001_1;
-
-----------------------------------------------------------------------------
-
-with C3A2001_1;
-package C3A2001_2 is
-
- type Basic_Breaker is new C3A2001_1.Breaker with private;
-
- type Voltages is ( V12, V110, V220, V440 );
- type Amps is ( A1, A5, A10, A25, A100 );
-
- function Construct( Voltage : Voltages; Amperage : Amps )
- return Basic_Breaker;
-
- procedure Flip ( The_Breaker : in out Basic_Breaker );
- procedure Trip ( The_Breaker : in out Basic_Breaker );
- procedure Reset( The_Breaker : in out Basic_Breaker );
-private
- type Basic_Breaker is new C3A2001_1.Breaker with record
- Voltage_Level : Voltages := V110;
- Amperage : Amps;
- end record;
-end C3A2001_2;
-
-----------------------------------------------------------------------------
-
-with TCTouch;
-package body C3A2001_2 is
- function Construct( Voltage : Voltages; Amperage : Amps )
- return Basic_Breaker is
- It : Basic_Breaker;
- begin
- TCTouch.Touch( 'c' ); --------------------------------------------- c
- It.Amperage := Amperage;
- It.Voltage_Level := Voltage;
- C3A2001_1.Set( It, C3A2001_1.Power_Off );
- return It;
- end Construct;
-
- procedure Flip ( The_Breaker : in out Basic_Breaker ) is
- begin
- TCTouch.Touch( 'd' ); --------------------------------------------- d
- case Status_Of( The_Breaker ) is
- when C3A2001_1.Power_Off =>
- C3A2001_1.Set( The_Breaker, C3A2001_1.Power_On );
- when C3A2001_1.Power_On =>
- C3A2001_1.Set( The_Breaker, C3A2001_1.Power_Off );
- when C3A2001_1.Tripped | C3A2001_1.Failed => null;
- end case;
- end Flip;
-
- procedure Trip ( The_Breaker : in out Basic_Breaker ) is
- begin
- TCTouch.Touch( 'e' ); --------------------------------------------- e
- C3A2001_1.Set( The_Breaker, C3A2001_1.Tripped );
- end Trip;
-
- procedure Reset( The_Breaker : in out Basic_Breaker ) is
- begin
- TCTouch.Touch( 'f' ); --------------------------------------------- f
- case Status_Of( The_Breaker ) is
- when C3A2001_1.Power_Off | C3A2001_1.Tripped =>
- C3A2001_1.Set( The_Breaker, C3A2001_1.Power_On );
- when C3A2001_1.Power_On | C3A2001_1.Failed => null;
- end case;
- end Reset;
-
-end C3A2001_2;
-
-----------------------------------------------------------------------------
-
-with C3A2001_1,C3A2001_2;
-package C3A2001_3 is
- use type C3A2001_1.Status;
-
- type Ground_Fault is new C3A2001_2.Basic_Breaker with private;
-
- function Construct( Voltage : C3A2001_2.Voltages;
- Amperage : C3A2001_2.Amps )
- return Ground_Fault;
-
- procedure Set_Trip( The_Breaker : in out Ground_Fault;
- Capacitance : in Integer );
-
-private
- type Ground_Fault is new C3A2001_2.Basic_Breaker with record
- Capacitance : Integer;
- end record;
-end C3A2001_3;
-
-----------------------------------------------------------------------------
-
-with TCTouch;
-package body C3A2001_3 is
-
- function Construct( Voltage : C3A2001_2.Voltages;
- Amperage : C3A2001_2.Amps )
- return Ground_Fault is
- begin
- TCTouch.Touch( 'g' ); --------------------------------------------- g
- return ( C3A2001_2.Construct( Voltage, Amperage )
- with Capacitance => 0 );
- end Construct;
-
-
- procedure Set_Trip( The_Breaker : in out Ground_Fault;
- Capacitance : in Integer ) is
- begin
- TCTouch.Touch( 'h' ); --------------------------------------------- h
- The_Breaker.Capacitance := Capacitance;
- end Set_Trip;
-
-end C3A2001_3;
-
-----------------------------------------------------------------------------
-
-with C3A2001_1, C3A2001_2;
-package C3A2001_4 is
-
- type Special_Breaker is new C3A2001_2.Basic_Breaker with private;
-
- function Construct( Voltage : C3A2001_2.Voltages;
- Amperage : C3A2001_2.Amps )
- return Special_Breaker;
-
- procedure Flip ( The_Breaker : in out Special_Breaker );
- procedure Trip ( The_Breaker : in out Special_Breaker );
- procedure Reset( The_Breaker : in out Special_Breaker );
- procedure Fail ( The_Breaker : in out Special_Breaker );
-
- function Status_Of( The_Breaker : Special_Breaker ) return C3A2001_1.Status;
- function On_Backup( The_Breaker : Special_Breaker ) return Boolean;
-
-private
- type Special_Breaker is new C3A2001_2.Basic_Breaker with record
- Backup : C3A2001_2.Basic_Breaker;
- end record;
-end C3A2001_4;
-
-----------------------------------------------------------------------------
-
-with TCTouch;
-package body C3A2001_4 is
-
- function Construct( Voltage : C3A2001_2.Voltages;
- Amperage : C3A2001_2.Amps )
- return Special_Breaker is
- It: Special_Breaker;
- procedure Set_Root( It: in out C3A2001_2.Basic_Breaker ) is
- begin
- It := C3A2001_2.Construct( Voltage, Amperage );
- end Set_Root;
- begin
- TCTouch.Touch( 'i' ); --------------------------------------------- i
- Set_Root( C3A2001_2.Basic_Breaker( It ) );
- Set_Root( It.Backup );
- return It;
- end Construct;
-
- function Status_Of( It: C3A2001_1.Breaker ) return C3A2001_1.Status
- renames C3A2001_1.Status_Of;
-
- procedure Flip ( The_Breaker : in out Special_Breaker ) is
- begin
- TCTouch.Touch( 'j' ); --------------------------------------------- j
- case Status_Of( C3A2001_1.Breaker( The_Breaker )) is
- when C3A2001_1.Power_Off | C3A2001_1.Power_On =>
- C3A2001_2.Flip( C3A2001_2.Basic_Breaker( The_Breaker ) );
- when others =>
- C3A2001_2.Flip( The_Breaker.Backup );
- end case;
- end Flip;
-
- procedure Trip ( The_Breaker : in out Special_Breaker ) is
- begin
- TCTouch.Touch( 'k' ); --------------------------------------------- k
- case Status_Of( C3A2001_1.Breaker( The_Breaker )) is
- when C3A2001_1.Power_Off => null;
- when C3A2001_1.Power_On =>
- C3A2001_2.Reset( The_Breaker.Backup );
- C3A2001_2.Trip( C3A2001_2.Basic_Breaker( The_Breaker ) );
- when others =>
- C3A2001_2.Trip( The_Breaker.Backup );
- end case;
- end Trip;
-
- procedure Reset( The_Breaker : in out Special_Breaker ) is
- begin
- TCTouch.Touch( 'l' ); --------------------------------------------- l
- case Status_Of( C3A2001_1.Breaker( The_Breaker )) is
- when C3A2001_1.Tripped =>
- C3A2001_2.Reset( C3A2001_2.Basic_Breaker( The_Breaker ));
- when C3A2001_1.Failed =>
- C3A2001_2.Reset( The_Breaker.Backup );
- when C3A2001_1.Power_On | C3A2001_1.Power_Off =>
- null;
- end case;
- end Reset;
-
- procedure Fail ( The_Breaker : in out Special_Breaker ) is
- begin
- TCTouch.Touch( 'm' ); --------------------------------------------- m
- case Status_Of( C3A2001_1.Breaker( The_Breaker )) is
- when C3A2001_1.Failed =>
- C3A2001_2.Fail( The_Breaker.Backup );
- when others =>
- C3A2001_2.Fail( C3A2001_2.Basic_Breaker( The_Breaker ));
- C3A2001_2.Reset( The_Breaker.Backup );
- end case;
- end Fail;
-
- function Status_Of( The_Breaker : Special_Breaker )
- return C3A2001_1.Status is
- begin
- TCTouch.Touch( 'n' ); --------------------------------------------- n
- case Status_Of( C3A2001_1.Breaker( The_Breaker )) is
- when C3A2001_1.Power_On => return C3A2001_1.Power_On;
- when C3A2001_1.Power_Off => return C3A2001_1.Power_Off;
- when others =>
- return C3A2001_2.Status_Of( The_Breaker.Backup );
- end case;
- end Status_Of;
-
- function On_Backup( The_Breaker : Special_Breaker ) return Boolean is
- use C3A2001_2;
- use type C3A2001_1.Status;
- begin
- return Status_Of(Basic_Breaker(The_Breaker)) = C3A2001_1.Tripped
- or Status_Of(Basic_Breaker(The_Breaker)) = C3A2001_1.Failed;
- end On_Backup;
-
-end C3A2001_4;
-
-----------------------------------------------------------------------------
-
-with C3A2001_1;
-package C3A2001_5 is
-
- type Component is access C3A2001_1.Breaker'Class;
-
- type Circuit;
- type Connection is access Circuit;
-
- type Circuit is record
- The_Gadget : Component;
- Next : Connection;
- end record;
-
- procedure Flipper( The_Circuit : Connection );
- procedure Tripper( The_Circuit : Connection );
- procedure Restore( The_Circuit : Connection );
- procedure Failure( The_Circuit : Connection );
-
- Short : Connection := null;
-
-end C3A2001_5;
-
-----------------------------------------------------------------------------
-with Report;
-with TCTouch;
-with C3A2001_1, C3A2001_2, C3A2001_3, C3A2001_4;
-
-pragma Elaborate_All( Report, TCTouch,
- C3A2001_1, C3A2001_2, C3A2001_3, C3A2001_4 );
-
-package body C3A2001_5 is
-
- function Neww( Breaker: in C3A2001_1.Breaker'Class )
- return Component is
- begin
- return new C3A2001_1.Breaker'Class'( Breaker );
- end Neww;
-
- procedure Add( Gadget : in Component;
- To_Circuit : in out Connection) is
- begin
- To_Circuit := new Circuit'(Gadget,To_Circuit);
- end Add;
-
- procedure Flipper( The_Circuit : Connection ) is
- Probe : Connection := The_Circuit;
- begin
- while Probe /= null loop
- C3A2001_1.Flip( Probe.The_Gadget.all );
- Probe := Probe.Next;
- end loop;
- end Flipper;
-
- procedure Tripper( The_Circuit : Connection ) is
- Probe : Connection := The_Circuit;
- begin
- while Probe /= null loop
- C3A2001_1.Trip( Probe.The_Gadget.all );
- Probe := Probe.Next;
- end loop;
- end Tripper;
-
- procedure Restore( The_Circuit : Connection ) is
- Probe : Connection := The_Circuit;
- begin
- while Probe /= null loop
- C3A2001_1.Reset( Probe.The_Gadget.all );
- Probe := Probe.Next;
- end loop;
- end Restore;
-
- procedure Failure( The_Circuit : Connection ) is
- Probe : Connection := The_Circuit;
- begin
- while Probe /= null loop
- C3A2001_1.Fail( Probe.The_Gadget.all );
- Probe := Probe.Next;
- end loop;
- end Failure;
-
-begin
- Add( Neww( C3A2001_2.Construct( C3A2001_2.V440, C3A2001_2.A5 )), Short );
- Add( Neww( C3A2001_3.Construct( C3A2001_2.V110, C3A2001_2.A1 )), Short );
- Add( Neww( C3A2001_4.Construct( C3A2001_2.V12, C3A2001_2.A100 )), Short );
-end C3A2001_5;
-
-----------------------------------------------------------------------------
-
-with Report;
-with TCTouch;
-with C3A2001_5;
-procedure C3A2001 is
-
-begin -- Main test procedure.
-
- Report.Test ("C3A2001", "Check that an abstract type can be declared " &
- "and used. Check actual subprograms dispatch correctly" );
-
- -- This Validate call must be _after_ the call to Report.Test
- TCTouch.Validate( "cgcicc", "Adding" );
-
- C3A2001_5.Flipper( C3A2001_5.Short );
- TCTouch.Validate( "jbdbdbdb", "Flipping" );
-
- C3A2001_5.Tripper( C3A2001_5.Short );
- TCTouch.Validate( "kbfbeee", "Tripping" );
-
- C3A2001_5.Restore( C3A2001_5.Short );
- TCTouch.Validate( "lbfbfbfb", "Restoring" );
-
- C3A2001_5.Failure( C3A2001_5.Short );
- TCTouch.Validate( "mbafbaa", "Circuits Failing" );
-
- Report.Result;
-
-end C3A2001;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c3a2002.a b/gcc/testsuite/ada/acats/tests/c3/c3a2002.a
deleted file mode 100644
index 63ea7008b66..00000000000
--- a/gcc/testsuite/ada/acats/tests/c3/c3a2002.a
+++ /dev/null
@@ -1,295 +0,0 @@
--- C3A2002.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that, for X'Access of a general access type A, Program_Error is
--- raised if the accessibility level of X is deeper than that of A.
--- Check for the case where X denotes a view that is a dereference of an
--- access parameter, or a rename thereof.
---
--- Check for cases where the actual corresponding to X is:
--- (a) An allocator.
--- (b) An expression of a named access type.
--- (c) Obj'Access.
---
--- TEST DESCRIPTION:
--- In order to satisfy accessibility requirements, the designated
--- object X must be at the same or a less deep nesting level than the
--- general access type A -- X must "live" as long as A. Nesting
--- levels are the run-time nestings of masters: block statements;
--- subprogram, task, and entry bodies; and accept statements. Packages
--- are invisible to accessibility rules.
---
--- This test declares subprograms with access parameters, within which
--- 'Access is attempted on a dereference of the access parameter, and
--- assigned to an access object whose type A is declared at some nesting
--- level. The test verifies that Program_Error is raised if the actual
--- corresponding to the access parameter is:
---
--- (1) an allocator, and the accessibility level of the execution
--- of the called subprogram is deeper than that of the access
--- type A.
---
--- (2) an expression of a named access type, and the accessibility
--- level of the named access type is deeper than that of the
--- access type A.
---
--- (3) a reference to the Access attribute (e.g., X'Access), and
--- the accessibility level of X is deeper than that of the
--- access type A.
---
--- Note that the static nesting level of the actual corresponding to the
--- access parameter can be deeper than that of the type A -- it is
--- the run-time nesting that matters for accessibility rules. Consider
--- the case where the access type A is declared within the called
--- subprogram. The accessibility check will never fail, even if the
--- actual happens to have a deeper static nesting level:
---
--- procedure P (X: access T) is
--- type A is access all T; -- Static level = 2, e.g.
--- Acc : A := X.all'Access; -- Check should never fail.
--- begin null; end;
--- . . .
--- declare
--- Actual : aliased T; -- Static level = 3, e.g.
--- begin
--- P (Actual'Access);
--- end;
---
--- For the execution of P, the accessibility level of type A will
--- always be deeper than that of Actual, so there is no danger of a
--- dangling reference arising from the assignment to Acc. Thus,
--- X.all'Access is safe, even though the static nesting level of
--- Actual is deeper than that of A.
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
---
---!
-
-package C3A2002_0 is
-
- type Desig is array (1 .. 10) of Integer;
-
- X0 : aliased Desig; -- Level = 0.
-
- type Acc_L0 is access all Desig; -- Level = 0.
- A0 : Acc_L0;
-
- type Result_Kind is (OK, P_E, O_E);
-
- procedure A_Is_Level_0 (X: access Desig; R : out Result_Kind);
- procedure Never_Fails (X: access Desig; R : out Result_Kind);
-
-end C3A2002_0;
-
-
- --==================================================================--
-
-package body C3A2002_0 is
-
- procedure A_Is_Level_0 (X : access Desig;
- R : out Result_Kind) is
- begin
- -- The accessibility level of the type of A0 is 0.
- A0 := X.all'Access;
- R := OK;
- exception
- when Program_Error =>
- R := P_E;
- when others =>
- R := O_E;
- end A_Is_Level_0;
-
- -----------------------------------------------
- procedure Never_Fails (X: access Desig;
- R : out Result_Kind) is
- type Acc_Local is access all Desig;
- AL : Acc_Local;
- begin
- -- X.all'Access below will always be safe, since the accessibility
- -- level (although not necessarily the static nesting depth) of the
- -- type of AL will always be deeper than or the same as that of the
- -- actual corresponding to Y.
- AL := X.all'Access;
- R := OK;
- exception
- when Program_Error =>
- R := P_E;
- when others =>
- R := O_E;
- end Never_Fails;
-
-end C3A2002_0;
-
-
- --==================================================================--
-
-
-with C3A2002_0;
-with Report;
-
-procedure C3A2002 is
-
- X1 : aliased C3A2002_0.Desig; -- Level = 1.
-
- type Acc_L1 is access all C3A2002_0.Desig; -- Level = 1.
- A1 : Acc_L1;
-
- Expr_L0 : C3A2002_0.Acc_L0 := C3A2002_0.X0'Access;
- Expr_L1 : Acc_L1 := X1'Access;
-
- Res : C3A2002_0.Result_Kind;
-
- use type C3A2002_0.Result_Kind;
-
- -----------------------------------------------
- procedure A_Is_Level_1 (X : access C3A2002_0.Desig;
- R : out C3A2002_0.Result_Kind) is
- -- Dereference of an access_to_object value is aliased.
- Ren : C3A2002_0.Desig renames X.all; -- Renaming of a dereference
- begin -- of an access parameter.
- -- The accessibility level of the type of A1 is 1.
- A1 := Ren'Access;
- R := C3A2002_0.OK;
- exception
- when Program_Error =>
- R := C3A2002_0.P_E;
- when others =>
- R := C3A2002_0.O_E;
- end A_Is_Level_1;
-
- -----------------------------------------------
- procedure Display_Results (Result : in C3A2002_0.Result_Kind;
- Expected: in C3A2002_0.Result_Kind;
- Message : in String) is
- begin
- if Result /= Expected then
- case Result is
- when C3A2002_0.OK => Report.Failed ("No exception raised: " &
- Message);
- when C3A2002_0.P_E => Report.Failed ("Program_Error raised: " &
- Message);
- when C3A2002_0.O_E => Report.Failed ("Unexpected exception " &
- "raised: " & Message);
- end case;
- end if;
- end Display_Results;
-
-begin -- C3A2002
-
- Report.Test ("C3A2002", "Check that, for X'Access of general access " &
- "type A, Program_Error is raised if the accessibility " &
- "level of X is deeper than that of A: X is an access " &
- "parameter; corresponding actual is an allocator, " &
- "expression of a named access type, Obj'Access, or a " &
- "rename thereof");
-
-
- -- Actual is X'Access:
-
- C3A2002_0.Never_Fails (C3A2002_0.X0'Access, Res);
- Display_Results (Res, C3A2002_0.OK, "X0'Access, local access type");
-
- C3A2002_0.A_Is_Level_0 (C3A2002_0.X0'Access, Res);
- Display_Results (Res, C3A2002_0.OK, "X0'Access, level 0 access type");
-
- C3A2002_0.A_Is_Level_0 (X1'Access, Res);
- Display_Results (Res, C3A2002_0.P_E, "X1'Access, level 0 access type");
-
- A_Is_Level_1 (X1'Access, Res);
- Display_Results (Res, C3A2002_0.OK, "X1'Access, level 1 access type");
-
-
- -- Actual is expression of a named access type:
-
- C3A2002_0.Never_Fails (Expr_L1, Res);
- Display_Results (Res, C3A2002_0.OK, "Expr_L1, local access type");
-
- C3A2002_0.A_Is_Level_0 (Expr_L1, Res);
- Display_Results (Res, C3A2002_0.P_E, "Expr_L1, level 0 access type");
-
- A_Is_Level_1 (Expr_L0, Res);
- Display_Results (Res, C3A2002_0.OK, "Expr_L0, level 1 access type");
-
- A_Is_Level_1 (Expr_L1, Res);
- Display_Results (Res, C3A2002_0.OK, "Expr_L1, level 1 access type");
-
- -- Actual is allocator (level of execution = 2):
-
- C3A2002_0.Never_Fails (new C3A2002_0.Desig, Res);
- Display_Results (Res, C3A2002_0.OK, "Allocator level 2, " &
- "local access type");
-
- -- Since actual is an allocator, its accessibility level is that of
- -- the execution of the called subprogram, i.e., level 2.
-
- C3A2002_0.A_Is_Level_0 (new C3A2002_0.Desig, Res);
- Display_Results (Res, C3A2002_0.P_E, "Allocator level 2, " &
- "level 0 access type");
-
- A_Is_Level_1 (new C3A2002_0.Desig, Res);
- Display_Results (Res, C3A2002_0.P_E, "Allocator level 2, " &
- "level 1 access type");
-
-
- Block_L2:
- declare
- X2 : aliased C3A2002_0.Desig; -- Level = 2.
- type Acc_L2 is access all C3A2002_0.Desig; -- Level = 2.
- Expr_L2 : Acc_L2 := X1'Access;
- begin
-
- -- Actual is X'Access:
-
- C3A2002_0.Never_Fails (X2'Access, Res);
- Display_Results (Res, C3A2002_0.OK, "X2'Access, local access type");
-
- C3A2002_0.A_Is_Level_0 (X2'Access, Res);
- Display_Results (Res, C3A2002_0.P_E, "X2'Access, level 0 access type");
-
-
- -- Actual is expression of a named access type:
-
- A_Is_Level_1 (Expr_L2, Res);
- Display_Results (Res, C3A2002_0.P_E, "Expr_L2, level 1 access type");
-
-
- -- Actual is allocator (level of execution = 3):
-
- C3A2002_0.Never_Fails (new C3A2002_0.Desig, Res);
- Display_Results (Res, C3A2002_0.OK, "Allocator level 3, " &
- "local access type");
-
- A_Is_Level_1 (new C3A2002_0.Desig, Res);
- Display_Results (Res, C3A2002_0.P_E, "Allocator level 3, " &
- "level 1 access type");
-
- end Block_L2;
-
- Report.Result;
-
-end C3A2002;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c3a2003.a b/gcc/testsuite/ada/acats/tests/c3/c3a2003.a
deleted file mode 100644
index deb92f1a8c5..00000000000
--- a/gcc/testsuite/ada/acats/tests/c3/c3a2003.a
+++ /dev/null
@@ -1,329 +0,0 @@
--- C3A2003.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that, for X'Access of a general access type A, Program_Error is
--- raised if the accessibility level of X is deeper than that of A.
--- Check for the case where X denotes a view that is a dereference of an
--- access parameter, or a rename thereof. Check for the case where X is
--- an access parameter and the corresponding actual is another access
--- parameter.
---
--- TEST DESCRIPTION:
--- In order to satisfy accessibility requirements, the designated
--- object X must be at the same or a less deep nesting level than the
--- general access type A -- X must "live" as long as A. Nesting
--- levels are the run-time nestings of masters: block statements;
--- subprogram, task, and entry bodies; and accept statements. Packages
--- are invisible to accessibility rules.
---
--- This test declares subprograms with access parameters, within which
--- 'Access is attempted on a dereference of an access parameter, and
--- assigned to an access object whose type A is declared at some nesting
--- level. The test verifies that Program_Error is raised if the actual
--- corresponding to the access parameter is another access parameter,
--- and the actual corresponding to this second access parameter is:
---
--- (1) an expression of a named access type, and the accessibility
--- level of the named access type is deeper than that of the
--- access type A.
---
--- (2) a reference to the Access attribute (e.g., X'Access), and
--- the accessibility level of X is deeper than that of the
--- access type A.
---
--- Note that the static nesting level of the actual corresponding to the
--- access parameter can be deeper than that of the type A -- it is
--- the run-time nesting that matters for accessibility rules. Consider
--- the case where the access type A is declared within the called
--- subprogram. The accessibility check will never fail, even if the
--- actual happens to have a deeper static nesting level:
---
--- procedure P (X: access T) is
--- type A is access all T; -- Static level = 2, e.g.
--- Acc : A := X.all'Access; -- Check should never fail.
--- begin null; end;
--- . . .
--- procedure Q (Y: access T) is
--- begin
--- P(Y);
--- end;
--- . . .
--- declare
--- Actual : aliased T; -- Static level = 3, e.g.
--- begin
--- Q (Actual'Access);
--- end;
---
--- For the execution of Q (and hence P), the accessibility level of
--- type A will always be deeper than that of Actual, so there is no
--- danger of a dangling reference arising from the assignment to
--- Acc. Thus, X.all'Access is safe, even though the static nesting
--- level of Actual is deeper than that of A.
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 15 Jul 98 EDS Avoid optimization.
--- 28 Jun 02 RLB Added pragma Elaborate_All (Report);.
---!
-
-with report; use report; pragma Elaborate_All (report);
-package C3A2003_0 is
-
- type Desig is array (1 .. 10) of Integer;
-
- X0 : aliased Desig := (Desig'Range => Ident_Int(3)); -- Level = 0.
-
- type Acc_L0 is access all Desig; -- Level = 0.
- A0 : Acc_L0;
-
- type Result_Kind is (OK, P_E, O_E);
-
- procedure Target_Is_Level_0_Nest (Y: access Desig; S: out Result_Kind);
- procedure Never_Fails_Nest (Y: access Desig; S: out Result_Kind);
- procedure Never_Fails_Same (Y: access Desig; S: out Result_Kind);
-
-end C3A2003_0;
-
-
- --==================================================================--
-
-
-package body C3A2003_0 is
-
- procedure Target_Is_Level_0_Nest (Y: access Desig; S: out Result_Kind) is
-
-
- -- This procedure utilizes 'Access on a dereference of an access
- -- parameter, and assigned to an access object whose type A is
- -- declared at some nesting level. Program_Error is raised if
- -- the accessibility level of the operand type is deeper than that
- -- of the target type.
-
- procedure Nested (X: access Desig; R: out Result_Kind) is
- -- Dereference of an access_to_object value is aliased.
- Ren : Desig renames X.all; -- Renaming of a dereference
- begin -- of an access parameter.
- -- The accessibility level of type A0 is 0.
- A0 := Ren'Access;
- R := OK;
- exception
- when Program_Error =>
- R := P_E;
- when others =>
- R := O_E;
- end Nested;
-
- begin -- Target_Is_Level_0_Nest
- Nested (Y, S);
- end Target_Is_Level_0_Nest;
-
- ------------------------------------------------------------------
-
- procedure Never_Fails_Nest (Y: access Desig; S: out Result_Kind) is
-
- type Acc_Deeper is access all Desig;
- AD : Acc_Deeper;
-
- function Nested (X: access Desig) return Result_Kind is
- begin
- -- X.all'Access below will always be safe, since the accessibility
- -- level (although not necessarily the static nesting depth) of the
- -- type of AD will always be deeper than or the same as that of the
- -- actual corresponding to Y.
- AD := X.all'Access;
- if Ident_Int (AD(4)) /= 3 then --Avoid Optimization of AD
- FAILED ("Initial Values not correct.");
- end if;
- return OK;
- exception
- when Program_Error =>
- return P_E;
- when others =>
- return O_E;
- end Nested;
-
- begin -- Never_Fails_Nest
- S := Nested (Y);
- end Never_Fails_Nest;
-
- ------------------------------------------------------------------
-
- procedure Called_By_Never_Fails_Same
- (X: access Desig; R: out Result_Kind) is
- type Acc_Local is access all Desig;
- AL : Acc_Local;
-
- -- Dereference of an access_to_object value is aliased.
- Ren : Desig renames X.all; -- Renaming of a dereference
- begin -- of an access parameter.
- -- Ren'Access below will always be safe, since the accessibility
- -- level (although not necessarily the static nesting depth) of
- -- type of AL will always be deeper than or the same as that of the
- -- actual corresponding to Y.
- AL := Ren'Access;
- if Ident_Int (AL(4)) /= 3 then --Avoid Optimization of AL
- FAILED ("Initial Values not correct.");
- end if;
- R := OK;
- exception
- when Program_Error =>
- R := P_E;
- when others =>
- R := O_E;
- end Called_By_Never_Fails_Same;
-
- ------------------------------------------------------------------
-
- procedure Never_Fails_Same (Y: access Desig; S: out Result_Kind) is
- begin
- Called_By_Never_Fails_Same (Y, S);
- end Never_Fails_Same;
-
-end C3A2003_0;
-
-
- --==================================================================--
-
-
-with C3A2003_0;
-use C3A2003_0;
-
-with Report; use report;
-
-procedure C3A2003 is
-
- type Acc_L1 is access all Desig; -- Level = 1.
- A1 : Acc_L1;
- X1 : aliased Desig := (Desig'Range => Ident_Int(3));
- Res : Result_Kind;
-
-
- procedure Called_By_Target_L1 (X: access Desig; R: out Result_Kind) is
- begin
- -- The accessibility level of the type of A1 is 1.
- A1 := X.all'Access;
- if IDENT_INT (A1(4)) /= 3 then --Avoid optimization of A1
- FAILED ("Initial values not correct.");
- end if;
- R := OK;
- exception
- when Program_Error =>
- R := P_E;
- when others =>
- R := O_E;
- end Called_By_Target_L1;
-
- ------------------------------------------------------------------
-
- function Target_Is_Level_1_Same (Y: access Desig) return Result_Kind is
- S : Result_Kind;
- begin
- Called_By_Target_L1 (Y, S);
- return S;
- end Target_Is_Level_1_Same;
-
- ------------------------------------------------------------------
-
- procedure Display_Results (Result : in Result_Kind;
- Expected: in Result_Kind;
- Msg : in String) is
- begin
- if Result /= Expected then
- case Result is
- when OK => Report.Failed ("No exception raised: " & Msg);
- when P_E => Report.Failed ("Program_Error raised: " & Msg);
- when O_E => Report.Failed ("Unexpected exception raised: " & Msg);
- end case;
- end if;
- end Display_Results;
-
-begin -- C3A2003
-
- Report.Test ("C3A2003", "Check that, for X'Access of general access " &
- "type A, Program_Error is raised if the accessibility " &
- "level of X is deeper than that of A: X is an access " &
- "parameter; corresponding actual is another access " &
- "parameter");
-
-
- -- Accessibility level of actual is 0 (actual is X'Access):
-
- Never_Fails_Same (X0'Access, Res);
- Display_Results (Res, OK, "Never_Fails_Same, level 0 actual");
-
- Never_Fails_Nest (X0'Access, Res);
- Display_Results (Res, OK, "Target_L1_Nest, level 0 actual");
-
- Target_Is_Level_0_Nest (X0'Access, Res);
- Display_Results (Res, OK, "Target_L0_Nest, level 0 actual");
-
- Res := Target_Is_Level_1_Same (X0'Access);
- Display_Results (Res, OK, "Target_L1_Same, level 0 actual");
-
-
- -- Accessibility level of actual is 1 (actual is X'Access):
-
- Never_Fails_Same (X1'Access, Res);
- Display_Results (Res, OK, "Never_Fails_Same, level 1 actual");
-
- Never_Fails_Nest (X1'Access, Res);
- Display_Results (Res, OK, "Target_L1_Nest, level 1 actual");
-
- Target_Is_Level_0_Nest (X1'Access, Res);
- Display_Results (Res, P_E, "Target_L0_Nest, level 1 actual");
-
- Res := Target_Is_Level_1_Same (X1'Access);
- Display_Results (Res, OK, "Target_L1_Same, level 1 actual");
-
-
- Block_L2:
- declare
- X2 : aliased Desig := (Desig'Range => Ident_Int(3));
- type Acc_L2 is access all Desig; -- Level = 2.
- Expr_L2 : Acc_L2 := X2'Access;
- begin
-
- -- Accessibility level of actual is 2 (actual is expression of named
- -- access type):
-
- Never_Fails_Same (Expr_L2, Res);
- Display_Results (Res, OK, "Never_Fails_Same, level 2 actual");
-
- Never_Fails_Nest (Expr_L2, Res);
- Display_Results (Res, OK, "Target_L1_Nest, level 2 actual");
-
- Target_Is_Level_0_Nest (Expr_L2, Res);
- Display_Results (Res, P_E, "Target_L0_Nest, level 2 actual");
-
- Res := Target_Is_Level_1_Same (Expr_L2);
- Display_Results (Res, P_E, "Target_L1_Same, level 2 actual");
-
- end Block_L2;
-
- Report.Result;
-
-end C3A2003;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c3a2a01.a b/gcc/testsuite/ada/acats/tests/c3/c3a2a01.a
deleted file mode 100644
index 8271d486904..00000000000
--- a/gcc/testsuite/ada/acats/tests/c3/c3a2a01.a
+++ /dev/null
@@ -1,367 +0,0 @@
--- C3A2A01.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that, for X'Access of a general access type A, Program_Error is
--- raised if the accessibility level of X is deeper than that of A.
--- Check for cases where X'Access occurs in an instance body, and A
--- is passed as an actual during instantiation.
---
--- TEST DESCRIPTION:
--- In order to satisfy accessibility requirements, the designated
--- object X must be at the same or a less deep nesting level than the
--- general access type A -- X must "live" as long as A. Nesting
--- levels are the run-time nestings of masters: block statements;
--- subprogram, task, and entry bodies; and accept statements. Packages
--- are invisible to accessibility rules.
---
--- This test declares three generic units, each of which has a formal
--- general access type:
---
--- (1) A generic package, in which X is declared in the specification,
--- and X'Access occurs within the declarative part of the body.
---
--- (2) A generic package, in which X is a formal in out object of a
--- tagged formal derived type, and X'Access occurs in the sequence
--- of statements of a nested subprogram.
---
--- (3) A generic procedure, in which X is a dereference of an access
--- parameter, and X'Access occurs in the sequence of statements.
---
--- The test verifies the following:
---
--- For (1), Program_Error is raised upon instantiation if the generic
--- package is instantiated at a deeper level than that of the general
--- access type passed as an actual. The exception is propagated to the
--- innermost enclosing master.
---
--- For (2), Program_Error is raised when the nested subprogram is
--- called if the object passed as an actual during instantiation of
--- the generic package has an accessibility level deeper than that of
--- the general access type passed as an actual. The exception is
--- handled within the nested subprogram. Also, check that
--- Program_Error is not raised if the level of the actual access type
--- is deeper than that of the actual object.
---
--- For (3), Program_Error is raised when the instance subprogram is
--- called if the object pointed to by the actual corresponding to
--- the access parameter has an accessibility level deeper than that of
--- the general access type passed as an actual during instantiation.
--- The exception is handled within the instance subprogram. Also,
--- check that Program_Error is not raised if the level of the actual
--- access type is deeper than that of the actual corresponding to the
--- access parameter.
---
--- TEST FILES:
--- The following files comprise this test:
---
--- F3A2A00.A
--- -> C3A2A01.A
---
---
--- CHANGE HISTORY:
--- 12 May 95 SAIC Initial prerelease version.
--- 10 Jul 95 SAIC Modified code to avoid dead variable optimization.
---
---!
-
-with F3A2A00;
-generic
- type FD is new F3A2A00.Array_Type;
- type FAF is access all FD;
-package C3A2A01_0 is
- X : aliased FD;
-
- procedure Dummy; -- Needed to allow package body.
-end C3A2A01_0;
-
-
- --==================================================================--
-
-
-with Report;
-package body C3A2A01_0 is
- Ptr : FAF := X'Access;
- Index : Integer := F3A2A00.Array_Type'First;
-
- procedure Dummy is
- begin
- null;
- end Dummy;
-begin
- -- Avoid optimization (dead variable removal of Ptr):
-
- if not Report.Equal (Ptr(Index).C, Ptr(Index).C) then -- Always false.
- Report.Failed ("Unexpected error in C3A2A01_0 instance");
- end if;
-end C3A2A01_0;
-
-
- --==================================================================--
-
-
-with F3A2A00;
-generic
- type FD is new F3A2A00.Tagged_Type with private;
- type FAF is access all FD;
- FObj : in out FD;
-package C3A2A01_1 is
- procedure Handle (R: out F3A2A00.TC_Result_Kind);
-end C3A2A01_1;
-
-
- --==================================================================--
-
-
-with Report;
-package body C3A2A01_1 is
-
- procedure Handle (R: out F3A2A00.TC_Result_Kind) is
- Ptr : FAF;
- begin
- Ptr := FObj'Access;
- R := F3A2A00.OK;
-
- -- Avoid optimization (dead variable removal of Ptr):
-
- if not Report.Equal (Ptr.C, Ptr.C) then -- Always false.
- Report.Failed ("Unexpected error in Handle");
- end if;
- exception
- when Program_Error => R := F3A2A00.P_E;
- when others => R := F3A2A00.O_E;
- end Handle;
-
-end C3A2A01_1;
-
-
- --==================================================================--
-
-
-with F3A2A00;
-generic
- type FD is new F3A2A00.Array_Type;
- type FAF is access all FD;
-procedure C3A2A01_2 (P: access FD; R: out F3A2A00.TC_Result_Kind);
-
-
- --==================================================================--
-
-
-with Report;
-procedure C3A2A01_2 (P: access FD; R: out F3A2A00.TC_Result_Kind) is
- Ptr : FAF;
- Index : Integer := F3A2A00.Array_Type'First;
-begin
- Ptr := P.all'Access;
- R := F3A2A00.OK;
-
- -- Avoid optimization (dead variable removal of Ptr):
-
- if not Report.Equal (Ptr(Index).C, Ptr(Index).C) then -- Always false.
- Report.Failed ("Unexpected error in C3A2A01_2 instance");
- end if;
-exception
- when Program_Error => R := F3A2A00.P_E;
- when others => R := F3A2A00.O_E;
-end C3A2A01_2;
-
-
- --==================================================================--
-
-
-with F3A2A00;
-with C3A2A01_0;
-with C3A2A01_1;
-with C3A2A01_2;
-
-with Report;
-procedure C3A2A01 is
-begin -- C3A2A01. -- [ Level = 1 ]
-
- Report.Test ("C3A2A01", "Run-time accessibility checks: instance " &
- "bodies. Type of X'Access is passed as actual to instance");
-
-
- SUBTEST1:
- declare -- [ Level = 2 ]
- Result : F3A2A00.TC_Result_Kind;
- begin -- SUBTEST1.
-
- declare -- [ Level = 3 ]
- type AccArr_L3 is access all F3A2A00.Array_Type;
- begin
- declare -- [ Level = 4 ]
- -- The accessibility level of Pack.X is that of the instantiation
- -- (4). The accessibility level of the actual access type used to
- -- instantiate Pack is 3. Therefore, the X'Access in Pack
- -- propagates Program_Error when the instance body is elaborated:
-
- package Pack is new C3A2A01_0 (F3A2A00.Array_Type, AccArr_L3);
- begin
- Result := F3A2A00.OK;
- end;
- exception
- when Program_Error => Result := F3A2A00.P_E; -- Expected result.
- when others => Result := F3A2A00.O_E;
- end;
-
- F3A2A00.TC_Display_Results (Result, F3A2A00.P_E, "SUBTEST #1");
-
- end SUBTEST1;
-
-
-
- SUBTEST2:
- declare -- [ Level = 2 ]
- Result : F3A2A00.TC_Result_Kind;
- begin -- SUBTEST2.
-
- declare -- [ Level = 3 ]
- -- The instantiation of C3A2A01_1 should NOT result in any
- -- exceptions.
-
- type AccTag_L3 is access all F3A2A00.Tagged_Type;
-
- package Pack_OK is new C3A2A01_1 (F3A2A00.Tagged_Type,
- AccTag_L3,
- F3A2A00.X_L0);
- begin
- -- The accessibility level of the actual object used to instantiate
- -- Pack_OK is 0. The accessibility level of the actual access type
- -- used to instantiate Pack_OK is 3. Therefore, the FObj'Access in
- -- Pack_OK.Handle does not raise an exception when the subprogram is
- -- called. If an exception is (incorrectly) raised, however, it is
- -- handled within the subprogram:
-
- Pack_OK.Handle (Result);
- end;
-
- F3A2A00.TC_Display_Results (Result, F3A2A00.OK, "SUBTEST #2");
-
- exception
- when Program_Error =>
- Report.Failed ("SUBTEST #2: Program_Error incorrectly raised " &
- "during instantiation of generic");
- when others =>
- Report.Failed ("SUBTEST #2: Unexpected exception raised " &
- "during instantiation of generic");
- end SUBTEST2;
-
-
-
- SUBTEST3:
- declare -- [ Level = 2 ]
- Result : F3A2A00.TC_Result_Kind;
- begin -- SUBTEST3.
-
- declare -- [ Level = 3 ]
- -- The instantiation of C3A2A01_1 should NOT result in any
- -- exceptions.
-
- X_L3: F3A2A00.Tagged_Type;
-
- package Pack_PE is new C3A2A01_1 (F3A2A00.Tagged_Type,
- F3A2A00.AccTag_L0,
- X_L3);
- begin
- -- The accessibility level of the actual object used to instantiate
- -- Pack_PE is 3. The accessibility level of the actual access type
- -- used to instantiate Pack_PE is 0. Therefore, the FObj'Access in
- -- Pack_OK.Handle raises Program_Error when the subprogram is
- -- called. The exception is handled within the subprogram:
-
- Pack_PE.Handle (Result);
- end;
-
- F3A2A00.TC_Display_Results (Result, F3A2A00.P_E, "SUBTEST #3");
-
- exception
- when Program_Error =>
- Report.Failed ("SUBTEST #3: Program_Error incorrectly raised " &
- "during instantiation of generic");
- when others =>
- Report.Failed ("SUBTEST #3: Unexpected exception raised " &
- "during instantiation of generic");
- end SUBTEST3;
-
-
-
- SUBTEST4:
- declare -- [ Level = 2 ]
- Result1 : F3A2A00.TC_Result_Kind;
- Result2 : F3A2A00.TC_Result_Kind;
- begin -- SUBTEST4.
-
- declare -- [ Level = 3 ]
- -- The instantiation of C3A2A01_2 should NOT result in any
- -- exceptions.
-
- X_L3: aliased F3A2A00.Array_Type;
- type AccArr_L3 is access all F3A2A00.Array_Type;
-
- procedure Proc is new C3A2A01_2 (F3A2A00.Array_Type, AccArr_L3);
- begin
- -- The accessibility level of Proc.P.all is that of the corresponding
- -- actual during the call (in this case 3). The accessibility level of
- -- the access type used to instantiate Proc is also 3. Therefore, the
- -- P.all'Access in Proc does not raise an exception when the
- -- subprogram is called. If an exception is (incorrectly) raised,
- -- however, it is handled within the subprogram:
-
- Proc (X_L3'Access, Result1);
-
- F3A2A00.TC_Display_Results (Result1, F3A2A00.OK,
- "SUBTEST #4: same levels");
-
- declare -- [ Level = 4 ]
- X_L4: aliased F3A2A00.Array_Type;
- begin
- -- Within this block, the accessibility level of the actual
- -- corresponding to Proc.P.all is 4. Therefore, the P.all'Access
- -- in Proc raises Program_Error when the subprogram is called. The
- -- exception is handled within the subprogram:
-
- Proc (X_L4'Access, Result2);
-
- F3A2A00.TC_Display_Results (Result2, F3A2A00.P_E,
- "SUBTEST #4: object at deeper level");
- end;
-
- end;
-
- exception
- when Program_Error =>
- Report.Failed ("SUBTEST #4: Program_Error incorrectly raised " &
- "during instantiation of generic");
- when others =>
- Report.Failed ("SUBTEST #4: Unexpected exception raised " &
- "during instantiation of generic");
- end SUBTEST4;
-
-
- Report.Result;
-
-end C3A2A01;
diff --git a/gcc/testsuite/ada/acats/tests/c3/c3a2a02.a b/gcc/testsuite/ada/acats/tests/c3/c3a2a02.a
deleted file mode 100644
index 23b2c1c5de8..00000000000
--- a/gcc/testsuite/ada/acats/tests/c3/c3a2a02.a
+++ /dev/null
@@ -1,396 +0,0 @@
--- C3A2A02.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that, for X'Access of a general access type A, Program_Error is
--- raised if the accessibility level of X is deeper than that of A.
--- Check for cases where X'Access occurs in an instance body, and A
--- is a type either declared inside the instance, or declared outside
--- the instance but not passed as an actual during instantiation.
---
--- TEST DESCRIPTION:
--- In order to satisfy accessibility requirements, the designated
--- object X must be at the same or a less deep nesting level than the
--- general access type A -- X must "live" as long as A. Nesting
--- levels are the run-time nestings of masters: block statements;
--- subprogram, task, and entry bodies; and accept statements. Packages
--- are invisible to accessibility rules.
---
--- This test declares three generic packages:
---
--- (1) One in which X is of a formal tagged derived type and declared
--- in the body, A is a type declared outside the instance, and
--- X'Access occurs in the declarative part of a nested subprogram.
---
--- (2) One in which X is a formal object of a tagged type, A is a
--- type declared outside the instance, and X'Access occurs in the
--- declarative part of the body.
---
--- (3) One in which there are two X's and two A's. In the first pair,
--- X is a formal in object of a tagged type, A is declared in the
--- specification, and X'Access occurs in the declarative part of
--- the body. In the second pair, X is of a formal derived type,
--- X and A are declared in the specification, and X'Access occurs
--- in the sequence of statements of the body.
---
--- The test verifies the following:
---
--- For (1), Program_Error is raised when the nested subprogram is
--- called, if the generic package is instantiated at a deeper level
--- than that of A. The exception is propagated to the innermost
--- enclosing master. Also, check that Program_Error is not raised
--- if the instantiation is at the same level as that of A.
---
--- For (2), Program_Error is raised upon instantiation if the object
--- passed as an actual during instantiation has an accessibility level
--- deeper than that of A. The exception is propagated to the innermost
--- enclosing master. Also, check that Program_Error is not raised if
--- the level of the actual object is not deeper than that of A.
---
--- For (3), Program_Error is not raised, for actual objects at
--- various accessibility levels (since A will have at least the same
--- accessibility level as X in all cases, no exception should ever
--- be raised).
---
--- TEST FILES:
--- The following files comprise this test:
---
--- F3A2A00.A
--- -> C3A2A02.A
---
---
--- CHANGE HISTORY:
--- 12 May 95 SAIC Initial prerelease version.
--- 10 Jul 95 SAIC Modified code to avoid dead variable optimization.
--- 26 Jun 98 EDS Added pragma Elaborate (C3A2A02_0) to package
--- package C3A2A02_3, in order to avoid possible
--- instantiation error.
---!
-
-with F3A2A00;
-generic
- type FD is new F3A2A00.Tagged_Type with private;
-package C3A2A02_0 is
- procedure Proc;
-end C3A2A02_0;
-
-
- --==================================================================--
-
-
-with Report;
-package body C3A2A02_0 is
- X : aliased FD;
-
- procedure Proc is
- Ptr : F3A2A00.AccTagClass_L0 := X'Access;
- begin
- -- Avoid optimization (dead variable removal of Ptr):
-
- if not Report.Equal (Ptr.C, Ptr.C) then -- Always false.
- Report.Failed ("Unexpected error in Proc");
- end if;
- end Proc;
-end C3A2A02_0;
-
-
- --==================================================================--
-
-
-with F3A2A00;
-generic
- FObj : in out F3A2A00.Tagged_Type;
-package C3A2A02_1 is
- procedure Dummy; -- Needed to allow package body.
-end C3A2A02_1;
-
-
- --==================================================================--
-
-
-with Report;
-package body C3A2A02_1 is
- Ptr : F3A2A00.AccTag_L0 := FObj'Access;
-
- procedure Dummy is
- begin
- null;
- end Dummy;
-begin
- -- Avoid optimization (dead variable removal of Ptr):
-
- if not Report.Equal (Ptr.C, Ptr.C) then -- Always false.
- Report.Failed ("Unexpected error in C3A2A02_1 instance");
- end if;
-end C3A2A02_1;
-
-
- --==================================================================--
-
-
-with F3A2A00;
-generic
- type FD is new F3A2A00.Array_Type;
- FObj : in F3A2A00.Tagged_Type;
-package C3A2A02_2 is
- type GAF is access all FD;
- type GAO is access constant F3A2A00.Tagged_Type;
- XG : aliased FD;
- PtrF : GAF;
- Index : Integer := FD'First;
-
- procedure Dummy; -- Needed to allow package body.
-end C3A2A02_2;
-
-
- --==================================================================--
-
-
-with Report;
-package body C3A2A02_2 is
- PtrO : GAO := FObj'Access;
-
- procedure Dummy is
- begin
- null;
- end Dummy;
-begin
- PtrF := XG'Access;
-
- -- Avoid optimization (dead variable removal of PtrO and/or PtrF):
-
- if not Report.Equal (PtrO.C, PtrO.C) then -- Always false.
- Report.Failed ("Unexpected error in C3A2A02_2 instance: PtrO");
- end if;
-
- if not Report.Equal (PtrF(Index).C, PtrF(Index).C) then -- Always false.
- Report.Failed ("Unexpected error in C3A2A02_2 instance: PtrF");
- end if;
-end C3A2A02_2;
-
-
- --==================================================================--
-
-
--- The instantiation of C3A2A02_0 should NOT result in any exceptions.
-
-with F3A2A00;
-with C3A2A02_0;
-pragma Elaborate (C3A2A02_0);
-package C3A2A02_3 is new C3A2A02_0 (F3A2A00.Tagged_Type);
-
-
- --==================================================================--
-
-
-with F3A2A00;
-with C3A2A02_0;
-with C3A2A02_1;
-with C3A2A02_2;
-with C3A2A02_3;
-
-with Report;
-procedure C3A2A02 is
-begin -- C3A2A02. -- [ Level = 1 ]
-
- Report.Test ("C3A2A02", "Run-time accessibility checks: instance " &
- "bodies. Type of X'Access is local or global to instance");
-
-
- SUBTEST1:
- declare -- [ Level = 2 ]
- Result1 : F3A2A00.TC_Result_Kind;
- Result2 : F3A2A00.TC_Result_Kind;
- begin -- SUBTEST1.
-
- declare -- [ Level = 3 ]
- package Pack_Same_Level renames C3A2A02_3;
- begin
- -- The accessibility level of Pack_Same_Level.X is that of the
- -- instance (0), not that of the renaming declaration. The level of
- -- the type of Pack_Same_Level.X'Access (F3A2A00.AccTagClass_L0) is
- -- 0. Therefore, the X'Access in Pack_Same_Level.Proc does not raise
- -- an exception when the subprogram is called. The level of execution
- -- of the subprogram is irrelevant:
-
- Pack_Same_Level.Proc;
- Result1 := F3A2A00.OK; -- Expected result.
- exception
- when Program_Error => Result1 := F3A2A00.P_E;
- when others => Result1 := F3A2A00.O_E;
- end;
-
- F3A2A00.TC_Display_Results (Result1, F3A2A00.OK,
- "SUBTEST #1 (same level)");
-
-
- declare -- [ Level = 3 ]
- -- The instantiation of C3A2A02_0 should NOT result in any
- -- exceptions.
-
- package Pack_Deeper_Level is new C3A2A02_0 (F3A2A00.Tagged_Type);
- begin
- -- The accessibility level of Pack_Deeper_Level.X is that of the
- -- instance (3). The level of the type of Pack_Deeper_Level.X'Access
- -- (F3A2A00.AccTagClass_L0) is 0. Therefore, the X'Access in
- -- Pack_Deeper_Level.Proc propagates Program_Error when the
- -- subprogram is called:
-
- Pack_Deeper_Level.Proc;
- Result2 := F3A2A00.OK;
- exception
- when Program_Error => Result2 := F3A2A00.P_E; -- Expected result.
- when others => Result2 := F3A2A00.O_E;
- end;
-
- F3A2A00.TC_Display_Results (Result2, F3A2A00.P_E,
- "SUBTEST #1: deeper level");
-
- exception
- when Program_Error =>
- Report.Failed ("SUBTEST #1: Program_Error incorrectly raised " &
- "during instantiation of generic");
- when others =>
- Report.Failed ("SUBTEST #1: Unexpected exception raised " &
- "during instantiation of generic");
- end SUBTEST1;
-
-
-
- SUBTEST2:
- declare -- [ Level = 2 ]
- Result1 : F3A2A00.TC_Result_Kind;
- Result2 : F3A2A00.TC_Result_Kind;
- begin -- SUBTEST2.
-
- declare -- [ Level = 3 ]
- X_L3 : F3A2A00.Tagged_Type;
- begin
- declare -- [ Level = 4 ]
- -- The accessibility level of the actual object corresponding to
- -- FObj in Pack_PE is 3. The level of the type of FObj'Access
- -- (F3A2A00.AccTag_L0) is 0. Therefore, the FObj'Access in Pack_PE
- -- propagates Program_Error when the instance body is elaborated:
-
- package Pack_PE is new C3A2A02_1 (X_L3);
- begin
- Result1 := F3A2A00.OK;
- end;
- exception
- when Program_Error => Result1 := F3A2A00.P_E; -- Expected result.
- when others => Result1 := F3A2A00.O_E;
- end;
-
- F3A2A00.TC_Display_Results (Result1, F3A2A00.P_E,
- "SUBTEST #2: deeper level");
-
-
- begin -- [ Level = 3 ]
- declare -- [ Level = 4 ]
- -- The accessibility level of the actual object corresponding to
- -- FObj in Pack_OK is 0. The level of the type of FObj'Access
- -- (F3A2A00.AccTag_L0) is also 0. Therefore, the FObj'Access in
- -- Pack_OK does not raise an exception when the instance body is
- -- elaborated:
-
- package Pack_OK is new C3A2A02_1 (F3A2A00.X_L0);
- begin
- Result2 := F3A2A00.OK; -- Expected result.
- end;
- exception
- when Program_Error => Result2 := F3A2A00.P_E;
- when others => Result2 := F3A2A00.O_E;
- end;
-
- F3A2A00.TC_Display_Results (Result2, F3A2A00.OK,
- "SUBTEST #2: same level");
-
- end SUBTEST2;
-
-
-
- SUBTEST3:
- declare -- [ Level = 2 ]
- Result1 : F3A2A00.TC_Result_Kind;
- Result2 : F3A2A00.TC_Result_Kind;
- begin -- SUBTEST3.
-
- declare -- [ Level = 3 ]
- X_L3 : F3A2A00.Tagged_Type;
- begin
- declare -- [ Level = 4 ]
- -- Since the accessibility level of the type of X'Access in
- -- both cases within Pack_OK1 is that of the instance, and since
- -- X is either passed as an actual (in which case its level will
- -- not be deeper than that of the instance) or is declared within
- -- the instance (in which case its level is the same as that of
- -- the instance), no exception should be raised when the instance
- -- body is elaborated:
-
- package Pack_OK1 is new C3A2A02_2 (F3A2A00.Array_Type, X_L3);
- begin
- Result1 := F3A2A00.OK; -- Expected result.
- end;
- exception
- when Program_Error => Result1 := F3A2A00.P_E;
- when others => Result1 := F3A2A00.O_E;
- end;
-
- F3A2A00.TC_Display_Results (Result1, F3A2A00.OK,
- "SUBTEST #3: 1st okay case");
-
-
- declare -- [ Level = 3 ]
- type My_Array is new F3A2A00.Array_Type;
- begin
- declare -- [ Level = 4 ]
- -- Since the accessibility level of the type of X'Access in
- -- both cases within Pack_OK2 is that of the instance, and since
- -- X is either passed as an actual (in which case its level will
- -- not be deeper than that of the instance) or is declared within
- -- the instance (in which case its level is the same as that of
- -- the instance), no exception should be raised when the instance
- -- body is elaborated:
-
- package Pack_OK2 is new C3A2A02_2 (My_Array, F3A2A00.X_L0);
- begin
- Result2 := F3A2A00.OK; -- Expected result.
- end;
- exception
- when Program_Error => Result2 := F3A2A00.P_E;
- when others => Result2 := F3A2A00.O_E;
- end;
-
- F3A2A00.TC_Display_Results (Result2, F3A2A00.OK,
- "SUBTEST #3: 2nd okay case");
-
-
- end SUBTEST3;
-
-
-
- Report.Result;
-
-end C3A2A02;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c410001.a b/gcc/testsuite/ada/acats/tests/c4/c410001.a
deleted file mode 100644
index 26555531b06..00000000000
--- a/gcc/testsuite/ada/acats/tests/c4/c410001.a
+++ /dev/null
@@ -1,303 +0,0 @@
--- C410001.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that evaluating an access to subprogram variable containing
--- the value null causes the exception Constraint_Error.
--- Check that the default value for objects of access to subprogram
--- types is null.
---
--- TEST DESCRIPTION:
--- This test defines a few simple access_to_subprogram types, and
--- objects of those types. It checks that the default values for
--- these objects is null, and that an attempt to make a subprogram
--- call via one of this objects containing a null value causes the
--- predefined exception Constraint_Error. The check is performed
---- both with the default null value, and with an explicitly assigned
--- null value, after the object has been used to successfully designate
--- and call a subprogram.
---
---
--- CHANGE HISTORY:
--- 05 APR 96 SAIC Initial version
--- 04 NOV 96 SAIC Revised for 2.1 release
--- 26 FEB 97 PWB.CTA Initialized variable before passing to function
---!
-
------------------------------------------------------------------ C410001_0
-
-package C410001_0 is
-
- -- used to "switch state" in the software
- Expect_Exception : Boolean;
-
- -- define a minimal mixture of access_to_subprogram types
-
- type Proc_Ref is access procedure;
-
- type Func_Ref is access function(I:Integer) return Integer;
-
- type Proc_Para_Ref is access procedure(P:Proc_Ref);
-
- type Func_Para_Ref is access function(F:Func_Ref) return Integer;
-
- type Prot_Proc_Ref is access protected procedure;
-
- type Prot_Func_Ref is access protected function return Boolean;
-
- -- define some subprograms for them to reference
-
- procedure Proc;
-
- function Func(I:Integer) return Integer;
-
- procedure Proc_Para( Param : Proc_Ref );
-
- function Func_Para( Param : Func_Ref ) return Integer;
-
- protected Prot_Obj is
- procedure Prot_Proc;
- function Prot_Func return Boolean;
- end Prot_Obj;
-
-end C410001_0;
-
--- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
-
-with Report;
-package body C410001_0 is
-
- -- Note that some failing cases will cause duplicate failure messages;
- -- rather than have the procedure/function bodies be null, the error
- -- checking code makes for a reasonable anti-optimization feature.
-
- procedure Proc is
- begin
- if Expect_Exception then
- Report.Failed("Expected exception did not occur: Proc");
- end if;
- end Proc;
-
- function Func(I:Integer) return Integer is
- begin
- if Expect_Exception then
- Report.Failed("Expected exception did not occur: Func");
- end if;
- return Report.Ident_Int(I);
- end Func;
-
- procedure Proc_Para( Param : Proc_Ref ) is
- begin
-
- Param.all; -- call by explicit dereference
-
- if Expect_Exception then
- Report.Failed("Expected exception did not occur: Proc_Para");
- end if;
-
- exception
- when Constraint_Error =>
- if not Expect_Exception then
- Report.Failed("Unexpected Constraint_Error: Proc_Para");
- end if; -- else null; expected the exception
- when others => Report.Failed("Unexpected exception: Proc_Para");
- end Proc_Para;
-
- function Func_Para( Param : Func_Ref ) return Integer is
- begin
-
- return Param(1); -- call by implicit dereference
-
- if Expect_Exception then
- Report.Failed("Expected exception did not occur: Func_Para");
- end if;
- return 1; -- really just to avoid warnings
-
- exception
- when Constraint_Error =>
- if not Expect_Exception then
- Report.Failed("Unexpected Constraint_Error: Func_Para");
- return 0;
- else
- return 1995; -- any value other than this is unexpected
- end if;
- when others => Report.Failed("Unexpected exception: Func_Para");
- return -42;
- end Func_Para;
-
- protected body Prot_Obj is
-
- procedure Prot_Proc is
- begin
- if Expect_Exception then
- Report.Failed("Expected exception did not occur: Prot_Proc");
- end if;
- end Prot_Proc;
-
- function Prot_Func return Boolean is
- begin
- if Expect_Exception then
- Report.Failed("Expected exception did not occur: Prot_Func");
- end if;
- return Report.Ident_Bool( True );
- end Prot_Func;
-
- end Prot_Obj;
-
-end C410001_0;
-
-------------------------------------------------------------------- C410001
-
-with Report;
-with TCTouch;
-with C410001_0;
-procedure C410001 is
-
- Proc_Ref_Var : C410001_0.Proc_Ref;
-
- Func_Ref_Var : C410001_0.Func_Ref;
-
- Proc_Para_Ref_Var : C410001_0.Proc_Para_Ref;
-
- Func_Para_Ref_Var : C410001_0.Func_Para_Ref;
-
- type Enclosure is record
- Prot_Proc_Ref_Var : C410001_0.Prot_Proc_Ref;
- Prot_Func_Ref_Var : C410001_0.Prot_Func_Ref;
- end record;
-
- Enclosed : Enclosure;
-
- Valid_Proc : C410001_0.Proc_Ref := C410001_0.Proc'Access;
-
- Valid_Func : C410001_0.Func_Ref := C410001_0.Func'Access;
-
- procedure Make_Calls( Expecting_Exceptions : Boolean ) is
- type Case_Numbers is range 1..6;
- Some_Integer : Integer := 0;
- begin
- for Cases in Case_Numbers loop
- Catch_Exception : begin
- case Cases is
- when 1 => Proc_Ref_Var.all;
- when 2 => Some_Integer := Func_Ref_Var.all( Some_Integer );
- when 3 => Proc_Para_Ref_Var( Valid_Proc );
- when 4 => Some_Integer := Func_Para_Ref_Var( Valid_Func );
- when 5 => Enclosed.Prot_Proc_Ref_Var.all;
- when 6 => TCTouch.Assert( Enclosed.Prot_Func_Ref_Var.all
- /= Expecting_Exceptions,
- "Case 6");
- end case;
- if Expecting_Exceptions then
- Report.Failed("Exception expected: Case"
- & Case_Numbers'Image(Cases) );
- end if;
- exception
- when Constraint_Error =>
- if not Expecting_Exceptions then
- Report.Failed("Constraint_Error not expected: Case"
- & Case_Numbers'Image(Cases) );
- end if;
- when others =>
- Report.Failed("Wrong/Bad Exception: Case"
- & Case_Numbers'Image(Cases) );
- end Catch_Exception;
- end loop;
- end Make_Calls;
-
-begin -- Main test procedure.
-
- Report.Test ("C410001", "Check that evaluating an access to subprogram " &
- "variable containing the value null causes the " &
- "exception Constraint_Error. Check that the " &
- "default value for objects of access to " &
- "subprogram types is null" );
-
- -- check that the default values are null
- declare
- use C410001_0; -- make all "="'s visible for all types
- begin
- TCTouch.Assert( Proc_Ref_Var = null, "Proc_Ref_Var = null" );
-
- TCTouch.Assert( Func_Ref_Var = null, "Func_Ref_Var = null" );
-
- TCTouch.Assert( Proc_Para_Ref_Var = null, "Proc_Para_Ref_Var = null" );
-
- TCTouch.Assert( Func_Para_Ref_Var = null, "Func_Para_Ref_Var = null" );
-
- TCTouch.Assert( Enclosed.Prot_Proc_Ref_Var = null,
- "Enclosed.Prot_Proc_Ref_Var = null" );
-
- TCTouch.Assert( Enclosed.Prot_Func_Ref_Var = null,
- "Enclosed.Prot_Func_Ref_Var = null" );
- end;
-
- -- check that calls via the default values cause Constraint_Error
-
- C410001_0.Expect_Exception := True;
-
- Make_Calls( Expecting_Exceptions => True );
-
- -- assign non-null values to the objects
-
- Proc_Ref_Var := C410001_0.Proc'Access;
- Func_Ref_Var := C410001_0.Func'Access;
- Proc_Para_Ref_Var := C410001_0.Proc_Para'Access;
- Func_Para_Ref_Var := C410001_0.Func_Para'Access;
- Enclosed := (C410001_0.Prot_Obj.Prot_Proc'Access,
- C410001_0.Prot_Obj.Prot_Func'Access);
-
- -- check that the calls perform normally
-
- C410001_0.Expect_Exception := False;
-
- Make_Calls( Expecting_Exceptions => False );
-
- -- check that a passed null value causes Constraint_Error
-
- C410001_0.Expect_Exception := True;
-
- Proc_Para_Ref_Var( null );
-
- TCTouch.Assert( Func_Para_Ref_Var( null ) = 1995,
- "Func_Para_Ref_Var( null )");
-
- -- assign the null value to the objects
-
- Proc_Ref_Var := null;
- Func_Ref_Var := null;
- Proc_Para_Ref_Var := null;
- Func_Para_Ref_Var := null;
- Enclosed := (null,null);
-
- -- check that calls now again cause Constraint_Error
-
- C410001_0.Expect_Exception := True;
-
- Make_Calls( Expecting_Exceptions => True );
-
- Report.Result;
-
-end C410001;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c420001.a b/gcc/testsuite/ada/acats/tests/c4/c420001.a
deleted file mode 100644
index ae4b4d8fdcd..00000000000
--- a/gcc/testsuite/ada/acats/tests/c4/c420001.a
+++ /dev/null
@@ -1,110 +0,0 @@
--- C420001.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687 and
--- F08630-91-C-0015, the U.S. Government obtained unlimited rights in the
--- software and documentation contained herein. Unlimited rights are
--- defined in DFAR 252.227-7013(a)(19). By making this public release,
--- the Government intends to confer upon all recipients unlimited rights
--- equal to those held by the Government. These rights include rights to
--- use, duplicate, release or disclose the released technical data and
--- computer software in whole or in part, in any manner and for any purpose
--- whatsoever, and to have or permit others to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE
--- Check that if the index subtype of a string type is a modular subtype
--- whose lower bound is zero, then the evaluation of a null string_literal
--- raises Constraint_Error. This was confirmed by AI95-00138.
---
--- TEST DESCRIPTION
--- In this test, we have a generic formal modular type, and we have
--- several null string literals of that type. Because the type is
--- generic formal, the string literals are not static, and therefore
--- the Constraint_Error should be detected at run time.
---
--- CHANGE HISTORY:
--- 29 JUN 1999 RAD Initial Version
--- 23 SEP 1999 RLB Improved comments and messages, renamed, issued.
---
---!
-with Report; use Report; pragma Elaborate_All(Report);
-with System;
-procedure C420001 is
- generic
- type Modular is mod <>;
- package Mod_Test is
- type Str is array(Modular range <>) of Character;
- procedure Test_String_Literal;
- end Mod_Test;
-
- package body Mod_Test is
- procedure Test_String_Literal is
- begin
- begin
- declare
- Null_String: Str := ""; -- Should raise C_E.
- begin
- Comment(String(Null_String)); -- Avoid 11.6 issues.
- end;
- Failed("Null string didn't raise Constraint_Error");
- exception
- when Exc: Constraint_Error =>
- null; -- Comment("Constraint_Error -- OK");
- when Exc2: others =>
- Failed("Null string raised wrong exception");
- end;
- begin
- Failed(String(Str'(""))); -- Should raise C_E, not do Failed.
- Failed("Null string didn't raise Constraint_Error");
- exception
- when Exc: Constraint_Error =>
- null; -- Comment("Constraint_Error -- OK");
- when Exc2: others =>
- Failed("Null string raised wrong exception");
- end;
- end Test_String_Literal;
- begin
- Test_String_Literal;
- end Mod_Test;
-begin
- Test("C420001", "Check that if the index subtype of a string type is a " &
- "modular subtype whose lower bound is zero, then the " &
- "evaluation of a null string_literal raises " &
- "Constraint_Error. ");
- declare
- type M1 is mod 1;
- package Test_M1 is new Mod_Test(M1);
- type M2 is mod 2;
- package Test_M2 is new Mod_Test(M2);
- type M3 is mod 3;
- package Test_M3 is new Mod_Test(M3);
- type M4 is mod 4;
- package Test_M4 is new Mod_Test(M4);
- type M5 is mod 5;
- package Test_M5 is new Mod_Test(M5);
- type M6 is mod 6;
- package Test_M6 is new Mod_Test(M6);
- type M7 is mod 7;
- package Test_M7 is new Mod_Test(M7);
- type M8 is mod 8;
- package Test_M8 is new Mod_Test(M8);
- type M_Max_Binary_Modulus is mod System.Max_Binary_Modulus;
- package Test_M_Max_Binary_Modulus is new Mod_Test(M_Max_Binary_Modulus);
- type M_Max_Nonbinary_Modulus is mod System.Max_Nonbinary_Modulus;
- package Test_M_Max_Nonbinary_Modulus is new Mod_Test(M_Max_Nonbinary_Modulus);
- begin
- null;
- end;
- Result;
-end C420001;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c431001.a b/gcc/testsuite/ada/acats/tests/c4/c431001.a
deleted file mode 100644
index 7d417ce69d9..00000000000
--- a/gcc/testsuite/ada/acats/tests/c4/c431001.a
+++ /dev/null
@@ -1,464 +0,0 @@
--- C431001.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that a record aggregate can be given for a nonprivate,
--- nonlimited record extension and that the tag of the aggregate
--- values are initialized to the tag of the record extension.
---
--- TEST DESCRIPTION:
--- From an initial parent tagged type, several type extensions
--- are declared. Each type extension adds components onto
--- the existing record structure.
---
--- In the main procedure, aggregates are declared in two ways.
--- In the declarative part, aggregates are used to supply
--- initial values for objects of specific types. In the executable
--- part, aggregates are used directly as actual parameters to
--- a class-wide formal parameter.
---
--- The abstraction is for a catalog of recordings. A recording
--- can be a CD or a record (vinyl). Additionally, a CD may also
--- be a CD-ROM, containing both music and data. This type is declared
--- as an extension to a type extension, to test that the inclusion
--- of record components is transitive across multiple extensions.
---
--- That the aggregate has the correct tag is verify by feeding
--- it to a dispatching operation and confirming that the
--- expected subprogram is called as a result. To accomplish this,
--- an enumeration type is declared with an enumeration literal
--- representing each of the declared types in the hierarchy. A value
--- of this type is passed as a parameter to the dispatching
--- operation which passes it along to the dispatched subprogram.
--- Each dispatched subprogram verifies that it received the
--- expected enumeration literal.
---
--- Not quite fitting the above abstraction are several test cases
--- for null records. These tests verify that the new syntax for
--- null record aggregates, (null record), is supported. A type is
--- declared which extends a null tagged type and adds components.
--- Aggregates of this type should include associations for the
--- components of the type extension only. Finally, a type is
--- declared that adds a null type extension onto a non-null tagged
--- type. The aggregate associations should remain the same.
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 19 Dec 94 SAIC Removed RM references from objective text.
---
---!
---
-package C431001_0 is
-
- -- Values of TC_Type_ID are passed through to dispatched subprogram
- -- calls so that it can be verified that the dispatching resulted in
- -- the expected call.
- type TC_Type_ID is (TC_Recording, TC_CD, TC_Vinyl, TC_CD_ROM);
-
- type Genre is (Classical, Country, Jazz, Rap, Rock, World);
-
- type Recording is tagged record
- Artist : String (1..20);
- Category : Genre;
- Length : Duration;
- Selections : Positive;
- end record;
-
- function Summary (R : in Recording;
- TC_Type : in TC_Type_ID) return String;
-
- type Recording_Method is (Audio, Digital);
- type CD is new Recording with record
- Recorded : Recording_Method;
- Mastered : Recording_Method;
- end record;
-
- function Summary (Disc : in CD;
- TC_Type : in TC_Type_ID) return String;
-
- type Playing_Speed is (LP_33, Single_45, Old_78);
- type Vinyl is new Recording with record
- Speed : Playing_Speed;
- end record;
-
- function Summary (Album : in Vinyl;
- TC_Type : in TC_Type_ID) return String;
-
-
- type CD_ROM is new CD with record
- Storage : Positive;
- end record;
-
- function Summary (Disk : in CD_ROM;
- TC_Type : in TC_Type_ID) return String;
-
- function Catalog_Entry (R : in Recording'Class;
- TC_Type : in TC_Type_ID) return String;
-
- procedure Print (S : in String); -- provides somewhere for the
- -- results of Catalog_Entry to
- -- "go", so they don't get
- -- optimized away.
-
- -- The types and procedures declared below are not a continuation
- -- of the Recording abstraction. These types are intended to test
- -- support for null tagged types and type extensions. TC_Check mirrors
- -- the operation of function Summary, above. Similarly, TC_Dispatch
- -- mirrors the operation of Catalog_Entry.
-
- type TC_N_Type_ID is
- (TC_Null_Tagged, TC_Null_Extension,
- TC_Extension_Of_Null, TC_Null_Extension_Of_Nonnull);
-
- type Null_Tagged is tagged null record;
- procedure TC_Check (N : in Null_Tagged;
- TC_Type : in TC_N_Type_ID);
-
- type Null_Extension is new Null_Tagged with null record;
- procedure TC_Check (N : in Null_Extension;
- TC_Type : in TC_N_Type_ID);
-
- type Extension_Of_Null is new Null_Tagged with record
- New_Component1 : Boolean;
- New_Component2 : Natural;
- end record;
- procedure TC_Check (N : in Extension_Of_Null;
- TC_Type : in TC_N_Type_ID);
-
- type Null_Extension_Of_Nonnull is new Extension_Of_Null
- with null record;
- procedure TC_Check (N : in Null_Extension_Of_Nonnull;
- TC_Type : in TC_N_Type_ID);
-
- procedure TC_Dispatch (N : in Null_Tagged'Class;
- TC_Type : in TC_N_Type_ID);
-
-end C431001_0;
-
-with Report;
-package body C431001_0 is
-
- function Summary (R : in Recording;
- TC_Type : in TC_Type_ID) return String is
- begin
-
- if TC_Type /= TC_Recording then
- Report.Failed ("Did not dispatch on tag for tagged parent " &
- "type Recording");
- end if;
-
- return R.Artist (1..10)
- & ' ' & Genre'Image (R.Category) (1..2)
- & ' ' & Duration'Image (R.Length)
- & ' ' & Integer'Image (R.Selections);
-
- end Summary;
-
- function Summary (Disc : in CD;
- TC_Type : in TC_Type_ID) return String is
- begin
-
- if TC_Type /= TC_CD then
- Report.Failed ("Did not dispatch on tag for type extension " &
- "CD");
- end if;
-
- return Summary (Recording (Disc), TC_Type => TC_Recording)
- & ' ' & Recording_Method'Image(Disc.Recorded)(1)
- & Recording_Method'Image(Disc.Mastered)(1);
-
- end Summary;
-
- function Summary (Album : in Vinyl;
- TC_Type : in TC_Type_ID) return String is
- begin
- if TC_Type /= TC_Vinyl then
- Report.Failed ("Did not dispatch on tag for type extension " &
- "Vinyl");
- end if;
-
- case Album.Speed is
- when LP_33 =>
- return Summary (Recording (Album), TC_Type => TC_Recording)
- & " 33";
- when Single_45 =>
- return Summary (Recording (Album), TC_Type => TC_Recording)
- & " 45";
- when Old_78 =>
- return Summary (Recording (Album), TC_Type => TC_Recording)
- & " 78";
- end case;
-
- end Summary;
-
- function Summary (Disk : in CD_ROM;
- TC_Type : in TC_Type_ID) return String is
- begin
- if TC_Type /= TC_CD_ROM then
- Report.Failed ("Did not dispatch on tag for type extension " &
- "CD_ROM. This is an extension of the type " &
- "extension CD");
- end if;
-
- return Summary (Recording(Disk), TC_Type => TC_Recording)
- & ' ' & Integer'Image (Disk.Storage) & 'K';
-
- end Summary;
-
- function Catalog_Entry (R : in Recording'Class;
- TC_Type : in TC_Type_ID) return String is
- begin
- return Summary (R, TC_Type); -- dispatched call
- end Catalog_Entry;
-
- procedure Print (S : in String) is
- T : String (1..S'Length) := Report.Ident_Str (S);
- begin
- -- Ada.Text_IO.Put_Line (S);
- null;
- end Print;
-
- -- Bodies for null type checks
- procedure TC_Check (N : in Null_Tagged;
- TC_Type : in TC_N_Type_ID) is
- begin
- if TC_Type /= TC_Null_Tagged then
- Report.Failed ("Did not dispatch on tag for null tagged " &
- "type Null_Tagged");
- end if;
- end TC_Check;
-
- procedure TC_Check (N : in Null_Extension;
- TC_Type : in TC_N_Type_ID) is
- begin
- if TC_Type /= TC_Null_Extension then
- Report.Failed ("Did not dispatch on tag for null tagged " &
- "type extension Null_Extension");
- end if;
- end TC_Check;
-
- procedure TC_Check (N : in Extension_Of_Null;
- TC_Type : in TC_N_Type_ID) is
- begin
- if TC_Type /= TC_Extension_Of_Null then
- Report.Failed
- ("Did not dispatch on tag for extension of null parent" &
- "type");
- end if;
- end TC_Check;
-
- procedure TC_Check (N : in Null_Extension_Of_Nonnull;
- TC_Type : in TC_N_Type_ID) is
- begin
- if TC_Type /= TC_Null_Extension_Of_Nonnull then
- Report.Failed
- ("Did not dispatch on tag for null extension of nonnull " &
- "parent type");
- end if;
- end TC_Check;
-
- procedure TC_Dispatch (N : in Null_Tagged'Class;
- TC_Type : in TC_N_Type_ID) is
- begin
- TC_Check (N, TC_Type); -- dispatched call
- end TC_Dispatch;
-
-end C431001_0;
-
-
-with C431001_0;
-with Report;
-procedure C431001 is
-
- -- Tagged type
- -- Named component associations
- DAT : C431001_0.Recording :=
- (Artist => "Aerosmith ",
- Category => C431001_0.Rock,
- Length => 48.5,
- Selections => 10);
-
- -- Type extensions
- -- Named component associations
- Disc1 : C431001_0.CD :=
- (Artist => "London Symphony ",
- Category => C431001_0.Classical,
- Length => 55.0,
- Selections => 4,
- Recorded => C431001_0.Digital,
- Mastered => C431001_0.Digital);
-
- -- Named component associations with others
- Disc2 : C431001_0.CD :=
- (Artist => "Pink Floyd ",
- Category => C431001_0.Rock,
- Length => 51.8,
- Selections => 5,
- others => C431001_0.Audio); -- Recorded
- -- Mastered
-
- -- Positional component associations
- Album1 : C431001_0.Vinyl :=
- ("Hammer ", -- Artist
- C431001_0.Rap, -- Category
- 46.2, -- Length
- 9, -- Selections
- C431001_0.LP_33); -- Speed
-
- -- Mixed positional and named component associations
- -- Named component associations out of order
- Album2 : C431001_0.Vinyl :=
- ("Balinese Gamelan ", -- Artist
- C431001_0.World, -- Category
- 42.6, -- Length
- 14, -- Selections
- C431001_0.LP_33); -- Speed
-
- -- Type extension, parent is also type extension
- -- Named notation, components out of order
- Data : C431001_0.CD_ROM :=
- (Storage => 140,
- Mastered => C431001_0.Digital,
- Category => C431001_0.Rock,
- Selections => 10,
- Recorded => C431001_0.Digital,
- Artist => "Black, Clint ",
- Length => 48.5);
-
- -- Null tagged type
- Null_Rec : C431001_0.Null_Tagged := (null record);
-
- -- Null type extension
- Null_Ext : C431001_0.Null_Extension := (null record);
-
- -- Nonnull extension of null parent
- Ext_Of_Null : C431001_0.Extension_Of_Null := (True, 0);
-
- -- Null extension of nonnull parent
- Null_Ext_Of_Nonnull : C431001_0.Null_Extension_Of_Nonnull
- := (False, 1);
-
-begin
-
- Report.Test ("C431001", "Aggregate values for type extensions");
-
- C431001_0.Print (C431001_0.Catalog_Entry (DAT, C431001_0.TC_Recording));
- C431001_0.Print (C431001_0.Catalog_Entry (Disc1, C431001_0.TC_CD));
- C431001_0.Print (C431001_0.Catalog_Entry (Disc2, C431001_0.TC_CD));
- C431001_0.Print (C431001_0.Catalog_Entry (Album1, C431001_0.TC_Vinyl));
- C431001_0.Print (C431001_0.Catalog_Entry (Album2, C431001_0.TC_Vinyl));
- C431001_0.Print (C431001_0.Catalog_Entry (Data, C431001_0.TC_CD_ROM));
-
- C431001_0.TC_Dispatch (Null_Rec, C431001_0.TC_Null_Tagged);
- C431001_0.TC_Dispatch (Null_Ext, C431001_0.TC_Null_Extension);
- C431001_0.TC_Dispatch (Ext_Of_Null, C431001_0.TC_Extension_Of_Null);
- C431001_0.TC_Dispatch
- (Null_Ext_Of_Nonnull, C431001_0.TC_Null_Extension_Of_Nonnull);
-
- -- Tagged type
- -- Named component associations
- C431001_0.Print (C431001_0.Catalog_Entry
- (TC_Type => C431001_0.TC_Recording,
- R => C431001_0.Recording'(Artist => "Zappa, Frank ",
- Category => C431001_0.Rock,
- Length => 70.0,
- Selections => 38)));
-
- -- Type extensions
- -- Named component associations
- C431001_0.Print (C431001_0.Catalog_Entry
- (TC_Type => C431001_0.TC_CD,
- R => C431001_0.CD'(Artist => "Dog, Snoop Doggy ",
- Category => C431001_0.Rap,
- Length => 37.3,
- Selections => 8,
- Recorded => C431001_0.Audio,
- Mastered => C431001_0.Digital)));
-
- -- Named component associations with others
- C431001_0.Print (C431001_0.Catalog_Entry
- (TC_Type => C431001_0.TC_CD,
- R => C431001_0.CD'(Artist => "Judd, Winona ",
- Category => C431001_0.Country,
- Length => 51.2,
- Selections => 11,
- others => C431001_0.Digital))); -- Recorded
- -- Mastered
-
- -- Positional component associations
- C431001_0.Print (C431001_0.Catalog_Entry
- (TC_Type => C431001_0.TC_Vinyl,
- R => C431001_0.Vinyl'("Davis, Miles ", -- Artist
- C431001_0.Jazz, -- Category
- 50.4, -- Length
- 10, -- Selections
- C431001_0.LP_33))); -- Speed
-
- -- Mixed positional and named component associations
- -- Named component associations out of order
- C431001_0.Print (C431001_0.Catalog_Entry
- (TC_Type => C431001_0.TC_Vinyl,
- R => C431001_0.Vinyl'("Zamfir ", -- Artist
- C431001_0.World, -- Category
- Speed => C431001_0.LP_33,
- Selections => 14,
- Length => 56.5)));
-
- -- Type extension, parent is also type extension
- -- Named notation, components out of order
- C431001_0.Print (C431001_0.Catalog_Entry
- (TC_Type => C431001_0.TC_CD_ROM,
- R => C431001_0.CD_ROM'(Storage => 720,
- Category => C431001_0.Classical,
- Recorded => C431001_0.Digital,
- Artist => "Baltimore Symphony ",
- Length => 68.9,
- Mastered => C431001_0.Digital,
- Selections => 5)));
-
- -- Null tagged type
- C431001_0.TC_Dispatch
- (TC_Type => C431001_0.TC_Null_Tagged,
- N => C431001_0.Null_Tagged'(null record));
-
- -- Null type extension
- C431001_0.TC_Dispatch
- (TC_Type => C431001_0.TC_Null_Extension,
- N => C431001_0.Null_Extension'(null record));
-
- -- Nonnull extension of null parent
- C431001_0.TC_Dispatch
- (TC_Type => C431001_0.TC_Extension_Of_Null,
- N => C431001_0.Extension_Of_Null'(True, 3));
-
- -- Null extension of nonnull parent
- C431001_0.TC_Dispatch
- (TC_Type => C431001_0.TC_Extension_Of_Null,
- N => C431001_0.Extension_Of_Null'(False, 4));
-
- Report.Result;
-
-end C431001;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c432001.a b/gcc/testsuite/ada/acats/tests/c4/c432001.a
deleted file mode 100644
index dab75b388f5..00000000000
--- a/gcc/testsuite/ada/acats/tests/c4/c432001.a
+++ /dev/null
@@ -1,512 +0,0 @@
--- C432001.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
---
--- Check that extension aggregates may be used to specify values
--- for types that are record extensions. Check that the
--- type of the ancestor expression may be any nonlimited type that
--- is a record extension, including private types and private
--- extensions. Check that the type for the aggregate is
--- derived from the type of the ancestor expression.
---
--- TEST DESCRIPTION:
---
--- Two progenitor nonlimited record types are declared, one
--- nonprivate and one private. Using these as parent types,
--- all possible combinations of record extensions are declared
--- (Nonprivate record extension of nonprivate type, private
--- extension of nonprivate type, nonprivate record extension of
--- private type, and private extension of private type). Finally,
--- each of these types is extended using nonprivate record
--- extensions.
---
--- Extension of private types is done in packages other than
--- the ones containing the parent declaration. This is done
--- to eliminate errors with extension of the partial view of
--- a type, which is not an objective of this test.
---
--- All components of private types and private extensions are given
--- default values. This eliminates the need for separate subprograms
--- whose sole purpose is to place a value into a private record type.
---
--- Types that have been extended are checked using an object of their
--- parent type as the ancestor expression. For those types that
--- have been extended twice, using only nonprivate record extensions,
--- a check is made using an object of their grandparent type as
--- the ancestor expression.
---
--- For each type, a subprogram is defined which checks the contents
--- of the parameter, which is a value of the record extension.
--- Components of nonprivate record extensions are checked against
--- passed-in parameters of the component type. Components of private
--- extensions are checked to ensure that they maintain their initial
--- values.
---
--- To check that the aggregate's type is derived from its ancestor,
--- each Check subprogram in turn calls the Check subprogram for
--- its parent type. Explicit conversion is used to convert the
--- record extension to the parent type.
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
---
---!
-
-with Report;
-package C432001_0 is
-
- type Eras is (Precambrian, Paleozoic, Mesozoic, Cenozoic);
-
- type N is tagged record
- How_Long_Ago : Natural := Report.Ident_Int(1);
- Era : Eras := Cenozoic;
- end record;
-
- function Check (Rec : in N;
- N : in Natural;
- E : in Eras) return Boolean;
-
- type P is tagged private;
-
- function Check (Rec : in P) return Boolean;
-
-private
-
- type P is tagged record
- How_Long_Ago : Natural := Report.Ident_Int(150);
- Era : Eras := Mesozoic;
- end record;
-
-end C432001_0;
-
-package body C432001_0 is
-
- function Check (Rec : in P) return Boolean is
- begin
- return Rec.How_Long_Ago = 150 and Rec.Era = Mesozoic;
- end Check;
-
- function Check (Rec : in N;
- N : in Natural;
- E : in Eras) return Boolean is
- begin
- return Rec.How_Long_Ago = N and Rec.Era = E;
- end Check;
-
-end C432001_0;
-
-with C432001_0;
-package C432001_1 is
-
- type Periods is
- (Aphebian, Helikian, Hadrynian,
- Cambrian, Ordovician, Silurian, Devonian, Carboniferous, Permian,
- Triassic, Jurassic, Cretaceous,
- Tertiary, Quaternary);
-
- type N_N is new C432001_0.N with record
- Period : Periods := C432001_1.Quaternary;
- end record;
-
- function Check (Rec : in N_N;
- N : in Natural;
- E : in C432001_0.Eras;
- P : in Periods) return Boolean;
-
- type N_P is new C432001_0.N with private;
-
- function Check (Rec : in N_P) return Boolean;
-
- type P_N is new C432001_0.P with record
- Period : Periods := C432001_1.Jurassic;
- end record;
-
- function Check (Rec : in P_N;
- P : in Periods) return Boolean;
-
- type P_P is new C432001_0.P with private;
-
- function Check (Rec : in P_P) return Boolean;
-
- type P_P_Null is new C432001_0.P with null record;
-
-private
-
- type N_P is new C432001_0.N with record
- Period : Periods := C432001_1.Quaternary;
- end record;
-
- type P_P is new C432001_0.P with record
- Period : Periods := C432001_1.Jurassic;
- end record;
-
-end C432001_1;
-
-with Report;
-package body C432001_1 is
-
- function Check (Rec : in N_N;
- N : in Natural;
- E : in C432001_0.Eras;
- P : in Periods) return Boolean is
- begin
- if not C432001_0.Check (C432001_0.N (Rec), N, E) then
- Report.Failed ("Conversion to parent type of " &
- "nonprivate portion of " &
- "nonprivate extension failed");
- end if;
- return Rec.Period = P;
- end Check;
-
-
- function Check (Rec : in N_P) return Boolean is
- begin
- if not C432001_0.Check (C432001_0.N (Rec), 1, C432001_0.Cenozoic) then
- Report.Failed ("Conversion to parent type of " &
- "nonprivate portion of " &
- "private extension failed");
- end if;
- return Rec.Period = C432001_1.Quaternary;
- end Check;
-
- function Check (Rec : in P_N;
- P : in Periods) return Boolean is
- begin
- if not C432001_0.Check (C432001_0.P (Rec)) then
- Report.Failed ("Conversion to parent type of " &
- "private portion of " &
- "nonprivate extension failed");
- end if;
- return Rec.Period = P;
- end Check;
-
- function Check (Rec : in P_P) return Boolean is
- begin
- if not C432001_0.Check (C432001_0.P (Rec)) then
- Report.Failed ("Conversion to parent type of " &
- "private portion of " &
- "private extension failed");
- end if;
- return Rec.Period = C432001_1.Jurassic;
- end Check;
-
-end C432001_1;
-
-with C432001_0;
-with C432001_1;
-package C432001_2 is
-
- -- All types herein are nonprivate extensions, since aggregates
- -- cannot be given for private extensions
-
- type N_N_N is new C432001_1.N_N with record
- Sample_On_Loan : Boolean;
- end record;
-
- function Check (Rec : in N_N_N;
- N : in Natural;
- E : in C432001_0.Eras;
- P : in C432001_1.Periods;
- B : in Boolean) return Boolean;
-
- type N_P_N is new C432001_1.N_P with record
- Sample_On_Loan : Boolean;
- end record;
-
- function Check (Rec : in N_P_N;
- B : Boolean) return Boolean;
-
- type P_N_N is new C432001_1.P_N with record
- Sample_On_Loan : Boolean;
- end record;
-
- function Check (Rec : in P_N_N;
- P : in C432001_1.Periods;
- B : Boolean) return Boolean;
-
- type P_P_N is new C432001_1.P_P with record
- Sample_On_Loan : Boolean;
- end record;
-
- function Check (Rec : in P_P_N;
- B : Boolean) return Boolean;
-
-end C432001_2;
-
-with Report;
-package body C432001_2 is
-
- -- direct access to operator
- use type C432001_1.Periods;
-
-
- function Check (Rec : in N_N_N;
- N : in Natural;
- E : in C432001_0.Eras;
- P : in C432001_1.Periods;
- B : in Boolean) return Boolean is
- begin
- if not C432001_1.Check (C432001_1.N_N (Rec), N, E, P) then
- Report.Failed ("Conversion to parent " &
- "nonprivate type extension " &
- "failed");
- end if;
- return Rec.Sample_On_Loan = B;
- end Check;
-
-
- function Check (Rec : in N_P_N;
- B : Boolean) return Boolean is
- begin
- if not C432001_1.Check (C432001_1.N_P (Rec)) then
- Report.Failed ("Conversion to parent " &
- "private type extension " &
- "failed");
- end if;
- return Rec.Sample_On_Loan = B;
- end Check;
-
- function Check (Rec : in P_N_N;
- P : in C432001_1.Periods;
- B : Boolean) return Boolean is
- begin
- if not C432001_1.Check (C432001_1.P_N (Rec), P) then
- Report.Failed ("Conversion to parent " &
- "nonprivate type extension " &
- "failed");
- end if;
- return Rec.Sample_On_Loan = B;
- end Check;
-
- function Check (Rec : in P_P_N;
- B : Boolean) return Boolean is
- begin
- if not C432001_1.Check (C432001_1.P_P (Rec)) then
- Report.Failed ("Conversion to parent " &
- "private type extension " &
- "failed");
- end if;
- return Rec.Sample_On_Loan = B;
- end Check;
-
-end C432001_2;
-
-
-with C432001_0;
-with C432001_1;
-with C432001_2;
-with Report;
-procedure C432001 is
-
- N_Object : C432001_0.N := (How_Long_Ago => Report.Ident_Int(375),
- Era => C432001_0.Paleozoic);
-
- P_Object : C432001_0.P; -- default value is (150,
- -- C432001_0.Mesozoic)
-
- N_N_Object : C432001_1.N_N :=
- (N_Object with Period => C432001_1.Devonian);
-
- P_N_Object : C432001_1.P_N :=
- (P_Object with Period => C432001_1.Jurassic);
-
- N_P_Object : C432001_1.N_P; -- default is (1,
- -- C432001_0.Cenozoic,
- -- C432001_1.Quaternary)
-
- P_P_Object : C432001_1.P_P; -- default is (150,
- -- C432001_0.Mesozoic,
- -- C432001_1.Jurassic)
-
- P_P_Null_Ob:C432001_1.P_P_Null := (P_Object with null record);
-
- N_N_N_Object : C432001_2.N_N_N :=
- (N_N_Object with Sample_On_Loan => Report.Ident_Bool(True));
-
- N_P_N_Object : C432001_2.N_P_N :=
- (N_P_Object with Sample_On_Loan => Report.Ident_Bool(False));
-
- P_N_N_Object : C432001_2.P_N_N :=
- (P_N_Object with Sample_On_Loan => Report.Ident_Bool(True));
-
- P_P_N_Object : C432001_2.P_P_N :=
- (P_P_Object with Sample_On_Loan => Report.Ident_Bool(False));
-
- P_N_Object_2 : C432001_1.P_N := (C432001_0.P(P_N_N_Object)
- with C432001_1.Carboniferous);
-
- N_N_Object_2 : C432001_1.N_N := (C432001_0.N'(42,C432001_0.Precambrian)
- with C432001_1.Carboniferous);
-
-begin
-
- Report.Test ("C432001", "Extension aggregates");
-
- -- check ultimate ancestor types
-
- if not C432001_0.Check (N_Object,
- 375,
- C432001_0.Paleozoic) then
- Report.Failed ("Object of " &
- "nonprivate type " &
- "failed content check");
- end if;
-
- if not C432001_0.Check (P_Object) then
- Report.Failed ("Object of " &
- "private type " &
- "failed content check");
- end if;
-
- -- check direct type extensions
-
- if not C432001_1.Check (N_N_Object,
- 375,
- C432001_0.Paleozoic,
- C432001_1.Devonian) then
- Report.Failed ("Object of " &
- "nonprivate extension of nonprivate type " &
- "failed content check");
- end if;
-
- if not C432001_1.Check (N_P_Object) then
- Report.Failed ("Object of " &
- "private extension of nonprivate type " &
- "failed content check");
- end if;
-
- if not C432001_1.Check (P_N_Object,
- C432001_1.Jurassic) then
- Report.Failed ("Object of " &
- "nonprivate extension of private type " &
- "failed content check");
- end if;
-
- if not C432001_1.Check (P_P_Object) then
- Report.Failed ("Object of " &
- "private extension of private type " &
- "failed content check");
- end if;
-
- if not C432001_1.Check (P_P_Null_Ob) then
- Report.Failed ("Object of " &
- "private type " &
- "failed content check");
- end if;
-
-
- -- check direct extensions of extensions
-
- if not C432001_2.Check (N_N_N_Object,
- 375,
- C432001_0.Paleozoic,
- C432001_1.Devonian,
- True) then
- Report.Failed ("Object of " &
- "nonprivate extension of nonprivate extension " &
- "(of nonprivate parent) " &
- "failed content check");
- end if;
-
- if not C432001_2.Check (N_P_N_Object, False) then
- Report.Failed ("Object of " &
- "nonprivate extension of private extension " &
- "(of nonprivate parent) " &
- "failed content check");
- end if;
-
- if not C432001_2.Check (P_N_N_Object,
- C432001_1.Jurassic,
- True) then
- Report.Failed ("Object of " &
- "nonprivate extension of nonprivate extension " &
- "(of private parent) " &
- "failed content check");
- end if;
-
- if not C432001_2.Check (P_P_N_Object, False) then
- Report.Failed ("Object of " &
- "nonprivate extension of private extension " &
- "(of private parent) " &
- "failed content check");
- end if;
-
- -- check that the extension aggregate may specify an expression of
- -- a "grandparent" ancestor type
-
- -- types tested are derived through nonprivate extensions only
- -- (extension aggregates are not allowed if the path from the
- -- ancestor type wanders through a private extension)
-
- N_N_N_Object :=
- (N_Object with Period => C432001_1.Devonian,
- Sample_On_Loan => Report.Ident_Bool(True));
-
- if not C432001_2.Check (N_N_N_Object,
- 375,
- C432001_0.Paleozoic,
- C432001_1.Devonian,
- True) then
- Report.Failed ("Object of " &
- "nonprivate extension " &
- "of nonprivate ancestor " &
- "failed content check");
- end if;
-
- P_N_N_Object :=
- (P_Object with Period => C432001_1.Jurassic,
- Sample_On_Loan => Report.Ident_Bool(True));
-
- if not C432001_2.Check (P_N_N_Object,
- C432001_1.Jurassic,
- True) then
- Report.Failed ("Object of " &
- "nonprivate extension " &
- "of private ancestor " &
- "failed content check");
- end if;
-
- -- Check additional cases
- if not C432001_1.Check (P_N_Object_2,
- C432001_1.Carboniferous) then
- Report.Failed ("Additional Object of " &
- "nonprivate extension of private type " &
- "failed content check");
- end if;
-
- if not C432001_1.Check (N_N_Object_2,
- 42,
- C432001_0.Precambrian,
- C432001_1.Carboniferous) then
- Report.Failed ("Additional Object of " &
- "nonprivate extension of nonprivate type " &
- "failed content check");
- end if;
-
- Report.Result;
-
-end C432001;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c432002.a b/gcc/testsuite/ada/acats/tests/c4/c432002.a
deleted file mode 100644
index 5de821b3052..00000000000
--- a/gcc/testsuite/ada/acats/tests/c4/c432002.a
+++ /dev/null
@@ -1,764 +0,0 @@
--- C432002.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that if an extension aggregate specifies a value for a record
--- extension and the ancestor expression has discriminants that are
--- inherited by the record extension, then a check is made that each
--- discriminant has the value specified.
---
--- Check that if an extension aggregate specifies a value for a record
--- extension and the ancestor expression has discriminants that are not
--- inherited by the record extension, then a check is made that each
--- such discriminant has the value specified for the corresponding
--- discriminant.
---
--- Check that the corresponding discriminant value may be specified
--- in the record component association list or in the derived type
--- definition for an ancestor.
---
--- Check the case of ancestors that are several generations removed.
--- Check the case where the value of the discriminant(s) in question
--- is supplied several generations removed.
---
--- Check the case of multiple discriminants.
---
--- Check that Constraint_Error is raised if the check fails.
---
--- TEST DESCRIPTION:
--- A hierarchy of tagged types is declared from a discriminated
--- root type. Each level declares two kinds of types: (1) a type
--- extension which constrains the discriminant of its parent to
--- the value of an expression and (2) a type extension that
--- constrains the discriminant of its parent to equal a new discriminant
--- of the type extension (These are the two categories of noninherited
--- discriminants).
---
--- Values for each type are declared within nested blocks. This is
--- done so that the instances that produce Constraint_Error may
--- be dealt with cleanly without forcing the program to exit.
---
--- Success and failure cases (which should raise Constraint_Error)
--- are set up for each kind of type. Additionally, for the first
--- level of the hierarchy, separate tests are done for ancestor
--- expressions specified by aggregates and those specified by
--- variables. Later tests are performed using variables only.
---
--- Additionally, the cases tested consist of the following kinds of
--- types:
---
--- Extensions of extensions, using both the parent and grandparent
--- types for the ancestor expression,
---
--- Ancestor expressions which are several generations removed
--- from the type of the aggregate,
---
--- Extensions of types with multiple discriminants, where the
--- extension declares a new discriminant which corresponds to
--- more than one discriminant of the ancestor types.
---
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 19 Dec 94 SAIC Removed RM references from objective text.
--- 20 Dec 94 SAIC Repair confusion WRT overridden discriminants
---
---!
-
-package C432002_0 is
-
- subtype Length is Natural range 0..256;
- type Discriminant (L : Length) is tagged
- record
- S1 : String (1..L);
- end record;
-
- procedure Do_Something (Rec : in out Discriminant);
- -- inherited by all type extensions
-
- -- Aggregates of Discriminant are of the form
- -- (L, S1) where L= S1'Length
-
- -- Discriminant of parent constrained to value of an expression
- type Constrained_Discriminant_Extension is
- new Discriminant (L => 10)
- with record
- S2 : String (1..20);
- end record;
-
- -- Aggregates of Constrained_Discriminant_Extension are of the form
- -- (L, S1, S2), where L = S1'Length = 10, S2'Length = 20
-
- type Once_Removed is new Constrained_Discriminant_Extension
- with record
- S3 : String (1..3);
- end record;
-
- type Twice_Removed is new Once_Removed
- with record
- S4 : String (1..8);
- end record;
-
- -- Aggregates of Twice_Removed are of the form
- -- (L, S1, S2, S3, S4), where L = S1'Length = 10,
- -- S2'Length = 20,
- -- S3'Length = 3,
- -- S4'Length = 8
-
- -- Discriminant of parent constrained to equal new discriminant
- type New_Discriminant_Extension (N : Length) is
- new Discriminant (L => N) with
- record
- S2 : String (1..N);
- end record;
-
- -- Aggregates of New_Discriminant_Extension are of the form
- -- (N, S1, S2), where N = S1'Length = S2'Length
-
- -- Discriminant of parent extension constrained to the value of
- -- an expression
- type Constrained_Extension_Extension is
- new New_Discriminant_Extension (N => 20)
- with record
- S3 : String (1..5);
- end record;
-
- -- Aggregates of Constrained_Extension_Extension are of the form
- -- (N, S1, S2, S3), where N = S1'Length = S2'Length = 20,
- -- S3'Length = 5
-
- -- Discriminant of parent extension constrained to equal a new
- -- discriminant
- type New_Extension_Extension (I : Length) is
- new New_Discriminant_Extension (N => I)
- with record
- S3 : String (1..I);
- end record;
-
- -- Aggregates of New_Extension_Extension are of the form
- -- (I, S1, 2, S3), where
- -- I = S1'Length = S2'Length = S3'Length
-
- type Multiple_Discriminants (A, B : Length) is tagged
- record
- S1 : String (1..A);
- S2 : String (1..B);
- end record;
-
- procedure Do_Something (Rec : in out Multiple_Discriminants);
- -- inherited by type extension
-
- -- Aggregates of Multiple_Discriminants are of the form
- -- (A, B, S1, S2), where A = S1'Length, B = S2'Length
-
- type Multiple_Discriminant_Extension (C : Length) is
- new Multiple_Discriminants (A => C, B => C)
- with record
- S3 : String (1..C);
- end record;
-
- -- Aggregates of Multiple_Discriminant_Extension are of the form
- -- (A, B, S1, S2, C, S3), where
- -- A = B = C = S1'Length = S2'Length = S3'Length
-
-end C432002_0;
-
-with Report;
-package body C432002_0 is
-
- S : String (1..20) := "12345678901234567890";
-
- procedure Do_Something (Rec : in out Discriminant) is
- begin
- Rec.S1 := Report.Ident_Str (S (1..Rec.L));
- end Do_Something;
-
- procedure Do_Something (Rec : in out Multiple_Discriminants) is
- begin
- Rec.S1 := Report.Ident_Str (S (1..Rec.A));
- end Do_Something;
-
-end C432002_0;
-
-
-with C432002_0;
-with Report;
-procedure C432002 is
-
- -- Various different-sized strings for variety
- String_3 : String (1..3) := Report.Ident_Str("123");
- String_5 : String (1..5) := Report.Ident_Str("12345");
- String_8 : String (1..8) := Report.Ident_Str("12345678");
- String_10 : String (1..10) := Report.Ident_Str("1234567890");
- String_11 : String (1..11) := Report.Ident_Str("12345678901");
- String_20 : String (1..20) := Report.Ident_Str("12345678901234567890");
-
-begin
-
- Report.Test ("C432002",
- "Extension aggregates for discriminated types");
-
- --------------------------------------------------------------------
- -- Extension constrains parent's discriminant to value of expression
- --------------------------------------------------------------------
-
- -- Successful cases - value matches corresponding discriminant value
-
- CD_Matched_Aggregate:
- begin
- declare
- CD : C432002_0.Constrained_Discriminant_Extension :=
- (C432002_0.Discriminant'(L => 10,
- S1 => String_10)
- with S2 => String_20);
- begin
- C432002_0.Do_Something(CD); -- success
- end;
- exception
- when Constraint_Error =>
- Report.Comment ("Ancestor expression is an aggregate");
- Report.Failed ("Aggregate of extension " &
- "with discriminant constrained: " &
- "Constraint_Error was incorrectly raised " &
- "for value that matches corresponding " &
- "discriminant");
- end CD_Matched_Aggregate;
-
- CD_Matched_Variable:
- begin
- declare
- D : C432002_0.Discriminant(L => 10) :=
- C432002_0.Discriminant'(L => 10,
- S1 => String_10);
-
- CD : C432002_0.Constrained_Discriminant_Extension :=
- (D with S2 => String_20);
- begin
- C432002_0.Do_Something(CD); -- success
- end;
- exception
- when Constraint_Error =>
- Report.Comment ("Ancestor expression is a variable");
- Report.Failed ("Aggregate of extension " &
- "with discriminant constrained: " &
- "Constraint_Error was incorrectly raised " &
- "for value that matches corresponding " &
- "discriminant");
- end CD_Matched_Variable;
-
-
- -- Unsuccessful cases - value does not match value of corresponding
- -- discriminant. Constraint_Error should be
- -- raised.
-
- CD_Unmatched_Aggregate:
- begin
- declare
- CD : C432002_0.Constrained_Discriminant_Extension :=
- (C432002_0.Discriminant'(L => 5,
- S1 => String_5)
- with S2 => String_20);
- begin
- Report.Comment ("Ancestor expression is an aggregate");
- Report.Failed ("Aggregate of extension " &
- "with discriminant constrained: " &
- "Constraint_Error was not raised " &
- "for discriminant value that does not match " &
- "corresponding discriminant");
- C432002_0.Do_Something(CD); -- disallow unused var optimization
- end;
- exception
- when Constraint_Error =>
- null; -- raise of Constraint_Error is expected
- end CD_Unmatched_Aggregate;
-
- CD_Unmatched_Variable:
- begin
- declare
- D : C432002_0.Discriminant(L => 5) :=
- C432002_0.Discriminant'(L => 5,
- S1 => String_5);
-
- CD : C432002_0.Constrained_Discriminant_Extension :=
- (D with S2 => String_20);
- begin
- Report.Comment ("Ancestor expression is an variable");
- Report.Failed ("Aggregate of extension " &
- "with discriminant constrained: " &
- "Constraint_Error was not raised " &
- "for discriminant value that does not match " &
- "corresponding discriminant");
- C432002_0.Do_Something(CD); -- disallow unused var optimization
- end;
- exception
- when Constraint_Error =>
- null; -- raise of Constraint_Error is expected
- end CD_Unmatched_Variable;
-
- -----------------------------------------------------------------------
- -- Extension constrains parent's discriminant to equal new discriminant
- -----------------------------------------------------------------------
-
- -- Successful cases - value matches corresponding discriminant value
-
- ND_Matched_Aggregate:
- begin
- declare
- ND : C432002_0.New_Discriminant_Extension (N => 8) :=
- (C432002_0.Discriminant'(L => 8,
- S1 => String_8)
- with N => 8,
- S2 => String_8);
- begin
- C432002_0.Do_Something(ND); -- success
- end;
- exception
- when Constraint_Error =>
- Report.Comment ("Ancestor expression is an aggregate");
- Report.Failed ("Aggregate of extension " &
- "with new discriminant: " &
- "Constraint_Error was incorrectly raised " &
- "for value that matches corresponding " &
- "discriminant");
- end ND_Matched_Aggregate;
-
- ND_Matched_Variable:
- begin
- declare
- D : C432002_0.Discriminant(L => 3) :=
- C432002_0.Discriminant'(L => 3,
- S1 => String_3);
-
- ND : C432002_0.New_Discriminant_Extension (N => 3) :=
- (D with N => 3,
- S2 => String_3);
- begin
- C432002_0.Do_Something(ND); -- success
- end;
- exception
- when Constraint_Error =>
- Report.Comment ("Ancestor expression is an variable");
- Report.Failed ("Aggregate of extension " &
- "with new discriminant: " &
- "Constraint_Error was incorrectly raised " &
- "for value that matches corresponding " &
- "discriminant");
- end ND_Matched_Variable;
-
-
- -- Unsuccessful cases - value does not match value of corresponding
- -- discriminant. Constraint_Error should be
- -- raised.
-
- ND_Unmatched_Aggregate:
- begin
- declare
- ND : C432002_0.New_Discriminant_Extension (N => 20) :=
- (C432002_0.Discriminant'(L => 11,
- S1 => String_11)
- with N => 20,
- S2 => String_20);
- begin
- Report.Comment ("Ancestor expression is an aggregate");
- Report.Failed ("Aggregate of extension " &
- "with new discriminant: " &
- "Constraint_Error was not raised " &
- "for discriminant value that does not match " &
- "corresponding discriminant");
- C432002_0.Do_Something(ND); -- disallow unused var optimization
- end;
- exception
- when Constraint_Error =>
- null; -- raise is expected
- end ND_Unmatched_Aggregate;
-
- ND_Unmatched_Variable:
- begin
- declare
- D : C432002_0.Discriminant(L => 5) :=
- C432002_0.Discriminant'(L => 5,
- S1 => String_5);
-
- ND : C432002_0.New_Discriminant_Extension (N => 20) :=
- (D with N => 20,
- S2 => String_20);
- begin
- Report.Comment ("Ancestor expression is an variable");
- Report.Failed ("Aggregate of extension " &
- "with new discriminant: " &
- "Constraint_Error was not raised " &
- "for discriminant value that does not match " &
- "corresponding discriminant");
- C432002_0.Do_Something(ND); -- disallow unused var optimization
- end;
- exception
- when Constraint_Error =>
- null; -- raise is expected
- end ND_Unmatched_Variable;
-
- --------------------------------------------------------------------
- -- Extension constrains parent's discriminant to value of expression
- -- Parent is a discriminant extension
- --------------------------------------------------------------------
-
- -- Successful cases - value matches corresponding discriminant value
-
- CE_Matched_Aggregate:
- begin
- declare
- CE : C432002_0.Constrained_Extension_Extension :=
- (C432002_0.Discriminant'(L => 20,
- S1 => String_20)
- with N => 20,
- S2 => String_20,
- S3 => String_5);
- begin
- C432002_0.Do_Something(CE); -- success
- end;
- exception
- when Constraint_Error =>
- Report.Comment ("Ancestor expression is an aggregate");
- Report.Failed ("Aggregate of extension (of extension) " &
- "with discriminant constrained: " &
- "Constraint_Error was incorrectly raised " &
- "for value that matches corresponding " &
- "discriminant");
- end CE_Matched_Aggregate;
-
- CE_Matched_Variable:
- begin
- declare
- ND : C432002_0.New_Discriminant_Extension (N => 20) :=
- C432002_0.New_Discriminant_Extension'
- (N => 20,
- S1 => String_20,
- S2 => String_20);
-
- CE : C432002_0.Constrained_Extension_Extension :=
- (ND with S3 => String_5);
- begin
- C432002_0.Do_Something(CE); -- success
- end;
- exception
- when Constraint_Error =>
- Report.Comment ("Ancestor expression is a variable");
- Report.Failed ("Aggregate of extension (of extension) " &
- "with discriminant constrained: " &
- "Constraint_Error was incorrectly raised " &
- "for value that matches corresponding " &
- "discriminant");
- end CE_Matched_Variable;
-
-
- -- Unsuccessful cases - value does not match value of corresponding
- -- discriminant. Constraint_Error should be
- -- raised.
-
- CE_Unmatched_Aggregate:
- begin
- declare
- CE : C432002_0.Constrained_Extension_Extension :=
- (C432002_0.New_Discriminant_Extension'
- (N => 11,
- S1 => String_11,
- S2 => String_11)
- with S3 => String_5);
- begin
- Report.Comment ("Ancestor expression is an aggregate");
- Report.Failed ("Aggregate of extension (of extension) " &
- "Constraint_Error was not raised " &
- "with discriminant constrained: " &
- "for discriminant value that does not match " &
- "corresponding discriminant");
- C432002_0.Do_Something(CE); -- disallow unused var optimization
- end;
- exception
- when Constraint_Error =>
- null; -- raise of Constraint_Error is expected
- end CE_Unmatched_Aggregate;
-
- CE_Unmatched_Variable:
- begin
- declare
- D : C432002_0.Discriminant(L => 8) :=
- C432002_0.Discriminant'(L => 8,
- S1 => String_8);
-
- CE : C432002_0.Constrained_Extension_Extension :=
- (D with N => 8,
- S2 => String_8,
- S3 => String_5);
- begin
- Report.Comment ("Ancestor expression is a variable");
- Report.Failed ("Aggregate of extension (of extension) " &
- "with discriminant constrained: " &
- "Constraint_Error was not raised " &
- "for discriminant value that does not match " &
- "corresponding discriminant");
- C432002_0.Do_Something(CE); -- disallow unused var optimization
- end;
- exception
- when Constraint_Error =>
- null; -- raise of Constraint_Error is expected
- end CE_Unmatched_Variable;
-
- -----------------------------------------------------------------------
- -- Extension constrains parent's discriminant to equal new discriminant
- -- Parent is a discriminant extension
- -----------------------------------------------------------------------
-
- -- Successful cases - value matches corresponding discriminant value
-
- NE_Matched_Aggregate:
- begin
- declare
- NE : C432002_0.New_Extension_Extension (I => 8) :=
- (C432002_0.Discriminant'(L => 8,
- S1 => String_8)
- with I => 8,
- S2 => String_8,
- S3 => String_8);
- begin
- C432002_0.Do_Something(NE); -- success
- end;
- exception
- when Constraint_Error =>
- Report.Comment ("Ancestor expression is an aggregate");
- Report.Failed ("Aggregate of extension (of extension) " &
- "with new discriminant: " &
- "Constraint_Error was incorrectly raised " &
- "for value that matches corresponding " &
- "discriminant");
- end NE_Matched_Aggregate;
-
- NE_Matched_Variable:
- begin
- declare
- ND : C432002_0.New_Discriminant_Extension (N => 3) :=
- C432002_0.New_Discriminant_Extension'
- (N => 3,
- S1 => String_3,
- S2 => String_3);
-
- NE : C432002_0.New_Extension_Extension (I => 3) :=
- (ND with I => 3,
- S3 => String_3);
- begin
- C432002_0.Do_Something(NE); -- success
- end;
- exception
- when Constraint_Error =>
- Report.Comment ("Ancestor expression is a variable");
- Report.Failed ("Aggregate of extension (of extension) " &
- "with new discriminant: " &
- "Constraint_Error was incorrectly raised " &
- "for value that matches corresponding " &
- "discriminant");
- end NE_Matched_Variable;
-
-
- -- Unsuccessful cases - value does not match value of corresponding
- -- discriminant. Constraint_Error should be
- -- raised.
-
- NE_Unmatched_Aggregate:
- begin
- declare
- NE : C432002_0.New_Extension_Extension (I => 8) :=
- (C432002_0.New_Discriminant_Extension'
- (C432002_0.Discriminant'(L => 11,
- S1 => String_11)
- with N => 11,
- S2 => String_11)
- with I => 8,
- S3 => String_8);
- begin
- Report.Comment ("Ancestor expression is an extension aggregate");
- Report.Failed ("Aggregate of extension (of extension) " &
- "with new discriminant: " &
- "Constraint_Error was not raised " &
- "for discriminant value that does not match " &
- "corresponding discriminant");
- C432002_0.Do_Something(NE); -- disallow unused var optimization
- end;
- exception
- when Constraint_Error =>
- null; -- raise is expected
- end NE_Unmatched_Aggregate;
-
- NE_Unmatched_Variable:
- begin
- declare
- D : C432002_0.Discriminant(L => 5) :=
- C432002_0.Discriminant'(L => 5,
- S1 => String_5);
-
- NE : C432002_0.New_Extension_Extension (I => 20) :=
- (D with I => 5,
- S2 => String_5,
- S3 => String_20);
- begin
- Report.Comment ("Ancestor expression is a variable");
- Report.Failed ("Aggregate of extension (of extension) " &
- "with new discriminant: " &
- "Constraint_Error was not raised " &
- "for discriminant value that does not match " &
- "corresponding discriminant");
- C432002_0.Do_Something(NE); -- disallow unused var optimization
- end;
- exception
- when Constraint_Error =>
- null; -- raise is expected
- end NE_Unmatched_Variable;
-
- -----------------------------------------------------------------------
- -- Corresponding discriminant is two levels deeper than aggregate
- -----------------------------------------------------------------------
-
- -- Successful case - value matches corresponding discriminant value
-
- TR_Matched_Variable:
- begin
- declare
- D : C432002_0.Discriminant (L => 10) :=
- C432002_0.Discriminant'(L => 10,
- S1 => String_10);
-
- TR : C432002_0.Twice_Removed :=
- C432002_0.Twice_Removed'(D with S2 => String_20,
- S3 => String_3,
- S4 => String_8);
- -- N is constrained to a value in the derived_type_definition
- -- of Constrained_Discriminant_Extension. Its omission from
- -- the above record_component_association_list is allowed by
- -- 4.3.2(6).
-
- begin
- C432002_0.Do_Something(TR); -- success
- end;
- exception
- when Constraint_Error =>
- Report.Failed ("Aggregate of far-removed extension " &
- "with discriminant constrained: " &
- "Constraint_Error was incorrectly raised " &
- "for value that matches corresponding " &
- "discriminant");
- end TR_Matched_Variable;
-
-
- -- Unsuccessful case - value does not match value of corresponding
- -- discriminant. Constraint_Error should be
- -- raised.
-
- TR_Unmatched_Variable:
- begin
- declare
- D : C432002_0.Discriminant (L => 5) :=
- C432002_0.Discriminant'(L => 5,
- S1 => String_5);
-
- TR : C432002_0.Twice_Removed :=
- C432002_0.Twice_Removed'(D with S2 => String_20,
- S3 => String_3,
- S4 => String_8);
-
- begin
- Report.Failed ("Aggregate of far-removed extension " &
- "with discriminant constrained: " &
- "Constraint_Error was not raised " &
- "for discriminant value that does not match " &
- "corresponding discriminant");
- C432002_0.Do_Something(TR); -- disallow unused var optimization
- end;
- exception
- when Constraint_Error =>
- null; -- raise is expected
- end TR_Unmatched_Variable;
-
- ------------------------------------------------------------------------
- -- Parent has multiple discriminants.
- -- Discriminant in extension corresponds to both parental discriminants.
- ------------------------------------------------------------------------
-
- -- Successful case - value matches corresponding discriminant value
-
- MD_Matched_Variable:
- begin
- declare
- MD : C432002_0.Multiple_Discriminants (A => 10, B => 10) :=
- C432002_0.Multiple_Discriminants'(A => 10,
- B => 10,
- S1 => String_10,
- S2 => String_10);
- MDE : C432002_0.Multiple_Discriminant_Extension (C => 10) :=
- (MD with C => 10,
- S3 => String_10);
-
- begin
- C432002_0.Do_Something(MDE); -- success
- end;
- exception
- when Constraint_Error =>
- Report.Failed ("Aggregate of extension " &
- "of multiply-discriminated parent: " &
- "Constraint_Error was incorrectly raised " &
- "for value that matches corresponding " &
- "discriminant");
- end MD_Matched_Variable;
-
-
- -- Unsuccessful case - value does not match value of corresponding
- -- discriminant. Constraint_Error should be
- -- raised.
-
- MD_Unmatched_Variable:
- begin
- declare
- MD : C432002_0.Multiple_Discriminants (A => 10, B => 8) :=
- C432002_0.Multiple_Discriminants'(A => 10,
- B => 8,
- S1 => String_10,
- S2 => String_8);
- MDE : C432002_0.Multiple_Discriminant_Extension (C => 10) :=
- (MD with C => 10,
- S3 => String_10);
-
- begin
- Report.Failed ("Aggregate of extension " &
- "of multiply-discriminated parent: " &
- "Constraint_Error was not raised " &
- "for discriminant value that does not match " &
- "corresponding discriminant");
- C432002_0.Do_Something(MDE); -- disallow unused var optimization
- end;
- exception
- when Constraint_Error =>
- null; -- raise is expected
- end MD_Unmatched_Variable;
-
- Report.Result;
-
-end C432002;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c432003.a b/gcc/testsuite/ada/acats/tests/c4/c432003.a
deleted file mode 100644
index 8988992c4e4..00000000000
--- a/gcc/testsuite/ada/acats/tests/c4/c432003.a
+++ /dev/null
@@ -1,594 +0,0 @@
--- C432003.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that if the type of the ancestor part of an extension aggregate
--- has discriminants that are not inherited by the type of the aggregate,
--- and the ancestor part is a subtype mark that denotes a constrained
--- subtype, Constraint_Error is raised if: 1) any discriminant of the
--- ancestor has a different value than that specified for a corresponding
--- discriminant in the derived type definition for some ancestor of the
--- type of the aggregate, or 2) the value for the discriminant in the
--- record association list is not the value of the corresponding
--- discriminant. Check that the components of the value of the
--- aggregate not given by the record component association list are
--- initialized by default as for an object of the ancestor type.
---
--- TEST DESCRIPTION:
--- Consider:
---
--- type T (D1: ...) is tagged ...
---
--- type DT is new T with ...
--- subtype ST is DT (D1 => 3); -- Constrained subtype.
---
--- type NT1 (D2: ...) is new DT (D1 => D2) with null record;
--- type NT2 (D2: ...) is new DT (D1 => 6) with null record;
--- type NT3 is new DT (D1 => 6) with null record;
---
--- A: NT1 := (T with D2 => 6); -- OK: T is unconstrained.
--- B: NT1 := (DT with D2 => 6); -- OK: DT is unconstrained.
--- C: NT1 := (ST with D2 => 6); -- NO: ST.D1 /= D2.
---
--- D: NT2 := (T with D2 => 4); -- OK: T is unconstrained.
--- E: NT2 := (DT with D2 => 4); -- OK: DT is unconstrained.
--- F: NT2 := (ST with . . . ); -- NO: ST.D1 /= DT.D1 as specified in NT2.
---
--- G: NT3 := (T with D1 => 6); -- OK: T is unconstrained.
--- H: NT3 := (DT with D1 => 6); -- OK: DT is unconstrained.
--- I: NT3 := (ST with D1 => 6); -- NO: ST.D1 /= DT.D1 as specified in NT3.
---
--- In A, B, D, E, G, and H the ancestor part is the name of an
--- unconstrained subtype, so this rule does not apply. In C, F, and I
--- the ancestor part (ST) is the name of a constrained subtype of DT,
--- which is itself a derived type of a discriminated tagged type T. ST
--- constrains the discriminant of DT (D1) to the value 3; thus, the
--- type of any extension aggregate for which ST is the ancestor part
--- must have an ancestor which also constrained D1 to 3. F and I raise
--- Constraint_Error because NT2 and NT3, respectively, constrain D1 to
--- 6. C raises Constraint_Error because NT1 constrains D1 to the value
--- of D2, which is set to 6 in the record component association list of
--- the aggregate.
---
--- This test verifies each of the three scenarios above:
---
--- (1) Ancestor of type of aggregate constrains discriminant with
--- new discriminant.
--- (2) Ancestor of type of aggregate constrains discriminant with
--- value, and has a new discriminant part.
--- (3) Ancestor of type of aggregate constrains discriminant with
--- value, and has no discriminant part.
---
--- Verification is made for cases where the type of the aggregate is
--- once- and twice-removed from the type of the ancestor part.
---
--- Additionally, a case is included where a new discriminant corresponds
--- to multiple discriminants of the type of the ancestor part.
---
--- To test the portion of the objective concerning "initialization by
--- default," the test verifies that, after a successful aggregate
--- assignment, components not assigned an explicit value by the aggregate
--- contain the default values for the corresponding components of the
--- ancestor type.
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 15 Dec 94 SAIC Removed discriminant defaults from tagged types.
--- 17 Nov 95 SAIC ACVC 2.0.1 fixes: Corrected subtype constraint
--- for component NT_C3.Str2. Added missing component
--- checks. Removed record component update from
--- Avoid_Optimization. Fixed incorrect component
--- checks.
--- 02 Dec 95 SAIC ACVC 2.0.1 fixes: Corrected Failed comment for
--- Q case.
---
---!
-
-package C432003_0 is
-
- Default_String : constant String := "This is a default string"; -- len = 24
- Another_String : constant String := "Another default string"; -- len = 22
-
- subtype Length is Natural range 0..255;
-
- type ROOT (D1 : Length) is tagged
- record
- S1 : String (1..D1) := Default_String(1..D1);
- Acc : Natural := 356;
- end record;
-
- procedure Avoid_Optimization (Rec : in out ROOT); -- Inherited by all type
- -- extensions.
-
- type Unconstrained_Der is new ROOT with
- record
- Str1 : String(1..5) := "abcde";
- end record;
-
- subtype Constrained_Subtype is Unconstrained_Der (D1 => 10);
-
- type NT_A1 (D2 : Length) is new Unconstrained_Der (D1 => D2) with
- record
- S2 : String(1..D2); -- Inherited discrim. constrained by
- end record; -- new discriminant.
-
- type NT_A2 (D3 : Length) is new NT_A1 (D2 => D3) with
- record
- S3 : String(1..D3); -- Inherited discrim. constrained by
- end record; -- new discriminant.
-
-
- type NT_B1 (D2 : Length) is new Unconstrained_Der (D1 => 5) with
- record
- S2 : String(1..D2); -- Inherited discrim. constrained by
- end record; -- explicit value.
-
- type NT_B2 (D3 : Length) is new NT_B1 (D2 => 10) with
- record
- S3 : String(1..D3); -- Inherited discrim. constrained by
- end record; -- explicit value.
-
- type NT_B3 (D2 : Length) is new Unconstrained_Der (D1 => 10) with
- record
- S2 : String(1..D2);
- end record;
-
-
- type NT_C1 is new Unconstrained_Der (D1 => 5) with
- record
- Str2 : String(1..5); -- Inherited discrim. constrained
- end record; -- No new value.
-
- type NT_C2 (D2 : Length) is new NT_C1 with
- record
- S2 : String(1..D2); -- Inherited discrim. not further
- end record; -- constrained, new discriminant.
-
- type NT_C3 is new Unconstrained_Der(D1 => 10) with
- record
- Str2 : String(1..5);
- end record;
-
-
- type MULTI_ROOT (D1 : Length; D2 : Length) is tagged
- record
- S1 : String (1..D1) := Default_String(1..D1);
- S2 : String (1..D2) := Another_String(1..D2);
- end record;
-
- procedure Avoid_Optimization (Rec : in out MULTI_ROOT); -- Inherited by all
- -- type extensions.
-
- type Mult_Unconstr_Der is new MULTI_ROOT with
- record
- Str1 : String(1..8) := "AbCdEfGh"; -- Derived, no constraints.
- end record;
-
- -- Subtypes with constrained discriminants.
- subtype Mult_Constr_Sub1 is Mult_Unconstr_Der(D1 => 15, -- Disc. have
- D2 => 20); -- diff values
-
- subtype Mult_Constr_Sub2 is Mult_Unconstr_Der(D1 => 15, -- Disc. have
- D2 => 15); -- same value
-
- type Mult_NT_A1 (D3 : Length) is
- new Mult_Unconstr_Der (D1 => D3, D2 => D3) with
- record
- S3 : String(1..D3); -- Both inherited discriminants constrained
- end record; -- by new discriminant.
-
-end C432003_0;
-
-
- --=====================================================================--
-
-
-with Report;
-package body C432003_0 is
-
- procedure Avoid_Optimization (Rec : in out ROOT) is
- begin
- Rec.S1 := Report.Ident_Str(Rec.S1);
- end Avoid_Optimization;
-
- procedure Avoid_Optimization (Rec : in out MULTI_ROOT) is
- begin
- Rec.S1 := Report.Ident_Str(Rec.S1);
- end Avoid_Optimization;
-
-end C432003_0;
-
-
- --=====================================================================--
-
-
-with C432003_0;
-with Report;
-procedure C432003 is
-begin
-
- Report.Test("C432003", "Extension aggregates where ancestor part " &
- "is a subtype mark that denotes a constrained " &
- "subtype causing Constraint_Error if any " &
- "discriminant of the ancestor has a different " &
- "value than that specified for a corresponding " &
- "discriminant in the derived type definition " &
- "for some ancestor of the type of the aggregate");
-
- Test_Block:
- declare
-
- -- Variety of string object declarations.
- String2 : String(1..2) := Report.Ident_Str("12");
- String5 : String(1..5) := Report.Ident_Str("12345");
- String8 : String(1..8) := Report.Ident_Str("AbCdEfGh");
- String10 : String(1..10) := Report.Ident_Str("1234567890");
- String15 : String(1..15) := Report.Ident_Str("123456789012345");
- String20 : String(1..20) := Report.Ident_Str("12345678901234567890");
-
- begin
-
-
- begin
- declare
- A : C432003_0.NT_A1 := -- OK
- (C432003_0.ROOT with D2 => 5,
- Str1 => "cdefg",
- S2 => String5);
- begin
- C432003_0.Avoid_Optimization(A);
- if A.Acc /= 356 or
- A.Str1 /= "cdefg" or
- A.S2 /= String5 or
- A.D2 /= 5 or
- A.S1 /= C432003_0.Default_String(1..5)
- then
- Report.Failed("Incorrect object values for Object A");
- end if;
- end;
- exception
- when Constraint_Error =>
- Report.Failed("Constraint_Error raised for Object A");
- end;
-
-
- begin
- declare
- C: C432003_0.NT_A1 := -- OK
- (C432003_0.Constrained_Subtype with D2 => 10,
- S2 => String10);
- begin
- C432003_0.Avoid_Optimization(C);
- if C.D2 /= 10 or C.Acc /= 356 or
- C.Str1 /= "abcde" or C.S2 /= String10 or
- C.S1 /= C432003_0.Default_String(1..10)
- then
- Report.Failed("Incorrect object values for Object C");
- end if;
- end;
- exception
- when Constraint_Error =>
- Report.Failed("Constraint_Error raised for Object C");
- end;
-
-
- begin
- declare
- D: C432003_0.NT_A1 := -- C_E
- (C432003_0.Constrained_Subtype with
- D2 => Report.Ident_Int(5),
- S2 => String5);
- begin
- C432003_0.Avoid_Optimization(D);
- Report.Failed("Constraint_Error not raised for Object D");
- end;
- exception
- when Constraint_Error =>
- null; -- Raise of Constraint_Error is expected.
- end;
-
-
- begin
- declare
- E: C432003_0.NT_A2 := -- OK
- (C432003_0.Constrained_Subtype with D3 => 10,
- S2 => String10,
- S3 => String10);
- begin
- C432003_0.Avoid_Optimization(E);
- if E.D3 /= 10 or E.Acc /= 356 or
- E.Str1 /= "abcde" or E.S2 /= String10 or
- E.S3 /= String10 or
- E.S1 /= C432003_0.Default_String(1..10)
- then
- Report.Failed("Incorrect object values for Object E");
- end if;
- end;
- exception
- when Constraint_Error =>
- Report.Failed("Constraint_Error raised for Object E");
- end;
-
-
- begin
- declare
- F: C432003_0.NT_A2 := -- C_E
- (C432003_0.Constrained_Subtype with
- D3 => Report.Ident_Int(5),
- S2 => String5,
- S3 => String5);
- begin
- C432003_0.Avoid_Optimization(F);
- Report.Failed("Constraint_Error not raised for Object F");
- end;
- exception
- when Constraint_Error =>
- null; -- Raise of Constraint_Error is expected.
- end;
-
-
- begin
- declare
- G: C432003_0.NT_B2 := -- OK
- (C432003_0.ROOT with D3 => 5,
- Str1 => "cdefg",
- S2 => String10,
- S3 => String5);
- begin
- C432003_0.Avoid_Optimization(G);
- if G.D3 /= 5 or G.Acc /= 356 or
- G.Str1 /= "cdefg" or G.S2 /= String10 or
- G.S3 /= String5 or
- G.S1 /= C432003_0.Default_String(1..5)
- then
- Report.Failed("Incorrect object values for Object G");
- end if;
- end;
- exception
- when Constraint_Error =>
- Report.Failed("Constraint_Error raised for Object G");
- end;
-
-
- begin
- declare
- H: C432003_0.NT_B3 := -- OK
- (C432003_0.Unconstrained_Der with D2 => 5,
- S2 => String5);
- begin
- C432003_0.Avoid_Optimization(H);
- if H.D2 /= 5 or H.Acc /= 356 or
- H.Str1 /= "abcde" or H.S2 /= String5 or
- H.S1 /= C432003_0.Default_String(1..10)
- then
- Report.Failed("Incorrect object values for Object H");
- end if;
- end;
- exception
- when Constraint_Error =>
- Report.Failed("Constraint_Error raised for Object H");
- end;
-
-
- begin
- declare
- I: C432003_0.NT_B1 := -- C_E
- (C432003_0.Constrained_Subtype with
- D2 => Report.Ident_Int(10),
- S2 => String10);
- begin
- C432003_0.Avoid_Optimization(I);
- Report.Failed("Constraint_Error not raised for Object I");
- end;
- exception
- when Constraint_Error =>
- null; -- Raise of Constraint_Error is expected.
- end;
-
-
- begin
- declare
- J: C432003_0.NT_B2 := -- C_E
- (C432003_0.Constrained_Subtype with
- D3 => Report.Ident_Int(10),
- S2 => String10,
- S3 => String10);
- begin
- C432003_0.Avoid_Optimization(J);
- Report.Failed("Constraint_Error not raised by Object J");
- end;
- exception
- when Constraint_Error =>
- null; -- Raise of Constraint_Error is expected.
- end;
-
-
- begin
- declare
- K: C432003_0.NT_B3 := -- OK
- (C432003_0.Constrained_Subtype with D2 => 5,
- S2 => String5);
- begin
- C432003_0.Avoid_Optimization(K);
- if K.D2 /= 5 or K.Acc /= 356 or
- K.Str1 /= "abcde" or K.S2 /= String5 or
- K.S1 /= C432003_0.Default_String(1..10)
- then
- Report.Failed("Incorrect object values for Object K");
- end if;
- end;
- exception
- when Constraint_Error =>
- Report.Failed("Constraint_Error raised for Object K");
- end;
-
-
- begin
- declare
- M: C432003_0.NT_C2 := -- OK
- (C432003_0.ROOT with D2 => 10,
- Str1 => "cdefg",
- Str2 => String5,
- S2 => String10);
- begin
- C432003_0.Avoid_Optimization(M);
- if M.D2 /= 10 or M.Acc /= 356 or
- M.Str1 /= "cdefg" or M.S2 /= String10 or
- M.Str2 /= String5 or
- M.S1 /= C432003_0.Default_String(1..5)
- then
- Report.Failed("Incorrect object values for Object M");
- end if;
- end;
- exception
- when Constraint_Error =>
- Report.Failed("Constraint_Error raised for Object M");
- end;
-
-
- begin
- declare
- O: C432003_0.NT_C1 := -- C_E
- (C432003_0.Constrained_Subtype with
- Str2 => Report.Ident_Str(String5));
- begin
- C432003_0.Avoid_Optimization(O);
- Report.Failed("Constraint_Error not raised for Object O");
- end;
- exception
- when Constraint_Error =>
- null; -- Raise of Constraint_Error is expected.
- end;
-
-
- begin
- declare
- P: C432003_0.NT_C2 := -- C_E
- (C432003_0.Constrained_Subtype with
- D2 => Report.Ident_Int(10),
- Str2 => String5,
- S2 => String10);
- begin
- C432003_0.Avoid_Optimization(P);
- Report.Failed("Constraint_Error not raised by Object P");
- end;
- exception
- when Constraint_Error =>
- null; -- Raise of Constraint_Error is expected.
- end;
-
-
- begin
- declare
- Q: C432003_0.NT_C3 :=
- (C432003_0.Constrained_Subtype with Str2 => String5); -- OK
- begin
- C432003_0.Avoid_Optimization(Q);
- if Q.Str2 /= String5 or
- Q.Acc /= 356 or
- Q.Str1 /= "abcde" or
- Q.D1 /= 10 or
- Q.S1 /= C432003_0.Default_String(1..10)
- then
- Report.Failed("Incorrect object values for Object Q");
- end if;
- end;
- exception
- when Constraint_Error =>
- Report.Failed("Constraint_Error raised for Object Q");
- end;
-
-
- -- The following cases test where a new discriminant corresponds
- -- to multiple discriminants of the type of the ancestor part.
-
- begin
- declare
- S: C432003_0.Mult_NT_A1 := -- OK
- (C432003_0.Mult_Unconstr_Der with D3 => 15,
- S3 => String15);
- begin
- C432003_0.Avoid_Optimization(S);
- if S.S1 /= C432003_0.Default_String(1..15) or
- S.Str1 /= String8 or
- S.S2 /= C432003_0.Another_String(1..15) or
- S.S3 /= String15 or
- S.D3 /= 15
- then
- Report.Failed("Incorrect object values for Object S");
- end if;
- end;
- exception
- when Constraint_Error =>
- Report.Failed("Constraint_Error raised for Object S");
- end;
-
-
- begin
- declare
- U: C432003_0.Mult_NT_A1 := -- C_E
- (C432003_0.Mult_Constr_Sub1 with
- D3 => Report.Ident_Int(15),
- S3 => String15);
- begin
- C432003_0.Avoid_Optimization(U);
- Report.Failed("Constraint_Error not raised for Object U");
- end;
- exception
- when Constraint_Error =>
- null; -- Raise of Constraint_Error is expected.
- end;
-
-
- begin
- declare
- V: C432003_0.Mult_NT_A1 := -- OK
- (C432003_0.Mult_Constr_Sub2 with D3 => 15,
- S3 => String15);
- begin
- C432003_0.Avoid_Optimization(V);
- if V.D3 /= 15 or
- V.Str1 /= String8 or
- V.S3 /= String15 or
- V.S1 /= C432003_0.Default_String(1..15) or
- V.S2 /= C432003_0.Another_String(1..15)
- then
- Report.Failed("Incorrect object values for Object V");
- end if;
- end;
- exception
- when Constraint_Error =>
- Report.Failed("Constraint_Error raised for Object V");
- end;
-
-
- exception
- when others => Report.Failed("Exception raised in Test_Block");
- end Test_Block;
-
- Report.Result;
-
-end C432003;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c432004.a b/gcc/testsuite/ada/acats/tests/c4/c432004.a
deleted file mode 100644
index 3a148621115..00000000000
--- a/gcc/testsuite/ada/acats/tests/c4/c432004.a
+++ /dev/null
@@ -1,319 +0,0 @@
--- C432004.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that the type of an extension aggregate may be derived from the
--- type of the ancestor part through multiple record extensions. Check
--- for ancestor parts that are subtype marks. Check that the type of the
--- ancestor part may be abstract.
---
--- TEST DESCRIPTION:
--- This test defines the following type hierarchies:
---
--- (A) (F)
--- Abstract Abstract
--- Tagged record Tagged private
--- / \ / \
--- / (C) (G) \
--- (B) Abstract Abstract (H)
--- Record private record Private
--- extension extension extension extension
--- | | | |
--- (D) (E) (I) (J)
--- Record Record Record Record
--- extension extension extension extension
---
--- Extension aggregates for B, D, E, I, and J are constructed using each
--- of its ancestor types as the ancestor part (except for E and J, for
--- which only the immediate ancestor is used, since using A and F,
--- respectively, as the ancestor part would be illegal).
---
--- X1 : B := (A with ...);
--- X2 : D := (A with ...); X5 : I := (F with ...);
--- X3 : D := (B with ...); X6 : I := (G with ...);
--- X4 : E := (C with ...); X7 : J := (H with ...);
---
--- For each assignment of an aggregate, the value of the target object is
--- checked to ensure that the proper values for each component were
--- assigned.
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
---
---!
-
-package C432004_0 is
-
- type Drawers is record
- Building : natural;
- end record;
-
- type Location is access Drawers;
-
- type Eras is (Precambrian, Paleozoic, Mesozoic, Cenozoic);
-
- type SampleType_A is abstract tagged record
- Era : Eras := Cenozoic;
- Loc : Location;
- end record;
-
- type SampleType_F is abstract tagged private;
-
- -- The following function is needed to verify the values of the
- -- private components.
- function TC_Correct_Result (Rec : SampleType_F'Class;
- E : Eras) return Boolean;
-
-private
- type SampleType_F is abstract tagged record
- Era : Eras := Mesozoic;
- end record;
-
-end C432004_0;
-
- --==================================================================--
-
-package body C432004_0 is
-
- function TC_Correct_Result (Rec : SampleType_F'Class;
- E : Eras) return Boolean is
- begin
- return (Rec.Era = E);
- end TC_Correct_Result;
-
-end C432004_0;
-
- --==================================================================--
-
-with C432004_0;
-package C432004_1 is
-
- type Periods is
- (Aphebian, Helikian, Hadrynian,
- Cambrian, Ordovician, Silurian, Devonian, Carboniferous, Permian,
- Triassic, Jurassic, Cretaceous,
- Tertiary, Quaternary);
-
- type SampleType_B is new C432004_0.SampleType_A with record
- Period : Periods := Quaternary;
- end record;
-
- type SampleType_C is abstract new C432004_0.SampleType_A with private;
-
- -- The following function is needed to verify the values of the
- -- extension's private components.
- function TC_Correct_Result (Rec : SampleType_C'Class;
- P : Periods) return Boolean;
-
- type SampleType_G is abstract new C432004_0.SampleType_F with record
- Period : Periods := Jurassic;
- Loc : C432004_0.Location;
- end record;
-
- type SampleType_H is new C432004_0.SampleType_F with private;
-
- -- The following function is needed to verify the values of the
- -- extension's private components.
- function TC_Correct_Result (Rec : SampleType_H'Class;
- P : Periods;
- E : C432004_0.Eras) return Boolean;
-
-private
- type SampleType_C is abstract new C432004_0.SampleType_A with record
- Period : Periods := Quaternary;
- end record;
-
- type SampleType_H is new C432004_0.SampleType_F with record
- Period : Periods := Jurassic;
- end record;
-
-end C432004_1;
-
- --==================================================================--
-
-package body C432004_1 is
-
- function TC_Correct_Result (Rec : SampleType_C'Class;
- P : Periods) return Boolean is
- begin
- return (Rec.Period = P);
- end TC_Correct_Result;
-
- -------------------------------------------------------------
- function TC_Correct_Result (Rec : SampleType_H'Class;
- P : Periods;
- E : C432004_0.Eras) return Boolean is
- begin
- return (Rec.Period = P) and C432004_0.TC_Correct_Result (Rec, E);
- end TC_Correct_Result;
-
-end C432004_1;
-
- --==================================================================--
-
-with C432004_0;
-with C432004_1;
-package C432004_2 is
-
- -- All types herein are record extensions, since aggregates
- -- cannot be given for private extensions
-
- type SampleType_D is new C432004_1.SampleType_B with record
- Sample_On_Loan : Boolean := False;
- end record;
-
- type SampleType_E is new C432004_1.SampleType_C
- with null record;
-
- type SampleType_I is new C432004_1.SampleType_G with record
- Sample_On_Loan : Boolean := True;
- end record;
-
- type SampleType_J is new C432004_1.SampleType_H with record
- Sample_On_Loan : Boolean := True;
- end record;
-
-end C432004_2;
-
-
- --==================================================================--
-
-with Report;
-with C432004_0;
-with C432004_1;
-with C432004_2;
-use C432004_1;
-use C432004_2;
-
-procedure C432004 is
-
- -- Variety of extension aggregates.
-
- -- Default values for the components of SampleType_A
- -- (Era => Cenozoic, Loc => null).
- Sample_B : SampleType_B
- := (C432004_0.SampleType_A with Period => Devonian);
-
- -- Default values from SampleType_A (Era => Cenozoic, Loc => null).
- Sample_D1 : SampleType_D
- := (C432004_0.SampleType_A with Period => Cambrian,
- Sample_On_Loan => True);
-
- -- Default values from SampleType_A and SampleType_B
- -- (Era => Cenozoic, Loc => null, Period => Quaternary).
- Sample_D2 : SampleType_D
- := (SampleType_B with Sample_On_Loan => True);
-
- -- Default values from SampleType_A and SampleType_C
- -- (Era => Cenozoic, Loc => null, Period => Quaternary).
- Sample_E : SampleType_E
- := (SampleType_C with null record);
-
- -- Default value from SampleType_F (Era => Mesozoic).
- Sample_I1 : SampleType_I
- := (C432004_0.SampleType_F with Period => Tertiary,
- Loc => new C432004_0.Drawers'(Building => 9),
- Sample_On_Loan => False);
-
- -- Default values from SampleType_F and SampleType_G
- -- (Era => Mesozoic, Period => Jurassic, Loc => null).
- Sample_I2 : SampleType_I
- := (SampleType_G with Sample_On_Loan => False);
-
- -- Default values from SampleType_H (Era => Mesozoic, Period => Jurassic).
- Sample_J : SampleType_J
- := (SampleType_H with Sample_On_Loan => False);
-
- use type C432004_0.Eras;
- use type C432004_0.Location;
-
-begin
-
- Report.Test ("C432004", "Check that the type of an extension aggregate " &
- "may be derived from the type of the ancestor part through " &
- "multiple record extensions");
-
- if Sample_B /= (C432004_0.Cenozoic, null, Devonian) then
- Report.Failed ("Object of record extension of abstract ancestor, " &
- "SampleType_B, failed content check");
- end if;
-
- -------------------
- if Sample_D1 /= (Era => C432004_0.Cenozoic, Loc => null,
- Period => Cambrian, Sample_On_Loan => True) then
- Report.Failed ("Object 1 of record extension of record extension, " &
- "of abstract ancestor, SampleType_D, failed content " &
- "check");
- end if;
-
- -------------------
- if Sample_D2 /= (C432004_0.Cenozoic, null, Quaternary, True) then
- Report.Failed ("Object 2 of record extension of record extension, " &
- "of abstract ancestor, SampleType_D, failed content " &
- "check");
- end if;
- -------------------
- if Sample_E.Era /= C432004_0.Cenozoic or
- Sample_E.Loc /= null or
- not TC_Correct_Result (Sample_E, Quaternary) then
- Report.Failed ("Object of record extension of abstract private " &
- "extension of abstract ancestor, SampleType_E, " &
- "failed content check");
- end if;
-
- -------------------
- if not C432004_0.TC_Correct_Result (Sample_I1, C432004_0.Mesozoic) or
- Sample_I1.Period /= Tertiary or
- Sample_I1.Loc.Building /= 9 or
- Sample_I1.Sample_On_Loan /= False then
- Report.Failed ("Object 1 of record extension of abstract record " &
- "extension of abstract private ancestor, " &
- "SampleType_I, failed content check");
- end if;
-
- -------------------
- if not C432004_0.TC_Correct_Result (Sample_I2, C432004_0.Mesozoic) or
- Sample_I2.Period /= Jurassic or
- Sample_I2.Loc /= null or
- Sample_I2.Sample_On_Loan /= False then
- Report.Failed ("Object 2 of record extension of abstract record " &
- "extension of abstract private ancestor, " &
- "SampleType_I, failed content check");
- end if;
-
- -------------------
- if not TC_Correct_Result (Sample_J,
- Jurassic,
- C432004_0.Mesozoic) or
- Sample_J.Sample_On_Loan /= False then
- Report.Failed ("Object of record extension of private extension " &
- "of abstract private ancestor, SampleType_J, " &
- "failed content check");
- end if;
-
- Report.Result;
-
-end C432004;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c433001.a b/gcc/testsuite/ada/acats/tests/c4/c433001.a
deleted file mode 100644
index 613b688c8ca..00000000000
--- a/gcc/testsuite/ada/acats/tests/c4/c433001.a
+++ /dev/null
@@ -1,302 +0,0 @@
--- C433001.A
-
--- Grant of Unlimited Rights
---
--- The Ada Conformity Assessment Authority (ACAA) holds unlimited
--- rights in the software and documentation contained herein. Unlimited
--- rights are the same as those granted by the U.S. Government for older
--- parts of the Ada Conformity Assessment Test Suite, and are defined
--- in DFAR 252.227-7013(a)(19). By making this public release, the ACAA
--- intends to confer upon all recipients unlimited rights equal to those
--- held by the ACAA. These rights include rights to use, duplicate,
--- release or disclose the released technical data and computer software
--- in whole or in part, in any manner and for any purpose whatsoever, and
--- to have or permit others to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE
--- Check that an others choice is allowed in an array aggregate whose
--- applicable index constraint is dynamic. (This was an extension to
--- Ada 83). Check that index choices are within the applicable index
--- constraint for array aggregates with others choices.
---
--- TEST DESCRIPTION
--- In this test, we declare several unconstrained array types, and
--- several dynamic subtypes. We then test a variety of cases of using
--- appropriate aggregates. Some cases expect to raise Constraint_Error.
---
--- HISTORY:
--- 16 DEC 1999 RLB Initial Version.
-
-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/c450001.a b/gcc/testsuite/ada/acats/tests/c4/c450001.a
deleted file mode 100644
index e398ffc6371..00000000000
--- a/gcc/testsuite/ada/acats/tests/c4/c450001.a
+++ /dev/null
@@ -1,434 +0,0 @@
--- C450001.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that operations on modular types perform correctly.
---
--- Check that loops over the range of a modular type do not over or
--- under run the loop.
---
--- TEST DESCRIPTION:
--- Check logical and arithmetic operations.
--- (Attributes are tested elsewhere)
--- Checks to make sure that:
--- for X in Mod_Type loop
--- doesn't do something silly like infinite loop.
---
---
--- CHANGE HISTORY:
--- 20 SEP 95 SAIC Initial version
--- 20 FEB 96 SAIC Added underrun cases for 2.1
---
---!
-
------------------------------------------------------------------ C450001_0
-
-package C450001_0 is
-
- type Unsigned_8_Bit is mod 2**8;
-
- Shy_By_One : constant := 2**8-1;
-
- Heavy_By_Two : constant := 2**8+2;
-
- type Unsigned_Edge_8 is mod Shy_By_One;
-
- type Unsigned_Over_8 is mod Heavy_By_Two;
-
- procedure Loop_Check;
-
- -- embed some calls to Report.Ident_Int:
-
- function ID( U8B: Unsigned_8_Bit ) return Unsigned_8_Bit;
- function ID( UEB: Unsigned_Edge_8 ) return Unsigned_Edge_8;
- function ID( UOB: Unsigned_Over_8 ) return Unsigned_Over_8;
-
-end C450001_0;
-
--- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
-
-with Report;
-package body C450001_0 is
-
- procedure Loop_Check is
- Counter_Check : Natural := 0;
- begin
- for Ever in Unsigned_8_Bit loop
- Counter_Check := Report.Ident_Int(Counter_Check) + 1;
- if Counter_Check > 2**8 then
- Report.Failed("Unsigned_8_Bit loop overrun");
- exit;
- end if;
- end loop;
-
- if Counter_Check < 2**8 then
- Report.Failed("Unsigned_8_Bit loop underrun");
- end if;
-
- Counter_Check := 0;
-
- for Never in Unsigned_Edge_8 loop
- Counter_Check := Report.Ident_Int(Counter_Check) + 1;
- if Counter_Check > Shy_By_One then
- Report.Failed("Unsigned_Edge_8 loop overrun");
- exit;
- end if;
- end loop;
-
- if Counter_Check < Shy_By_One then
- Report.Failed("Unsigned_Edge_8 loop underrun");
- end if;
-
- Counter_Check := 0;
-
- for Getful in reverse Unsigned_Over_8 loop
- Counter_Check := Report.Ident_Int(Counter_Check) + 1;
- if Counter_Check > Heavy_By_Two then
- Report.Failed("Unsigned_Over_8 loop overrun");
- exit;
- end if;
- end loop;
-
- if Counter_Check < Heavy_By_Two then
- Report.Failed("Unsigned_Over_8 loop underrun");
- end if;
-
- end Loop_Check;
-
- function ID( U8B: Unsigned_8_Bit ) return Unsigned_8_Bit is
- begin
- return Unsigned_8_Bit(Report.Ident_Int(Integer(U8B)));
- end ID;
-
- function ID( UEB: Unsigned_Edge_8 ) return Unsigned_Edge_8 is
- begin
- return Unsigned_Edge_8(Report.Ident_Int(Integer(UEB)));
- end ID;
-
- function ID( UOB: Unsigned_Over_8 ) return Unsigned_Over_8 is
- begin
- return Unsigned_Over_8(Report.Ident_Int(Integer(UOB)));
- end ID;
-
-end C450001_0;
-
-------------------------------------------------------------------- C450001
-
-with Report;
-with C450001_0;
-with TCTouch;
-procedure C450001 is
- use C450001_0;
-
- BR : constant String := " produced the wrong result";
-
- procedure Is_T(B:Boolean;S:String) renames TCTouch.Assert;
- procedure Is_F(B:Boolean;S:String) renames TCTouch.Assert_Not;
-
- Whole_8_A, Whole_8_B, Whole_8_C : C450001_0.Unsigned_8_Bit;
-
- Short_8_A, Short_8_B, Short_8_C : C450001_0.Unsigned_Edge_8;
-
- Over_8_A, Over_8_B, Over_8_C : C450001_0.Unsigned_Over_8;
-
-begin -- Main test procedure. C450001
-
- Report.Test ("C450001", "Check that operations on modular types " &
- "perform correctly." );
-
-
- -- the cases for the whole 8 bit type are pretty simple
-
- Whole_8_A := 2#00000000#;
- Whole_8_B := 2#11111111#;
-
- Is_T((ID(Whole_8_A) and ID(Whole_8_B)) = 2#00000000#,"8 bit and" & BR);
- Is_T((ID(Whole_8_A) or ID(Whole_8_B)) = 2#11111111#,"8 bit or" & BR);
- Is_T((ID(Whole_8_A) xor ID(Whole_8_B)) = 2#11111111#,"8 bit xor" & BR);
-
- Whole_8_A := 2#00001111#;
- Whole_8_B := 2#11111111#;
-
- Is_T((ID(Whole_8_A) and ID(Whole_8_B)) = 2#00001111#,"8 bit and" & BR);
- Is_T((ID(Whole_8_A) or ID(Whole_8_B)) = 2#11111111#,"8 bit or" & BR);
- Is_T((ID(Whole_8_A) xor ID(Whole_8_B)) = 2#11110000#,"8 bit xor" & BR);
-
- Whole_8_A := 2#10101010#;
- Whole_8_B := 2#11110000#;
-
- Is_T((ID(Whole_8_A) and ID(Whole_8_B)) = 2#10100000#,"8 bit and" & BR);
- Is_T((ID(Whole_8_A) or ID(Whole_8_B)) = 2#11111010#,"8 bit or" & BR);
- Is_T((ID(Whole_8_A) xor ID(Whole_8_B)) = 2#01011010#,"8 bit xor" & BR);
-
- -- the cases for the partial 8 bit type involve subtracting the modulus
- -- from results that exceed the modulus.
- -- hence, any of the following operations that exceed 2#11111110# must
- -- have 2#11111111# subtracted from the result; i.e. where you would
- -- expect to see 2#11111111# as in the above operations, the correct
- -- result will be 2#00000000#. Note that 2#11111111# is not a legal
- -- value of type C450001_0.Unsigned_Edge_8.
-
- Short_8_A := 2#11100101#;
- Short_8_B := 2#00011111#;
-
- Is_T((ID(Short_8_A) and ID(Short_8_B)) = 2#00000101#,"8 short and 1" & BR);
- Is_T((ID(Short_8_A) or ID(Short_8_B)) = 2#00000000#,"8 short or 1" & BR);
- Is_T((ID(Short_8_A) xor ID(Short_8_B)) = 2#11111010#,"8 short xor 1" & BR);
-
- Short_8_A := 2#11110000#;
- Short_8_B := 2#11111110#;
-
- Is_T((ID(Short_8_A) and ID(Short_8_B)) = 2#11110000#,"8 short and 2" & BR);
- Is_T((ID(Short_8_A) or ID(Short_8_B)) = 2#11111110#,"8 short or 2" & BR);
- Is_T((ID(Short_8_A) xor ID(Short_8_B)) = 2#00001110#,"8 short xor 2" & BR);
-
- Short_8_A := 2#10101010#;
- Short_8_B := 2#01010101#;
-
- Is_T((ID(Short_8_A) and ID(Short_8_B)) = 2#00000000#,"8 short and 3" & BR);
- Is_T((ID(Short_8_A) or ID(Short_8_B)) = 2#00000000#,"8 short or 3" & BR);
- Is_T((ID(Short_8_A) xor ID(Short_8_B)) = 2#00000000#,"8 short xor 3" & BR);
-
- Short_8_A := 2#10101010#;
- Short_8_B := 2#11111110#;
-
- Is_T((ID(Short_8_A) and ID(Short_8_B)) = 2#10101010#,"8 short and 4" & BR);
- Is_T((ID(Short_8_A) or ID(Short_8_B)) = 2#11111110#,"8 short or 4" & BR);
- Is_T((ID(Short_8_A) xor ID(Short_8_B)) = 2#01010100#,"8 short xor 4" & BR);
-
- -- the cases for the over 8 bit type have similar issues to the short type
- -- however the bit patterns are a little different. The rule is to subtract
- -- the modulus (258) from any resulting value equal or greater than the
- -- modulus -- note that 258 = 2#100000010#
-
- Over_8_A := 2#100000000#;
- Over_8_B := 2#011111111#;
-
- Is_T((ID(Over_8_A) and ID(Over_8_B)) = 2#000000000#,"8 over and" & BR);
- Is_T((ID(Over_8_A) or ID(Over_8_B)) = 2#011111101#,"8 over or" & BR);
- Is_T((ID(Over_8_A) xor ID(Over_8_B)) = 2#011111101#,"8 over xor" & BR);
-
- Over_8_A := 2#100000001#;
- Over_8_B := 2#011111111#;
-
- Is_T((ID(Over_8_A) and ID(Over_8_B)) = 2#000000001#,"8 over and" & BR);
- Is_T((ID(Over_8_A) or ID(Over_8_B)) = 2#011111101#,"8 over or" & BR);
- Is_T((ID(Over_8_A) xor ID(Over_8_B)) = 2#011111100#,"8 over xor" & BR);
-
-
-
- Whole_8_A := 128;
- Whole_8_B := 255;
-
- Is_T(ID(Whole_8_A) /= ID(Whole_8_B), "8 /=" & BR);
- Is_F(ID(Whole_8_A) = ID(Whole_8_B), "8 =" & BR);
-
- Is_T(ID(Whole_8_A) <= ID(Whole_8_B), "8 <=" & BR);
- Is_T(ID(Whole_8_A) < ID(Whole_8_B), "8 < " & BR);
-
- Is_F(ID(Whole_8_A) >= ID(Whole_8_B), "8 >=" & BR);
- Is_T(ID(Whole_8_A) > ID(Whole_8_B + 7), "8 > " & BR);
-
- Is_T(ID(Whole_8_A) in ID(100)..ID(200), "8 in" & BR);
- Is_F(ID(Whole_8_A) not in ID(100)..ID(200), "8 not in" & BR);
-
- Is_F(ID(Whole_8_A) in ID(200)..ID(250), "8 in" & BR);
- Is_T(ID(Whole_8_A) not in ID(200)..ID(250), "8 not in" & BR);
-
- Short_8_A := 127;
- Short_8_B := 254;
-
- Is_T(ID(Short_8_A) /= ID(Short_8_B), "short 8 /=" & BR);
- Is_F(ID(Short_8_A) = ID(Short_8_B), "short 8 =" & BR);
-
- Is_T(ID(Short_8_A) <= ID(Short_8_B), "short 8 <=" & BR);
- Is_T(ID(Short_8_A) < ID(Short_8_B), "short 8 < " & BR);
-
- Is_F(ID(Short_8_A) >= ID(Short_8_B), "short 8 >=" & BR);
- Is_F(ID(Short_8_A) > ID(Short_8_B), "short 8 > " & BR);
-
- Is_T(ID(Short_8_A) in ID(100)..ID(200), "8 in" & BR);
- Is_F(ID(Short_8_A) not in ID(100)..ID(200), "8 not in" & BR);
-
- Is_F(ID(Short_8_A) in ID(200)..ID(250), "8 in" & BR);
- Is_T(ID(Short_8_A) not in ID(200)..ID(250), "8 not in" & BR);
-
-
- Whole_8_A := 1;
- Whole_8_B := 254;
- Short_8_A := 1;
- Short_8_B := 2;
-
- Whole_8_C := ID(Whole_8_A) + ID(Whole_8_B);
- Is_T(Whole_8_C = C450001_0.Unsigned_8_Bit'Last, "8 binary + 1" & BR);
-
- Whole_8_C := Whole_8_C + ID(Whole_8_A);
- Is_T(Whole_8_C = C450001_0.Unsigned_8_Bit'First, "8 binary + 2" & BR);
-
- Whole_8_C := ID(Whole_8_A) - ID(Whole_8_A);
- Is_T(Whole_8_C = 0, "8 binary -" & BR);
-
- Whole_8_C := Whole_8_C - ID(Whole_8_A);
- Is_T(Whole_8_C = C450001_0.Unsigned_8_Bit'Last, "8 binary + 3" & BR);
-
- Short_8_C := ID(Short_8_A) + ID(C450001_0.Unsigned_Edge_8'Last);
- Is_T(Short_8_C = C450001_0.Unsigned_Edge_8'First, "Short binary + 1" & BR);
-
- Short_8_C := Short_8_A + ID(Short_8_A);
- Is_T(Short_8_C = ID(Short_8_B), "Short binary + 2" & BR);
-
- Short_8_C := ID(Short_8_A) - ID(Short_8_A);
- Is_T(Short_8_C = 0, "Short 8 binary -" & BR);
-
- Short_8_C := Short_8_C - ID(Short_8_A);
- Is_T(Short_8_C = C450001_0.Unsigned_Edge_8'Last, "Short binary + 3" & BR);
-
-
- Whole_8_C := ( + ID(Whole_8_B) );
- Is_T(Whole_8_C = 254, "8 unary +" & BR);
-
- Whole_8_C := ( - ID(Whole_8_A) );
- Is_T(Whole_8_C = C450001_0.Unsigned_8_Bit'Last, "8 unary -" & BR);
-
- Whole_8_C := ( - ID(0) );
- Is_T(Whole_8_C = 0, "8 unary -0" & BR);
-
- Short_8_C := ( + ID(C450001_0.Unsigned_Edge_8'Last) );
- Is_T(Short_8_C = 254, "Short 8 unary +" & BR);
-
- Short_8_C := ( - ID(Short_8_A) );
- Is_T(Short_8_C = C450001_0.Unsigned_Edge_8'Last, "Short 8 unary -" & BR);
-
-
- Whole_8_A := 20;
- Whole_8_B := 255;
-
- Whole_8_C := ID(Whole_8_A) * ID(Whole_8_B); -- 5100 = 19*256 + 236 (256-20)
- Is_T(Whole_8_C = 236, "8 *" & BR);
-
- Short_8_A := 9;
- Short_8_B := 254;
-
- Short_8_C := ID(Short_8_A) * ID(Short_8_B); -- 2286 = 8*255 + 246 (255-9)
- Is_T(Short_8_C = 246, "short 8 *" & BR);
-
- Over_8_A := 12;
- Over_8_B := 86;
-
- Over_8_C := ID(Over_8_A) * ID(Over_8_B); -- 1032 = 4*258 + 0
- Is_T(Over_8_C = 0, "over 8 *" & BR);
-
-
- Whole_8_A := 255;
- Whole_8_B := 4;
-
- Whole_8_C := ID(Whole_8_A) / ID(Whole_8_B);
- Is_T(Whole_8_C = 63, "8 /" & BR);
-
- Short_8_A := 253;
- Short_8_B := 127;
-
- Short_8_C := ID(Short_8_A) / ID(Short_8_B);
- Is_T(Short_8_C = 1, "short 8 / 1" & BR);
-
- Short_8_C := ID(Short_8_A) / ID(126);
- Is_T(Short_8_C = 2, "short 8 / 2" & BR);
-
-
- Whole_8_A := 255;
- Whole_8_B := 254;
-
- Whole_8_C := ID(Whole_8_A) rem ID(Whole_8_B);
- Is_T(Whole_8_C = 1, "8 rem" & BR);
-
- Short_8_A := 222;
- Short_8_B := 111;
-
- Short_8_C := ID(Short_8_A) rem ID(Short_8_B);
- Is_T(Short_8_C = 0, "short 8 rem" & BR);
-
-
- Whole_8_A := 99;
- Whole_8_B := 9;
-
- Whole_8_C := ID(Whole_8_A) mod ID(Whole_8_B);
- Is_T(Whole_8_C = 0, "8 mod" & BR);
-
- Short_8_A := 254;
- Short_8_B := 250;
-
- Short_8_C := ID(Short_8_A) mod ID(Short_8_B);
- Is_T(Short_8_C = 4, "short 8 mod" & BR);
-
-
- Whole_8_A := 99;
-
- Whole_8_C := abs Whole_8_A;
- Is_T(Whole_8_C = ID(99), "8 abs" & BR);
-
- Short_8_A := 254;
-
- Short_8_C := ID( abs Short_8_A );
- Is_T(Short_8_C = 254, "short 8 abs" & BR);
-
-
- Whole_8_B := 2#00001111#;
-
- Whole_8_C := not Whole_8_B;
- Is_T(Whole_8_C = ID(2#11110000#), "8 not" & BR);
-
- Short_8_B := 2#00001111#; -- 15
-
- Short_8_C := ID( not Short_8_B ); -- 254 - 15
- Is_T(Short_8_C = 2#11101111#, "short 8 not" & BR); -- 239
-
-
- Whole_8_A := 2;
-
- Whole_8_C := Whole_8_A ** 7;
- Is_T(Whole_8_C = ID(128), "2 ** 7, whole 8" & BR);
-
- Whole_8_C := Whole_8_A ** 9;
- Is_T(Whole_8_C = ID(0), "2 ** 9, whole 8" & BR);
-
- Short_8_A := 4;
-
- Short_8_C := ID( Short_8_A ) ** 4;
- Is_T(Short_8_C = 1, "4 ** 4, short" & BR);
-
- Over_8_A := 4;
-
- Over_8_C := ID( Over_8_A ) ** 4;
- Is_T(Over_8_C = 256, "4 ** 4, over" & BR);
-
- Over_8_C := ID( Over_8_A ) ** 5; -- 1024 = 3*258 + 250
- Is_T(Over_8_C = 250, "4 ** 5, over" & BR);
-
-
- C450001_0.Loop_Check;
-
- Report.Result;
-
-end C450001;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c452001.a b/gcc/testsuite/ada/acats/tests/c4/c452001.a
deleted file mode 100644
index ec78cd2a5a0..00000000000
--- a/gcc/testsuite/ada/acats/tests/c4/c452001.a
+++ /dev/null
@@ -1,707 +0,0 @@
--- C452001.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- For a type extension, check that predefined equality is defined in
--- terms of the primitive equals operator of the parent type and any
--- tagged components of the extension part.
---
--- For other composite types, check that the primitive equality operator
--- of any matching tagged components is used to determine equality of the
--- enclosing type.
---
--- For private types, check that predefined equality is defined in
--- terms of the user-defined (primitive) operator of the full type if
--- the full type is tagged. The partial view of the type may be
--- tagged or untagged. Check that predefined equality for a private
--- type whose full view is untagged is defined in terms of the
--- predefined equality operator of its full type.
---
--- TEST DESCRIPTION:
--- Tagged types are declared and used as components in several
--- differing composite type declarations, both tagged and untagged.
--- To differentiate between predefined and primitive equality
--- operations, user-defined equality operators are declared for
--- each component type that is to contribute to the equality
--- operator of the composite type that houses it. All user-defined
--- equality operations are designed to yield the opposite result
--- from the predefined operator, given the same component values.
---
--- For cases where primitive equality is to be incorporated into
--- equality for the enclosing composite type, values are assigned
--- to the component type so that user-defined equality will return
--- True. If predefined equality is to be used instead, then the
--- same strategy results in the equality operator returning False.
---
--- When equality for a type incorporates the user-defined equality
--- operator of one of its component types, the resulting operator
--- is considered to be the predefined operator of the composite type.
--- This case is confirmed by defining an tagged component of an
--- untagged composite type, then using the resulting untagged type
--- as a component of another composite type. The user-defined operator
--- for the lowest level should still be called.
---
--- Three cases are set up to test private types:
---
--- Case 1 Case 2 Case 3
--- partial view: tagged untagged untagged
--- full view: tagged tagged untagged
---
--- Types are declared for each of the above cases and user-defined
--- (primitive) operators are declared following the full type
--- declaration of each type (i.e., in the private part).
---
--- Values are assigned into objects of these types using the same
--- strategy outlined above. Cases 1 and 2 should execute the
--- user-defined operator. Case 3 should ignore the user-defined
--- operator and user predefined equality for the type.
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 19 Dec 94 SAIC Removed RM references from objective text.
--- 15 Nov 95 SAIC Fixed for 2.0.1
--- 04 NOV 96 SAIC Typographical revision
---
---!
-
-package c452001_0 is
-
- type Point is
- record
- X : Integer := 0;
- Y : Integer := 0;
- end record;
-
- type Circle is tagged
- record
- Center : Point;
- Radius : Integer;
- end record;
-
- function "=" (L, R : Circle) return Boolean;
-
- type Colors is (Red, Orange, Yellow, Green, Blue, Purple, Black, White);
-
- type Colored_Circle is new Circle
- with record
- Color : Colors := White;
- end record;
-
- function "=" (L, R : Colored_Circle) return Boolean;
- -- Override predefined equality for this tagged type. Predefined
- -- equality should incorporate user-defined (primitive) equality
- -- from type Circle. See C340001 for a test of that feature.
-
- -- Equality is overridden to ensure that predefined equality
- -- incorporates this user-defined function for
- -- any composite type with Colored_Circle as a component type.
- -- (i.e., the type extension is recognized as a tagged type for
- -- the purpose of defining predefined equality for the composite type).
-
-end C452001_0;
-
-package body c452001_0 is
-
- function "=" (L, R : Circle) return Boolean is
- begin
- return L.Radius = R.Radius; -- circles are same size
- end "=";
-
- function "=" (L, R : Colored_Circle) return Boolean is
- begin
- return Circle(L) = Circle(R);
- end "=";
-
-end C452001_0;
-
-with C452001_0;
-package C452001_1 is
-
- type Planet is tagged record
- Name : String (1..15);
- Representation : C452001_0.Colored_Circle;
- end record;
-
- -- Type Planet will be used to check that predefined equality
- -- for a tagged type with a tagged component incorporates
- -- user-defined equality for the component type.
-
- type TC_Planet is new Planet with null record;
-
- -- A "copy" of Planet. Used to create a type extension. An "="
- -- operator will be defined for this type that should be
- -- incorporated by the type extension.
-
- function "=" (Arg1, Arg2 : in TC_Planet) return Boolean;
-
- type Craters is array (1..3) of C452001_0.Colored_Circle;
-
- -- An array type (untagged) with tagged components
-
- type Moon is new TC_Planet
- with record
- Crater : Craters;
- end record;
-
- -- A tagged record type. Extended component type is untagged,
- -- but its predefined equality operator should incorporate
- -- the user-defined operator of its tagged component type.
-
-end C452001_1;
-
-package body C452001_1 is
-
- function "=" (Arg1, Arg2 : in TC_Planet) return Boolean is
- begin
- return Arg1.Name = Arg2.Name;
- end "=";
-
-end C452001_1;
-
-package C452001_2 is
-
- -- Untagged record types
- -- Equality should not be incorporated
-
- type Spacecraft_Design is (Mariner, Pioneer, Viking, Voyager);
- type Spacecraft is record
- Design : Spacecraft_Design;
- Operational : Boolean;
- end record;
-
- function "=" (L : in Spacecraft; R : in Spacecraft) return Boolean;
-
- type Mission is record
- Craft : Spacecraft;
- Launch_Date : Natural;
- end record;
-
- type Inventory is array (Positive range <>) of Spacecraft;
-
-end C452001_2;
-
-package body C452001_2 is
-
- function "=" (L : in Spacecraft; R : in Spacecraft) return Boolean is
- begin
- return L.Design = R.Design;
- end "=";
-
-end C452001_2;
-
-package C452001_3 is
-
- type Tagged_Partial_Tagged_Full is tagged private;
- procedure Change (Object : in out Tagged_Partial_Tagged_Full;
- Value : in Boolean);
-
- type Untagged_Partial_Tagged_Full is private;
- procedure Change (Object : in out Untagged_Partial_Tagged_Full;
- Value : in Integer);
-
- type Untagged_Partial_Untagged_Full is private;
- procedure Change (Object : in out Untagged_Partial_Untagged_Full;
- Value : in Duration);
-
-private
-
- type Tagged_Partial_Tagged_Full is
- tagged record
- B : Boolean := True;
- C : Character := ' ';
- end record;
- -- predefined equality checks that all components are equal
-
- function "=" (L, R : in Tagged_Partial_Tagged_Full) return Boolean;
- -- primitive equality checks that records equate in component C only
-
- type Untagged_Partial_Tagged_Full is
- tagged record
- I : Integer := 0;
- P : Positive := 1;
- end record;
- -- predefined equality checks that all components are equal
-
- function "=" (L, R : in Untagged_Partial_Tagged_Full) return Boolean;
- -- primitive equality checks that records equate in component P only
-
- type Untagged_Partial_Untagged_Full is
- record
- D : Duration := 0.0;
- S : String (1..12) := "Ada 9X rules";
- end record;
- -- predefined equality checks that all components are equal
-
- function "=" (L, R : in Untagged_Partial_Untagged_Full) return Boolean;
- -- primitive equality checks that records equate in component S only
-
-end C452001_3;
-
-with Report;
-package body C452001_3 is
-
- procedure Change (Object : in out Tagged_Partial_Tagged_Full;
- Value : in Boolean) is
- begin
- Object := (Report.Ident_Bool(Value), Object.C);
- end Change;
-
- procedure Change (Object : in out Untagged_Partial_Tagged_Full;
- Value : in Integer) is
- begin
- Object := (Report.Ident_Int(Value), Object.P);
- end Change;
-
- procedure Change (Object : in out Untagged_Partial_Untagged_Full;
- Value : in Duration) is
- begin
- Object := (Value, Report.Ident_Str(Object.S));
- end Change;
-
- function "=" (L, R : in Tagged_Partial_Tagged_Full) return Boolean is
- begin
- return L.C = R.C;
- end "=";
-
- function "=" (L, R : in Untagged_Partial_Tagged_Full) return Boolean is
- begin
- return L.P = R.P;
- end "=";
-
- function "=" (L, R : in Untagged_Partial_Untagged_Full) return Boolean is
- begin
- return R.S = L.S;
- end "=";
-
-end C452001_3;
-
-
-with C452001_0;
-with C452001_1;
-with C452001_2;
-with C452001_3;
-with Report;
-procedure C452001 is
-
- Mars_Aphelion : C452001_1.Planet :=
- (Name => "Mars ",
- Representation => (Center => (Report.Ident_Int(20),
- Report.Ident_Int(0)),
- Radius => Report.Ident_Int(4),
- Color => C452001_0.Red));
-
- Mars_Perihelion : C452001_1.Planet :=
- (Name => "Mars ",
- Representation => (Center => (Report.Ident_Int(-20),
- Report.Ident_Int(0)),
- Radius => Report.Ident_Int(4),
- Color => C452001_0.Red));
-
- -- Mars_Perihelion = Mars_Aphelion if user-defined equality from
- -- the tagged type Colored_Circle was incorporated into
- -- predefined equality for the tagged type Planet. User-defined
- -- equality for Colored_Circle checks only that the Radii are equal.
-
- Blue_Mars : C452001_1.Planet :=
- (Name => "Mars ",
- Representation => (Center => (Report.Ident_Int(10),
- Report.Ident_Int(10)),
- Radius => Report.Ident_Int(4),
- Color => C452001_0.Blue));
-
- -- Blue_Mars should equal Mars_Perihelion, because Names and
- -- Radii are equal (all other components are not).
-
- Green_Mars : C452001_1.Planet :=
- (Name => "Mars ",
- Representation => (Center => (Report.Ident_Int(10),
- Report.Ident_Int(10)),
- Radius => Report.Ident_Int(4),
- Color => C452001_0.Green));
-
- -- Blue_Mars should equal Green_Mars. They differ only in the
- -- Color component. All user-defined equality operations return
- -- True, but records are not equal by predefined equality.
-
- -- Blue_Mars should equal Mars_Perihelion, because Names and
- -- Radii are equal (all other components are not).
-
- Moon_Craters : C452001_1.Craters :=
- ((Center => (Report.Ident_Int(9), Report.Ident_Int(11)),
- Radius => Report.Ident_Int(1),
- Color => C452001_0.Black),
- (Center => (Report.Ident_Int(10), Report.Ident_Int(10)),
- Radius => Report.Ident_Int(1),
- Color => C452001_0.Black),
- (Center => (Report.Ident_Int(11), Report.Ident_Int(9)),
- Radius => Report.Ident_Int(1),
- Color => C452001_0.Black));
-
- Alternate_Moon_Craters : C452001_1.Craters :=
- ((Center => (Report.Ident_Int(9), Report.Ident_Int(9)),
- Radius => Report.Ident_Int(1),
- Color => C452001_0.Yellow),
- (Center => (Report.Ident_Int(10), Report.Ident_Int(10)),
- Radius => Report.Ident_Int(1),
- Color => C452001_0.Purple),
- (Center => (Report.Ident_Int(11), Report.Ident_Int(11)),
- Radius => Report.Ident_Int(1),
- Color => C452001_0.Purple));
-
- -- Moon_Craters = Alternate_Moon_Craters if user-defined equality from
- -- the tagged type Colored_Circle was incorporated into
- -- predefined equality for the untagged type Craters. User-defined
- -- equality checks only that the Radii are equal.
-
- New_Moon : C452001_1.Moon :=
- (Name => "Moon ",
- Representation => (Center => (Report.Ident_Int(10),
- Report.Ident_Int(8)),
- Radius => Report.Ident_Int(3),
- Color => C452001_0.Black),
- Crater => Moon_Craters);
-
- Full_Moon : C452001_1.Moon :=
- (Name => "Moon ",
- Representation => (Center => (Report.Ident_Int(10),
- Report.Ident_Int(8)),
- Radius => Report.Ident_Int(3),
- Color => C452001_0.Black),
- Crater => Alternate_Moon_Craters);
-
- -- New_Moon = Full_Moon if user-defined equality from
- -- the tagged type Colored_Circle was incorporated into
- -- predefined equality for the untagged type Craters. This
- -- equality test should call user-defined equality for type
- -- TC_Planet (checks that Names are equal), then predefined
- -- equality for Craters (ultimately calls user-defined equality
- -- for type Circle, checking that Radii of craters are equal).
-
- Mars_Moon : C452001_1.Moon :=
- (Name => "Phobos ",
- Representation => (Center => (Report.Ident_Int(10),
- Report.Ident_Int(8)),
- Radius => Report.Ident_Int(3),
- Color => C452001_0.Black),
- Crater => Alternate_Moon_Craters);
-
- -- Mars_Moon /= Full_Moon since the Names differ.
-
- Alternate_Moon_Craters_2 : C452001_1.Craters :=
- ((Center => (Report.Ident_Int(10), Report.Ident_Int(10)),
- Radius => Report.Ident_Int(1),
- Color => C452001_0.Red),
- (Center => (Report.Ident_Int(9), Report.Ident_Int(9)),
- Radius => Report.Ident_Int(1),
- Color => C452001_0.Red),
- (Center => (Report.Ident_Int(10), Report.Ident_Int(9)),
- Radius => Report.Ident_Int(1),
- Color => C452001_0.Red));
-
- Harvest_Moon : C452001_1.Moon :=
- (Name => "Moon ",
- Representation => (Center => (Report.Ident_Int(11),
- Report.Ident_Int(7)),
- Radius => Report.Ident_Int(4),
- Color => C452001_0.Orange),
- Crater => Alternate_Moon_Craters_2);
-
- -- Only the fields that are employed by the user-defined equality
- -- operators are the same. Everything else differs. Equality should
- -- still return True.
-
- Viking_1_Orbiter : C452001_2.Mission :=
- (Craft => (Design => C452001_2.Viking,
- Operational => Report.Ident_Bool(False)),
- Launch_Date => 1975);
-
- Viking_1_Lander : C452001_2.Mission :=
- (Craft => (Design => C452001_2.Viking,
- Operational => Report.Ident_Bool(True)),
- Launch_Date => 1975);
-
- -- Viking_1_Orbiter /= Viking_1_Lander if predefined equality
- -- from the untagged type Spacecraft is used for equality
- -- of matching components in type Mission. If user-defined
- -- equality for type Spacecraft is incorporated, which it
- -- should not be by 4.5.2(21), then Viking_1_Orbiter = Viking_1_Lander.
-
- Voyagers : C452001_2.Inventory (1..2):=
- ((C452001_2.Voyager, Operational => Report.Ident_Bool(True)),
- (C452001_2.Voyager, Operational => Report.Ident_Bool(False)));
-
- Jupiter_Craft : C452001_2.Inventory (1..2):=
- ((C452001_2.Voyager, Operational => Report.Ident_Bool(True)),
- (C452001_2.Voyager, Operational => Report.Ident_Bool(True)));
-
- -- Voyagers /= Jupiter_Craft if predefined equality
- -- from the untagged type Spacecraft is used for equality
- -- of matching components in type Inventory. If user-defined
- -- equality for type Spacecraft is incorporated, which it
- -- should not be by 4.5.2(21), then Voyagers = Jupiter_Craft.
-
- TPTF_1 : C452001_3.Tagged_Partial_Tagged_Full;
- TPTF_2 : C452001_3.Tagged_Partial_Tagged_Full;
-
- -- With differing values for Boolean component, user-defined
- -- (primitive) equality returns True, predefined equality
- -- returns False. Since full type is tagged, primitive equality
- -- should be used.
-
- UPTF_1 : C452001_3.Untagged_Partial_Tagged_Full;
- UPTF_2 : C452001_3.Untagged_Partial_Tagged_Full;
-
- -- With differing values for Boolean component, user-defined
- -- (primitive) equality returns True, predefined equality
- -- returns False. Since full type is tagged, primitive equality
- -- should be used.
-
- UPUF_1 : C452001_3.Untagged_Partial_Untagged_Full;
- UPUF_2 : C452001_3.Untagged_Partial_Untagged_Full;
-
- -- With differing values for Duration component, user-defined
- -- (primitive) equality returns True, predefined equality
- -- returns False. Since full type is untagged, predefined equality
- -- should be used.
-
- -- Use type clauses make "=" and "/=" operators directly visible
- use type C452001_1.Planet;
- use type C452001_1.Craters;
- use type C452001_1.Moon;
- use type C452001_2.Mission;
- use type C452001_2.Inventory;
- use type C452001_3.Tagged_Partial_Tagged_Full;
- use type C452001_3.Untagged_Partial_Tagged_Full;
- use type C452001_3.Untagged_Partial_Untagged_Full;
-
-begin
-
- Report.Test ("C452001", "Equality of private types and " &
- "composite types with tagged components");
-
- -------------------------------------------------------------------
- -- Tagged type with tagged component.
- -------------------------------------------------------------------
-
- if not (Mars_Aphelion = Mars_Perihelion) then
- Report.Failed ("User-defined equality for tagged component " &
- "was not incorporated into predefined equality " &
- "for enclosing tagged record type");
- end if;
-
- if Mars_Aphelion /= Mars_Perihelion then
- Report.Failed ("User-defined equality for tagged component " &
- "was not incorporated into predefined inequality " &
- "for enclosing tagged record type");
- end if;
-
- if not (Blue_Mars = Mars_Perihelion) then
- Report.Failed ("Equality test for tagged record type " &
- "incorporates record components " &
- "other than those used by user-defined equality");
- end if;
-
- if Blue_Mars /= Mars_Perihelion then
- Report.Failed ("Inequality test for tagged record type " &
- "incorporates record components " &
- "other than those used by user-defined equality");
- end if;
-
- if Blue_Mars /= Green_Mars then
- Report.Failed ("Records are unequal even though they only differ " &
- "in a component not used by user-defined equality");
- end if;
-
- if not (Blue_Mars = Green_Mars) then
- Report.Failed ("Records are not equal even though they only differ " &
- "in a component not used by user-defined equality");
- end if;
-
- -------------------------------------------------------------------
- -- Untagged (array) type with tagged component.
- -------------------------------------------------------------------
-
- if not (Moon_Craters = Alternate_Moon_Craters) then
- Report.Failed ("User-defined equality for tagged component " &
- "was not incorporated into predefined equality " &
- "for enclosing array type");
- end if;
-
- if Moon_Craters /= Alternate_Moon_Craters then
- Report.Failed ("User-defined equality for tagged component " &
- "was not incorporated into predefined inequality " &
- "for enclosing array type");
- end if;
-
- -------------------------------------------------------------------
- -- Tagged type with untagged composite component. Untagged
- -- component itself has tagged components.
- -------------------------------------------------------------------
- if not (New_Moon = Full_Moon) then
- Report.Failed ("User-defined equality for tagged component " &
- "was not incorporated into predefined equality " &
- "for array component of tagged record type");
- end if;
-
- if New_Moon /= Full_Moon then
- Report.Failed ("User-defined equality for tagged component " &
- "was not incorporated into predefined inequality " &
- "for array component of tagged record type");
- end if;
-
- if Mars_Moon = Full_Moon then
- Report.Failed ("User-defined equality for tagged component " &
- "was not incorporated into predefined equality " &
- "for array component of tagged record type");
- end if;
-
- if not (Mars_Moon /= Full_Moon) then
- Report.Failed ("User-defined equality for tagged component " &
- "was not incorporated into predefined inequality " &
- "for array component of tagged record type");
- end if;
-
- if not (Harvest_Moon = Full_Moon) then
- Report.Failed ("Equality test for record with array of tagged " &
- "components incorporates record components " &
- "other than those used by user-defined equality");
- end if;
-
- if Harvest_Moon /= Full_Moon then
- Report.Failed ("Inequality test for record with array of tagged " &
- "components incorporates record components " &
- "other than those used by user-defined equality");
- end if;
-
- -------------------------------------------------------------------
- -- Untagged types with no tagged components.
- -------------------------------------------------------------------
-
- -- Record type
-
- if Viking_1_Orbiter = Viking_1_Lander then
- Report.Failed ("User-defined equality for untagged composite " &
- "component was incorporated into predefined " &
- "equality for " &
- "untagged record type");
- end if;
-
- if not (Viking_1_Orbiter /= Viking_1_Lander) then
- Report.Failed ("User-defined equality for untagged composite " &
- "component was incorporated into predefined " &
- "inequality for " &
- "untagged record type");
- end if;
-
- -- Array type
-
- if Voyagers = Jupiter_Craft then
- Report.Failed ("User-defined equality for untagged composite " &
- "component was incorporated into predefined " &
- "equality for " &
- "array type");
- end if;
-
- if not (Voyagers /= Jupiter_Craft) then
- Report.Failed ("User-defined equality for untagged composite " &
- "component was incorporated into predefined " &
- "inequality for " &
- "array type");
- end if;
-
- -------------------------------------------------------------------
- -- Private types tests.
- -------------------------------------------------------------------
-
- -- Make objects differ from one another
-
- C452001_3.Change (TPTF_1, False);
- C452001_3.Change (UPTF_1, 999);
- C452001_3.Change (UPUF_1, 40.0);
-
- -------------------------------------------------------------------
- -- Partial type and full type are tagged. (Full type must be tagged
- -- if partial type is tagged)
- -------------------------------------------------------------------
-
- if not (TPTF_1 = TPTF_2) then
- Report.Failed ("Predefined equality for full type " &
- "was used to determine equality of " &
- "tagged private type " &
- "instead of user-defined (primitive) equality");
- end if;
-
- if TPTF_1 /= TPTF_2 then
- Report.Failed ("Predefined equality for full type " &
- "was used to determine inequality of " &
- "tagged private type " &
- "instead of user-defined (primitive) equality");
- end if;
-
- -------------------------------------------------------------------
- -- Partial type untagged, full type tagged.
- -------------------------------------------------------------------
-
- if not (UPTF_1 = UPTF_2) then
- Report.Failed ("Predefined equality for full type " &
- "was used to determine equality of " &
- "private type (untagged partial view, " &
- "tagged full view) " &
- "instead of user-defined (primitive) equality");
- end if;
-
- if UPTF_1 /= UPTF_2 then
- Report.Failed ("Predefined equality for full type " &
- "was used to determine inequality of " &
- "private type (untagged partial view, " &
- "tagged full view) " &
- "instead of user-defined (primitive) equality");
- end if;
-
- -------------------------------------------------------------------
- -- Partial type and full type are both untagged.
- -------------------------------------------------------------------
-
- if UPUF_1 = UPUF_2 then
- Report.Failed ("User-defined (primitive) equality for full type " &
- "was used to determine equality of " &
- "private type (untagged partial view, " &
- "untagged full view) " &
- "instead of predefined equality");
- end if;
-
- if not (UPUF_1 /= UPUF_2) then
- Report.Failed ("User-defined (primitive) equality for full type " &
- "was used to determine inequality of " &
- "private type (untagged partial view, " &
- "untagged full view) " &
- "instead of predefined equality");
- end if;
-
- -------------------------------------------------------------------
- Report.Result;
-
-end C452001;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c455001.a b/gcc/testsuite/ada/acats/tests/c4/c455001.a
deleted file mode 100644
index 8685e1b3381..00000000000
--- a/gcc/testsuite/ada/acats/tests/c4/c455001.a
+++ /dev/null
@@ -1,164 +0,0 @@
--- C455001.A
-
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687 and
--- F08630-91-C-0015, the U.S. Government obtained unlimited rights in the
--- software and documentation contained herein. Unlimited rights are
--- defined in DFAR 252.227-7013(a)(19). By making this public release,
--- the Government intends to confer upon all recipients unlimited rights
--- equal to those held by the Government. These rights include rights to
--- use, duplicate, release or disclose the released technical data and
--- computer software in whole or in part, in any manner and for any purpose
--- whatsoever, and to have or permit others to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that universal fixed multiplying operators can be used without
--- a conversion in contexts where the result type is determined.
---
--- Note: This is intended to check the changes made to these operators
--- in Ada 95; legacy tests should cover cases from Ada 83.
---
--- CHANGE HISTORY:
--- 18 MAR 99 RLB Initial version
---
---!
-
-with Report; use Report;
-
-procedure C455001 is
-
- type F1 is delta 2.0**(-1) range 0.0 .. 8.0;
-
- type F2 is delta 2.0**(-2) range 0.0 .. 4.0;
-
- type F3 is delta 2.0**(-3) range 0.0 .. 2.0;
-
- A : F1;
- B : F2;
- C : F3;
-
- type Fixed_Record is record
- D : F1;
- E : F2;
- end record;
-
- R : Fixed_Record;
-
- function Ident_Fix (X : F3) return F3 is
- begin
- if Equal(3,3) then
- return X;
- else
- return 0.0;
- end if;
- end Ident_Fix;
-
-begin
- Test ("C455001", "Check that universal fixed multiplying operators " &
- "can be used without a conversion in contexts where " &
- "the result type is determined.");
-
- A := 1.0; B := 1.0;
- C := A * B; -- Assignment context.
-
- if C /= Ident_Fix(1.0) then
- Failed ("Incorrect results for multiplication (1) - result is " &
- F3'Image(C));
- end if;
-
- C := A / B;
-
- if C /= Ident_Fix(1.0) then
- Failed ("Incorrect results for division (1) - result is " &
- F3'Image(C));
- end if;
-
- A := 2.5;
- C := A * 0.25;
-
- if C /= Ident_Fix(0.625) then
- Failed ("Incorrect results for multiplication (2) - result is " &
- F3'Image(C));
- end if;
-
- C := A / 4.0;
-
- if C /= Ident_Fix(0.625) then
- Failed ("Incorrect results for division (2) - result is " &
- F3'Image(C));
- end if;
-
- C := Ident_Fix(0.75);
- C := C * 0.5;
-
- if C /= Ident_Fix(0.375) then
- Failed ("Incorrect results for multiplication (3) - result is " &
- F3'Image(C));
- end if;
-
- C := Ident_Fix(0.75);
- C := C / 0.5;
-
- if C /= Ident_Fix(1.5) then
- Failed ("Incorrect results for division (3) - result is " &
- F3'Image(C));
- end if;
-
- A := 0.5; B := 0.3; -- Function parameter context.
- if Ident_Fix(A * B) not in Ident_Fix(0.125) .. Ident_Fix(0.25) then
- Failed ("Incorrect results for multiplication (4) - result is " &
- F3'Image(A * B)); -- Exact = 0.15
- end if;
-
- B := 0.8;
- if Ident_Fix(A / B) not in Ident_Fix(0.5) .. Ident_Fix(0.75) then
- Failed ("Incorrect results for division (4) - result is " &
- F3'Image(A / B));
- -- Exact = 0.625..., but B is only restricted to the range
- -- 0.75 .. 1.0, so the result can be anywhere in the range
- -- 0.5 .. 0.75.
- end if;
-
- C := 0.875; B := 1.5;
- R := (D => C * 4.0, E => B / 0.5); -- Aggregate context.
-
- if R.D /= 3.5 then
- Failed ("Incorrect results for multiplication (5) - result is " &
- F1'Image(R.D));
- end if;
-
- if R.E /= 3.0 then
- Failed ("Incorrect results for division (5) - result is " &
- F2'Image(R.E));
- end if;
-
- A := 0.5;
- C := A * F1'(B * 2.0); -- Qualified expression context.
-
- if C /= Ident_Fix(1.5) then
- Failed ("Incorrect results for multiplication (6) - result is " &
- F3'Image(C));
- end if;
-
- A := 4.0;
- C := F1'(B / 0.5) / A;
-
- if C /= Ident_Fix(0.75) then
- Failed ("Incorrect results for division (6) - result is " &
- F3'Image(C));
- end if;
-
- Result;
-
-end C455001;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c460001.a b/gcc/testsuite/ada/acats/tests/c4/c460001.a
deleted file mode 100644
index 907b8564f6d..00000000000
--- a/gcc/testsuite/ada/acats/tests/c4/c460001.a
+++ /dev/null
@@ -1,300 +0,0 @@
--- C460001.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that if the target type of a type conversion is a general
--- access type, Program_Error is raised if the accessibility level
--- of the operand type is deeper than that of the target type.
--- Check for the case where the operand is an access parameter.
---
--- Check for cases where the actual corresponding to the access
--- parameter is:
--- (a) An allocator.
--- (b) An expression of a named access type.
--- (c) Obj'Access.
---
--- TEST DESCRIPTION:
--- In order to satisfy accessibility requirements, the operand type
--- must be at the same or a less deep nesting level than the target
--- type -- the operand type must "live" as long as the target type.
--- Nesting levels are the run-time nestings of masters: block statements;
--- subprogram, task, and entry bodies; and accept statements. Packages
--- are invisible to accessibility rules.
---
--- This test declares subprograms with access parameters, within which
--- a type conversion is attempted on the access parameter to an access
--- type A declared at some nesting level. The test verifies that
--- Program_Error is raised if the actual corresponding to the access
--- parameter is:
---
--- (1) an allocator, and the accessibility level of the execution
--- of the called subprogram is deeper than that of the access
--- type A.
---
--- (2) an expression of a named access type, and the accessibility
--- level of the named access type is deeper than that of the
--- access type A.
---
--- (3) a reference to the Access attribute (e.g., X'Access), and
--- the accessibility level of X is deeper than that of the
--- access type A.
---
--- Note that the static nesting level of the actual corresponding to the
--- access parameter can be deeper than that of the target type -- it is
--- the run-time nesting that matters for accessibility rules. Consider
--- the case where the access type A is declared within the called
--- subprogram. The accessibility check will never fail, even if the
--- actual happens to have a deeper static nesting level:
---
--- procedure P (X: access T) is
--- type A is access all T; -- Static level = 2, e.g.
--- Acc : A := A(X); -- Check should never fail.
--- begin null; end;
--- . . .
--- declare
--- Actual : aliased T; -- Static level = 3, e.g.
--- begin
--- P (Actual'Access);
--- end;
---
--- For the execution of P, the accessibility level of type A will
--- always be deeper than that of Actual, so there is no danger of a
--- dangling reference arising from the assignment to Acc. Thus, the
--- type conversion is safe, even though the static nesting level of
--- Actual is deeper than that of A.
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
---
---!
-
-package C460001_0 is
-
- type Desig is array (1 .. 10) of Integer;
-
- X0 : aliased Desig; -- Level = 0.
-
- type Acc_L0 is access all Desig; -- Level = 0.
- A0 : Acc_L0;
-
- type Result_Kind is (OK, P_E, O_E);
-
- procedure Target_Is_Level_0 (X: access Desig; R : out Result_Kind);
- procedure Never_Fails (X: access Desig; R : out Result_Kind);
-
-end C460001_0;
-
-
- --==================================================================--
-
-
-package body C460001_0 is
-
- procedure Target_Is_Level_0 (X : access Desig;
- R : out Result_Kind) is
- begin
- -- The accessibility level of type Acc_L0 is 0.
- A0 := Acc_L0(X);
- R := OK;
- exception
- when Program_Error =>
- R := P_E;
- when others =>
- R := O_E;
- end Target_Is_Level_0;
-
- -----------------------------------------------
- procedure Never_Fails (X: access Desig;
- R : out Result_Kind) is
- type Acc_Local is access all Desig;
- AL : Acc_Local;
- begin
- -- The type conversion below will always be safe, since the
- -- accessibility level (although not necessarily the static nesting
- -- depth) of Acc_Local will always be deeper than or the same as that
- -- of the actual corresponding to X.
- AL := Acc_Local(X);
- R := OK;
- exception
- when Program_Error =>
- R := P_E;
- when others =>
- R := O_E;
- end Never_Fails;
-
-end C460001_0;
-
-
- --==================================================================--
-
-
-with C460001_0;
-with Report;
-
-procedure C460001 is
-
- X1 : aliased C460001_0.Desig; -- Level = 1.
-
- type Acc_L1 is access all C460001_0.Desig; -- Level = 1.
- A1 : Acc_L1;
-
- Expr_L0 : C460001_0.Acc_L0 := C460001_0.X0'Access;
- Expr_L1 : Acc_L1 := X1'Access;
-
- Res : C460001_0.Result_Kind;
-
- use type C460001_0.Result_Kind;
-
- -----------------------------------------------
- procedure Target_Is_Level_1 (X : access C460001_0.Desig;
- R : out C460001_0.Result_Kind) is
- begin
- -- The accessibility level of type Acc_L1 is 1.
- A1 := Acc_L1(X);
- R := C460001_0.OK;
- exception
- when Program_Error =>
- R := C460001_0.P_E;
- when others =>
- R := C460001_0.O_E;
- end Target_Is_Level_1;
-
- -----------------------------------------------
- procedure Display_Results (Result : in C460001_0.Result_Kind;
- Expected: in C460001_0.Result_Kind;
- Message : in String) is
- begin
- if Result /= Expected then
- case Result is
- when C460001_0.OK => Report.Failed ("No exception raised: " &
- Message);
- when C460001_0.P_E => Report.Failed ("Program_Error raised: " &
- Message);
- when C460001_0.O_E => Report.Failed ("Unexpected exception " &
- "raised: " & Message);
- end case;
- end if;
- end Display_Results;
-
-begin -- C460001
-
- Report.Test ("C460001", "Check that if the target type of a type " &
- "conversion is a general access type, Program_Error is " &
- "raised if the accessibility level of the operand type " &
- "is deeper than that of the target type: operand is an " &
- "access parameter; corresponding actual is an allocator, " &
- "expression of a named access type, Obj'Access");
-
-
- -- Actual is X'Access:
-
- C460001_0.Never_Fails (X1'Access, Res);
- Display_Results (Res, C460001_0.OK, "X1'Access, local access type");
-
- C460001_0.Target_Is_Level_0 (X1'Access, Res);
- Display_Results (Res, C460001_0.P_E, "X1'Access, level 0 access type");
-
- Target_Is_Level_1 (C460001_0.X0'Access, Res);
- Display_Results (Res, C460001_0.OK, "X0'Access, level 1 access type");
-
- Target_Is_Level_1 (X1'Access, Res);
- Display_Results (Res, C460001_0.OK, "X1'Access, level 1 access type");
-
- C460001_0.Target_Is_Level_0 (C460001_0.X0'Access, Res);
- Display_Results (Res, C460001_0.OK, "X0'Access, level 0 access type");
-
-
- -- Actual is expression of a named access type:
-
- C460001_0.Never_Fails (Expr_L0, Res);
- Display_Results (Res, C460001_0.OK, "Expr_L0, local access type");
-
- C460001_0.Target_Is_Level_0 (Expr_L0, Res);
- Display_Results (Res, C460001_0.OK, "Expr_L0, level 0 access type");
-
- C460001_0.Target_Is_Level_0 (Expr_L1, Res);
- Display_Results (Res, C460001_0.P_E, "Expr_L1, level 0 access type");
-
- Target_Is_Level_1 (Expr_L1, Res);
- Display_Results (Res, C460001_0.OK, "Expr_L1, level 1 access type");
-
- Target_Is_Level_1 (Expr_L0, Res);
- Display_Results (Res, C460001_0.OK, "Expr_L0, level 1 access type");
-
- -- Actual is allocator (level of execution = 2):
-
- C460001_0.Never_Fails (new C460001_0.Desig, Res);
- Display_Results (Res, C460001_0.OK, "Allocator level 2, " &
- "local access type");
-
- C460001_0.Target_Is_Level_0 (new C460001_0.Desig, Res);
- Display_Results (Res, C460001_0.P_E, "Allocator level 2, " &
- "level 0 access type");
-
- Target_Is_Level_1 (new C460001_0.Desig, Res);
- Display_Results (Res, C460001_0.P_E, "Allocator level 2, " &
- "level 1 access type");
-
-
- Block_L2:
- declare
- X2 : aliased C460001_0.Desig; -- Level = 2.
- type Acc_L2 is access all C460001_0.Desig; -- Level = 2.
- Expr_L2 : Acc_L2 := X1'Access;
- begin
-
- -- Actual is X'Access:
-
- C460001_0.Never_Fails (X2'Access, Res);
- Display_Results (Res, C460001_0.OK, "X2'Access, local access type");
-
- Target_Is_Level_1 (X2'Access, Res);
- Display_Results (Res, C460001_0.P_E, "X2'Access, level 1 access type");
-
- -- Actual is expression of a named access type:
-
- C460001_0.Never_Fails (Expr_L2, Res);
- Display_Results (Res, C460001_0.OK, "Expr_L2, local access type");
-
- C460001_0.Target_Is_Level_0 (Expr_L2, Res);
- Display_Results (Res, C460001_0.P_E, "Expr_L2, level 0 access type");
-
-
- -- Actual is allocator (level of execution = 3):
-
- C460001_0.Never_Fails (new C460001_0.Desig, Res);
- Display_Results (Res, C460001_0.OK, "Allocator level 3, " &
- "local access type");
-
- Target_Is_Level_1 (new C460001_0.Desig, Res);
- Display_Results (Res, C460001_0.P_E, "Allocator level 3, " &
- "level 1 access type");
-
- end Block_L2;
-
- Report.Result;
-
-end C460001;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c460002.a b/gcc/testsuite/ada/acats/tests/c4/c460002.a
deleted file mode 100644
index 945dd567720..00000000000
--- a/gcc/testsuite/ada/acats/tests/c4/c460002.a
+++ /dev/null
@@ -1,330 +0,0 @@
--- C460002.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that if the target type of a type conversion is a general
--- access type, Program_Error is raised if the accessibility level
--- of the operand type is deeper than that of the target type.
--- Check for the case where the operand is an access parameter,
--- and the actual corresponding to the access parameter is another
--- access parameter.
---
--- TEST DESCRIPTION:
--- In order to satisfy accessibility requirements, the operand type
--- must be at the same or a less deep nesting level than the target
--- type -- the operand type must "live" as long as the target type.
--- Nesting levels are the run-time nestings of masters: block statements;
--- subprogram, task, and entry bodies; and accept statements. Packages
--- are invisible to accessibility rules.
---
--- This test declares subprograms with access parameters, within which
--- a type conversion is attempted on the access parameter to an access
--- type A declared at some nesting level. The test verifies that
--- Program_Error is raised if the actual corresponding to the access
--- parameter is another access parameter, and the actual corresponding
--- to this second access parameter is:
---
--- (1) an expression of a named access type, and the accessibility
--- level of the named access type is deeper than that of the
--- access type A.
---
--- (2) a reference to the Access attribute (e.g., X'Access), and
--- the accessibility level of X is deeper than that of the
--- access type A.
---
--- Note that the static nesting level of the actual corresponding to the
--- access parameter can be deeper than that of the target type -- it is
--- the run-time nesting that matters for accessibility rules. Consider
--- the case where the access type A is declared within the called
--- subprogram. The accessibility check will never fail, even if the
--- actual happens to have a deeper static nesting level:
---
--- procedure P (X: access T) is
--- type A is access all T; -- Static level = 2, e.g.
--- Acc : A := A(X); -- Check should never fail.
--- begin null; end;
--- . . .
--- procedure Q (Y: access T) is
--- begin
--- P(Y);
--- end;
--- . . .
--- declare
--- Actual : aliased T; -- Static level = 3, e.g.
--- begin
--- Q (Actual'Access);
--- end;
---
--- For the execution of Q (and hence P), the accessibility level of
--- type A will always be deeper than that of Actual, so there is no
--- danger of a dangling reference arising from the assignment to
--- Acc. Thus, the type conversion is safe, even though the static
--- nesting level of Actual is deeper than that of A.
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 19 Dec 94 SAIC Changed maintenance documentation.
--- 15 Jul 98 EDS Avoid Optimization
--- 28 Jun 02 RLB Added pragma Elaborate_All.
---!
-
-with Report; use Report; pragma Elaborate_All (Report);
-package C460002_0 is
-
- type Component is array (1 .. 10) of Natural;
-
- type Desig is record
- C: Component;
- end record;
-
- X0 : aliased Desig := (C=>(others => Ident_Int(3))); -- Level = 0.
-
- type Acc_L0 is access all Desig; -- Level = 0.
- A0 : Acc_L0;
-
- type Result_Kind is (OK, P_E, O_E);
-
- procedure Target_Is_Level_0_Nest (Y: access Desig; S: out Result_Kind);
- procedure Never_Fails_Nest (Y: access Desig; S: out Result_Kind);
- procedure Never_Fails_Same (Y: access Desig; S: out Result_Kind);
-
-end C460002_0;
-
-
- --==================================================================--
-
-
-package body C460002_0 is
-
- procedure Target_Is_Level_0_Nest (Y: access Desig; S: out Result_Kind) is
-
- procedure Nested (X: access Desig; R: out Result_Kind) is
- -- This procedure attempts a type conversion on the access parameter to
- -- an access type declared at some nesting level. Program_Error is
- -- raised if the accessibility level of the operand type is deeper than
- -- that of the target type.
-
- begin
- -- The accessibility level of type Acc_L0 is 0.
- A0 := Acc_L0(X);
- R := OK;
- exception
- when Program_Error =>
- R := P_E;
- when others =>
- R := O_E;
- end Nested;
-
- begin
- Nested (Y, S);
- end Target_Is_Level_0_Nest;
-
- -------------------------------------------------------------
-
- procedure Never_Fails_Nest (Y: access Desig; S: out Result_Kind) is
-
- type Acc_Deeper is access all Desig;
- AD : Acc_Deeper;
-
- function Nested (X: access Desig) return Result_Kind is
- begin
- -- The type conversion below will always be safe, since the
- -- accessibility level (although not necessarily the static nesting
- -- depth) of Acc_Deeper will always be deeper than or the same as that
- -- of the actual corresponding to Y.
- AD := Acc_Deeper(X);
- if Natural(Ident_Int(AD.C(1))) /= 3 then --Avoid Optimization of AD
- Report.Failed ("Initial Values not correct.");
- end if;
- return OK;
- exception
- when Program_Error =>
- return P_E;
- when others =>
- return O_E;
- end Nested;
-
- begin
- S := Nested (Y);
- end Never_Fails_Nest;
-
- -------------------------------------------------------------
-
- procedure Called_By_Never_Fails_Same
- (X: access Desig; R: out Result_Kind) is
- type Acc_Local is access all Desig;
- AL : Acc_Local;
- begin
- -- The type conversion below will always be safe, since the
- -- accessibility level (although not necessarily the static nesting
- -- depth) of Acc_Local will always be deeper than or the same as that
- -- of the actual corresponding to X.
- AL := Acc_Local(X);
- if Natural(Ident_Int(AL.C(1))) /= 3 then --Avoid Optimization of AL
- Report.Failed ("Initial Values not correct.");
- end if;
- R := OK;
- exception
- when Program_Error =>
- R := P_E;
- when others =>
- R := O_E;
- end Called_By_Never_Fails_Same;
-
- -------------------------------------------------------------
-
- procedure Never_Fails_Same (Y: access Desig; S: out Result_Kind) is
- begin
- Called_By_Never_Fails_Same (Y, S);
- end Never_Fails_Same;
-
-end C460002_0;
-
-
- --==================================================================--
-
-
-with C460002_0;
-use C460002_0;
-
-with Report; use Report;
-
-procedure C460002 is
-
- type Acc_L1 is access all Desig; -- Level = 1.
- A1 : Acc_L1;
- X1 : aliased Desig := (C=>(others => Ident_Int(3)));
- Res : Result_Kind;
-
-
-
- procedure Called_By_Target_L1 (X: access Desig; R: out Result_Kind) is
- begin
- -- The accessibility level of type Acc_L1 is 1.
- A1 := Acc_L1(X);
- if Natural(Ident_Int(A1.C(1))) /= 3 then --Avoid Optimization of A1
- Report.Failed ("Initial Values not correct.");
- end if;
- R := OK;
- exception
- when Program_Error =>
- R := P_E;
- when others =>
- R := O_E;
- end Called_By_Target_L1;
-
- -------------------------------------------------------------
-
- function Target_Is_Level_1_Same (Y: access Desig) return Result_Kind is
- S : Result_Kind;
- begin
- Called_By_Target_L1 (Y, S);
- return S;
- end Target_Is_Level_1_Same;
-
- -------------------------------------------------------------
-
- procedure Display_Results (Result : in Result_Kind;
- Expected: in Result_Kind;
- Msg : in String) is
- begin
- if Result /= Expected then
- case Result is
- when OK => Report.Failed ("No exception raised: " & Msg);
- when P_E => Report.Failed ("Program_Error raised: " & Msg);
- when O_E => Report.Failed ("Unexpected exception raised: " & Msg);
- end case;
- end if;
- end Display_Results;
-
-begin -- C460002.
-
- Report.Test ("C460002", "Check that if the target type of a type " &
- "conversion is a general access type, Program_Error is " &
- "raised if the accessibility level of the operand type " &
- "is deeper than that of the target type: operand is an " &
- "access parameter; corresponding actual is another " &
- "access parameter");
-
-
- -- Accessibility level of actual is 0 (actual is X'Access):
-
- Never_Fails_Same (X0'Access, Res);
- Display_Results (Res, OK, "Never_Fails_Same, level 0 actual");
-
- Never_Fails_Nest (X0'Access, Res);
- Display_Results (Res, OK, "Target_L1_Nest, level 0 actual");
-
- Target_Is_Level_0_Nest (X0'Access, Res);
- Display_Results (Res, OK, "Target_L0_Nest, level 0 actual");
-
- Res := Target_Is_Level_1_Same (X0'Access);
- Display_Results (Res, OK, "Target_L1_Same, level 0 actual");
-
-
- -- Accessibility level of actual is 1 (actual is X'Access):
-
- Never_Fails_Same (X1'Access, Res);
- Display_Results (Res, OK, "Never_Fails_Same, level 1 actual");
-
- Never_Fails_Nest (X1'Access, Res);
- Display_Results (Res, OK, "Target_L1_Nest, level 1 actual");
-
- Target_Is_Level_0_Nest (X1'Access, Res);
- Display_Results (Res, P_E, "Target_L0_Nest, level 1 actual");
-
- Res := Target_Is_Level_1_Same (X1'Access);
- Display_Results (Res, OK, "Target_L1_Same, level 1 actual");
-
-
- Block_L2:
- declare
- X2 : aliased Desig := (C=>(others => Ident_Int(3)));
- type Acc_L2 is access all Desig; -- Level = 2.
- Expr_L2 : Acc_L2 := X2'Access;
- begin
-
- -- Accessibility level of actual is 2 (actual is expression of named
- -- access type):
-
- Never_Fails_Same (Expr_L2, Res);
- Display_Results (Res, OK, "Never_Fails_Same, level 2 actual");
-
- Never_Fails_Nest (Expr_L2, Res);
- Display_Results (Res, OK, "Target_L1_Nest, level 2 actual");
-
- Target_Is_Level_0_Nest (Expr_L2, Res);
- Display_Results (Res, P_E, "Target_L0_Nest, level 2 actual");
-
- Res := Target_Is_Level_1_Same (Expr_L2);
- Display_Results (Res, P_E, "Target_L1_Same, level 2 actual");
-
- end Block_L2;
-
-
- Report.Result;
-
-end C460002;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c460004.a b/gcc/testsuite/ada/acats/tests/c4/c460004.a
deleted file mode 100644
index b00428121b8..00000000000
--- a/gcc/testsuite/ada/acats/tests/c4/c460004.a
+++ /dev/null
@@ -1,335 +0,0 @@
--- C460004.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that if the operand type of a type conversion is class-wide,
--- Constraint_Error is raised if the tag of the operand does not
--- identify a specific type that is covered by or descended from the
--- target type.
---
--- TEST DESCRIPTION:
--- View conversions of class-wide operands to specific types are
--- placed on the right and left sides of assignment statements, and
--- conversions of class-wide operands to class-wide types are used
--- as actual parameters to dispatching operations. In all cases, a
--- check is made that Constraint_Error is raised if the tag of the
--- operand does not identify a specific type covered by or descended
--- from the target type, and not raised otherwise.
---
--- A specific type is descended from itself and from those types it is
--- directly or indirectly derived from. A specific type is covered by
--- itself and each class-wide type to whose class it belongs.
---
--- A class-wide type T'Class is descended from T and those types which
--- T is descended from. A class-wide type is covered by each class-wide
--- type to whose class it belongs.
---
---
--- CHANGE HISTORY:
--- 19 Jul 95 SAIC Initial prerelease version.
--- 18 Apr 96 SAIC ACVC 2.1: Added a check for correct tag.
---
---!
-package C460004_0 is
-
- type Tag_Type is tagged record
- C1 : Natural;
- end record;
-
- procedure Proc (X : in out Tag_Type);
-
-
- type DTag_Type is new Tag_Type with record
- C2 : String (1 .. 5);
- end record;
-
- procedure Proc (X : in out DTag_Type);
-
-
- type DDTag_Type is new DTag_Type with record
- C3 : String (1 .. 5);
- end record;
-
- procedure Proc (X : in out DDTag_Type);
-
- procedure NewProc (X : in DDTag_Type);
-
- function CWFunc (X : Tag_Type'Class) return Tag_Type'Class;
-
-end C460004_0;
-
-
- --==================================================================--
-
-with Report;
-package body C460004_0 is
-
- procedure Proc (X : in out Tag_Type) is
- begin
- X.C1 := 25;
- end Proc;
-
- -----------------------------------------
- procedure Proc (X : in out DTag_Type) is
- begin
- Proc ( Tag_Type(X) );
- X.C2 := "Earth";
- end Proc;
-
- -----------------------------------------
- procedure Proc (X : in out DDTag_Type) is
- begin
- Proc ( DTag_Type(X) );
- X.C3 := "Orbit";
- end Proc;
-
- -----------------------------------------
- procedure NewProc (X : in DDTag_Type) is
- Y : DDTag_Type := X;
- begin
- Proc (Y);
- exception
- when others =>
- Report.Failed ("Unexpected exception in NewProc");
- end NewProc;
-
- -----------------------------------------
- function CWFunc (X : Tag_Type'Class) return Tag_Type'Class is
- Y : Tag_Type'Class := X;
- begin
- Proc (Y);
- return Y;
- end CWFunc;
-
-end C460004_0;
-
-
- --==================================================================--
-
-
-with C460004_0;
-use C460004_0;
-
-with Report;
-procedure C460004 is
-
- Tag_Type_Init : constant Tag_Type := (C1 => 0);
- DTag_Type_Init : constant DTag_Type := (Tag_Type_Init with "Hello");
- DDTag_Type_Init : constant DDTag_Type := (DTag_Type_Init with "World");
-
- Tag_Type_Value : constant Tag_Type := (C1 => 25);
- DTag_Type_Value : constant DTag_Type := (Tag_Type_Value with "Earth");
- DDTag_Type_Value : constant DDTag_Type := (DTag_Type_Value with "Orbit");
-
-begin
-
- Report.Test ("C460004", "Check that for a view conversion of a " &
- "class-wide operand, Constraint_Error is raised if the " &
- "tag of the operand does not identify a specific type " &
- "covered by or descended from the target type");
-
---
--- View conversion to specific type:
---
-
- declare
- procedure CW_Proc (P : Tag_Type'Class) is
- Target : Tag_Type := Tag_Type_Init;
- begin
- Target := Tag_Type(P);
- if (Target /= Tag_Type_Value) then
- Report.Failed ("Target has wrong value: #01");
- end if;
- exception
- when Constraint_Error =>
- Report.Failed ("Constraint_Error raised: #01");
- when others =>
- Report.Failed ("Unexpected exception: #01");
- end CW_Proc;
-
- begin
- CW_Proc (DDTag_Type_Value);
- end;
-
- ----------------------------------------------------------------------
-
- declare
- Target : DTag_Type := DTag_Type_Init;
- begin
- Target := DTag_Type(CWFunc(DDTag_Type_Value));
- if (Target /= DTag_Type_Value) then
- Report.Failed ("Target has wrong value: #02");
- end if;
- exception
- when Constraint_Error => Report.Failed ("Constraint_Error raised: #02");
- when others => Report.Failed ("Unexpected exception: #02");
- end;
-
- ----------------------------------------------------------------------
-
- declare
- Target : DDTag_Type;
- begin
- Target := DDTag_Type(CWFunc(Tag_Type_Value));
- -- CWFunc returns a Tag_Type; its tag is preserved through
- -- the view conversion. Constraint_Error should be raised.
-
- Report.Failed ("Constraint_Error not raised: #03");
-
- exception
- when Constraint_Error => null; -- expected exception
- when others => Report.Failed ("Unexpected exception: #03");
- end;
-
- ----------------------------------------------------------------------
-
- declare
- procedure CW_Proc (P : Tag_Type'Class) is
- begin
- NewProc (DDTag_Type(P));
- Report.Failed ("Constraint_Error not raised: #04");
-
- exception
- when Constraint_Error => null; -- expected exception
- when others => Report.Failed ("Unexpected exception: #04");
- end CW_Proc;
-
- begin
- CW_Proc (DTag_Type_Value);
- end;
-
- ----------------------------------------------------------------------
-
- declare
- procedure CW_Proc (P : Tag_Type'Class) is
- Target : DDTag_Type := DDTag_Type_Init;
- begin
- Target := DDTag_Type(P);
- if (Target /= DDTag_Type_Value) then
- Report.Failed ("Target has wrong value: #05");
- end if;
-
- exception
- when Constraint_Error =>
- Report.Failed ("Constraint_Error raised: #05");
- when others
- => Report.Failed ("Unexpected exception: #05");
- end CW_Proc;
-
- begin
- CW_Proc (DDTag_Type_Value);
- end;
-
-
---
--- View conversion to class-wide type:
---
-
- declare
- procedure CW_Proc (P : Tag_Type'Class) is
- Operand : Tag_Type'Class := P;
- begin
- Proc( DTag_Type'Class(Operand) );
- Report.Failed ("Constraint_Error not raised: #06");
-
- exception
- when Constraint_Error => null; -- expected exception
- when others => Report.Failed ("Unexpected exception: #06");
- end CW_Proc;
-
- begin
- CW_Proc (Tag_Type_Init);
- end;
-
- ----------------------------------------------------------------------
-
- declare
- procedure CW_Proc (P : Tag_Type'Class) is
- Operand : Tag_Type'Class := P;
- begin
- Proc( DDTag_Type'Class(Operand) );
- Report.Failed ("Constraint_Error not raised: #07");
-
- exception
- when Constraint_Error => null; -- expected exception
- when others => Report.Failed ("Unexpected exception: #07");
- end CW_Proc;
-
- begin
- CW_Proc (Tag_Type_Init);
- end;
-
- ----------------------------------------------------------------------
-
- declare
- procedure CW_Proc (P : Tag_Type'Class) is
- Operand : Tag_Type'Class := P;
- begin
- Proc( DTag_Type'Class(Operand) );
- if Operand not in DTag_Type then
- Report.Failed ("Operand has wrong tag: #08");
- elsif (Operand /= Tag_Type'Class (DTag_Type_Value)) then
- Report.Failed ("Operand has wrong value: #08");
- end if;
-
- exception
- when Constraint_Error =>
- Report.Failed ("Constraint_Error raised: #08");
- when others =>
- Report.Failed ("Unexpected exception: #08");
- end CW_Proc;
-
- begin
- CW_Proc (DTag_Type_Init);
- end;
-
- ----------------------------------------------------------------------
-
- declare
- procedure CW_Proc (P : Tag_Type'Class) is
- Operand : Tag_Type'Class := P;
- begin
- Proc( Tag_Type'Class(Operand) );
- if Operand not in DDTag_Type then
- Report.Failed ("Operand has wrong tag: #09");
- elsif (Operand /= Tag_Type'Class (DDTag_Type_Value)) then
- Report.Failed ("Operand has wrong value: #09");
- end if;
-
- exception
- when Constraint_Error =>
- Report.Failed ("Constraint_Error raised: #09");
- when others =>
- Report.Failed ("Unexpected exception: #09");
- end CW_Proc;
-
- begin
- CW_Proc (DDTag_Type_Init);
- end;
-
-
- Report.Result;
-
-end C460004;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c460005.a b/gcc/testsuite/ada/acats/tests/c4/c460005.a
deleted file mode 100644
index 95b14a9a20a..00000000000
--- a/gcc/testsuite/ada/acats/tests/c4/c460005.a
+++ /dev/null
@@ -1,260 +0,0 @@
--- C460005.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that, for a view conversion of a tagged type that is the left
--- side of an assignment statement, the assignment assigns to the
--- corresponding part of the object denoted by the operand.
---
--- TEST DESCRIPTION:
--- View conversions of class-wide operands to specific types are
--- placed on the right and left sides of assignment statements, and
--- conversions of class-wide operands to class-wide types are used
--- as actual parameters to dispatching operations. In all cases, a
--- check is made that Constraint_Error is raised if the tag of the
--- operand does not identify a specific type covered by or descended
--- from the target type, and not raised otherwise.
---
--- For the cases where the view conversion is the left side of an
--- assignment statement, and Constraint_Error should not be raised,
--- an additional check is made that only the corresponding portion
--- of the operand is updated by the assignment. For example:
---
--- type T is tagged record
--- C1 : Integer := 0;
--- end record;
---
--- type DT is new T with record
--- C2 : Integer := 0;
--- end record;
---
--- A : T := (C1 => 5);
--- B : DT := (C1 => 0, C2 => 10);
--- CWDT : T'Class := B;
---
--- T(CWDT) := A; -- Updates component C1; C2 remains unchanged.
--- -- Value of CWDT is (C1 => 5, C2 => 10).
---
---
--- CHANGE HISTORY:
--- 31 Jul 95 SAIC Initial prerelease version.
--- 22 Apr 96 SAIC ACVC 2.1: Added a check for correct tag.
--- 08 Sep 96 SAIC ACVC 2.1: Modified Report.Test.
---
---!
-
-package C460005_0 is
-
- type Tag_Type is tagged record
- C1 : Natural;
- end record;
-
- procedure Proc (X : in out Tag_Type);
-
-
- type DTag_Type is new Tag_Type with record
- C2 : String (1 .. 5);
- end record;
-
- procedure Proc (X : in out DTag_Type);
-
-
- type DDTag_Type is new DTag_Type with record
- C3 : String (1 .. 5);
- end record;
-
- procedure Proc (X : in out DDTag_Type);
-
-end C460005_0;
-
-
- --==================================================================--
-
-
-package body C460005_0 is
-
- procedure Proc (X : in out Tag_Type) is
- begin
- X.C1 := 25;
- end Proc;
-
- -----------------------------------------
- procedure Proc (X : in out DTag_Type) is
- begin
- Proc ( Tag_Type(X) );
- X.C2 := "Earth";
- end Proc;
-
- -----------------------------------------
- procedure Proc (X : in out DDTag_Type) is
- begin
- Proc ( DTag_Type(X) );
- X.C3 := "Orbit";
- end Proc;
-
-end C460005_0;
-
-
- --==================================================================--
-
-
-with C460005_0;
-use C460005_0;
-
-with Report;
-procedure C460005 is
-
- Tag_Type_Init : constant Tag_Type := (C1 => 0);
- DTag_Type_Init : constant DTag_Type := (Tag_Type_Init with "Hello");
- DDTag_Type_Init : constant DDTag_Type := (DTag_Type_Init with "World");
-
- Tag_Type_Value : constant Tag_Type := (C1 => 25);
- DTag_Type_Value : constant DTag_Type := (Tag_Type_Value with "Earth");
- DDTag_Type_Value : constant DDTag_Type := (DTag_Type_Value with "Orbit");
-
- Tag_Type_Res : constant Tag_Type := (C1 => 25);
- DTag_Type_Res : constant DTag_Type := (Tag_Type_Res with "Hello");
- DDTag_Type_Res : constant DDTag_Type := (DTag_Type_Res with "World");
-
-begin
-
- Report.Test ("C460005", "Check that, for a view conversion of a tagged " &
- "type that is the left side of an assignment statement, " &
- "the assignment assigns to the corresponding part of the " &
- "object denoted by the operand");
-
-
- declare
- procedure CW_Proc (P : Tag_Type'Class) is
- Operand : Tag_Type'Class := P;
- begin
- Tag_Type(Operand) := Tag_Type_Value;
-
- if (Operand /= Tag_Type'Class (Tag_Type_Value)) then
- Report.Failed ("Operand has wrong value: #01");
- end if;
-
- exception
- when Constraint_Error =>
- Report.Failed ("Constraint_Error raised: #01");
- when others =>
- Report.Failed ("Unexpected exception: #01");
- end CW_Proc;
-
- begin
- CW_Proc (Tag_Type_Init);
- end;
-
- ----------------------------------------------------------------------
-
- declare
- procedure CW_Proc (P : Tag_Type'Class) is
- Operand : Tag_Type'Class := P;
- begin
- DTag_Type(Operand) := DTag_Type_Value;
- Report.Failed ("Constraint_Error not raised: #02");
-
- exception
- when Constraint_Error => null; -- expected exception
- when others => Report.Failed ("Unexpected exception: #02");
- end CW_Proc;
-
- begin
- CW_Proc (Tag_Type_Init);
- end;
-
- ----------------------------------------------------------------------
-
- declare
- procedure CW_Proc (P : Tag_Type'Class) is
- Operand : Tag_Type'Class := P;
- begin
- DDTag_Type(Operand) := DDTag_Type_Value;
- Report.Failed ("Constraint_Error not raised: #03");
-
- exception
- when Constraint_Error => null; -- expected exception
- when others => Report.Failed ("Unexpected exception: #03");
- end CW_Proc;
-
- begin
- CW_Proc (Tag_Type_Init);
- end;
-
- ----------------------------------------------------------------------
-
- declare
- procedure CW_Proc (P : Tag_Type'Class) is
- Operand : Tag_Type'Class := P;
- begin
- Tag_Type(Operand) := Tag_Type_Value;
-
- if Operand not in DTag_Type then
- Report.Failed ("Operand has wrong tag: #04");
- elsif (Operand /= Tag_Type'Class (DTag_Type_Res))
- then -- Check to make
- Report.Failed ("Operand has wrong value: #04"); -- sure that C2 was
- end if; -- not modified.
-
- exception
- when Constraint_Error =>
- Report.Failed ("Constraint_Error raised: #04");
- when others =>
- Report.Failed ("Unexpected exception: #04");
- end CW_Proc;
-
- begin
- CW_Proc (DTag_Type_Init);
- end;
-
- ----------------------------------------------------------------------
-
- declare
- procedure CW_Proc (P : Tag_Type'Class) is
- Operand : Tag_Type'Class := P;
- begin
- Tag_Type(Operand) := Tag_Type_Value;
-
- if Operand not in DDTag_Type then
- Report.Failed ("Operand has wrong tag: #05");
- elsif (Operand /= Tag_Type'Class (DDTag_Type_Res))
- then -- Check to make
- Report.Failed ("Operand has wrong value: #05"); -- sure that C2, C3
- end if; -- were not changed.
-
- exception
- when Constraint_Error =>
- Report.Failed ("Constraint_Error raised: #05");
- when others =>
- Report.Failed ("Unexpected exception: #05");
- end CW_Proc;
-
- begin
- CW_Proc (DDTag_Type_Init);
- end;
-
- Report.Result;
-
-end C460005;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c460006.a b/gcc/testsuite/ada/acats/tests/c4/c460006.a
deleted file mode 100644
index 99968847b9b..00000000000
--- a/gcc/testsuite/ada/acats/tests/c4/c460006.a
+++ /dev/null
@@ -1,378 +0,0 @@
--- C460006.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that a view conversion to a tagged type is permitted in the
--- prefix of a selected component, an object renaming declaration, and
--- (if the operand is a variable) on the left side of an assignment
--- statement. Check that such a renaming or assignment does not change
--- the tag of the operand.
---
--- Check that, for a view conversion of a tagged type, each
--- nondiscriminant component of the new view denotes the matching
--- component of the operand object. Check that reading the value of the
--- view yields the result of converting the value of the operand object
--- to the target subtype.
---
--- TEST DESCRIPTION:
--- The fact that the tag of an object is not changed is verified by
--- making calls to primitive operations which in turn make (re)dispatching
--- calls, and confirming that the proper bodies are executed.
---
--- Selected components are checked in three contexts: as the object name
--- in an object renaming declaration, as the left operand of an inequality
--- operation, and as the left side of an assignment statement.
---
--- View conversions of an object of a 2nd level type extension are
--- renamed as objects of an ancestor type and of a class-wide type. In
--- one case the operand of the conversion is itself a renaming of an
--- object.
---
--- View conversions of an object of a 2nd level type extension are
--- checked for equality with record aggregates of various ancestor types.
--- In one case, the view conversion is to a class-wide type, and it is
--- checked for equality with the result of a class-wide function with
--- the following structure:
---
--- function F return T'Class is
--- A : DDT := Expected_Value;
--- X : T'Class := T(A);
--- begin
--- return X;
---
--- end F;
---
--- ...
---
--- Var : DDT := Expected_Value;
---
--- if (T'Class(Var) /= F) then -- Condition should yield FALSE.
--- FAIL;
--- end if;
---
--- The view conversion to which X is initialized does not affect the
--- value or tag of the operand; the tag of X is that of type DDT (not T),
--- and the components are those of A. The result of this function
--- should equal the value of an object of type DDT initialized to the
--- same value as F.A.
---
--- To check that assignment to a view conversion does not change the tag
--- of the operand, an assignment is made to a conversion of an object,
--- and the object is then passed as an actual to a dispatching operation.
--- Conversions to both specific and class-wide types are checked.
---
---
--- CHANGE HISTORY:
--- 20 Jul 95 SAIC Initial prerelease version.
--- 24 Apr 96 SAIC Added type conversions.
---
---!
-
-package C460006_0 is
-
- type Call_ID_Kind is (None, Parent_Outer, Parent_Inner,
- Child_Outer, Child_Inner,
- Grandchild_Outer, Grandchild_Inner);
-
- type Root_Type is abstract tagged record
- First_Call : Call_ID_Kind := None;
- Second_Call : Call_ID_Kind := None;
- end record;
-
- procedure Inner_Proc (X : in out Root_Type) is abstract;
- procedure Outer_Proc (X : in out Root_Type) is abstract;
-
-end C460006_0;
-
-
- --==================================================================--
-
-
-package C460006_0.C460006_1 is
-
- type Parent_Type is new Root_Type with record
- C1 : Integer := 0;
- end record;
-
- procedure Inner_Proc (X : in out Parent_Type);
- procedure Outer_Proc (X : in out Parent_Type);
-
-end C460006_0.C460006_1;
-
-
- --==================================================================--
-
-
-package body C460006_0.C460006_1 is
-
- procedure Inner_Proc (X : in out Parent_Type) is
- begin
- X.Second_Call := Parent_Inner;
- end Inner_Proc;
-
- -------------------------------------------------
- procedure Outer_Proc (X : in out Parent_Type) is
- begin
- X.First_Call := Parent_Outer;
- Inner_Proc ( Parent_Type'Class(X) );
- end Outer_Proc;
-
-end C460006_0.C460006_1;
-
-
- --==================================================================--
-
-
-package C460006_0.C460006_1.C460006_2 is
-
- type Child_Type is new Parent_Type with record
- C2 : String(1 .. 5) := "-----";
- end record;
-
- procedure Inner_Proc (X : in out Child_Type);
- procedure Outer_Proc (X : in out Child_Type);
-
-end C460006_0.C460006_1.C460006_2;
-
-
- --==================================================================--
-
-
-package body C460006_0.C460006_1.C460006_2 is
-
- procedure Inner_Proc (X : in out Child_Type) is
- begin
- X.Second_Call := Child_Inner;
- end Inner_Proc;
-
- -------------------------------------------------
- procedure Outer_Proc (X : in out Child_Type) is
- begin
- X.First_Call := Child_Outer;
- Inner_Proc ( Parent_Type'Class(X) );
- end Outer_Proc;
-
-end C460006_0.C460006_1.C460006_2;
-
-
- --==================================================================--
-
-
-package C460006_0.C460006_1.C460006_2.C460006_3 is
-
- type Grandchild_Type is new Child_Type with record
- C3: String(1 .. 5) := "-----";
- end record;
-
- procedure Inner_Proc (X : in out Grandchild_Type);
- procedure Outer_Proc (X : in out Grandchild_Type);
-
-
- function ClassWide_Func return Parent_Type'Class;
-
-
- Grandchild_Value : constant Grandchild_Type := (First_Call => None,
- Second_Call => None,
- C1 => 15,
- C2 => "Hello",
- C3 => "World");
-
-end C460006_0.C460006_1.C460006_2.C460006_3;
-
-
- --==================================================================--
-
-
-package body C460006_0.C460006_1.C460006_2.C460006_3 is
-
- procedure Inner_Proc (X : in out Grandchild_Type) is
- begin
- X.Second_Call := Grandchild_Inner;
- end Inner_Proc;
-
- -------------------------------------------------
- procedure Outer_Proc (X : in out Grandchild_Type) is
- begin
- X.First_Call := Grandchild_Outer;
- Inner_Proc ( Parent_Type'Class(X) );
- end Outer_Proc;
-
- -------------------------------------------------
- function ClassWide_Func return Parent_Type'Class is
- A : Grandchild_Type := Grandchild_Value;
- X : Parent_Type'Class := Parent_Type(A); -- Value of X is still that of A.
- begin
- return X;
- end ClassWide_Func;
-
-end C460006_0.C460006_1.C460006_2.C460006_3;
-
-
- --==================================================================--
-
-
-with C460006_0.C460006_1.C460006_2.C460006_3;
-
-with Report;
-procedure C460006 is
-
- package Root_Package renames C460006_0;
- package Parent_Package renames C460006_0.C460006_1;
- package Child_Package renames C460006_0.C460006_1.C460006_2;
- package Grandchild_Package renames C460006_0.C460006_1.C460006_2.C460006_3;
-
-begin
- Report.Test ("C460006", "Check that a view conversion to a tagged type " &
- "is permitted in the prefix of a selected component, an " &
- "object renaming declaration, and (if the operand is a " &
- "variable) on the left side of an assignment statement. " &
- "Check that such a renaming or assignment does not change " &
- " the tag of the operand");
-
-
- --
- -- Check conversion as prefix of selected component:
- --
-
- Selected_Component_Subtest:
- declare
- use Root_Package, Parent_Package, Child_Package, Grandchild_Package;
-
- Var : Grandchild_Type := Grandchild_Value;
- CW_Var : Parent_Type'Class := Var;
-
- Ren : Integer renames Parent_Type(Var).C1;
-
- begin
- if Ren /= 15 then
- Report.Failed ("Wrong value: selected component in renaming");
- end if;
-
- if Child_Type(Var).C2 /= "Hello" then
- Report.Failed ("Wrong value: selected component in IF");
- end if;
-
- Grandchild_Type(CW_Var).C3(2..4) := "eir";
- if CW_Var /= Parent_Type'Class
- (Grandchild_Type'(None, None, 15, "Hello", "Weird"))
- then
- Report.Failed ("Wrong value: selected component in assignment");
- end if;
- end Selected_Component_Subtest;
-
-
- --
- -- Check conversion in object renaming:
- --
-
- Object_Renaming_Subtest:
- declare
- use Root_Package, Parent_Package, Child_Package, Grandchild_Package;
-
- Var : Grandchild_Type := Grandchild_Value;
- Ren1 : Parent_Type renames Parent_Type(Var);
- Ren2 : Child_Type renames Child_Type(Var);
- Ren3 : Parent_Type'Class renames Parent_Type'Class(Var);
- Ren4 : Parent_Type renames Parent_Type(Ren2); -- Rename of rename.
- begin
- Outer_Proc (Ren1);
- if Ren1 /= (Parent_Outer, Grandchild_Inner, 15) then
- Report.Failed ("Value or tag not preserved by object renaming: Ren1");
- end if;
-
- Outer_Proc (Ren2);
- if Ren2 /= (Child_Outer, Grandchild_Inner, 15, "Hello") then
- Report.Failed ("Value or tag not preserved by object renaming: Ren2");
- end if;
-
- Outer_Proc (Ren3);
- if Ren3 /= Parent_Type'Class
- (Grandchild_Type'(Grandchild_Outer,
- Grandchild_Inner,
- 15,
- "Hello",
- "World"))
- then
- Report.Failed ("Value or tag not preserved by object renaming: Ren3");
- end if;
-
- Outer_Proc (Ren4);
- if Ren4 /= (Parent_Outer, Grandchild_Inner, 15) then
- Report.Failed ("Value or tag not preserved by object renaming: Ren4");
- end if;
- end Object_Renaming_Subtest;
-
-
- --
- -- Check reading view conversion, and conversion as left side of assignment:
- --
-
- View_Conversion_Subtest:
- declare
- use Root_Package, Parent_Package, Child_Package, Grandchild_Package;
-
- Var : Grandchild_Type := Grandchild_Value;
- Specific : Child_Type;
- ClassWide : Parent_Type'Class := Var; -- Grandchild_Type tag.
- begin
- if Parent_Type(Var) /= (None, None, 15) then
- Report.Failed ("View has wrong value: #1");
- end if;
-
- if Child_Type(Var) /= (None, None, 15, "Hello") then
- Report.Failed ("View has wrong value: #2");
- end if;
-
- if Parent_Type'Class(Var) /= ClassWide_Func then
- Report.Failed ("Upward view conversion did not preserve " &
- "extension's components");
- end if;
-
-
- Parent_Type(Specific) := (None, None, 26); -- Assign to view.
- Outer_Proc (Specific); -- Call dispatching op.
-
- if Specific /= (Child_Outer, Child_Inner, 26, "-----") then
- Report.Failed ("Value or tag not preserved by assignment: Specific");
- end if;
-
-
- Parent_Type(ClassWide) := (None, None, 44); -- Assign to view.
- Outer_Proc (ClassWide); -- Call dispatching op.
-
- if ClassWide /= Parent_Type'Class
- (Grandchild_Type'(Grandchild_Outer,
- Grandchild_Inner,
- 44,
- "Hello",
- "World"))
- then
- Report.Failed ("Value or tag not preserved by assignment: ClassWide");
- end if;
- end View_Conversion_Subtest;
-
- Report.Result;
-
-end C460006;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c460007.a b/gcc/testsuite/ada/acats/tests/c4/c460007.a
deleted file mode 100644
index fdcc1adcc3d..00000000000
--- a/gcc/testsuite/ada/acats/tests/c4/c460007.a
+++ /dev/null
@@ -1,239 +0,0 @@
--- C460007.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that, in a numeric type conversion, if the target type is an
--- integer type and the operand type is real, the result is rounded
--- to the nearest integer, and away from zero if the result is exactly
--- halfway between two integers. Check for static and non-static type
--- conversions.
---
--- TEST DESCRIPTION:
--- The following cases are considered:
---
--- X.5 X.5 + delta -X.5 + delta
--- -X.5 X.5 - delta -X.5 - delta
---
--- Both zero and non-zero values are used for X. The value of delta is
--- chosen to be a very small increment (on the order of 1.0E-10). For
--- fixed and floating point cases, the value of delta is chosen such that
--- "(-)X.5 +(-) delta" is a multiple of the small, or a machine number,
--- respectively.
---
--- The following type conversions are performed:
---
--- ID Real operand Cases Target integer subtype
--- ------------------------------------------------------------------
--- 1 Real named number X.5 Nonstatic
--- 2 X.5 - delta Nonstatic
--- 3 -X.5 - delta Static
--- 4 Real literal -X.5 Static
--- 5 X.5 + delta Static
--- 6 -X.5 + delta Nonstatic
--- 7 Floating point object -X.5 - delta Nonstatic
--- 8 X.5 - delta Static
--- 9 Fixed point object X.5 Static
--- 10 X.5 + delta Static
--- 11 -X.5 + delta Nonstatic
--- The conversion is either assigned to a variable of the target subtype
--- or passed as a parameter to a subprogram (both nonstatic contexts).
---
--- The subprogram Equal is used to circumvent potential optimizations.
---
---
--- CHANGE HISTORY:
--- 03 Oct 95 SAIC Initial prerelease version.
---
---!
-
-with System;
-package C460007_0 is
-
---
--- Target integer subtype (static):
---
-
- type Static_Integer_Subtype is range -32_000 .. 32_000;
-
- Static_Target : Static_Integer_Subtype;
-
- function Equal (L, R: Static_Integer_Subtype) return Boolean;
-
-
---
--- Named numbers:
---
-
- NN_Half : constant := 0.5000000000;
- NN_Less_Half : constant := 126.4999999999;
- NN_More_Half : constant := -NN_Half - 0.0000000001;
-
-
---
--- Floating point:
---
-
- type My_Float is digits System.Max_Digits;
-
- Flt_Rnd_Toward_Zero : My_Float := My_Float'Pred(NN_Half);
- Flt_Rnd_Away_Zero : constant My_Float := My_Float'Pred(-113.5);
-
-
---
--- Fixed point:
---
-
- type My_Fixed is delta 0.1 range -5.0 .. 5.0;
-
- Fix_Half : My_Fixed := 0.5;
- Fix_Rnd_Away_Zero : My_Fixed := Fix_Half + My_Fixed'Small;
- Fix_Rnd_Toward_Zero : constant My_Fixed := -3.5 + My_Fixed'Small;
-
-end C460007_0;
-
-
- --==================================================================--
-
-
-package body C460007_0 is
-
- function Equal (L, R: Static_Integer_Subtype) return Boolean is
- begin
- return (L = R);
- end Equal;
-
-end C460007_0;
-
-
- --==================================================================--
-
-
-with C460007_0;
-use C460007_0;
-
-with Report;
-procedure C460007 is
-
---
--- Target integer subtype (nonstatic):
---
-
- Limit : Static_Integer_Subtype :=
- Static_Integer_Subtype(Report.Ident_Int(128));
-
- subtype Nonstatic_Integer_Subtype is Static_Integer_Subtype
- range -Limit .. Limit;
-
- Nonstatic_Target : Static_Integer_Subtype;
-
-begin
-
- Report.Test ("C460007", "Rounding for type conversions of real operand " &
- "to integer target");
-
-
- -- --------------------------
- -- Named number/literal cases:
- -- --------------------------
-
- Nonstatic_Target := Nonstatic_Integer_Subtype(NN_Half);
-
- if not Equal(Nonstatic_Target, 1) then -- Case 1.
- Report.Failed ("Wrong result for named number operand" &
- "(case 1), nonstatic target subtype");
- end if;
-
- if not Equal(Nonstatic_Integer_Subtype(NN_Less_Half), 126) then -- Case 2.
- Report.Failed ("Wrong result for named number operand" &
- "(case 2), nonstatic target subtype");
- end if;
-
- Static_Target := Static_Integer_Subtype(NN_More_Half);
-
- if not Equal(Static_Target, -1) then -- Case 3.
- Report.Failed ("Wrong result for named number operand" &
- "(case 3), static target subtype");
- end if;
-
- if not Equal(Static_Integer_Subtype(-0.50), -1) then -- Case 4.
- Report.Failed ("Wrong result for literal operand" &
- "(case 4), static target subtype");
- end if;
-
- if not Equal(Static_Integer_Subtype(29_546.5001), 29_547) then -- Case 5.
- Report.Failed ("Wrong result for literal operand" &
- "(case 5), static target subtype");
- end if;
-
- if not Equal(Nonstatic_Integer_Subtype(-66.499), -66) then -- Case 6.
- Report.Failed ("Wrong result for literal operand" &
- "(case 6), nonstatic target subtype");
- end if;
-
-
- -- --------------------
- -- Floating point cases:
- -- --------------------
-
- Nonstatic_Target := Nonstatic_Integer_Subtype(Flt_Rnd_Away_Zero);
-
- if not Equal(Nonstatic_Target, -114) then -- Case 7.
- Report.Failed ("Wrong result for floating point operand" &
- "(case 7), nonstatic target subtype");
- end if;
- -- Case 8.
- if not Equal(Static_Integer_Subtype(Flt_Rnd_Toward_Zero), 0) then
- Report.Failed ("Wrong result for floating point operand" &
- "(case 8), static target subtype");
- end if;
-
-
- -- -----------------
- -- Fixed point cases:
- -- -----------------
-
- Static_Target := Static_Integer_Subtype(Fix_Half);
-
- if not Equal(Static_Target, 1) then -- Case 9.
- Report.Failed ("Wrong result for fixed point operand" &
- "(case 9), static target subtype");
- end if;
-
- if not Equal(Static_Integer_Subtype(Fix_Rnd_Away_Zero), 1) then -- Case 10.
- Report.Failed ("Wrong result for fixed point operand" &
- "(case 10), static target subtype");
- end if;
-
- Nonstatic_Target := Nonstatic_Integer_Subtype(Fix_Rnd_Toward_Zero);
-
- if not Equal(Nonstatic_Target, -3) then -- Case 11.
- Report.Failed ("Wrong result for fixed point operand" &
- "(case 11), nonstatic target subtype");
- end if;
-
-
- Report.Result;
-
-end C460007;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c460008.a b/gcc/testsuite/ada/acats/tests/c4/c460008.a
deleted file mode 100644
index 29d48ecd4c4..00000000000
--- a/gcc/testsuite/ada/acats/tests/c4/c460008.a
+++ /dev/null
@@ -1,286 +0,0 @@
--- C460008.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that conversion to a modular type raises Constraint_Error
--- when the operand value is outside the base range of the modular type.
---
--- TEST DESCRIPTION:
--- Test conversion from integer, float, fixed and decimal types to
--- modular types. Test conversion to mod 255, mod 256 and mod 258
--- to test the boundaries of 8 bit (+/-) unsigned numbers.
--- Test operand values that are negative, the value of the mod,
--- and greater than the value of the mod.
--- Declare a generic test procedure and instantiate it for each of the
--- unsigned types for each operand type.
---
---
--- CHANGE HISTORY:
--- 04 OCT 95 SAIC Initial version
--- 15 MAY 96 SAIC Revised for 2.1
--- 24 NOV 98 RLB Moved decimal cases into new test, C460011, to
--- prevent this test from being inapplicable to
--- implementations not supporting decimal types.
---
---!
-
-------------------------------------------------------------------- C460008
-
-with Report;
-
-procedure C460008 is
-
- Shy_By_One : constant := 2**8-1;
- Heavy_By_Two : constant := 2**8+2;
-
- type Unsigned_Edge_8 is mod Shy_By_One;
- type Unsigned_8_Bit is mod 2**8;
- type Unsigned_Over_8 is mod Heavy_By_Two;
-
- NPC : constant String := " not properly converted";
-
- procedure Assert( Truth: Boolean; Message: String ) is
- begin
- if not Truth then
- Report.Failed(Message);
- end if;
- end Assert;
-
--- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
-
- generic
- type Source is range <>;
- type Target is mod <>;
- procedure Integer_Conversion_Check( For_The_Value : Source;
- Message : String );
-
- procedure Integer_Conversion_Check( For_The_Value : Source;
- Message : String ) is
-
- Item : Target;
-
- begin
- Item := Target( For_The_Value );
- Report.Failed("Int expected Constraint_Error " & Message);
- -- the call to Comment is to make the otherwise dead assignment to
- -- Item live.
- -- To avoid invoking C_E on a call to 'Image in Report.Failed that
- -- could cause a false pass
- Report.Comment("Value of" & Target'Image(Item) & NPC);
- exception
- when Constraint_Error => null; -- expected case
- when others => Report.Failed("Int Raised wrong exception " & Message);
- end Integer_Conversion_Check;
-
- procedure Int_To_Short is
- new Integer_Conversion_Check( Integer, Unsigned_Edge_8 );
-
- procedure Int_To_Eight is
- new Integer_Conversion_Check( Integer, Unsigned_8_Bit );
-
- procedure Int_To_Wide is
- new Integer_Conversion_Check( Integer, Unsigned_Over_8 );
-
--- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
-
- generic
- type Source is digits <>;
- type Target is mod <>;
- procedure Float_Conversion_Check( For_The_Value : Source;
- Message : String );
-
- procedure Float_Conversion_Check( For_The_Value : Source;
- Message : String ) is
-
- Item : Target;
-
- begin
- Item := Target( For_The_Value );
- Report.Failed("Flt expected Constraint_Error " & Message);
- Report.Comment("Value of" & Target'Image(Item) & NPC);
- exception
- when Constraint_Error => null; -- expected case
- when others => Report.Failed("Flt raised wrong exception " & Message);
- end Float_Conversion_Check;
-
- procedure Float_To_Short is
- new Float_Conversion_Check( Float, Unsigned_Edge_8 );
-
- procedure Float_To_Eight is
- new Float_Conversion_Check( Float, Unsigned_8_Bit );
-
- procedure Float_To_Wide is
- new Float_Conversion_Check( Float, Unsigned_Over_8 );
-
- function Identity( Root_Beer: Float ) return Float is
- -- a knockoff of Report.Ident_Int for type Float
- Nothing : constant Float := 0.0;
- begin
- if Report.Ident_Bool( Root_Beer = Nothing ) then
- return Nothing;
- else
- return Root_Beer;
- end if;
- end Identity;
-
--- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
-
- generic
- type Source is delta <>;
- type Target is mod <>;
- procedure Fixed_Conversion_Check( For_The_Value : Source;
- Message : String );
-
- procedure Fixed_Conversion_Check( For_The_Value : Source;
- Message : String ) is
-
- Item : Target;
-
- begin
- Item := Target( For_The_Value );
- Report.Failed("Fix expected Constraint_Error " & Message);
- Report.Comment("Value of" & Target'Image(Item) & NPC);
- exception
- when Constraint_Error => null; -- expected case
- when others => Report.Failed("Fix raised wrong exception " & Message);
- end Fixed_Conversion_Check;
-
- procedure Fixed_To_Short is
- new Fixed_Conversion_Check( Duration, Unsigned_Edge_8 );
-
- procedure Fixed_To_Eight is
- new Fixed_Conversion_Check( Duration, Unsigned_8_Bit );
-
- procedure Fixed_To_Wide is
- new Fixed_Conversion_Check( Duration, Unsigned_Over_8 );
-
- function Identity( A_Stitch: Duration ) return Duration is
- Threadbare : constant Duration := 0.0;
- begin
- if Report.Ident_Bool( A_Stitch = Threadbare ) then
- return Threadbare;
- else
- return A_Stitch;
- end if;
- end Identity;
-
--- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
-
-begin -- Main test procedure.
-
- Report.Test ("C460008", "Check that conversion to " &
- "a modular type raises Constraint_Error when " &
- "the operand value is outside the base range " &
- "of the modular type" );
-
-
- -- Integer Error cases
-
- Int_To_Short( Report.Ident_Int( -1 ), "I2S Dynamic, Negative" );
- Int_To_Short( Report.Ident_Int( Shy_By_One ), "I2S Dynamic, At_Mod" );
- Int_To_Short( Report.Ident_Int( Heavy_By_Two+1 ), "I2S Dynamic, Over_Mod" );
-
- Int_To_Eight( -Shy_By_One, "I28 Static, Negative" );
- Int_To_Eight( 2**8, "I28 Static, At_Mod" );
- Int_To_Eight( Heavy_By_Two+1, "I28 Static, Over_Mod" );
-
- Int_To_Wide ( Report.Ident_Int( -(Heavy_By_Two*2) ),
- "I2W Dynamic, Negative" );
- Int_To_Wide ( Heavy_By_Two, "I2W Static, At_Mod" );
- Int_To_Wide ( Report.Ident_Int( Heavy_By_Two*2 ), "I2W Dynamic, Over_Mod" );
-
- -- Float Error cases
-
- Float_To_Short( -13.31, "F2S Static, Negative" );
- Float_To_Short( Identity ( Float(Shy_By_One)), "F2S Dynamic, At_Mod" );
- Float_To_Short( 6378.388, "F2S Static, Over_Mod" );
-
- Float_To_Eight( Identity( -99.3574 ), "F28 Dynamic, Negative" );
- Float_To_Eight( 2.0**8, "F28 Static, At_Mod" );
- Float_To_Eight( 2.0**9, "F28 Static, Over_Mod" );
-
- Float_To_Wide ( -0.54953_93129_81644, "FTW Static, Negative" );
- Float_To_Wide ( Identity( 2.0**8 +2.0 ), "FTW Dynamic, At_Mod" );
- Float_To_Wide ( Identity( 2.0**8 +2.5001 ), "FTW Dynamic, Over_Mod" );
- Float_To_Wide ( Identity( Float'Last ), "FTW Dynamic, Over_Mod" );
-
- -- Fixed Error cases
-
- Fixed_To_Short( Identity( -5.00 ), "D2S Dynamic, Negative" );
- Fixed_To_Short( Shy_By_One * 1.0, "D2S Static, At_Mod" );
- Fixed_To_Short( 1995.9, "D2S Static, Over_Mod" );
-
- Fixed_To_Eight( -0.5, "D28 Static, Negative" );
- Fixed_To_Eight( 2.0*128, "D28 Static, At_Mod" );
- Fixed_To_Eight( Identity( 2001.2 ), "D28 Dynamic, Over_Mod" );
-
- Fixed_To_Wide ( Duration'First, "D2W Static, Negative" );
- Fixed_To_Wide ( Identity( 2*128.0 +2.0 ), "D2W Dynamic, At_Mod" );
- Fixed_To_Wide ( Duration'Last, "D2W Static, Over_Mod" );
-
- -- having made it this far, the rest is downhill...
- -- check a few, correct, edge cases, and we're done
-
- Eye_Dew: declare
- A_Float : Float := 0.0;
- Your_Time : Duration := 0.0;
- Number : Integer := 0;
-
- Little : Unsigned_Edge_8;
- Moderate : Unsigned_8_Bit;
- Big : Unsigned_Over_8;
-
- begin
- Little := Unsigned_Edge_8(A_Float);
- Assert( Little = 0, "Float => Little, 0");
-
-
- Moderate := Unsigned_8_Bit (Your_Time);
- Assert( Moderate = 0, "Your_Time => Moderate, 0");
-
- Big := Unsigned_Over_8 (Number);
- Assert( Big = 0, "Number => Big, 0");
-
- A_Float := 2.0**8-2.0;
- Your_Time := 2.0*128-2.0;
- Number := 2**8;
-
- Little := Unsigned_Edge_8(A_Float);
- Assert( Little = 254, "Float => Little, 254");
-
- Little := Unsigned_Edge_8(Your_Time);
- Assert( Little = 254, "Your_Time => Little, 254");
-
- Big := Unsigned_Over_8 (A_Float + 2.0);
- Assert( Big = 256, "Sense => Big, 256");
-
- Big := Unsigned_Over_8 (Number);
- Assert( Big = 256, "Number => Big, 256");
-
- end Eye_Dew;
-
- Report.Result;
-
-end C460008;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c460009.a b/gcc/testsuite/ada/acats/tests/c4/c460009.a
deleted file mode 100644
index 62dbd47c2c7..00000000000
--- a/gcc/testsuite/ada/acats/tests/c4/c460009.a
+++ /dev/null
@@ -1,467 +0,0 @@
--- C460009.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that Constraint_Error is raised in cases of null arrays when:
--- 1. an assignment is made to a null array if the length of each
--- dimension of the operand does not match the length of
--- the corresponding dimension of the target subtype.
--- 2. an array actual parameter does not match the length of
--- corresponding dimensions of the formal in out parameter where
--- the actual parameter has the form of a type conversion.
--- 3. an array actual parameter does not match the length of
--- corresponding dimensions of the formal out parameter where
--- the actual parameter has the form of a type conversion.
---
--- TEST DESCRIPTION:
--- This transition test creates examples where array of null ranges
--- raises Constraint_Error if any of the lengths mismatch.
---
--- Inspired by C52103S.ADA, C64105E.ADA, and C64105F.ADA.
---
---
--- CHANGE HISTORY:
--- 21 Mar 96 SAIC Initial version for ACVC 2.1.
--- 21 Sep 96 SAIC ACVC 2.1: Added new case.
---
---!
-
-with Report;
-
-procedure C460009 is
-
- subtype Int is Integer range 1 .. 3;
-
-begin
-
- Report.Test("C460009","Check that Constraint_Error is raised in " &
- "cases of null arrays if any of the lengths mismatch " &
- "in assignments and parameter passing");
-
- ---------------------------------------------------------------------------
- declare
-
- type Arr_Int1 is array (Int range <>) of Integer;
- Arr_Obj1 : Arr_Int1 (2 .. Report.Ident_Int(1)); -- null array object
-
- begin
-
- -- Same lengths, no Constraint_Error raised.
- Arr_Obj1 := (Report.Ident_Int(3) .. 2 => Report.Ident_Int(1));
-
- Report.Comment ("Dead assignment prevention in Arr_Obj1 => " &
- Integer'Image (Arr_Obj1'Last));
-
- exception
-
- when Constraint_Error =>
- Report.Failed ("Arr_Obj1 - Constraint_Error exception raised");
- when others =>
- Report.Failed ("Arr_Obj1 - others exception raised");
-
- end;
-
- ---------------------------------------------------------------------------
- declare
-
- type Arr_Int2 is array (Int range <>, Int range <>) of Integer;
- Arr_Obj2 : Arr_Int2 (1 .. Report.Ident_Int(2),
- Report.Ident_Int(3) .. Report.Ident_Int(2));
- -- null array object
- begin
-
- -- Same lengths, no Constraint_Error raised.
- Arr_Obj2 := Arr_Int2'(Report.Ident_Int(2) .. 3 =>
- (Report.Ident_Int(2) .. Report.Ident_Int(1) =>
- Report.Ident_Int(1)));
-
- Report.Comment ("Dead assignment prevention in Arr_Obj2 => " &
- Integer'Image (Arr_Obj2'Last));
-
- exception
-
- when Constraint_Error =>
- Report.Failed ("Arr_Obj2 - Constraint_Error exception raised");
- when others =>
- Report.Failed ("Arr_Obj2 - others exception raised");
-
- end;
-
- ---------------------------------------------------------------------------
- declare
-
- type Arr_Int3 is array (Int range <>, Int range <>) of Integer;
- Arr_Obj3 : Arr_Int3 (1 .. Report.Ident_Int(2),
- Report.Ident_Int(3) .. Report.Ident_Int(2));
- -- null array object
-
- begin
-
- -- Lengths mismatch, Constraint_Error raised.
- Arr_Obj3 := Arr_Int3'(Report.Ident_Int(3) .. 2 =>
- (Report.Ident_Int(1) .. Report.Ident_Int(3) =>
- Report.Ident_Int(1)));
-
- Report.Comment ("Dead assignment prevention in Arr_Obj3 => " &
- Integer'Image (Arr_Obj3'Last));
-
- Report.Failed ("Constraint_Error not raised in Arr_Obj3");
-
- exception
-
- when Constraint_Error => null; -- exception expected.
- when others =>
- Report.Failed ("Arr_Obj3 - others exception raised");
-
- end;
-
- ---------------------------------------------------------------------------
- declare
-
- type Arr_Int4 is array (Int range <>, Int range <>, Int range <>) of
- Integer;
- Arr_Obj4 : Arr_Int4 (1 .. Report.Ident_Int(2),
- Report.Ident_Int(1) .. Report.Ident_Int(3),
- Report.Ident_Int(3) .. Report.Ident_Int(2));
- -- null array object
- begin
-
- -- Lengths mismatch, Constraint_Error raised.
- Arr_Obj4 := Arr_Int4'(Report.Ident_Int(1) .. 3 =>
- (Report.Ident_Int(1) .. Report.Ident_Int(2) =>
- (Report.Ident_Int(3) .. Report.Ident_Int(2) =>
- Report.Ident_Int(1))));
-
- Report.Comment ("Dead assignment prevention in Arr_Obj4 => " &
- Integer'Image (Arr_Obj4'Last));
-
- Report.Failed ("Constraint_Error not raised in Arr_Obj4");
-
- exception
-
- when Constraint_Error => null; -- exception expected.
- when others =>
- Report.Failed ("Arr_Obj4 - others exception raised");
-
- end;
-
- ---------------------------------------------------------------------------
- declare
-
- type Arr_Int5 is array (Int range <>) of Integer;
- Arr_Obj5 : Arr_Int5 (2 .. Report.Ident_Int(1)); -- null array object
-
- begin
-
- -- Only lengths of two null ranges are different, no Constraint_Error
- -- raised.
- Arr_Obj5 := (Report.Ident_Int(3) .. 1 => Report.Ident_Int(1));
-
- Report.Comment ("Dead assignment prevention in Arr_Obj5 => " &
- Integer'Image (Arr_Obj5'Last));
-
- exception
-
- when Constraint_Error =>
- Report.Failed ("Arr_Obj5 - Constraint_Error exception raised");
- when others =>
- Report.Failed ("Arr_Obj5 - others exception raised");
-
- end;
-
- ---------------------------------------------------------------------------
- declare
- subtype Str is String (Report.Ident_Int(5) .. 4);
- -- null string
- Str_Obj : Str;
-
- begin
-
- -- Same lengths, no Constraint_Error raised.
- Str_Obj := (Report.Ident_Int(1) .. 0 => 'Z');
- Str_Obj(2 .. 1) := "";
- Str_Obj(4 .. 2) := (others => 'X');
- Str_Obj(Report.Ident_Int(6) .. 3) := "";
- Str_Obj(Report.Ident_Int(0) .. Report.Ident_Int(-1)) := (others => 'Y');
-
- exception
-
- when Constraint_Error =>
- Report.Failed ("Str_Obj - Constraint_Error exception raised");
- when others =>
- Report.Failed ("Str_Obj - others exception raised");
-
- end;
-
- ---------------------------------------------------------------------------
- declare
-
- type Arr_Char5 is array (Int range <>, Int range <>) of Character;
- subtype Formal is Arr_Char5
- (Report.Ident_Int(2) .. 0, 1 .. Report.Ident_Int(3));
- Arr_Obj5 : Arr_Char5 (Report.Ident_Int(2) .. Report.Ident_Int(1),
- Report.Ident_Int(1) .. Report.Ident_Int(2))
- := (Report.Ident_Int(2) .. Report.Ident_Int(1) =>
- (Report.Ident_Int(1) .. Report.Ident_Int(2) => ' '));
-
- procedure Proc5 (P : in out Formal) is
- begin
- Report.Failed ("No exception raised in Proc5");
-
- exception
-
- when Constraint_Error =>
- Report.Failed ("Constraint_Error exception raised in Proc5");
- when others =>
- Report.Failed ("Others exception raised in Proc5");
- end;
-
- begin
-
- -- Lengths mismatch in the type conversion, Constraint_Error raised.
- Proc5 (Formal(Arr_Obj5));
-
- Report.Failed ("Constraint_Error not raised in the call Proc5");
-
- exception
-
- when Constraint_Error => null; -- exception expected.
- when others =>
- Report.Failed ("Arr_Obj5 - others exception raised");
-
- end;
-
- ---------------------------------------------------------------------------
- declare
-
- type Formal is array
- (Report.Ident_Int(1) .. 3, 3 .. Report.Ident_Int(1)) of Character;
-
- type Actual is array
- (Report.Ident_Int(5) .. 3, 3 .. Report.Ident_Int(5)) of Character;
-
- Arr_Obj6 : Actual := (5 .. 3 => (3 .. 5 => ' '));
-
- procedure Proc6 (P : in out Formal) is
- begin
- Report.Failed ("No exception raised in Proc6");
-
- exception
-
- when Constraint_Error =>
- Report.Failed ("Constraint_Error exception raised in Proc6");
- when others =>
- Report.Failed ("Others exception raised in Proc6");
- end;
-
- begin
-
- -- Lengths mismatch in the type conversion, Constraint_Error raised.
- Proc6 (Formal(Arr_Obj6));
-
- Report.Failed ("Constraint_Error not raised in the call Proc6");
-
- exception
-
- when Constraint_Error => null; -- exception expected.
- when others =>
- Report.Failed ("Arr_Obj6 - others exception raised");
-
- end;
-
- ---------------------------------------------------------------------------
- declare
-
- type Formal is array (Int range <>, Int range <>) of Character;
- type Actual is array (Positive range 5 .. 2,
- Positive range 1 .. 3) of Character;
-
- Arr_Obj7 : Actual := (5 .. 2 => (1 .. 3 => ' '));
-
- procedure Proc7 (P : in out Formal) is
- begin
- if P'Last /= 2 and P'Last(2) /= 3 then
- Report.Failed ("Wrong bounds passed for Arr_Obj7");
- end if;
-
- -- Lengths mismatch, Constraint_Error raised.
- P := (1 .. 3 => (3 .. 0 => ' '));
-
- Report.Comment ("Dead assignment prevention in Proc7 => " &
- Integer'Image (P'Last));
-
- Report.Failed ("No exception raised in Proc7");
-
- exception
-
- when Constraint_Error => null; -- exception expected.
- when others =>
- Report.Failed ("Others exception raised in Proc7");
- end;
-
- begin
-
- -- Same lengths, no Constraint_Error raised.
- Proc7 (Formal(Arr_Obj7));
-
- if Arr_Obj7'Last /= 2 and Arr_Obj7'Last(2) /= 3 then
- Report.Failed ("Bounds changed for Arr_Obj7");
- end if;
-
- exception
-
- when Constraint_Error =>
- Report.Failed ("Constraint_Error exception raised after call Proc7");
- when others =>
- Report.Failed ("Arr_Obj7 - others exception raised");
-
- end;
-
- ---------------------------------------------------------------------------
- declare
-
- type Arr_Char8 is array (Int range <>, Int range <>) of Character;
- subtype Formal is Arr_Char8
- (Report.Ident_Int(2) .. 0, 1 .. Report.Ident_Int(3));
- Arr_Obj8 : Arr_Char8 (Report.Ident_Int(2) .. Report.Ident_Int(1),
- Report.Ident_Int(1) .. Report.Ident_Int(2));
-
- procedure Proc8 (P : out Formal) is
- begin
- Report.Failed ("No exception raised in Proc8");
-
- exception
-
- when Constraint_Error =>
- Report.Failed ("Constraint_Error exception raised in Proc8");
- when others =>
- Report.Failed ("Others exception raised in Proc8");
- end;
-
- begin
-
- -- Lengths mismatch in the type conversion, Constraint_Error raised.
- Proc8 (Formal(Arr_Obj8));
-
- Report.Failed ("Constraint_Error not raised in the call Proc8");
-
- exception
-
- when Constraint_Error => null; -- exception expected.
- when others =>
- Report.Failed ("Arr_Obj8 - others exception raised");
-
- end;
-
- ---------------------------------------------------------------------------
- declare
-
- type Formal is array
- (Report.Ident_Int(1) .. 3, 3 .. Report.Ident_Int(1)) of Character;
-
- type Actual is array
- (Report.Ident_Int(5) .. 3, 3 .. Report.Ident_Int(5)) of Character;
-
- Arr_Obj9 : Actual;
-
- procedure Proc9 (P : out Formal) is
- begin
- Report.Failed ("No exception raised in Proc9");
-
- exception
-
- when Constraint_Error =>
- Report.Failed ("Constraint_Error exception raised in Proc9");
- when others =>
- Report.Failed ("Others exception raised in Proc9");
- end;
-
- begin
-
- -- Lengths mismatch in the type conversion, Constraint_Error raised.
- Proc9 (Formal(Arr_Obj9));
-
- Report.Failed ("Constraint_Error not raised in the call Proc9");
-
- exception
-
- when Constraint_Error => null; -- exception expected.
- when others =>
- Report.Failed ("Arr_Obj9 - others exception raised");
-
- end;
-
- ---------------------------------------------------------------------------
- declare
-
- type Formal is array (Int range <>, Int range <>) of Character;
- type Actual is array (Positive range 5 .. 2,
- Positive range 1 .. 3) of Character;
-
- Arr_Obj10 : Actual;
-
- procedure Proc10 (P : out Formal) is
- begin
- if P'Last /= 2 and P'Last(2) /= 3 then
- Report.Failed ("Wrong bounds passed for Arr_Obj10");
- end if;
-
- -- Lengths mismatch, Constraint_Error raised.
- P := (1 .. 3 => (3 .. 1 => ' '));
-
- Report.Comment ("Dead assignment prevention in Proc10 => " &
- Integer'Image (P'Last));
-
- Report.Failed ("No exception raised in Proc10");
-
- exception
-
- when Constraint_Error => null; -- exception expected.
- when others =>
- Report.Failed ("Others exception raised in Proc10");
- end;
-
- begin
-
- -- Same lengths, no Constraint_Error raised.
- Proc10 (Formal(Arr_Obj10));
-
- if Arr_Obj10'Last /= 2 and Arr_Obj10'Last(2) /= 3 then
- Report.Failed ("Bounds changed for Arr_Obj10");
- end if;
-
- exception
-
- when Constraint_Error =>
- Report.Failed ("Constraint_Error exception raised after call Proc10");
- when others =>
- Report.Failed ("Arr_Obj10 - others exception raised");
-
- end;
-
- ---------------------------------------------------------------------------
- Report.Result;
-
-end C460009;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c460010.a b/gcc/testsuite/ada/acats/tests/c4/c460010.a
deleted file mode 100644
index 790a8c3396c..00000000000
--- a/gcc/testsuite/ada/acats/tests/c4/c460010.a
+++ /dev/null
@@ -1,354 +0,0 @@
--- C460010.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that, for an array aggregate without an others choice assigned
--- to an object of a constrained array subtype, Constraint_Error is not
--- raised if the length of each dimension of the aggregate equals the
--- length of the corresponding dimension of the target object, even if
--- the bounds of the corresponding index ranges do not match.
---
--- TEST DESCRIPTION:
--- The test verifies that sliding of array bounds is performed on array
--- aggregates that are part of a larger aggregate, where the bounds of
--- the corresponding index ranges do not match but the lengths of the
--- corresponding dimensions are the same. Both aggregates containing
--- named associations and positional associations are checked. Cases
--- involving static and nonstatic index constraints, as well as pre-
--- defined and modular integer index subtypes, are included.
---
---
--- CHANGE HISTORY:
--- 15 Apr 96 SAIC Prerelease version for ACVC 2.1.
--- 20 Oct 96 SAIC Removed unnecessary parentheses and type
--- conversions.
---
---!
-
-with Report;
-pragma Elaborate (Report);
-
-package C460010_0 is
-
- type Modular_Type is mod 10; -- Range 0 .. 9.
-
-
- Two : Modular_Type := Modular_Type (Report.Ident_Int(2));
- Four : Modular_Type := Modular_Type (Report.Ident_Int(4));
-
- type Array_Modular_Index is array (Modular_Type range <>) of Integer;
-
- subtype Array_Static_Modular_Constraint is Array_Modular_Index(2..4);
- subtype Array_Nonstatic_Modular_Constraint is Array_Modular_Index(Two..Four);
-
-end C460010_0;
-
-
- --==================================================================--
-
-
-with Report;
-pragma Elaborate (Report);
-
-package C460010_1 is
-
- One : Integer := Report.Ident_Int(1);
- Ten : Integer := Report.Ident_Int(10);
-
- subtype Integer_Subtype is Integer range One .. Ten;
-
-
- Two : Integer := Report.Ident_Int(2);
- Four : Integer := Report.Ident_Int(4);
-
- type Array_Integer_Index is array (Integer_Subtype range <>) of Boolean;
-
- subtype Array_Static_Integer_Constraint is Array_Integer_Index(2..4);
- subtype Array_Nonstatic_Integer_Constraint is Array_Integer_Index(Two..Four);
-
-end C460010_1;
-
-
- --==================================================================--
-
-
--- Generic equality function:
-
-generic
- type Operand_Type is private;
-function C460010_2 (L, R : Operand_Type) return Boolean;
-
-
-function C460010_2 (L, R : Operand_Type) return Boolean is
-begin
- return L = R;
-end C460010_2;
-
-
- --==================================================================--
-
-
-with C460010_0;
-with C460010_1;
-with C460010_2;
-
-with Report;
-
-procedure C460010 is
-
- generic function Generic_Equality renames C460010_2;
-
-begin
- Report.Test ("C460010", "Check that Constraint_Error is not raised if " &
- "an array aggregate without an others choice is assigned " &
- "to an object of a constrained array subtype, and the " &
- "length of each dimension of the aggregate equals the " &
- "length of the corresponding dimension of the target object");
-
-
- ---=---=---=---=---=---=---=---=---=---=---
-
-
- declare
- type Arr is array (1..1) of C460010_0.Array_Static_Modular_Constraint;
- function Equals is new Generic_Equality (Arr);
- Target : Arr;
- begin
- ---=---=---=---=---=---=---
- CASE_1:
- begin
- Target := (1 => (1 => 1, 2 => 2, 3 => 3)); -- Named associations.
-
- if not Equals (Target, Target) then
- Report.Failed ("Avoid optimization"); -- Never executed.
- end if;
- exception
- when Constraint_Error =>
- Report.Failed ("Constraint_Error raised: Case 1");
- when others =>
- Report.Failed ("Unexpected exception raised: Case 1");
- end CASE_1;
-
- ---=---=---=---=---=---=---
-
- CASE_2:
- begin
- Target := (1 => (5, 10, 15)); -- Positional associations.
-
- if not Equals (Target, Target) then
- Report.Failed ("Avoid optimization"); -- Never executed.
- end if;
- exception
- when Constraint_Error =>
- Report.Failed ("Constraint_Error raised: Case 2");
- when others =>
- Report.Failed ("Unexpected exception raised: Case 2");
- end CASE_2;
-
- ---=---=---=---=---=---=---
- end;
-
-
- ---=---=---=---=---=---=---=---=---=---=---
-
-
- declare
- type Rec (Disc : C460010_0.Modular_Type := 4) is record
- Arr : C460010_0.Array_Modular_Index(2 .. Disc);
- end record;
-
- function Equals is new Generic_Equality (Rec);
- Target : Rec;
- begin
- ---=---=---=---=---=---=---
- CASE_3:
- begin
- Target := (Disc => 4, Arr => (1 => 1, 2 => 2, 3 => 3)); -- Named.
-
- if not Equals (Target, Target) then
- Report.Failed ("Avoid optimization"); -- Never executed.
- end if;
- exception
- when Constraint_Error =>
- Report.Failed ("Constraint_Error raised: Case 3");
- when others =>
- Report.Failed ("Unexpected exception raised: Case 3");
- end CASE_3;
-
- ---=---=---=---=---=---=---
-
- CASE_4:
- begin
- Target := (Disc => 4, Arr => (1 ,2, 3)); -- Positional.
-
- if not Equals (Target, Target) then
- Report.Failed ("Avoid optimization"); -- Never executed.
- end if;
- exception
- when Constraint_Error =>
- Report.Failed ("Constraint_Error raised: Case 4");
- when others =>
- Report.Failed ("Unexpected exception raised: Case 4");
- end CASE_4;
-
- ---=---=---=---=---=---=---
- end;
-
-
- ---=---=---=---=---=---=---=---=---=---=---
-
-
- declare
- type Arr is array (1..1) of C460010_0.Array_Nonstatic_Modular_Constraint;
- function Equals is new Generic_Equality (Arr);
- Target : Arr;
- begin
- ---=---=---=---=---=---=---
- CASE_5:
- begin
- Target := (1 => (1 => 1, 2 => 2, 3 => 3)); -- Named associations.
-
- if not Equals (Target, Target) then
- Report.Failed ("Avoid optimization"); -- Never executed.
- end if;
- exception
- when Constraint_Error =>
- Report.Failed ("Constraint_Error raised: Case 5");
- when others =>
- Report.Failed ("Unexpected exception raised: Case 5");
- end CASE_5;
-
- ---=---=---=---=---=---=---
-
- CASE_6:
- begin
- Target := (1 => ((5, 10, 15))); -- Positional associations.
-
- if not Equals (Target, Target) then
- Report.Failed ("Avoid optimization"); -- Never executed.
- end if;
- exception
- when Constraint_Error =>
- Report.Failed ("Constraint_Error raised: Case 6");
- when others =>
- Report.Failed ("Unexpected exception raised: Case 6");
- end CASE_6;
-
- ---=---=---=---=---=---=---
- end;
-
-
- ---=---=---=---=---=---=---=---=---=---=---
-
-
- declare
- type Arr is array (1..1) of C460010_1.Array_Static_Integer_Constraint;
- function Equals is new Generic_Equality (Arr);
- Target : Arr;
- begin
- ---=---=---=---=---=---=---
- CASE_7:
- begin
- Target := (1 => (1 => True, 2 => True, 3 => False)); -- Named.
-
- if not Equals (Target, Target) then
- Report.Failed ("Avoid optimization"); -- Never executed.
- end if;
- exception
- when Constraint_Error =>
- Report.Failed ("Constraint_Error raised: Case 7");
- when others =>
- Report.Failed ("Unexpected exception raised: Case 7");
- end CASE_7;
-
- ---=---=---=---=---=---=---
-
- CASE_8:
- begin
- Target := (1 => ((False, False, True))); -- Positional.
-
- if not Equals (Target, Target) then
- Report.Failed ("Avoid optimization"); -- Never executed.
- end if;
- exception
- when Constraint_Error =>
- Report.Failed ("Constraint_Error raised: Case 8");
- when others =>
- Report.Failed ("Unexpected exception raised: Case 8");
- end CASE_8;
-
- ---=---=---=---=---=---=---
- end;
-
-
- ---=---=---=---=---=---=---=---=---=---=---
-
-
- declare
- type Arr is array (1..1) of C460010_1.Array_Nonstatic_Integer_Constraint;
- function Equals is new Generic_Equality (Arr);
- Target : Arr;
- begin
- ---=---=---=---=---=---=---
- CASE_9:
- begin
- Target := (1 => (1 => True, 2 => True, 3 => False)); -- Named.
-
- if not Equals (Target, Target) then
- Report.Failed ("Avoid optimization"); -- Never executed.
- end if;
- exception
- when Constraint_Error =>
- Report.Failed ("Constraint_Error raised: Case 9");
- when others =>
- Report.Failed ("Unexpected exception raised: Case 9");
- end CASE_9;
-
- ---=---=---=---=---=---=---
-
- CASE_10:
- begin
- Target := (1 => (False, False, True)); -- Positional.
-
- if not Equals (Target, Target) then
- Report.Failed ("Avoid optimization"); -- Never executed.
- end if;
- exception
- when Constraint_Error =>
- Report.Failed ("Constraint_Error raised: Case 10");
- when others =>
- Report.Failed ("Unexpected exception raised: Case 10");
- end CASE_10;
-
- ---=---=---=---=---=---=---
- end;
-
-
- ---=---=---=---=---=---=---=---=---=---=---
-
-
- Report.Result;
-
-end C460010;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c460011.a b/gcc/testsuite/ada/acats/tests/c4/c460011.a
deleted file mode 100644
index 56e4c0c4ec2..00000000000
--- a/gcc/testsuite/ada/acats/tests/c4/c460011.a
+++ /dev/null
@@ -1,210 +0,0 @@
--- C460011.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687 and
--- F08630-91-C-0015, the U.S. Government obtained unlimited rights in the
--- software and documentation contained herein. Unlimited rights are
--- defined in DFAR 252.227-7013(a)(19). By making this public release,
--- the Government intends to confer upon all recipients unlimited rights
--- equal to those held by the Government. These rights include rights to
--- use, duplicate, release or disclose the released technical data and
--- computer software in whole or in part, in any manner and for any purpose
--- whatsoever, and to have or permit others to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that conversion of a decimal type to a modular type raises
--- Constraint_Error when the operand value is outside the base range
--- of the modular type.
--- Check that a conversion of a decimal type to an integer type
--- rounds correctly.
---
--- TEST DESCRIPTION:
--- Test conversion from decimal types to modular types. Test
--- conversion to mod 255, mod 256 and mod 258 to test the boundaries
--- of 8 bit (+/-) unsigned numbers.
--- Test operand values that are negative, the value of the mod,
--- and greater than the value of the mod.
--- Declare a generic test procedure and instantiate it for each of the
--- unsigned types for each operand type.
--- Check that the the operand is properly rounded during the conversion.
---
--- APPLICABILITY CRITERIA:
--- This test is applicable to all implementations which support
--- decimal types.
---
--- CHANGE HISTORY:
--- 24 NOV 98 RLB Split decimal cases from C460008 into this
--- test, added conversions to integer types.
--- 18 JAN 99 RLB Repaired errors in test.
---
---!
-
-------------------------------------------------------------------- C460011
-
-with Report;
-
-procedure C460011 is
-
- Shy_By_One : constant := 2**8-1;
- Heavy_By_Two : constant := 2**8+2;
-
- type Unsigned_Edge_8 is mod Shy_By_One;
- type Unsigned_8_Bit is mod 2**8;
- type Unsigned_Over_8 is mod Heavy_By_Two;
-
- type Signed_8_Bit is range -128 .. 127;
- type Signed_Over_8 is range -200 .. 200;
-
- NPC : constant String := " not properly converted";
-
- procedure Assert( Truth: Boolean; Message: String ) is
- begin
- if not Truth then
- Report.Failed(Message);
- end if;
- end Assert;
-
--- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
-
- type Decim is delta 0.1 digits 5; -- N/A => ERROR.
-
- generic
- type Source is delta <> digits <>;
- type Target is mod <>;
- procedure Decimal_Conversion_Check( For_The_Value : Source;
- Message : String );
-
- procedure Decimal_Conversion_Check( For_The_Value : Source;
- Message : String ) is
-
- Item : Target;
-
- begin
- Item := Target( For_The_Value );
- Report.Failed("Deci expected Constraint_Error " & Message);
- Report.Comment("Value of" & Target'Image(Item) & NPC);
- exception
- when Constraint_Error => null; -- expected case
- when others => Report.Failed("Deci raised wrong exception " & Message);
- end Decimal_Conversion_Check;
-
- procedure Decim_To_Short is
- new Decimal_Conversion_Check( Decim, Unsigned_Edge_8 );
-
- procedure Decim_To_Eight is
- new Decimal_Conversion_Check( Decim, Unsigned_8_Bit );
-
- procedure Decim_To_Wide is
- new Decimal_Conversion_Check( Decim, Unsigned_Over_8 );
-
- function Identity( Launder: Decim ) return Decim is
- Flat_Broke : constant Decim := 0.0;
- begin
- if Report.Ident_Bool( Launder = Flat_Broke ) then
- return Flat_Broke;
- else
- return Launder;
- end if;
- end Identity;
-
--- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
-
-begin -- Main test procedure.
-
- Report.Test ("C460011", "Check that conversion to " &
- "a modular type raises Constraint_Error when " &
- "the operand value is outside the base range " &
- "of the modular type" );
-
- -- Decimal Error cases
-
- Decim_To_Short( Identity( -5.00 ), "M2S Dynamic, Negative" );
- Decim_To_Short( Shy_By_One * 1.0, "M2S Static, At_Mod" );
- Decim_To_Short( 1995.9, "M2S Static, Over_Mod" );
-
- Decim_To_Eight( -0.5, "M28 Static, Negative" );
- Decim_To_Eight( 2.0*128, "M28 Static, At_Mod" );
- Decim_To_Eight( Identity( 2001.2 ), "M28 Dynamic, Over_Mod" );
-
- Decim_To_Wide ( Decim'First, "M2W Static, Negative" );
- Decim_To_Wide ( Identity( 2*128.0 +2.0 ), "M2W Dynamic, At_Mod" );
- Decim_To_Wide ( Decim'Last, "M2W Static, Over_Mod" );
-
- -- Check a few, correct, edge cases, for modular types.
-
- Eye_Dew: declare
- Sense : Decim := 0.00;
-
- Little : Unsigned_Edge_8;
- Moderate : Unsigned_8_Bit;
- Big : Unsigned_Over_8;
-
- begin
- Moderate := Unsigned_8_Bit (Sense);
- Assert( Moderate = 0, "Sense => Moderate, 0");
-
- Sense := 2*128.0;
-
- Big := Unsigned_Over_8 (Sense);
- Assert( Big = 256, "Sense => Big, 256");
-
- end Eye_Dew;
-
- Rounding: declare
- Easy : Decim := Identity ( 2.0);
- Simple : Decim := Identity ( 2.1);
- Halfway : Decim := Identity ( 2.5);
- Upward : Decim := Identity ( 2.8);
- Chop : Decim := Identity (-2.2);
- Neg_Half : Decim := Identity (-2.5);
- Downward : Decim := Identity (-2.7);
-
- Little : Unsigned_Edge_8;
- Moderate : Unsigned_8_Bit;
- Big : Unsigned_Over_8;
-
- Also_Little:Signed_8_Bit;
- Also_Big : Signed_Over_8;
-
- begin
- Little := Unsigned_Edge_8 (Easy);
- Assert( Little = 2, "Easy => Little, 2");
-
- Moderate := Unsigned_8_Bit (Simple);
- Assert( Moderate = 2, "Simple => Moderate, 2");
-
- Big := Unsigned_Over_8 (Halfway); -- Rounds up by 4.6(33).
- Assert( Big = 3, "Halfway => Big, 3");
-
- Little := Unsigned_Edge_8 (Upward);
- Assert( Little = 3, "Upward => Little, 3");
-
- Also_Big := Signed_Over_8 (Halfway); -- Rounds up by 4.6(33).
- Assert( Also_Big = 3, "Halfway => Also_Big, 3");
-
- Also_Little := Signed_8_Bit (Chop);
- Assert( Also_Little = -2, "Chop => Also_Little, -2");
-
- Also_Big := Signed_Over_8 (Neg_Half); -- Rounds down by 4.6(33).
- Assert( Also_Big = -3, "Halfway => Also_Big, -3");
-
- Also_Little := Signed_8_Bit (Downward);
- Assert( Also_Little = -3, "Downward => Also_Little, -3");
-
- end Rounding;
-
-
- Report.Result;
-
-end C460011;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c460012.a b/gcc/testsuite/ada/acats/tests/c4/c460012.a
deleted file mode 100644
index 0fb32060a4c..00000000000
--- a/gcc/testsuite/ada/acats/tests/c4/c460012.a
+++ /dev/null
@@ -1,93 +0,0 @@
--- C460012.A
---
--- Grant of Unlimited Rights
---
--- The Ada Conformity Assessment Authority (ACAA) holds unlimited
--- rights in the software and documentation contained herein. Unlimited
--- rights are the same as those granted by the U.S. Government for older
--- parts of the Ada Conformity Assessment Test Suite, and are defined
--- in DFAR 252.227-7013(a)(19). By making this public release, the ACAA
--- intends to confer upon all recipients unlimited rights equal to those
--- held by the ACAA. These rights include rights to use, duplicate,
--- release or disclose the released technical data and computer software
--- in whole or in part, in any manner and for any purpose whatsoever, and
--- to have or permit others to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that the view created by a view conversion is constrained if the
--- target subtype is indefinite. (Defect Report 8652/0017, Technical
--- Corrigendum 4.6(54/1)).
---
--- CHANGE HISTORY:
--- 25 JAN 2001 PHL Initial version.
--- 29 JUN 2001 RLB Reformatted for ACATS. Added optimization blocking.
--- 02 JUL 2001 RLB Fixed discriminant reference.
---
---!
-with Ada.Exceptions;
-use Ada.Exceptions;
-with Report;
-use Report;
-procedure C460012 is
-
- subtype Index is Positive range 1 .. 10;
-
- type Definite_Parent (D1 : Index := 6) is
- record
- F : String (1 .. D1) := (others => 'a');
- end record;
-
- type Indefinite_Child (D2 : Index) is new Definite_Parent (D1 => D2);
-
- Y : Definite_Parent;
-
- procedure P (X : in out Indefinite_Child) is
- C : Character renames X.F (3);
- begin
- X := (1, "a");
- if C /= 'a' then
- Failed ("No exception raised when changing the " &
- "discriminant of a view conversion, value of C changed");
- elsif X.D2 /= 1 then
- Failed ("No exception raised when changing the " &
- "discriminant of a view conversion, discriminant not " &
- "changed");
- -- This check primarily exists to prevent X from being optimized by
- -- 11.6 permissions, or the Failed call being made before the assignment.
- else
- Failed ("No exception raised when changing the " &
- "discriminant of a view conversion, discriminant changed");
- end if;
- exception
- when Constraint_Error =>
- null;
- when E: others =>
- Failed ("Wrong exception " & Exception_Name (E) & " raised - " &
- Exception_Message (E));
- end P;
-
-begin
- Test ("C460012",
- "Check that the view created by a view conversion " &
- "is constrained if the target subtype is indefinite");
-
- P (Indefinite_Child (Y));
-
- if Y.D1 /= Ident_Int(6) then
- Failed ("Discriminant of indefinite view changed");
- -- This check exists mainly to prevent Y from being optimized away.
- end if;
-
- Result;
-end C460012;
-
diff --git a/gcc/testsuite/ada/acats/tests/c4/c460a01.a b/gcc/testsuite/ada/acats/tests/c4/c460a01.a
deleted file mode 100644
index 2d583706eb9..00000000000
--- a/gcc/testsuite/ada/acats/tests/c4/c460a01.a
+++ /dev/null
@@ -1,408 +0,0 @@
--- C460A01.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that if the target type of a type conversion is a general
--- access type, Program_Error is raised if the accessibility level of
--- the operand type is deeper than that of the target type. Check for
--- cases where the type conversion occurs in an instance body, and
--- the operand type is passed as an actual during instantiation.
---
--- TEST DESCRIPTION:
--- In order to satisfy accessibility requirements, the operand type must
--- be at the same or a less deep nesting level than the target type -- the
--- operand type must "live" as long as the target type. Nesting levels
--- are the run-time nestings of masters: block statements; subprogram,
--- task, and entry bodies; and accept statements. Packages are invisible
--- to accessibility rules.
---
--- This test checks for cases where the operand is a subprogram formal
--- parameter.
---
--- The test declares three generic packages, each containing an access
--- type conversion in which the operand type is a formal type:
---
--- (1) One in which the target type is declared within the
--- specification, and the conversion occurs within a nested
--- function.
---
--- (2) One in which the target type is also a formal type, and
--- the conversion occurs within a nested function.
---
--- (3) One in which the target type is declared outside the
--- generic, and the conversion occurs within a nested
--- procedure.
---
--- The test verifies the following:
---
--- For (1), Program_Error is not raised when the nested function is
--- called. Since the actual corresponding to the formal operand type
--- must always have the same or a less deep level than the target
--- type declared within the instance, the access type conversion is
--- always safe.
---
--- For (2), Program_Error is raised when the nested function is
--- called if the operand type passed as an actual during instantiation
--- has an accessibility level deeper than that of the target type
--- passed as an actual, and that no exception is raised otherwise.
--- The exception is propagated to the innermost enclosing master.
---
--- For (3), Program_Error is raised when the nested procedure is
--- called if the operand type passed as an actual during instantiation
--- has an accessibility level deeper than that of the target type.
--- The exception is handled within the nested procedure.
---
--- TEST FILES:
--- The following files comprise this test:
---
--- F460A00.A
--- => C460A01.A
---
---
--- CHANGE HISTORY:
--- 09 May 95 SAIC Initial prerelease version.
--- 24 Apr 96 SAIC Added code to avoid dead variable optimization.
--- 13 Feb 97 PWB.CTA Removed 'Class from qual expression at line 342.
---!
-
-generic
- type Designated_Type is tagged private;
- type Operand_Type is access Designated_Type;
-package C460A01_0 is
- type Target_Type is access all Designated_Type;
- function Convert (P : Operand_Type) return Target_Type;
-end C460A01_0;
-
-
- --==================================================================--
-
-
-package body C460A01_0 is
- function Convert (P : Operand_Type) return Target_Type is
- begin
- return Target_Type(P); -- Never fails.
- end Convert;
-end C460A01_0;
-
-
- --==================================================================--
-
-
-generic
- type Designated_Type is tagged private;
- type Operand_Type is access all Designated_Type;
- type Target_Type is access all Designated_Type;
-package C460A01_1 is
- function Convert (P : Operand_Type) return Target_Type;
-end C460A01_1;
-
-
- --==================================================================--
-
-
-package body C460A01_1 is
- function Convert (P : Operand_Type) return Target_Type is
- begin
- return Target_Type(P);
- end Convert;
-end C460A01_1;
-
-
- --==================================================================--
-
-
-with F460A00;
-generic
- type Designated_Type (<>) is new F460A00.Tagged_Type with private;
- type Operand_Type is access Designated_Type;
-package C460A01_2 is
- procedure Proc (P : Operand_Type;
- Res : out F460A00.TC_Result_Kind);
-end C460A01_2;
-
-
- --==================================================================--
-
-with Report;
-package body C460A01_2 is
- procedure Proc (P : Operand_Type;
- Res : out F460A00.TC_Result_Kind) is
- Ptr : F460A00.AccTag_L0;
- begin
- Ptr := F460A00.AccTag_L0(P);
-
- -- Avoid optimization (dead variable removal of Ptr):
- if not Report.Equal (Ptr.C, Ptr.C) then -- Always false.
- Report.Failed ("Unexpected error in C460A01_2 instance");
- end if;
-
- Res := F460A00.OK;
- exception
- when Program_Error => Res := F460A00.PE_Exception;
- when others => Res := F460A00.Others_Exception;
- end Proc;
-end C460A01_2;
-
-
- --==================================================================--
-
-
-with F460A00;
-with C460A01_0;
-with C460A01_1;
-with C460A01_2;
-
-with Report;
-procedure C460A01 is
-begin -- C460A01. -- [ Level = 1 ]
-
- Report.Test ("C460A01", "Run-time accessibility checks: instance " &
- "bodies. Operand type of access type conversion is " &
- "passed as actual to instance");
-
-
- SUBTEST1:
- declare -- [ Level = 2 ]
- type AccTag_L2 is access all F460A00.Tagged_Type;
- Operand: AccTag_L2 := new F460A00.Tagged_Type;
-
- Result : F460A00.TC_Result_Kind := F460A00.UN_Init;
- begin -- SUBTEST1.
-
- declare -- [ Level = 3 ]
- -- The instantiation of C460A01_0 should NOT result in any
- -- exceptions.
-
- package Pack_OK is new C460A01_0 (F460A00.Tagged_Type, AccTag_L2);
- Target : Pack_OK.Target_Type;
- begin
- -- The accessibility level of Pack_OK.Target_Type will always be at
- -- least as deep as the operand type passed as an actual. Thus,
- -- a call to Pack_OK.Convert does not propagate an exception:
-
- Target := Pack_OK.Convert(Operand);
-
- -- Avoid optimization (dead variable removal of Target):
- if not Report.Equal (Target.C, Target.C) then -- Always false.
- Report.Failed ("Unexpected error in SUBTEST #1");
- end if;
-
- Result := F460A00.OK; -- Expected result.
- exception
- when Program_Error => Result := F460A00.PE_Exception;
- when others => Result := F460A00.Others_Exception;
- end;
-
- F460A00.TC_Check_Results (Result, F460A00.OK, "SUBTEST #1");
-
- exception
- when Program_Error =>
- Report.Failed ("SUBTEST #1: Program_Error incorrectly raised");
- when others =>
- Report.Failed ("SUBTEST #1: Unexpected exception raised");
- end SUBTEST1;
-
-
-
- SUBTEST2:
- declare -- [ Level = 2 ]
- type AccTag_L2 is access all F460A00.Tagged_Type;
- Operand : AccTag_L2 := new F460A00.Tagged_Type;
-
- Result : F460A00.TC_Result_Kind := F460A00.UN_Init;
- begin -- SUBTEST2.
-
- declare -- [ Level = 3 ]
-
- type AccTag_L3 is access all F460A00.Tagged_Type;
- Target : AccTag_L3;
-
- -- The instantiation of C460A01_1 should NOT result in any
- -- exceptions.
-
- package Pack_OK is new C460A01_1
- (Designated_Type => F460A00.Tagged_Type,
- Operand_Type => AccTag_L2,
- Target_Type => AccTag_L3);
- begin
- -- The accessibility level of the actual passed as the operand type
- -- in Pack_OK is 2. The accessibility level of the actual passed as
- -- the target type is 3. Therefore, the access type conversion in
- -- Pack_OK.Convert does not raise an exception when the subprogram is
- -- called. If an exception is (incorrectly) raised, it is propagated
- -- to the innermost enclosing master:
-
- Target := Pack_OK.Convert(Operand);
-
- -- Avoid optimization (dead variable removal of Target):
- if not Report.Equal (Target.C, Target.C) then -- Always false.
- Report.Failed ("Unexpected error in SUBTEST #2");
- end if;
-
- Result := F460A00.OK; -- Expected result.
- exception
- when Program_Error => Result := F460A00.PE_Exception;
- when others => Result := F460A00.Others_Exception;
- end;
-
- F460A00.TC_Check_Results (Result, F460A00.OK, "SUBTEST #2");
-
- exception
- when Program_Error =>
- Report.Failed ("SUBTEST #2: Program_Error incorrectly raised");
- when others =>
- Report.Failed ("SUBTEST #2: Unexpected exception raised");
- end SUBTEST2;
-
-
-
- SUBTEST3:
- declare -- [ Level = 2 ]
- type AccTag_L2 is access all F460A00.Tagged_Type;
- Target : AccTag_L2;
-
- Result : F460A00.TC_Result_Kind := F460A00.UN_Init;
- begin -- SUBTEST3.
-
- declare -- [ Level = 3 ]
-
- type AccTag_L3 is access all F460A00.Tagged_Type;
- Operand : AccTag_L3 := new F460A00.Tagged_Type;
-
- -- The instantiation of C460A01_1 should NOT result in any
- -- exceptions.
-
- package Pack_PE is new C460A01_1
- (Designated_Type => F460A00.Tagged_Type,
- Operand_Type => AccTag_L3,
- Target_Type => AccTag_L2);
- begin
- -- The accessibility level of the actual passed as the operand type
- -- in Pack_PE is 3. The accessibility level of the actual passed as
- -- the target type is 2. Therefore, the access type conversion in
- -- Pack_PE.Convert raises Program_Error when the subprogram is
- -- called. The exception is propagated to the innermost enclosing
- -- master:
-
- Target := Pack_PE.Convert(Operand);
-
- -- Avoid optimization (dead variable removal of Target):
- if not Report.Equal (Target.C, Target.C) then -- Always false.
- Report.Failed ("Unexpected error in SUBTEST #3");
- end if;
-
- Result := F460A00.OK;
- exception
- when Program_Error => Result := F460A00.PE_Exception;
- -- Expected result.
- when others => Result := F460A00.Others_Exception;
- end;
-
- F460A00.TC_Check_Results (Result, F460A00.PE_Exception, "SUBTEST #3");
-
- exception
- when Program_Error =>
- Report.Failed ("SUBTEST #3: Program_Error incorrectly raised");
- when others =>
- Report.Failed ("SUBTEST #3: Unexpected exception raised");
- end SUBTEST3;
-
-
-
- SUBTEST4:
- declare -- [ Level = 2 ]
- Result : F460A00.TC_Result_Kind := F460A00.UN_Init;
- begin -- SUBTEST4.
-
- declare -- [ Level = 3 ]
-
- TType : F460A00.Tagged_Type;
- Operand : F460A00.AccTagClass_L0
- := new F460A00.Tagged_Type'(TType);
-
- -- The instantiation of C460A01_2 should NOT result in any
- -- exceptions.
-
- package Pack_OK is new C460A01_2 (F460A00.Tagged_Type'Class,
- F460A00.AccTagClass_L0);
- begin
- -- The accessibility level of the actual passed as the operand type
- -- in Pack_OK is 0. The accessibility level of the target type
- -- (F460A00.AccTag_L0) is also 0. Therefore, the access type
- -- conversion in Pack_OK.Proc does not raise an exception when the
- -- subprogram is called. If an exception is (incorrectly) raised,
- -- it is handled within the subprogram:
-
- Pack_OK.Proc(Operand, Result);
- end;
-
- F460A00.TC_Check_Results (Result, F460A00.OK, "SUBTEST #4");
-
- exception
- when Program_Error =>
- Report.Failed ("SUBTEST #4: Program_Error incorrectly raised");
- when others =>
- Report.Failed ("SUBTEST #4: Unexpected exception raised");
- end SUBTEST4;
-
-
-
- SUBTEST5:
- declare -- [ Level = 2 ]
- Result : F460A00.TC_Result_Kind := F460A00.UN_Init;
- begin -- SUBTEST5.
-
- declare -- [ Level = 3 ]
-
- type AccDerTag_L3 is access all F460A00.Derived_Tagged_Type;
- Operand : AccDerTag_L3 := new F460A00.Derived_Tagged_Type;
-
- -- The instantiation of C460A01_2 should NOT result in any
- -- exceptions.
-
- package Pack_PE is new C460A01_2 (F460A00.Derived_Tagged_Type,
- AccDerTag_L3);
- begin
- -- The accessibility level of the actual passed as the operand type
- -- in Pack_PE is 3. The accessibility level of the target type
- -- (F460A00.AccTag_L0) is 0. Therefore, the access type conversion
- -- in Pack_PE.Proc raises Program_Error when the subprogram is
- -- called. The exception is handled within the subprogram:
-
- Pack_PE.Proc(Operand, Result);
- end;
-
- F460A00.TC_Check_Results (Result, F460A00.PE_Exception, "SUBTEST #5");
-
- exception
- when Program_Error =>
- Report.Failed ("SUBTEST #5: Program_Error incorrectly raised");
- when others =>
- Report.Failed ("SUBTEST #5: Unexpected exception raised");
- end SUBTEST5;
-
- Report.Result;
-
-end C460A01;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c460a02.a b/gcc/testsuite/ada/acats/tests/c4/c460a02.a
deleted file mode 100644
index 1d79d3a614e..00000000000
--- a/gcc/testsuite/ada/acats/tests/c4/c460a02.a
+++ /dev/null
@@ -1,413 +0,0 @@
--- C460A02.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that if the target type of a type conversion is a general
--- access type, Program_Error is raised if the accessibility level of
--- the operand type is deeper than that of the target type. Check for
--- cases where the type conversion occurs in an instance body, and
--- the operand type is declared inside the instance or is the anonymous
--- access type of an access parameter or access discriminant.
---
--- TEST DESCRIPTION:
--- In order to satisfy accessibility requirements, the operand type must
--- be at the same or a less deep nesting level than the target type -- the
--- operand type must "live" as long as the target type. Nesting levels
--- are the run-time nestings of masters: block statements; subprogram,
--- task, and entry bodies; and accept statements. Packages are invisible
--- to accessibility rules.
---
--- This test checks for cases where the operand is a component of a
--- generic formal object, a stand-alone object, and an access parameter.
---
--- The test declares three generic units, each containing an access
--- type conversion in which the target type is a formal type:
---
--- (1) A generic package in which the operand type is the anonymous
--- access type of an access discriminant, and the conversion
--- occurs within the declarative part of the body.
---
--- (2) A generic package in which the operand type is declared within
--- the specification, and the conversion occurs within the
--- sequence of statements of the body.
---
--- (3) A generic procedure in which the operand type is the anonymous
--- access type of an access parameter, and the conversion occurs
--- within the sequence of statements.
---
--- The test verifies the following:
---
--- For (1), Program_Error is raised when the package is instantiated
--- if the actual passed through the formal object has an accessibility
--- level deeper than that of the target type passed as an actual, and
--- that no exception is raised otherwise. The exception is propagated
--- to the innermost enclosing master.
---
--- For (2), Program_Error is raised when the package is instantiated
--- if the package is instantiated at a level deeper than that of the
--- target type passed as an actual, and that no exception is raised
--- otherwise. The exception is handled within the package body.
---
--- For (3), Program_Error is raised when the instance procedure is
--- called if the actual passed through the access parameter has an
--- accessibility level deeper than that of the target type passed as
--- an actual, and that no exception is raised otherwise. The exception
--- is handled within the instance procedure.
---
--- TEST FILES:
--- The following files comprise this test:
---
--- F460A00.A
--- => C460A02.A
---
---
--- CHANGE HISTORY:
--- 10 May 95 SAIC Initial prerelease version.
--- 24 Apr 96 SAIC Changed the target type formal to be
--- access-to-constant; Modified code to avoid dead
--- variable optimization.
---
---!
-
-with F460A00;
-generic
- type Target_Type is access all F460A00.Tagged_Type;
- FObj: in out F460A00.Composite_Type;
-package C460A02_0 is
- procedure Dummy; -- Needed to allow package body.
-end C460A02_0;
-
-
- --==================================================================--
-
-with Report;
-package body C460A02_0 is
- Ptr: Target_Type := Target_Type(FObj.D);
-
- procedure Dummy is
- begin
- null;
- end Dummy;
-
-begin
- -- Avoid optimization (dead variable removal of Ptr):
- if not Report.Equal (Ptr.C, Ptr.C) then -- Always false.
- Report.Failed ("Unexpected error in C460A02_0 instance");
- end if;
-
-end C460A02_0;
-
-
- --==================================================================--
-
-
-with F460A00;
-generic
- type Designated_Type is private;
- type Target_Type is access all Designated_Type;
- FObj : in out Target_Type;
- FRes : in out F460A00.TC_Result_Kind;
-package C460A02_1 is
- type Operand_Type is access Designated_Type;
- Ptr : Operand_Type := new Designated_Type;
-
- procedure Dummy; -- Needed to allow package body.
-end C460A02_1;
-
-
- --==================================================================--
-
-
-package body C460A02_1 is
- procedure Dummy is
- begin
- null;
- end Dummy;
-begin
- FRes := F460A00.UN_Init;
- FObj := Target_Type(Ptr);
- FRes := F460A00.OK;
-exception
- when Program_Error => FRes := F460A00.PE_Exception;
- when others => FRes := F460A00.Others_Exception;
-end C460A02_1;
-
-
- --==================================================================--
-
-
-with F460A00;
-generic
- type Designated_Type is new F460A00.Tagged_Type with private;
- type Target_Type is access constant Designated_Type;
-procedure C460A02_2 (P : access Designated_Type'Class;
- Res : out F460A00.TC_Result_Kind);
-
-
- --==================================================================--
-
-
-with Report;
-procedure C460A02_2 (P : access Designated_Type'Class;
- Res : out F460A00.TC_Result_Kind) is
- Ptr : Target_Type;
-begin
- Res := F460A00.UN_Init;
- Ptr := Target_Type(P);
-
- -- Avoid optimization (dead variable removal of Ptr):
- if not Report.Equal (Ptr.C, Ptr.C) then -- Always false.
- Report.Failed ("Unexpected error in C460A02_2 instance");
- end if;
- Res := F460A00.OK;
-exception
- when Program_Error => Res := F460A00.PE_Exception;
- when others => Res := F460A00.Others_Exception;
-end C460A02_2;
-
-
- --==================================================================--
-
-
-with F460A00;
-with C460A02_0;
-with C460A02_1;
-with C460A02_2;
-
-with Report;
-procedure C460A02 is
-begin -- C460A02. -- [ Level = 1 ]
-
- Report.Test ("C460A02", "Run-time accessibility checks: instance " &
- "bodies. Operand type of access type conversion is " &
- "declared inside instance or is anonymous");
-
-
- SUBTEST1:
- declare -- [ Level = 2 ]
- type AccTag_L2 is access all F460A00.Tagged_Type;
- PTag_L2 : AccTag_L2 := new F460A00.Tagged_Type;
- Operand_L2 : F460A00.Composite_Type(PTag_L2);
-
- Result : F460A00.TC_Result_Kind := F460A00.UN_Init;
- begin -- SUBTEST1.
-
- begin -- [ Level = 3 ]
- declare -- [ Level = 4 ]
- -- The accessibility level of the actual passed as the target type
- -- in Pack_OK is 2. The accessibility level of the composite actual
- -- (and thus, the level of the anonymous type of the access
- -- discriminant, which is the same as that of the containing
- -- object) is also 2. Therefore, the access type conversion in
- -- Pack_OK does not raise an exception upon instantiation:
-
- package Pack_OK is new C460A02_0
- (Target_Type => AccTag_L2, FObj => Operand_L2);
- begin
- Result := F460A00.OK; -- Expected result.
- end;
- exception
- when Program_Error => Result := F460A00.PE_Exception;
- when others => Result := F460A00.Others_Exception;
- end;
-
- F460A00.TC_Check_Results (Result, F460A00.OK, "SUBTEST #1");
-
- end SUBTEST1;
-
-
-
- SUBTEST2:
- declare -- [ Level = 2 ]
- type AccTag_L2 is access all F460A00.Tagged_Type;
- PTag_L2 : AccTag_L2 := new F460A00.Tagged_Type;
-
- Result : F460A00.TC_Result_Kind := F460A00.UN_Init;
- begin -- SUBTEST2.
-
- declare -- [ Level = 3 ]
- Operand_L3 : F460A00.Composite_Type(PTag_L2);
- begin
- declare -- [ Level = 4 ]
- -- The accessibility level of the actual passed as the target type
- -- in Pack_PE is 2. The accessibility level of the composite actual
- -- (and thus, the level of the anonymous type of the access
- -- discriminant, which is the same as that of the containing
- -- object) is 3. Therefore, the access type conversion in Pack_PE
- -- propagates Program_Error upon instantiation:
-
- package Pack_PE is new C460A02_0 (AccTag_L2, Operand_L3);
- begin
- Result := F460A00.OK;
- end;
- exception
- when Program_Error => Result := F460A00.PE_Exception;
- -- Expected result.
- when others => Result := F460A00.Others_Exception;
- end;
-
- F460A00.TC_Check_Results (Result, F460A00.PE_Exception, "SUBTEST #2");
-
- end SUBTEST2;
-
-
-
- SUBTEST3:
- declare -- [ Level = 2 ]
- Result : F460A00.TC_Result_Kind := F460A00.UN_Init;
- begin -- SUBTEST3.
-
- declare -- [ Level = 3 ]
- type AccArr_L3 is access all F460A00.Array_Type;
- Target: AccArr_L3;
-
- -- The accessibility level of the actual passed as the target type
- -- in Pack_OK is 3. The accessibility level of the operand type is
- -- that of the instance, which is also 3. Therefore, the access type
- -- conversion in Pack_OK does not raise an exception upon
- -- instantiation. If an exception is (incorrectly) raised, it is
- -- handled within the instance:
-
- package Pack_OK is new C460A02_1
- (Designated_Type => F460A00.Array_Type,
- Target_Type => AccArr_L3,
- FObj => Target,
- FRes => Result);
- begin
- null;
- end;
-
- F460A00.TC_Check_Results (Result, F460A00.OK, "SUBTEST #3");
-
- exception
- when Program_Error =>
- Report.Failed ("SUBTEST #3: Program_Error incorrectly propagated");
- when others =>
- Report.Failed ("SUBTEST #3: Unexpected exception propagated");
- end SUBTEST3;
-
-
-
- SUBTEST4:
- declare -- [ Level = 2 ]
- Result : F460A00.TC_Result_Kind := F460A00.UN_Init;
- begin -- SUBTEST4.
-
- declare -- [ Level = 3 ]
- Target: F460A00.AccArr_L0;
-
- -- The accessibility level of the actual passed as the target type
- -- in Pack_PE is 0. The accessibility level of the operand type is
- -- that of the instance, which is 3. Therefore, the access type
- -- conversion in Pack_PE raises Program_Error upon instantiation.
- -- The exception is handled within the instance:
-
- package Pack_PE is new C460A02_1
- (Designated_Type => F460A00.Array_Type,
- Target_Type => F460A00.AccArr_L0,
- FObj => Target,
- FRes => Result);
- begin
- null;
- end;
-
- F460A00.TC_Check_Results (Result, F460A00.PE_Exception, "SUBTEST #4");
-
- exception
- when Program_Error =>
- Report.Failed ("SUBTEST #4: Program_Error incorrectly raised");
- when others =>
- Report.Failed ("SUBTEST #4: Unexpected exception raised");
- end SUBTEST4;
-
-
-
- SUBTEST5:
- declare -- [ Level = 2 ]
- Result : F460A00.TC_Result_Kind := F460A00.UN_Init;
- begin -- SUBTEST5.
-
- declare -- [ Level = 3 ]
- -- The instantiation of C460A02_2 should NOT result in any
- -- exceptions.
-
- procedure Proc is new C460A02_2 (F460A00.Tagged_Type,
- F460A00.AccTag_L0);
- begin
- -- The accessibility level of the actual passed to Proc is 0. The
- -- accessibility level of the actual passed as the target type is
- -- also 0. Therefore, the access type conversion in Proc does not
- -- raise an exception when the subprogram is called. If an exception
- -- is (incorrectly) raised, it is handled within the subprogram:
-
- Proc (F460A00.PTagClass_L0, Result);
- end;
-
- F460A00.TC_Check_Results (Result, F460A00.OK, "SUBTEST #5");
-
- exception
- when Program_Error =>
- Report.Failed ("SUBTEST #5: Program_Error incorrectly raised");
- when others =>
- Report.Failed ("SUBTEST #5: Unexpected exception raised");
- end SUBTEST5;
-
-
-
- SUBTEST6:
- declare -- [ Level = 2 ]
- Result : F460A00.TC_Result_Kind := F460A00.UN_Init;
- begin -- SUBTEST6.
-
- declare -- [ Level = 3 ]
- -- The instantiation of C460A02_2 should NOT result in any
- -- exceptions.
-
- procedure Proc is new C460A02_2 (F460A00.Tagged_Type,
- F460A00.AccTag_L0);
- begin
- -- In the call to (instantiated) procedure Proc, the first actual
- -- parameter is an allocator. Its accessibility level is that of
- -- the level of execution of Proc, which is 3. The accessibility
- -- level of the actual passed as the target type is 0. Therefore,
- -- the access type conversion in Proc raises Program_Error when the
- -- subprogram is called. The exception is handled within the
- -- subprogram:
-
- Proc (new F460A00.Tagged_Type, Result);
- end;
-
- F460A00.TC_Check_Results (Result, F460A00.PE_Exception, "SUBTEST #6");
-
- exception
- when Program_Error =>
- Report.Failed ("SUBTEST #6: Program_Error incorrectly raised");
- when others =>
- Report.Failed ("SUBTEST #6: Unexpected exception raised");
- end SUBTEST6;
-
- Report.Result;
-
-end C460A02;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c490001.a b/gcc/testsuite/ada/acats/tests/c4/c490001.a
deleted file mode 100644
index 19153504cb0..00000000000
--- a/gcc/testsuite/ada/acats/tests/c4/c490001.a
+++ /dev/null
@@ -1,215 +0,0 @@
--- C490001.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that, for a real static expression that is not part of a larger
--- static expression, and whose expected type T is a floating point type
--- that is not a descendant of a formal scalar type, the value is rounded
--- to the nearest machine number of T if T'Machine_Rounds is true, and is
--- truncated otherwise. Check that if rounding is performed, and the value
--- is exactly halfway between two machine numbers, one of the two machine
--- numbers is used.
---
--- TEST DESCRIPTION:
--- The test obtains a machine number M1 for a floating point subtype S by
--- passing a real literal to S'Machine. It then obtains an adjacent
--- machine number M2 by using S'Succ (or S'Pred). It then constructs
--- values which lie between these two machine numbers: one (A) which is
--- closer to M1, one (B) which is exactly halfway between M1 and M2, and
--- one (C) which is closer to M2. This is done for both positive and
--- negative machine numbers.
---
--- Let M1 be closer to zero than M2. Then if S'Machine_Rounds is true,
--- C must be rounded to M2, A must be rounded to M1, and B must be rounded
--- to either M1 or M2. If S'Machine_Rounds is false, all the values must
--- be truncated to M1.
---
--- A, B, and C are constructed using the following static expressions:
---
--- A: constant S := M1 + (M2 - M1)*Z; -- Z slightly less than 0.5.
--- B: constant S := M1 + (M2 - M1)*Z; -- Z equals 0.5.
--- C: constant S := M1 + (M2 - M1)*Z; -- Z slightly more than 0.5.
---
--- Since these are static expressions, they must be evaluated exactly,
--- and no rounding may occur until the final result is calculated.
---
--- The checks for equality between the members of (A, B, C) and (M1, M2)
--- are performed at run-time within the body of a subprogram.
---
--- The test performs additional checks that the rounding performed on
--- real literals is consistent for a floating point subtype. A literal is
--- assigned to a constant of a floating point subtype S. The same literal
--- is then passed to a subprogram, along with the constant, and an
--- equality check is performed within the body of the subprogram.
---
---
--- CHANGE HISTORY:
--- 25 Sep 95 SAIC Initial prerelease version.
--- 25 May 01 RLB Repaired to work with the repeal of the round away
--- rule by AI-268.
---
---!
-
-with System;
-package C490001_0 is
-
- type My_Flt is digits System.Max_Digits;
-
- procedure Float_Subtest (A, B: in My_Flt; Msg: in String);
-
- procedure Float_Subtest (A, B, C: in My_Flt; Msg: in String);
-
-
---
--- Positive cases:
---
-
- -- |----|-------------|-----------------|-------------------|-----------|
- -- | | | | | |
- -- 0 P_M1 Less_Pos_Than_Half Pos_Exactly_Half More_Pos_Than_Half P_M2
-
-
- Positive_Float : constant My_Flt := 12.440193950021943;
-
- -- The literal value 12.440193950021943 is rounded up or down to the
- -- nearest machine number of My_Flt when Positive_Float is initialized.
- -- The value of Positive_Float should therefore be a machine number, and
- -- the use of 'Machine in the initialization of P_M1 will be redundant for
- -- a correct implementation. It's done anyway to make certain that P_M1 is
- -- a machine number, independent of whether an implementation correctly
- -- performs rounding.
-
- P_M1 : constant My_Flt := My_Flt'Machine(Positive_Float);
- P_M2 : constant My_Flt := My_Flt'Succ(P_M1);
-
- -- P_M1 and P_M2 are adjacent machine numbers. Note that because it is not
- -- certain whether 12.440193950021943 is a machine number, nor whether
- -- 'Machine rounds it up or down, 12.440193950021943 may not lie between
- -- P_M1 and P_M2. The test does not depend on this information, however;
- -- the literal is only used as a "seed" to obtain the machine numbers.
-
-
- -- The following entities are used to verify that rounding is performed
- -- according to the value of 'Machine_Rounds. If language rules are
- -- obeyed, the intermediate expressions in the following static
- -- initialization expressions will not be rounded; all calculations will
- -- be performed exactly. The final result, however, will be rounded to
- -- a machine number (either P_M1 or P_M2, depending on the value of
- -- My_Flt'Machine_Rounds). Thus, the value of each constant below will
- -- equal that of P_M1 or P_M2.
-
- Less_Pos_Than_Half : constant My_Flt := P_M1 + ((P_M2 - P_M1)*2.9/6.0);
- Pos_Exactly_Half : constant My_Flt := P_M1 + ((P_M2 - P_M1)/2.0);
- More_Pos_Than_Half : constant My_Flt := P_M1 + ((P_M2 - P_M1)*4.6/9.0);
-
-
---
--- Negative cases:
---
-
- -- -|-------------|-----------------|-------------------|-----------|----|
- -- | | | | | |
- -- N_M2 More_Neg_Than_Half Neg_Exactly_Half Less_Neg_Than_Half N_M1 0
-
-
- -- The descriptions for the positive cases above apply to the negative
- -- cases below as well. Note that, for N_M2, 'Pred is used rather than
- -- 'Succ. Thus, N_M2 is further from 0.0 (i.e. more negative) than N_M1.
-
- Negative_Float : constant My_Flt := -0.692074550952117;
-
-
- N_M1 : constant My_Flt := My_Flt'Machine(Negative_Float);
- N_M2 : constant My_Flt := My_Flt'Pred(N_M1);
-
- More_Neg_Than_Half : constant My_Flt := N_M1 + ((N_M2 - N_M1)*4.1/8.0);
- Neg_Exactly_Half : constant My_Flt := N_M1 + ((N_M2 - N_M1)/2.0);
- Less_Neg_Than_Half : constant My_Flt := N_M1 + ((N_M2 - N_M1)*2.4/5.0);
-
-end C490001_0;
-
-
- --==================================================================--
-
-
-with TCTouch;
-package body C490001_0 is
-
- procedure Float_Subtest (A, B: in My_Flt; Msg: in String) is
- begin
- TCTouch.Assert (A = B, Msg);
- end Float_Subtest;
-
- procedure Float_Subtest (A, B, C: in My_Flt; Msg: in String) is
- begin
- TCTouch.Assert (A = B or A = C, Msg);
- end Float_Subtest;
-
-end C490001_0;
-
-
- --==================================================================--
-
-
-with C490001_0; -- Floating point support.
-use C490001_0;
-
-with Report;
-procedure C490001 is
-begin
- Report.Test ("C490001", "Rounding of real static expressions: " &
- "floating point subtypes");
-
-
- -- Check that rounding direction is consistent for literals:
-
- Float_Subtest (12.440193950021943, P_M1, "Positive Float: literal");
- Float_Subtest (-0.692074550952117, N_M1, "Negative Float: literal");
-
-
- -- Now check that rounding is performed correctly for values between
- -- machine numbers, according to the value of 'Machine_Rounds:
-
- if My_Flt'Machine_Rounds then
- Float_Subtest (Pos_Exactly_Half, P_M1, P_M2, "Positive Float: = half");
- Float_Subtest (More_Pos_Than_Half, P_M2, "Positive Float: > half");
- Float_Subtest (Less_Pos_Than_Half, P_M1, "Positive Float: < half");
-
- Float_Subtest (Neg_Exactly_Half, N_M1, N_M2, "Negative Float: = half");
- Float_Subtest (More_Neg_Than_Half, N_M2, "Negative Float: > half");
- Float_Subtest (Less_Neg_Than_Half, N_M1, "Negative Float: < half");
- else
- Float_Subtest (Pos_Exactly_Half, P_M1, "Positive Float: = half");
- Float_Subtest (More_Pos_Than_Half, P_M1, "Positive Float: > half");
- Float_Subtest (Less_Pos_Than_Half, P_M1, "Positive Float: < half");
-
- Float_Subtest (Neg_Exactly_Half, N_M1, "Negative Float: = half");
- Float_Subtest (More_Neg_Than_Half, N_M1, "Negative Float: > half");
- Float_Subtest (Less_Neg_Than_Half, N_M1, "Negative Float: < half");
- end if;
-
-
- Report.Result;
-end C490001;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c490002.a b/gcc/testsuite/ada/acats/tests/c4/c490002.a
deleted file mode 100644
index 71169b833e4..00000000000
--- a/gcc/testsuite/ada/acats/tests/c4/c490002.a
+++ /dev/null
@@ -1,239 +0,0 @@
--- C490002.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that, for a real static expression that is not part of a larger
--- static expression, and whose expected type T is an ordinary fixed
--- point type that is not a descendant of a formal scalar type, the value
--- is rounded to the nearest integral multiple of the small of T if
--- T'Machine_Rounds is true, and is truncated otherwise. Check that if
--- rounding is performed, and the value is exactly halfway between two
--- multiples of the small, one of the two multiples of small is used.
---
--- TEST DESCRIPTION:
--- The test obtains an integral multiple M1 of the small of an ordinary
--- fixed point subtype S by dividing a real literal by S'Small, and then
--- truncating the result using 'Truncation. It then obtains an adjacent
--- multiple M2 of the small by using S'Succ (or S'Pred). It then
--- constructs values which lie between these multiples: one (A) which is
--- closer to M1, one (B) which is exactly halfway between M1 and M2, and
--- one (C) which is closer to M2. This is done for both positive and
--- negative multiples of the small.
---
--- Let M1 be closer to zero than M2. Then if S'Machine_Rounds is true,
--- C must be rounded to M2, A must be rounded to M1, and B must be rounded
--- to either M1 or M2. If S'Machine_Rounds is false, all the values must
--- be truncated to M1.
---
--- A, B, and C are constructed using the following static expressions:
---
--- A: constant S := M1 + (M2 - M1)/Z; -- Z slightly more than 2.0.
--- B: constant S := M1 + (M2 - M1)/Z; -- Z equals 2.0.
--- C: constant S := M1 + (M2 - M1)/Z; -- Z slightly less than 2.0.
---
--- Since these are static expressions, they must be evaluated exactly,
--- and no rounding may occur until the final result is calculated.
---
--- The checks for equality between the members of (A, B, C) and (M1, M2)
--- are performed at run-time within the body of a subprogram.
---
--- The test performs additional checks that the rounding performed on
--- real literals is consistent for ordinary fixed point subtypes. A
--- named number (initialized with a literal) is assigned to a constant of
--- a fixed point subtype S. The same literal is then passed to a
--- subprogram, along with the constant, and an equality check is
--- performed within the body of the subprogram.
---
---
--- CHANGE HISTORY:
--- 26 Sep 95 SAIC Initial prerelease version.
---
---!
-
-package C490002_0 is
-
- type My_Fix is delta 0.0625 range -1000.0 .. 1000.0;
-
- Small : constant := My_Fix'Small; -- Named number.
-
- procedure Fixed_Subtest (A, B: in My_Fix; Msg: in String);
-
- procedure Fixed_Subtest (A, B, C: in My_Fix; Msg: in String);
-
-
---
--- Positive cases:
---
-
- -- |----|-------------|-----------------|-------------------|-----------|
- -- | | | | | |
- -- 0 P_M1 Less_Pos_Than_Half Pos_Exactly_Half More_Pos_Than_Half P_M2
-
-
- Positive_Real : constant := 0.11433; -- Named number.
- Pos_Multiplier : constant := Float'Truncation(Positive_Real/Small);
-
- -- Pos_Multiplier is the number of integral multiples of small contained
- -- in Positive_Real. P_M1 is thus the largest integral multiple of
- -- small less than or equal to Positive_Real. Note that since Positive_Real
- -- is a named number and not a fixed point object, P_M1 is generated
- -- without assuming that rounding is performed correctly for fixed point
- -- subtypes.
-
- Positive_Fixed : constant My_Fix := Positive_Real;
-
- P_M1 : constant My_Fix := Pos_Multiplier * Small;
- P_M2 : constant My_Fix := My_Fix'Succ(P_M1);
-
- -- P_M1 and P_M2 are adjacent multiples of the small of My_Fix. Note that
- -- 0.11433 either equals P_M1 (if it is an integral multiple of the small)
- -- or lies between P_M1 and P_M2 (since truncation was forced in
- -- generating Pos_Multiplier). It is not certain, however, exactly where
- -- it lies between them (halfway, less than halfway, more than halfway).
- -- This fact is irrelevant to the test.
-
-
- -- The following entities are used to verify that rounding is performed
- -- according to the value of 'Machine_Rounds. If language rules are
- -- obeyed, the intermediate expressions in the following static
- -- initialization expressions will not be rounded; all calculations will
- -- be performed exactly. The final result, however, will be rounded to
- -- an integral multiple of the small (either P_M1 or P_M2, depending on the
- -- value of My_Fix'Machine_Rounds). Thus, the value of each constant below
- -- will equal that of P_M1 or P_M2.
-
- Less_Pos_Than_Half : constant My_Fix := P_M1 + ((P_M2 - P_M1)/2.050);
- Pos_Exactly_Half : constant My_Fix := P_M1 + ((P_M2 - P_M1)/2.000);
- More_Pos_Than_Half : constant My_Fix := P_M1 + ((P_M2 - P_M1)/1.975);
-
-
---
--- Negative cases:
---
-
- -- -|-------------|-----------------|-------------------|-----------|----|
- -- | | | | | |
- -- N_M2 More_Neg_Than_Half Neg_Exactly_Half Less_Neg_Than_Half N_M1 0
-
-
- -- The descriptions for the positive cases above apply to the negative
- -- cases below as well. Note that, for N_M2, 'Pred is used rather than
- -- 'Succ. Thus, N_M2 is further from 0.0 (i.e. more negative) than N_M1.
-
- Negative_Real : constant := -467.13988; -- Named number.
- Neg_Multiplier : constant := Float'Truncation(Negative_Real/Small);
-
- Negative_Fixed : constant My_Fix := Negative_Real;
-
- N_M1 : constant My_Fix := Neg_Multiplier * Small;
- N_M2 : constant My_Fix := My_Fix'Pred(N_M1);
-
- More_Neg_Than_Half : constant My_Fix := N_M1 + ((N_M2 - N_M1)/1.980);
- Neg_Exactly_Half : constant My_Fix := N_M1 + ((N_M2 - N_M1)/2.000);
- Less_Neg_Than_Half : constant My_Fix := N_M1 + ((N_M2 - N_M1)/2.033);
-
-end C490002_0;
-
-
- --==================================================================--
-
-
-with TCTouch;
-package body C490002_0 is
-
- procedure Fixed_Subtest (A, B: in My_Fix; Msg: in String) is
- begin
- TCTouch.Assert (A = B, Msg);
- end Fixed_Subtest;
-
- procedure Fixed_Subtest (A, B, C: in My_Fix; Msg: in String) is
- begin
- TCTouch.Assert (A = B or A = C, Msg);
- end Fixed_Subtest;
-
-end C490002_0;
-
-
- --==================================================================--
-
-
-with C490002_0; -- Fixed point support.
-use C490002_0;
-
-with Report;
-procedure C490002 is
-begin
- Report.Test ("C490002", "Rounding of real static expressions: " &
- "ordinary fixed point subtypes");
-
-
- -- Literal cases: If the named numbers used to initialize Positive_Fixed
- -- and Negative_Fixed are rounded to an integral multiple of the small
- -- prior to assignment (as expected), then Positive_Fixed and
- -- Negative_Fixed are already integral multiples of the small, and
- -- equal either P_M1 or P_M2 (resp., N_M1 or N_M2). An equality check
- -- can determine in which direction rounding occurred. For example:
- --
- -- if (Positive_Fixed = P_M1) then -- Rounding was toward 0.0.
- --
- -- Check here that the rounding direction is consistent for literals:
-
- if (Positive_Fixed = P_M1) then
- Fixed_Subtest (0.11433, P_M1, "Positive Fixed: literal");
- else
- Fixed_Subtest (0.11433, P_M2, "Positive Fixed: literal");
- end if;
-
- if (Negative_Fixed = N_M1) then
- Fixed_Subtest (-467.13988, N_M1, "Negative Fixed: literal");
- else
- Fixed_Subtest (-467.13988, N_M2, "Negative Fixed: literal");
- end if;
-
-
- -- Now check that rounding is performed correctly for values between
- -- multiples of the small, according to the value of 'Machine_Rounds:
-
- if My_Fix'Machine_Rounds then
- Fixed_Subtest (Pos_Exactly_Half, P_M1, P_M2, "Positive Fixed: = half");
- Fixed_Subtest (More_Pos_Than_Half, P_M2, "Positive Fixed: > half");
- Fixed_Subtest (Less_Pos_Than_Half, P_M1, "Positive Fixed: < half");
-
- Fixed_Subtest (Neg_Exactly_Half, N_M1, N_M2, "Negative Fixed: = half");
- Fixed_Subtest (More_Neg_Than_Half, N_M2, "Negative Fixed: > half");
- Fixed_Subtest (Less_Neg_Than_Half, N_M1, "Negative Fixed: < half");
- else
- Fixed_Subtest (Pos_Exactly_Half, P_M1, "Positive Fixed: = half");
- Fixed_Subtest (More_Pos_Than_Half, P_M1, "Positive Fixed: > half");
- Fixed_Subtest (Less_Pos_Than_Half, P_M1, "Positive Fixed: < half");
-
- Fixed_Subtest (Neg_Exactly_Half, N_M1, "Negative Fixed: = half");
- Fixed_Subtest (More_Neg_Than_Half, N_M1, "Negative Fixed: > half");
- Fixed_Subtest (Less_Neg_Than_Half, N_M1, "Negative Fixed: < half");
- end if;
-
-
- Report.Result;
-end C490002;
diff --git a/gcc/testsuite/ada/acats/tests/c4/c490003.a b/gcc/testsuite/ada/acats/tests/c4/c490003.a
deleted file mode 100644
index a135b5ac3a2..00000000000
--- a/gcc/testsuite/ada/acats/tests/c4/c490003.a
+++ /dev/null
@@ -1,215 +0,0 @@
--- C490003.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that a static expression is legal if its evaluation fails
--- no language-defined check other than Overflow_Check. Check that such
--- a static expression is legal if it is part of a larger static
--- expression, even if its value is outside the base range of the
--- expected type.
---
--- Check that if a static expression is part of the right operand of a
--- short circuit control form whose value is determined by its left
--- operand, it is not evaluated.
---
--- Check that a static expression in a non-static context is evaluated
--- exactly.
---
--- TEST DESCRIPTION:
--- The first part of the objective is tested by constructing static
--- expressions which involve predefined operations of integer, floating
--- point, and fixed point subtypes. Intermediate expressions within the
--- static expressions have values outside the base range of the expected
--- type. In one case, the extended-range intermediates are compared as
--- part of a boolean expression. In the remaining two cases, further
--- predefined operations on the intermediates bring the final result
--- within the base range. An implementation which compiles these static
--- expressions satisfies this portion of the objective. A check is
--- performed at run-time to ensure that the static expressions evaluate
--- to values within the base range of their respective expected types.
---
--- The second part of the objective is tested by constructing
--- short-circuit control forms whose left operands have the values
--- shown below:
---
--- (TRUE) or else (...)
--- (FALSE) and then (...)
---
--- In both cases the left operand determines the value of the condition.
--- In the test each right operand involves a division by zero, which will
--- raise Constraint_Error if evaluated. A check is made that no exception
--- is raised when each short-circuit control form is evaluated, and that
--- the value of the condition is that of the left operand.
---
--- The third part of the objective is tested by evaluating static
--- expressions involving many operations in contexts which do not
--- require a static expression, and verifying that the exact
--- mathematical results are calculated.
---
---
--- CHANGE HISTORY:
--- 15 Sep 95 SAIC Initial prerelease version for ACVC 2.1.
--- 20 Oct 96 SAIC Modified expressions in C490003_0 to avoid
--- the use of universal operands.
---
---!
-
-with System;
-package C490003_0 is
-
- type My_Flt is digits System.Max_Digits;
-
- Flt_Range_Diff : My_Flt := (My_Flt'Base'Last - My_Flt'Base'First) -
- (My_Flt'Last - My_Flt'First); -- OK.
-
-
- type My_Fix is delta 0.125 range -128.0 .. 128.0;
-
- Symmetric : Boolean := (My_Fix'Base'Last - My_Fix'Base'First) =
- (My_Fix'Base'Last + My_Fix'Base'Last); -- OK.
-
-
- Center : constant Integer := Integer'Base'Last -
- (Integer'Base'Last -
- Integer'Base'First) / 2; -- OK.
-
-end C490003_0;
-
-
- --==================================================================--
-
-
-with Ada.Numerics;
-package C490003_1 is
-
- Zero : constant := 0.0;
- Pi : constant := Ada.Numerics.Pi;
-
- Two_Pi : constant := 2.0 * Pi;
- Half_Pi : constant := Pi/2.0;
-
- Quarter : constant := 90.0;
- Half : constant := 180.0;
- Full : constant := 360.0;
-
- Deg_To_Rad : constant := Half_Pi/90;
- Rad_To_Deg : constant := 1.0/Deg_To_Rad;
-
-end C490003_1;
-
-
- --==================================================================--
-
-
-with C490003_0;
-with C490003_1;
-
-with Report;
-procedure C490003 is
-begin
- Report.Test ("C490003", "Check that static expressions failing " &
- "Overflow_Check are legal if part of a larger static " &
- "expression. Check that static expressions as right " &
- "operands of short-circuit control forms are not " &
- "evaluated if value of control form is determined by " &
- "left operand. Check that static expressions in non-static " &
- "contexts are evaluated exactly");
-
-
---
--- Static expressions within larger static expressions:
---
-
-
- if C490003_0.Flt_Range_Diff not in C490003_0.My_Flt'Base'Range then
- Report.Failed ("Error evaluating static expression: floating point");
- end if;
-
- if C490003_0.Symmetric not in Boolean'Range then
- Report.Failed ("Error evaluating static expression: fixed point");
- end if;
-
- if C490003_0.Center not in Integer'Base'Range then
- Report.Failed ("Error evaluating static expression: integer");
- end if;
-
-
---
--- Short-circuit control forms:
---
-
- declare
- N : constant := 0.0;
- begin
-
- begin
- if not ( (N = 0.0) or else (1.0/N > 0.5) ) then
- Report.Failed ("Error evaluating OR ELSE");
- end if;
- exception
- when Constraint_Error =>
- Report.Failed ("Right side of OR ELSE was evaluated");
- when others =>
- Report.Failed ("OR ELSE: unexpected exception raised");
- end;
-
- begin
- if (N /= 0.0) and then (1.0/N <= 0.5) then
- Report.Failed ("Error evaluating AND THEN");
- end if;
- exception
- when Constraint_Error =>
- Report.Failed ("Right side of AND THEN was evaluated");
- when others =>
- Report.Failed ("AND THEN: unexpected exception raised");
- end;
-
- end;
-
-
---
--- Exact evaluation of static expressions:
---
-
-
- declare
- use C490003_1;
-
- Left : constant := 6.0 + 0.3125*( (Full*0.375) + (Half/2.4) -
- ((Quarter + 36.0)/3.0) )/10.0; -- 11.25
- Right : constant := (Pi/3.0) * 1.2 * (15.0/96.0); -- Pi/16
- begin
- if Deg_To_Rad*Left /= Right then
- Report.Failed ("Static expressions not evaluated exactly: #1");
- end if;
-
- if ((Pi*Rad_To_Deg)*2.0 + 4.0*Quarter)/16.0 /= Rad_To_Deg*(Pi/4.0) then
- Report.Failed ("Static expressions not evaluated exactly: #2");
- end if;
- end;
-
-
- Report.Result;
-end C490003;
diff --git a/gcc/testsuite/ada/acats/tests/c5/c540001.a b/gcc/testsuite/ada/acats/tests/c5/c540001.a
deleted file mode 100644
index b7dbdd6e97f..00000000000
--- a/gcc/testsuite/ada/acats/tests/c5/c540001.a
+++ /dev/null
@@ -1,410 +0,0 @@
--- C540001.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that an expression in a case statement may be of a generic formal
--- type. Check that a function call may be used as a case statement
--- expression. Check that a call to a generic formal function may be
--- used as a case statement expression. Check that a call to an inherited
--- function may be used as a case statement expression even if its result
--- type does not correspond to any nameable subtype.
---
--- TEST DESCRIPTION:
--- This transition test creates examples where expressions in a case
--- statement can be a generic formal object and a call to a generic formal
--- function. This test also creates examples when either a function call,
--- a renaming of a function, or a call to an inherited function is used
--- in the case expressions, the choices of the case statement only need
--- to cover the values in the result of the function.
---
--- Inspired by B54A08A.ADA.
---
---
--- CHANGE HISTORY:
--- 12 Feb 96 SAIC Initial version for ACVC 2.1.
---
---!
-
-package C540001_0 is
- type Int is range 1 .. 2;
-
-end C540001_0;
-
- --==================================================================--
-
-with C540001_0;
-package C540001_1 is
- type Enum_Type is (Eh, Bee, Sea, Dee); -- Range of Enum_Type'Val is 0..3.
- type Mixed is ('A','B', 'C', None);
- subtype Small_Num is Natural range 0 .. 10;
- type Small_Int is range 1 .. 2;
- function Get_Small_Int (P : Boolean) return Small_Int;
- procedure Assign_Mixed (P1 : in Boolean;
- P2 : out Mixed);
-
- type Tagged_Type is tagged
- record
- C1 : Enum_Type;
- end record;
- function Get_Tagged (P : Tagged_Type) return C540001_0.Int;
-
-end C540001_1;
-
- --==================================================================--
-
-package body C540001_1 is
- function Get_Small_Int (P : Boolean) return Small_Int is
- begin
- if P then
- return Small_Int'First;
- else
- return Small_Int'Last;
- end if;
- end Get_Small_Int;
-
- ---------------------------------------------------------------------
- procedure Assign_Mixed (P1 : in Boolean;
- P2 : out Mixed) is
- begin
- case Get_Small_Int (P1) is -- Function call as expression
- when 1 => P2 := None; -- in case statement.
- when 2 => P2 := 'A';
- -- No others needed.
- end case;
-
- end Assign_Mixed;
-
- ---------------------------------------------------------------------
- function Get_Tagged (P : Tagged_Type) return C540001_0.Int is
- begin
- return C540001_0.Int'Last;
- end Get_Tagged;
-
-end C540001_1;
-
- --==================================================================--
-
-generic
-
- type Formal_Scalar is range <>;
-
- FSO : Formal_Scalar;
-
-package C540001_2 is
-
- type Enum is (Alpha, Beta, Theta);
-
- procedure Assign_Enum (ET : out Enum);
-
-end C540001_2;
-
- --==================================================================--
-
-package body C540001_2 is
-
- procedure Assign_Enum (ET : out Enum) is
- begin
- case FSO is -- Type of expression in case
- when 1 => ET := Alpha; -- statement is generic formal type.
- when 2 => ET := Beta;
- when others => ET := Theta;
- end case;
-
- end Assign_Enum;
-
-end C540001_2;
-
- --==================================================================--
-
-with C540001_1;
-generic
-
- type Formal_Enum_Type is new C540001_1.Enum_Type;
-
- with function Formal_Func (P : C540001_1.Small_Num)
- return Formal_Enum_Type is <>;
-
-function C540001_3 (P : C540001_1.Small_Num) return Formal_Enum_Type;
-
- --==================================================================--
-
-function C540001_3 (P : C540001_1.Small_Num) return Formal_Enum_Type is
-
-begin
- return Formal_Func (P);
-end C540001_3;
-
- --==================================================================--
-
-with C540001_1;
-generic
-
- type Formal_Int_Type is new C540001_1.Small_Int;
-
- with function Formal_Func return Formal_Int_Type;
-
-package C540001_4 is
-
- procedure Gen_Assign_Mixed (P : out C540001_1.Mixed);
-
-end C540001_4;
-
- --==================================================================--
-
-package body C540001_4 is
-
- procedure Gen_Assign_Mixed (P : out C540001_1.Mixed) is
- begin
- case Formal_Func is -- Case expression is
- when 1 => P := C540001_1.'A'; -- generic function.
- when others => P := C540001_1.'B';
- end case;
-
- end Gen_Assign_Mixed;
-
-end C540001_4;
-
- --==================================================================--
-
-with C540001_1;
-package C540001_5 is
- type New_Tagged is new C540001_1.Tagged_Type with
- record
- C2 : C540001_1.Mixed;
- end record;
-
- -- Inherits Get_Tagged (P : New_Tagged) return C540001_0.Int;
- -- Note that the return type of the inherited function is not
- -- nameable here.
-
- procedure Assign_Tagged (P1 : in New_Tagged;
- P2 : out New_Tagged);
-
-end C540001_5;
-
- --==================================================================--
-
-package body C540001_5 is
-
- procedure Assign_Tagged (P1 : in New_Tagged;
- P2 : out New_Tagged) is
- begin
- case Get_Tagged (P1) is -- Case expression is
- -- inherited function.
- when 2 => P2 := (C540001_1.Bee, 'B');
- when others => P2 := (C540001_1.Sea, C540001_1.None);
- end case;
-
- end Assign_Tagged;
-
-end C540001_5;
-
- --==================================================================--
-
-with Report;
-with C540001_1;
-with C540001_2;
-with C540001_3;
-with C540001_4;
-with C540001_5;
-
-procedure C540001 is
- type Value is range 1 .. 5;
-
-begin
- Report.Test ("C540001", "Check that an expression in a case statement " &
- "may be of a generic formal type. Check that a function " &
- "call may be used as a case statement expression. Check " &
- "that a call to a generic formal function may be used as " &
- "a case statement expression. Check that a call to an " &
- "inherited function may be used as a case statement " &
- "expression");
-
- Generic_Formal_Object_Subtest:
- begin
- declare
- One : Value := 1;
- package One_Pck is new C540001_2 (Value, One);
- use One_Pck;
- EObj : Enum;
- begin
- Assign_Enum (EObj);
- if EObj /= Alpha then
- Report.Failed ("Incorrect result for value of one in generic" &
- "formal object subtest");
- end if;
- end;
-
- declare
- Five : Value := 5;
- package Five_Pck is new C540001_2 (Value, Five);
- use Five_Pck;
- EObj : Enum;
- begin
- Assign_Enum (EObj);
- if EObj /= Theta then
- Report.Failed ("Incorrect result for value of five in generic" &
- "formal object subtest");
- end if;
- end;
-
- end Generic_Formal_Object_Subtest;
-
- Instantiated_Generic_Function_Subtest:
- declare
- type New_Enum_Type is new C540001_1.Enum_Type;
-
- function Get_Enum_Value (P : C540001_1.Small_Num)
- return New_Enum_Type is
- begin
- return New_Enum_Type'Val (P);
- end Get_Enum_Value;
-
- function Val_Func is new C540001_3
- (Formal_Enum_Type => New_Enum_Type,
- Formal_Func => Get_Enum_Value);
-
- procedure Assign_Num (P : in out C540001_1.Small_Num) is
- begin
- case Val_Func (P) is -- Case expression is
- -- instantiated generic
- when New_Enum_Type (C540001_1.Eh) | -- function.
- New_Enum_Type (C540001_1.Sea) => P := 4;
- when New_Enum_Type (C540001_1.Bee) => P := 7;
- when others => P := 9;
- end case;
-
- end Assign_Num;
-
- SNObj : C540001_1.Small_Num;
-
- begin
- SNObj := 0;
- Assign_Num (SNObj);
- if SNObj /= 4 then
- Report.Failed ("Incorrect result for value of zero in call to " &
- "generic function subtest");
- end if;
-
- SNObj := 3;
- Assign_Num (SNObj);
- if SNObj /= 9 then
- Report.Failed ("Incorrect result for value of three in call to " &
- "generic function subtest");
- end if;
-
- end Instantiated_Generic_Function_Subtest;
-
- -- When a function call, a renaming of a function, or a call to an
- -- inherited function is used in the case expressions, the choices
- -- of the case statement only need to cover the values in the result
- -- of the function.
-
- Function_Call_Subtest:
- declare
- MObj : C540001_1.Mixed := 'B';
- BObj : Boolean := True;
- use type C540001_1.Mixed;
- begin
- C540001_1.Assign_Mixed (BObj, MObj);
- if MObj /= C540001_1.None then
- Report.Failed ("Incorrect result for value of true in function" &
- "call subtest");
- end if;
-
- BObj := False;
- C540001_1.Assign_Mixed (BObj, MObj);
- if MObj /= C540001_1.'A' then
- Report.Failed ("Incorrect result for value of false in function" &
- "call subtest");
- end if;
-
- end Function_Call_Subtest;
-
- Function_Renaming_Subtest:
- declare
- use C540001_1;
- function Rename_Get_Small_Int (P : Boolean)
- return Small_Int renames Get_Small_Int;
- MObj : Mixed := None;
- BObj : Boolean := False;
- begin
- case Rename_Get_Small_Int (BObj) is
- when 1 => MObj := 'A';
- when 2 => MObj := 'B';
- -- No others needed.
- end case;
-
- if MObj /= 'B' then
- Report.Failed ("Incorrect result for value of false in function" &
- "renaming subtest");
- end if;
-
- end Function_Renaming_Subtest;
-
- Call_To_Generic_Formal_Function_Subtest:
- declare
- type New_Small_Int is new C540001_1.Small_Int;
-
- function Get_Int_Value return New_Small_Int is
- begin
- return New_Small_Int'First;
- end Get_Int_Value;
-
- package Int_Pck is new C540001_4
- (Formal_Int_Type => New_Small_Int,
- Formal_Func => Get_Int_Value);
-
- use type C540001_1.Mixed;
- MObj : C540001_1.Mixed := C540001_1.None;
-
- begin
- Int_Pck.Gen_Assign_Mixed (MObj);
- if MObj /= C540001_1.'A' then
- Report.Failed ("Incorrect result in call to generic formal " &
- "function subtest");
- end if;
-
- end Call_To_Generic_Formal_Function_Subtest;
-
- Call_To_Inherited_Function_Subtest:
- declare
- NTObj1 : C540001_5.New_Tagged := (C1 => C540001_1.Eh,
- C2 => C540001_1.'A');
- NTObj2 : C540001_5.New_Tagged := (C540001_1.Dee, C540001_1.'C');
- use type C540001_1.Mixed;
- use type C540001_1.Enum_Type;
- begin
- C540001_5.Assign_Tagged (NTObj1, NTObj2);
- if NTObj2.C1 /= C540001_1.Bee or
- NTObj2.C2 /= C540001_1.'B' then
- Report.Failed ("Incorrect result in inherited function subtest");
- end if;
-
- end Call_To_Inherited_Function_Subtest;
-
- Report.Result;
-
-end C540001;
diff --git a/gcc/testsuite/ada/acats/tests/c6/c631001.a b/gcc/testsuite/ada/acats/tests/c6/c631001.a
deleted file mode 100644
index f8b0c775b15..00000000000
--- a/gcc/testsuite/ada/acats/tests/c6/c631001.a
+++ /dev/null
@@ -1,134 +0,0 @@
--- C631001.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that if different forms of a name are used in the default
--- expression of a discriminant part, the selector may be an operator
--- symbol or a character literal.
---
--- TEST DESCRIPTION:
--- This transition test defines private types where their selectors in
--- the default expression of the discriminant parts at the full type
--- declarations are an operator and a literal, respectively.
--- The test also declares procedures that use an operator and a literal
--- as selectors in the formal parts.
---
--- Inspired by B63102A.ADA.
---
---
--- CHANGE HISTORY:
--- 25 Mar 96 SAIC Initial version for ACVC 2.1.
--- 26 Feb 97 PWB.CTA Removed use of function called before elaboration
---!
-
-with Report;
-
-procedure C631001 is
-
- package C631001_0 is
-
- type Int_Type is range 1 .. 100;
- type Enu_Type is ('A', 'B', 'C', 'D');
-
- type Private_Enu (D : Enu_Type := 'B') is private;
-
- function "+" (X, Y : Int_Type) return Int_Type;
-
- procedure Int_Proc (P1 : in Int_Type := "+" (10, 15);
- P2 : out Int_Type);
-
- procedure Enu_Proc (P1 : in Enu_Type := 'C';
- P2 : out Enu_Type);
-
- private
-
- type Private_Enu (D : Enu_Type := C631001_0.'B') is -- OK.
- record
- C2 : Enu_Type := D;
- end record;
-
- -----------------------------------------------------------------
- PE_Obj : C631001_0.Private_Enu;
-
- end C631001_0;
-
- --==================================================================--
-
- package body C631001_0 is
-
- function "+" (X, Y : Int_Type) return Int_Type is
- begin
- return 10;
- end "+";
-
- -----------------------------------------------------------------
- procedure Int_Proc (P1 : in Int_Type := C631001_0."+" (10, 15); -- OK.
- P2 : out Int_Type) is
-
- begin
- P2 := P1;
- end Int_Proc;
-
- -----------------------------------------------------------------
- procedure Enu_Proc (P1 : in Enu_Type := C631001_0.'C'; -- OK.
- P2 : out Enu_Type) is
- begin
- P2 := P1;
- end Enu_Proc;
-
- -----------------------------------------------------------------
-
- end C631001_0;
-
- ---------------------------------------------------------------------------
- Int_Obj : C631001_0.Int_Type := 50;
- Enu_Obj : C631001_0.Enu_Type := C631001_0.'D';
-
- -- Direct visibility to operator symbols
- use type C631001_0.Int_Type;
- use type C631001_0.Enu_Type;
-
-begin -- main
-
- Report.Test ("C631001", "Check that if different forms of a name are " &
- "used in the default expression of a discriminant part, " &
- "the selector may be an operator symbol or a character " &
- "literal");
-
- C631001_0.Int_Proc (P2 => Int_Obj);
-
- if Int_Obj /= 10 then
- Report.Failed ("Wrong result for Int_Obj");
- end if;
-
- C631001_0.Enu_Proc (P2 => Enu_Obj);
-
- if Enu_Obj /= 'C' then
- Report.Failed ("Wrong result for Enu_Obj");
- end if;
-
- Report.Result;
-
-end C631001;
diff --git a/gcc/testsuite/ada/acats/tests/c6/c640001.a b/gcc/testsuite/ada/acats/tests/c6/c640001.a
deleted file mode 100644
index 8e259162e17..00000000000
--- a/gcc/testsuite/ada/acats/tests/c6/c640001.a
+++ /dev/null
@@ -1,334 +0,0 @@
--- C640001.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that the prefix of a subprogram call with an actual parameter
--- part may be an implicit dereference of an access-to-subprogram value.
--- Check that, for an access-to-subprogram type whose designated profile
--- contains parameters of a tagged generic formal type, an access-to-
--- subprogram value may designate dispatching and non-dispatching
--- operations, and that dereferences of such a value call the appropriate
--- subprogram.
---
--- TEST DESCRIPTION:
--- The test declares a tagged type (Table) with a dispatching operation
--- (Clear), as well as a derivative (Table2) which overrides that
--- operation. A subprogram with the same name and profile as Clear is
--- declared in a separate package -- it is therefore not a dispatching
--- operation of Table. For the purposes of the test, each version of Clear
--- modifies the components of its parameter in a unique way.
---
--- Additionally, an operation (Reset) of type Table is declared which
--- makes a re-dispatching call to Clear, i.e.,
---
--- procedure Reset (A: in out Table) is
--- begin
--- ...
--- Clear (Table'Class(A)); -- Re-dispatch based on tag of actual.
--- ...
--- end Reset;
---
--- An access-to-subprogram type is declared within a generic package,
--- with a designated profile which declares a parameter of a generic
--- formal tagged private type.
---
--- The generic is instantiated with type Table. The instance defines an
--- array of access-to-subprogram values (which represents a table of
--- operations to be performed sequentially on a single operand).
--- Access values designating the dispatching version of Clear, the
--- non-dispatching version of Clear, and Reset (which re-dispatches to
--- Clear) are placed in this array.
---
--- In the instance, each subprogram in the array is called by implicitly
--- dereferencing the corresponding access value. For the dispatching and
--- non-dispatching versions of Clear, the actual parameter passed is of
--- type Table. For Reset, the actual parameter passed is a view conversion
--- of an object of type Table2 to type Table, i.e., Table(Table2_Obj).
--- Since the tag of the operand never changes, the call to Clear within
--- Reset should execute Table2's version of Clear.
---
--- The main program verifies that the appropriate version of Clear is
--- called in each case, by checking that the components of the actual are
--- updated as expected.
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
---
---!
-
-package C640001_0 is
-
- -- Data type artificial for testing purposes.
-
- Row_Len : constant := 10;
-
- T : constant Boolean := True;
- F : constant Boolean := False;
-
- type Row_Type is array (1 .. Row_Len) of Boolean;
-
- function Is_True (A : in Row_Type) return Boolean;
- function Is_False (A : in Row_Type) return Boolean;
-
-
- Init : constant Row_Type := (T, F, T, F, T, F, T, F, T, F);
-
- type Table is tagged record -- Tagged type.
- Row1 : Row_Type := Init;
- Row2 : Row_Type := Init;
- end record;
-
- procedure Clear (A : in out Table); -- Dispatching operation.
-
- procedure Reset (A : in out Table); -- Re-dispatching operation.
-
- -- ...Other operations.
-
-
- type Table2 is new Table with null record; -- Extension of Table (but
- -- structurally identical).
-
- procedure Clear (A : in out Table2); -- Overrides parent's op.
-
- -- ...Other operations.
-
-
-end C640001_0;
-
-
- --===================================================================--
-
-
-package body C640001_0 is
-
- function Is_True (A : in Row_Type) return Boolean is
- begin
- for I in A'Range loop
- if A(I) /= True then -- Return true if all elements
- return False; -- of A are True.
- end if;
- end loop;
- return True;
- end Is_True;
-
-
- function Is_False (A : in Row_Type) return Boolean is
- begin
- return A = Row_Type'(others => False); -- Return true if all elements
- end Is_False; -- of A are False.
-
-
- procedure Clear (A : in out Table) is
- begin
- for I in Row_Type'Range loop -- This version of Clear sets
- A.Row1(I) := False; -- the elements of Row1 only
- end loop; -- to False.
- end Clear;
-
-
- procedure Reset (A : in out Table) is
- begin
- Clear (Table'Class(A)); -- Redispatch to appropriate
- -- ... Other "reset" activities. -- version of Clear.
- end Reset;
-
-
- procedure Clear (A : in out Table2) is
- begin
- for I in Row_Type'Range loop -- This version of Clear sets
- A.Row1(I) := True; -- the elements of Row1 only
- end loop; -- to True.
- end Clear;
-
-
-end C640001_0;
-
-
- --===================================================================--
-
-
-with C640001_0;
-package C640001_1 is
-
- procedure Clear (T : in out C640001_0.Table); -- Non-dispatching operation.
-
-end C640001_1;
-
-
- --===================================================================--
-
-
-package body C640001_1 is
-
- procedure Clear (T : in out C640001_0.Table) is
- begin
- for I in C640001_0.Row_Type'Range loop -- This version of Clear sets
- T.Row2(I) := True; -- the elements of Row2 only
- end loop; -- to True.
- end Clear;
-
-end C640001_1;
-
-
- --===================================================================--
-
-
--- This unit represents a support package for table-driven processing of
--- data objects. Process_Operand performs a set of operations are performed
--- sequentially on a single operand. Note that parameters are provided to
--- specify which subset of operations in the operations table are to be
--- performed (ordinarily these might be omitted, but the test requires that
--- each operation be called individually for a single operand).
-
-generic
- type Tag is tagged private;
-package C640001_2 is
-
- type Proc_Ptr is access procedure (P: in out Tag);
-
- type Op_List is private;
-
- procedure Add_Op (Op : in Proc_Ptr; -- Add operation to
- List : in out Op_List); -- to list of ops.
-
- procedure Process_Operand (Operand : in out Tag; -- Execute a subset
- List : in Op_List; -- of a list of
- First_Op : in Positive; -- operations using
- Last_Op : in Positive); -- a given operand.
-
- -- ...Other operations.
-
-private
- type Op_Array is array (1 .. 3) of Proc_Ptr;
-
- type Op_List is record
- Top : Natural := 0;
- Ops : Op_Array;
- end record;
-end C640001_2;
-
-
- --===================================================================--
-
-
-package body C640001_2 is
-
- procedure Add_Op (Op : in Proc_Ptr;
- List : in out Op_List) is
- begin
- List.Top := List.Top + 1; -- Artificial; no Constraint_Error protection.
- List.Ops(List.Top) := Op;
- end Add_Op;
-
-
- procedure Process_Operand (Operand : in out Tag;
- List : in Op_List;
- First_Op : in Positive;
- Last_Op : in Positive) is
- begin
- for I in First_Op .. Last_Op loop
- List.Ops(I)(Operand); -- Implicit dereference of an
- end loop; -- access-to-subprogram value.
- end Process_Operand;
-
-end C640001_2;
-
-
- --===================================================================--
-
-
-with C640001_0;
-with C640001_1;
-with C640001_2;
-
-with Report;
-procedure C640001 is
-
- package Table_Support is new C640001_2 (C640001_0.Table);
-
- Sub_Ptr : Table_Support.Proc_Ptr;
- My_List : Table_Support.Op_List;
- My_Table1 : C640001_0.Table; -- Initial values of both Row1 &
- -- Row2 are (T,F,T,F,T,F,T,F,T,F).
- My_Table2 : C640001_0.Table2; -- Initial values of both Row1 &
- -- Row2 are (T,F,T,F,T,F,T,F,T,F).
-begin
- Report.Test ("C640001", "Check that, for an access-to-subprogram type " &
- "whose designated profile contains parameters " &
- "of a tagged generic formal type, an access-" &
- "to-subprogram value may designate dispatching " &
- "and non-dispatching operations");
-
- --
- -- Add subprogram access values to list:
- --
-
- Sub_Ptr := C640001_0.Clear'Access; -- Designates dispatching op.
- Table_Support.Add_Op (Sub_Ptr, My_List); -- (1st operation on My_List).
-
- Sub_Ptr := C640001_1.Clear'Access; -- Designates non-dispatching op.
- Table_Support.Add_Op (Sub_Ptr, My_List); -- (2nd operation on My_List).
-
- Sub_Ptr := C640001_0.Reset'Access; -- Designates re-dispatching op.
- Table_Support.Add_Op (Sub_Ptr, My_List); -- (3rd operation on My_List).
-
-
- --
- -- Call dispatching operation:
- --
-
- Table_Support.Process_Operand (My_Table1, My_List, 1, 1); -- Call 1st op.
-
- if not C640001_0.Is_False (My_Table1.Row1) then
- Report.Failed ("Wrong result after calling dispatching operation");
- end if;
-
-
- --
- -- Call non-dispatching operation:
- --
-
- Table_Support.Process_Operand (My_Table1, My_List, 2, 2); -- Call 2nd op.
-
- if not C640001_0.Is_True (My_Table1.Row2) then
- Report.Failed ("Wrong result after calling non-dispatching operation");
- end if;
-
-
- --
- -- Call re-dispatching operation:
- --
-
- Table_Support.Process_Operand (C640001_0.Table(My_Table2), -- View conv.
- My_List, 3, 3); -- Call 3rd op.
-
- if not C640001_0.Is_True (My_Table2.Row1) then
- Report.Failed ("Wrong result after calling re-dispatching operation");
- end if;
-
-
- Report.Result;
-end C640001;
diff --git a/gcc/testsuite/ada/acats/tests/c6/c641001.a b/gcc/testsuite/ada/acats/tests/c6/c641001.a
deleted file mode 100644
index 84ee58a7ed5..00000000000
--- a/gcc/testsuite/ada/acats/tests/c6/c641001.a
+++ /dev/null
@@ -1,281 +0,0 @@
--- C641001.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that actual parameters passed by reference are view converted
--- to the nominal subtype of the formal parameter.
---
--- TEST DESCRIPTION:
--- Check that sliding is allowed for formal parameters, especially
--- check cases that would have caused errors in Ada'83.
--- Check that length check for a formal parameter (esp out mode)
--- is performed before the call, not after.
---
--- notes: 6.2; by reference ::= tagged, task, protected,
--- limited (nonprivate), or composite containing such
--- 4.6; view conversion
---
---
--- CHANGE HISTORY:
--- 26 JAN 96 SAIC Initial version
--- 04 NOV 96 SAIC Commentary revision for release 2.1
--- 27 FEB 97 PWB.CTA Corrected reference to the wrong string
---!
-
------------------------------------------------------------------ C641001_0
-
-package C641001_0 is
-
- subtype String_10 is String(1..10);
-
- procedure Check_String_10( S : out String_10; Start, Stop: Natural );
-
- procedure Check_Illegal_Slice_Reference( Slice_Passed : in out String;
- Index: Natural );
-
- type Tagged_Data(Bound: Natural) is tagged record
- Data_Item : String(1..Bound) := (others => '*');
- end record;
-
- type Tag_List is array(Natural range <>) of Tagged_Data(5);
-
- subtype Tag_List_10 is Tag_List(1..10);
-
- procedure Check_Tag_Slice( TL : in out Tag_List_10 );
-
- procedure Check_Out_Tagged_Data( Formal : out Tagged_Data );
-
-end C641001_0;
-
--- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
-
-with Report;
-with TCTouch;
-package body C641001_0 is
-
- String_Data : constant String := "1234567890ABCDEFGHIJKLMNOPQRSTUVWXYZ";
-
- procedure Check_String_10( S : out String_10; Start, Stop: Natural ) is
- begin
- if S'Length /= 10 then
- Report.Failed("Length check not performed prior to execution");
- end if;
- S := String_Data(Start..Stop);
- exception
- when others => Report.Failed("Exception encountered in Check_String_10");
- end Check_String_10;
-
- procedure Check_Illegal_Slice_Reference( Slice_Passed : in out String;
- Index: Natural ) is
- begin
- -- essentially "do-nothing" for optimization foilage...
- if Slice_Passed(Index) in Character then
- -- Intent is ^^^^^ should raise Constraint_Error
- Report.Failed("Illegal Slice provided legal character");
- else
- Report.Failed("Illegal Slice provided illegal character");
- end if;
- exception
- when Constraint_Error =>
- null; -- expected case
- when others =>
- Report.Failed("Wrong exception in Check_Illegal_Slice_Reference");
- end Check_Illegal_Slice_Reference;
-
- procedure Check_Tag_Slice( TL : in out Tag_List_10 ) is
- -- if the view conversion is not performed, one of the following checks
- -- will fail (given data passed as 0..9 and then 2..11)
- begin
- Check_Under_Index: -- index 0 should raise C_E
- begin
- TCTouch.Assert( TL(Report.Ident_Int(0)).Data_Item = "*****",
- "Index 0 (illegal); bad data" );
- Report.Failed("Index 0 did not raise Constraint_Error");
- exception
- when Constraint_Error =>
- null; -- expected case
- when others =>
- Report.Failed("Wrong exception in Check_Under_Index ");
- end Check_Under_Index;
-
- Check_Over_Index: -- index 11 should raise C_E
- begin
- TCTouch.Assert( TL(Report.Ident_Int(11)).Data_Item = "*****",
- "Index 11 (illegal); bad data" );
- Report.Failed("Index 11 did not raise Constraint_Error");
- exception
- when Constraint_Error =>
- null; -- expected case
- when others =>
- Report.Failed("Wrong exception in Check_Over_Index ");
- end Check_Over_Index;
-
- end Check_Tag_Slice;
-
- procedure Check_Out_Tagged_Data( Formal : out Tagged_Data ) is
- begin
- TCTouch.Assert( Formal.Data_Item = "*****", "out formal data bad" );
- Formal.Data_Item(1) := '!';
- end Check_Out_Tagged_Data;
-
-end C641001_0;
-
-------------------------------------------------------------------- C641001
-
-with Report;
-with TCTouch;
-with C641001_0;
-procedure C641001 is
-
- function II( I: Integer ) return Integer renames Report.Ident_Int;
- -- ^^ name chosen to allow embedding in calls
-
- A_String_10 : C641001_0.String_10;
- Slicable : String(1..40);
- Tag_Slices : C641001_0.Tag_List(0..11);
-
- Global_Data : String(1..26) := "ABCDEFGHIJKLMNOPQRSTUVWXYZ";
-
- procedure Check_Out_Sliding( Lo1, Hi1, Lo2, Hi2 : Natural ) is
-
- subtype One_Constrained_String is String(Lo1..Hi1); -- 1 5
- subtype Two_Constrained_String is String(Lo2..Hi2); -- 6 10
-
- procedure Out_Param( Param : out One_Constrained_String ) is
- begin
- Param := Report.Ident_Str( Global_Data(Lo2..Hi2) );
- end Out_Param;
- Object : Two_Constrained_String;
- begin
- Out_Param( Object );
- if Object /= Report.Ident_Str( Global_Data(Lo2..Hi2) ) then
- Report.Failed("Bad result in Check_Out_Sliding");
- end if;
- exception
- when others => Report.Failed("Exception in Check_Out_Sliding");
- end Check_Out_Sliding;
-
- procedure Check_Dynamic_Subtype_Cases(F_Lower,F_Upper: Natural;
- A_Lower,A_Upper: Natural) is
-
- subtype Dyn_String is String(F_Lower..F_Upper);
-
- procedure Check_Dyn_Subtype_Formal_Out( Param : out Dyn_String ) is
- begin
- Param := Global_Data(11..20);
- end Check_Dyn_Subtype_Formal_Out;
-
- procedure Check_Dyn_Subtype_Formal_In( Param : in Dyn_String ) is
- begin
- if Param /= Global_Data(11..20) then
- Report.Failed("Dynamic case, data mismatch");
- end if;
- end Check_Dyn_Subtype_Formal_In;
-
- Stuff: String(A_Lower..A_Upper);
-
- begin
- Check_Dyn_Subtype_Formal_Out( Stuff );
- Check_Dyn_Subtype_Formal_In( Stuff );
- end Check_Dynamic_Subtype_Cases;
-
-begin -- Main test procedure.
-
- Report.Test ("C641001", "Check that actual parameters passed by " &
- "reference are view converted to the nominal " &
- "subtype of the formal parameter" );
-
- -- non error cases for string slices
-
- C641001_0.Check_String_10( A_String_10, 1, 10 );
- TCTouch.Assert( A_String_10 = "1234567890", "Nominal case" );
-
- C641001_0.Check_String_10( A_String_10, 11, 20 );
- TCTouch.Assert( A_String_10 = "ABCDEFGHIJ", "Sliding to subtype" );
-
- C641001_0.Check_String_10( Slicable(1..10), 1, 10 );
- TCTouch.Assert( Slicable(1..10) = "1234567890", "Slice, no sliding" );
-
- C641001_0.Check_String_10( Slicable(1..10), 21, 30 );
- TCTouch.Assert( Slicable(1..10) = "KLMNOPQRST", "Sliding to slice" );
-
- C641001_0.Check_String_10( Slicable(11..20), 11, 20 );
- TCTouch.Assert( Slicable(11..20) = "ABCDEFGHIJ", "Sliding to same" );
-
- C641001_0.Check_String_10( Slicable(21..30), 11, 20 );
- TCTouch.Assert( Slicable(21..30) = "ABCDEFGHIJ", "Sliding up" );
-
- -- error cases for string slices
-
- C641001_0.Check_Illegal_Slice_Reference( Slicable(21..30), 20 );
-
- C641001_0.Check_Illegal_Slice_Reference( Slicable(1..15), Slicable'Last );
-
- -- checks for view converting actuals to formals
-
- -- catch low bound fault
- C641001_0.Check_Tag_Slice( Tag_Slices(II(0)..9) ); -- II ::= Ident_Int
- TCTouch.Assert( Tag_Slices'First = 0, "Tag_Slices'First = 0" );
- TCTouch.Assert( Tag_Slices'Last = 11, "Tag_Slices'Last = 11" );
-
- -- catch high bound fault
- C641001_0.Check_Tag_Slice( Tag_Slices(2..II(11)) );
- TCTouch.Assert( Tag_Slices'First = 0, "Tag_Slices'First = 0" );
- TCTouch.Assert( Tag_Slices'Last = 11, "Tag_Slices'Last = 11" );
-
- Check_Formal_Association_Check:
- begin
- C641001_0.Check_String_10( Slicable, 1, 10 ); -- catch length fault
- Report.Failed("Exception not raised at Check_Formal_Association_Check");
- exception
- when Constraint_Error =>
- null; -- expected case
- when others =>
- Report.Failed("Wrong exception at Check_Formal_Association_Check");
- end Check_Formal_Association_Check;
-
- -- check for constrained actual, unconstrained formal
- C641001_0.Check_Out_Tagged_Data( Tag_Slices(5) );
- TCTouch.Assert( Tag_Slices(5).Data_Item = "!****",
- "formal out returned bad result" );
-
- -- additional checks for out mode formal parameters, dynamic subtypes
-
- Check_Out_Sliding( II(1),II(5), II(6),II(10) );
-
- Check_Out_Sliding( 21,25, 6,10 );
-
- Check_Dynamic_Subtype_Cases(F_Lower => II(1), F_Upper => II(10),
- A_Lower => II(1), A_Upper => II(10));
-
- Check_Dynamic_Subtype_Cases(F_Lower => II(21), F_Upper => II(30),
- A_Lower => II( 1), A_Upper => II(10));
-
- Check_Dynamic_Subtype_Cases(F_Lower => II( 1), F_Upper => II(10),
- A_Lower => II(21), A_Upper => II(30));
-
- Report.Result;
-
-end C641001;
diff --git a/gcc/testsuite/ada/acats/tests/c6/c650001.a b/gcc/testsuite/ada/acats/tests/c6/c650001.a
deleted file mode 100644
index 595e81dad47..00000000000
--- a/gcc/testsuite/ada/acats/tests/c6/c650001.a
+++ /dev/null
@@ -1,412 +0,0 @@
--- C650001.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that, for a function result type that is a return-by-reference
--- type, Program_Error is raised if the return expression is a name that
--- denotes an object view whose accessibility level is deeper than that
--- of the master that elaborated the function body.
---
--- Check for cases where the result type is:
--- (a) A tagged limited type.
--- (b) A task type.
--- (c) A protected type.
--- (d) A composite type with a subcomponent of a
--- return-by-reference type (task type).
---
--- TEST DESCRIPTION:
--- The accessibility level of the master that elaborates the body of a
--- return-by-reference function will always be less deep than that of
--- the function (which is itself a master).
---
--- Thus, the return object may not be any of the following, since each
--- has an accessibility level at least as deep as that of the function:
---
--- (1) An object declared local to the function.
--- (2) The result of a local function.
--- (3) A parameter of the function.
---
--- Verify that Program_Error is raised within the return-by-reference
--- function if the return object is any of (1)-(3) above, for various
--- subsets of the return types (a)-(d) above. Include cases where (1)-(3)
--- are operands of parenthesized expressions.
---
--- Verify that no exception is raised if the return object is any of the
--- following:
---
--- (4) An object declared at a less deep level than that of the
--- master that elaborated the function body.
--- (5) The result of a function declared at the same level as the
--- original function (assuming the new function is also legal).
--- (6) A parameter of the master that elaborated the function body.
---
--- For (5), pass the new function as an actual via an access-to-
--- subprogram parameter of the original function. Check for cases where
--- the new function does and does not raise an exception.
---
--- Since the functions to be tested cannot be part of an assignment
--- statement (since they return values of a limited type), pass each
--- function result as an actual parameter to a dummy procedure, e.g.,
---
--- Dummy_Proc ( Function_Call );
---
---
--- CHANGE HISTORY:
--- 03 May 95 SAIC Initial prerelease version.
--- 08 Feb 99 RLB Removed subcase with two errors.
---
---!
-
-package C650001_0 is
-
- type Tagged_Limited is tagged limited record
- C: String (1 .. 10);
- end record;
-
- task type Task_Type;
-
- protected type Protected_Type is
- procedure Op;
- end Protected_Type;
-
- type Task_Array is array (1 .. 10) of Task_Type;
-
- type Variant_Record (Toggle: Boolean) is record
- case Toggle is
- when True =>
- T: Task_Type; -- Return-by-reference component.
- when False =>
- I: Integer; -- Non-return-by-reference component.
- end case;
- end record;
-
- -- Limited type even though variant contains no limited components:
- type Non_Task_Variant is new Variant_Record (Toggle => False);
-
-end C650001_0;
-
-
- --==================================================================--
-
-
-package body C650001_0 is
-
- task body Task_Type is
- begin
- null;
- end Task_Type;
-
- protected body Protected_Type is
- procedure Op is
- begin
- null;
- end Op;
- end Protected_Type;
-
-end C650001_0;
-
-
- --==================================================================--
-
-
-with C650001_0;
-package C650001_1 is
-
- type TC_Result_Kind is (OK, P_E, O_E);
-
- procedure TC_Display_Results (Actual : in TC_Result_Kind;
- Expected: in TC_Result_Kind;
- Message : in String);
-
- -- Dummy procedures:
-
- procedure Check_Tagged (P: C650001_0.Tagged_Limited);
- procedure Check_Task (P: C650001_0.Task_Type);
- procedure Check_Protected (P: C650001_0.Protected_Type);
- procedure Check_Composite (P: C650001_0.Non_Task_Variant);
-
-end C650001_1;
-
-
- --==================================================================--
-
-
-with Report;
-package body C650001_1 is
-
- procedure TC_Display_Results (Actual : in TC_Result_Kind;
- Expected: in TC_Result_Kind;
- Message : in String) is
- begin
- if Actual /= Expected then
- case Actual is
- when OK =>
- Report.Failed ("No exception raised: " & Message);
- when P_E =>
- Report.Failed ("Program_Error raised: " & Message);
- when O_E =>
- Report.Failed ("Unexpected exception raised: " & Message);
- end case;
- end if;
- end TC_Display_Results;
-
-
- procedure Check_Tagged (P: C650001_0.Tagged_Limited) is
- begin
- null;
- end;
-
- procedure Check_Task (P: C650001_0.Task_Type) is
- begin
- null;
- end;
-
- procedure Check_Protected (P: C650001_0.Protected_Type) is
- begin
- null;
- end;
-
- procedure Check_Composite (P: C650001_0.Non_Task_Variant) is
- begin
- null;
- end;
-
-end C650001_1;
-
-
-
- --==================================================================--
-
-
-with C650001_0;
-with C650001_1;
-
-with Report;
-procedure C650001 is
-begin
-
- Report.Test ("C650001", "Check that, for a function result type that " &
- "is a return-by-reference type, Program_Error is raised " &
- "if the return expression is a name that denotes an " &
- "object view whose accessibility level is deeper than " &
- "that of the master that elaborated the function body");
-
-
-
- SUBTEST1:
- declare
-
- Result: C650001_1.TC_Result_Kind;
- PO : C650001_0.Protected_Type;
-
- function Return_Prot (P: C650001_0.Protected_Type)
- return C650001_0.Protected_Type is
- begin
- Result := C650001_1.OK;
- return P; -- Formal parameter (3).
- exception
- when Program_Error =>
- Result := C650001_1.P_E; -- Expected result.
- return PO;
- when others =>
- Result := C650001_1.O_E;
- return PO;
- end Return_Prot;
-
- begin -- SUBTEST1.
- C650001_1.Check_Protected ( Return_Prot(PO) );
- C650001_1.TC_Display_Results (Result, C650001_1.P_E, "SUBTEST #1");
- exception
- when others =>
- Report.Failed ("SUBTEST #1: Unexpected exception in outer block");
- end SUBTEST1;
-
-
-
- SUBTEST2:
- declare
-
- Result: C650001_1.TC_Result_Kind;
- Comp : C650001_0.Non_Task_Variant;
-
- function Return_Composite return C650001_0.Non_Task_Variant is
- Local: C650001_0.Non_Task_Variant;
- begin
- Result := C650001_1.OK;
- return (Local); -- Parenthesized local object (1).
- exception
- when Program_Error =>
- Result := C650001_1.P_E; -- Expected result.
- return Comp;
- when others =>
- Result := C650001_1.O_E;
- return Comp;
- end Return_Composite;
-
- begin -- SUBTEST2.
- C650001_1.Check_Composite ( Return_Composite );
- C650001_1.TC_Display_Results (Result, C650001_1.P_E, "SUBTEST #2");
- exception
- when others =>
- Report.Failed ("SUBTEST #2: Unexpected exception in outer block");
- end SUBTEST2;
-
-
-
- SUBTEST3:
- declare
-
- Result: C650001_1.TC_Result_Kind;
- Tsk : C650001_0.Task_Type;
- TskArr: C650001_0.Task_Array;
-
- function Return_Task (P: C650001_0.Task_Array)
- return C650001_0.Task_Type is
-
- function Inner return C650001_0.Task_Type is
- begin
- return P(P'First); -- OK: should not raise exception (6).
- exception
- when Program_Error =>
- Report.Failed ("SUBTEST #3: Program_Error incorrectly " &
- "raised within function Inner");
- return Tsk;
- when others =>
- Report.Failed ("SUBTEST #3: Unexpected exception " &
- "raised within function Inner");
- return Tsk;
- end Inner;
-
- begin -- Return_Task.
- Result := C650001_1.OK;
- return Inner; -- Call to local function (2).
- exception
- when Program_Error =>
- Result := C650001_1.P_E; -- Expected result.
- return Tsk;
- when others =>
- Result := C650001_1.O_E;
- return Tsk;
- end Return_Task;
-
- begin -- SUBTEST3.
- C650001_1.Check_Task ( Return_Task(TskArr) );
- C650001_1.TC_Display_Results (Result, C650001_1.P_E, "SUBTEST #3");
- exception
- when others =>
- Report.Failed ("SUBTEST #3: Unexpected exception in outer block");
- end SUBTEST3;
-
-
-
- SUBTEST4:
- declare
-
- Result: C650001_1.TC_Result_Kind;
- TagLim: C650001_0.Tagged_Limited;
-
- function Return_TagLim (P: C650001_0.Tagged_Limited'Class)
- return C650001_0.Tagged_Limited is
- begin
- Result := C650001_1.OK;
- return C650001_0.Tagged_Limited(P); -- Conversion of formal param (3).
- exception
- when Program_Error =>
- Result := C650001_1.P_E; -- Expected result.
- return TagLim;
- when others =>
- Result := C650001_1.O_E;
- return TagLim;
- end Return_TagLim;
-
- begin -- SUBTEST4.
- C650001_1.Check_Tagged ( Return_TagLim(TagLim) );
- C650001_1.TC_Display_Results (Result, C650001_1.P_E,
- "SUBTEST #4 (root type)");
- exception
- when others =>
- Report.Failed ("SUBTEST #4: Unexpected exception in outer block");
- end SUBTEST4;
-
-
-
- SUBTEST5:
- declare
- Tsk : C650001_0.Task_Type;
- begin -- SUBTEST5.
-
- declare
- Result: C650001_1.TC_Result_Kind;
-
- type AccToFunc is access function return C650001_0.Task_Type;
-
- function Return_Global return C650001_0.Task_Type is
- begin
- return Tsk; -- OK: should not raise exception (4).
- end Return_Global;
-
- function Return_Local return C650001_0.Task_Type is
- Local : C650001_0.Task_Type;
- begin
- return Local; -- Propagate Program_Error.
- end Return_Local;
-
-
- function Return_Func (P: AccToFunc) return C650001_0.Task_Type is
- begin
- Result := C650001_1.OK;
- return P.all; -- Function call (5).
- exception
- when Program_Error =>
- Result := C650001_1.P_E;
- return Tsk;
- when others =>
- Result := C650001_1.O_E;
- return Tsk;
- end Return_Func;
-
- RG : AccToFunc := Return_Global'Access;
- RL : AccToFunc := Return_Local'Access;
-
- begin
- C650001_1.Check_Task ( Return_Func(RG) );
- C650001_1.TC_Display_Results (Result, C650001_1.OK,
- "SUBTEST #5 (global task)");
-
- C650001_1.Check_Task ( Return_Func(RL) );
- C650001_1.TC_Display_Results (Result, C650001_1.P_E,
- "SUBTEST #5 (local task)");
- exception
- when others =>
- Report.Failed ("SUBTEST #5: Unexpected exception in outer block");
- end;
-
- end SUBTEST5;
-
-
-
- Report.Result;
-
-end C650001;
diff --git a/gcc/testsuite/ada/acats/tests/c7/c730001.a b/gcc/testsuite/ada/acats/tests/c7/c730001.a
deleted file mode 100644
index 24cf8e0fdc5..00000000000
--- a/gcc/testsuite/ada/acats/tests/c7/c730001.a
+++ /dev/null
@@ -1,437 +0,0 @@
--- C730001.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that the full view of a private extension may be derived
--- indirectly from the ancestor type (i.e., the parent type of the full
--- type may be any descendant of the ancestor type). Check that, for
--- a primitive subprogram of the private extension that is inherited from
--- the ancestor type and not overridden, the formal parameter names and
--- default expressions come from the corresponding primitive subprogram
--- of the ancestor type, while the body comes from that of the parent
--- type. Check both dispatching and non-dispatching cases.
---
--- TEST DESCRIPTION:
--- Consider:
---
--- package P is
--- type Ancestor is tagged ...
--- procedure Op (P1: Ancestor; P2: Boolean := True);
--- end P;
---
--- with P;
--- package Q is
--- type Derived is new P.Ancestor with ...
--- procedure Op (X: Ancestor; Y: Boolean := False);
--- end Q;
---
--- with P, Q;
--- package R is
--- type Priv_Ext is new P.Ancestor with private; -- (A)
--- -- Inherits procedure Op (P1: Priv_Ext; P2: Boolean := True);
--- -- But body executed is that of Q.Op.
--- private
--- type Priv_Ext is new Q.Derived with record ... -- (B)
--- end R;
---
--- The ancestor type in (A) differs from the parent type in (B); the
--- parent of the full type is descended from the ancestor type of the
--- private extension. For a call to Op (from outside the scope of the
--- full view) with an operand of type Priv_Ext, the formal parameter
--- names and default expression come from that of P.Op (the ancestor
--- type's version), but the body executed will be that of
--- Q.Op (the parent type's version)
---
--- One half of the test mirrors the above template, where an inherited
--- subprogram (Set_Display) is called using the formal parameter
--- name (C) and default parameter expression of the ancestor type's
--- version (type Clock), but the version of the body executed is from
--- the parent type.
---
--- The test also includes an examination of the dynamic evaluation
--- case, where correct body associations are required through dispatching
--- calls. As described for the non-dispatching case above, the formal
--- parameter name and default values of the ancestor type's (Phone)
--- version of the inherited subprogram (Answer) are used in the
--- dispatching call, but the body executed is from the parent type.
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
---
---!
-
-package C730001_0 is
-
- type Display_Kind is (None, Analog, Digital);
- type Illumination_Type is (None, Light, Phosphorescence);
- type Capability_Type is (Available, In_Use, Call_Waiting, Conference);
- type Indicator_Type is (None, Light, Bell, Buzzer, Click, Modem);
-
- type Clock is abstract tagged record -- ancestor type associated
- Display : Display_Kind := None; -- with non-dispatching case.
- Illumination : Illumination_Type := None;
- end record;
-
- type Phone is tagged record -- ancestor type associated
- Status : Capability_Type := Available; -- with dispatching case.
- Indicator : Indicator_Type := None;
- end record;
-
- -- The Set_Display procedure for type Clock implements a basic, no-frills
- -- clock display.
- procedure Set_Display (C : in out Clock;
- Disp: in Display_Kind := Digital);
-
- -- The Answer procedure for type Phone implements a phone status change
- -- operation.
- procedure Answer (The_Phone : in out Phone;
- Ind : in Indicator_Type := Light);
- -- ...Other general clock and/or phone operations (not specified in this
- -- test scenario).
-
-end C730001_0;
-
-
- --==================================================================--
-
-
-package body C730001_0 is
-
- procedure Set_Display (C : in out Clock;
- Disp: in Display_Kind := Digital) is
- begin
- C.Display := Disp;
- C.Illumination := Light;
- end Set_Display;
-
- procedure Answer (The_Phone : in out Phone;
- Ind : in Indicator_Type := Light) is
- begin
- The_Phone.Status := In_Use;
- The_Phone.Indicator := Ind;
- end Answer;
-
-end C730001_0;
-
-
- --==================================================================--
-
-
-with C730001_0; use C730001_0;
-package C730001_1 is
-
- type Power_Supply_Type is (Spring, Battery, AC_Current);
- type Speaker_Type is (None, Present, Adjustable, Stereo);
-
- type Wall_Clock is new Clock with record
- Power_Source : Power_Supply_Type := Spring;
- end record;
-
- type Office_Phone is new Phone with record
- Speaker : Speaker_Type := Present;
- end record;
-
- -- Note: Both procedures below, parameter names and defaults differ from
- -- parent's version.
-
- -- The Set_Display procedure for type Wall_Clock improves upon the
- -- basic Set_Display procedure of type Clock.
-
- procedure Set_Display (WC: in out Wall_Clock;
- D : in Display_Kind := Analog);
-
- procedure Answer (OP : in out Office_Phone;
- OI : in Indicator_Type := Buzzer);
-
- -- ...Other wall clock and/or Office_Phone operations (not specified in
- -- this test scenario).
-
-end C730001_1;
-
-
- --==================================================================--
-
-
-package body C730001_1 is
-
- -- Note: This body is the one that should be executed in the test block
- -- below, not the version of the body corresponding to type Clock.
-
- procedure Set_Display (WC: in out Wall_Clock;
- D : in Display_Kind := Analog) is
- begin
- WC.Display := D;
- WC.Illumination := Phosphorescence;
- end Set_Display;
-
-
- procedure Answer (OP : in out Office_Phone;
- OI : in Indicator_Type := Buzzer) is
- begin
- OP.Status := Call_Waiting;
- OP.Indicator := OI;
- end Answer;
-
-end C730001_1;
-
-
- --==================================================================--
-
-
-with C730001_0; use C730001_0;
-with C730001_1; use C730001_1;
-package C730001_2 is
-
- type Alarm_Type is (Buzzer, Radio, Both);
- type Video_Type is (None, TV_Monitor, Wall_Projection);
-
- type Alarm_Clock is new Clock with private;
- -- Inherits proc Set_Display (C : in out Clock;
- -- Disp: in Display_Kind := Digital); -- (A)
- --
- -- Would also inherit other general clock operations (if present).
-
-
- type Conference_Room_Phone is new Office_Phone with record
- Display : Video_Type := TV_Monitor;
- end record;
-
- procedure Answer (CP : in out Conference_Room_Phone;
- CI : in Indicator_Type := Modem);
-
-
- function TC_Get_Display (C: Alarm_Clock) return Display_Kind;
- function TC_Get_Display_Illumination (C: Alarm_Clock)
- return Illumination_Type;
-
-private
-
- -- ...however, certain of the wall clock's operations (Set_Display, in
- -- this example) improve on the implementations provided for the general
- -- clock. We want to call the improved implementations, so we
- -- derive from Wall_Clock in the private part.
-
- type Alarm_Clock is new Wall_Clock with record
- Alarm : Alarm_Type := Buzzer;
- end record;
-
- -- Inherits proc Set_Display (WC: in out Wall_Clock;
- -- D : in Display_Kind := Analog); -- (B)
-
- -- The implicit Set_Display at (B) overrides the implicit Set_Display at
- -- (A), but only within the scope of the full view.
- --
- -- Outside the scope of the full view, only (A) is visible, so calls
- -- from outside the scope will get the formal parameter names and default
- -- from (A). Both inside and outside the scope, however, the body executed
- -- will be that corresponding to Set_Display of the parent type.
-
-end C730001_2;
-
-
- --==================================================================--
-
-
-package body C730001_2 is
-
- procedure Answer (CP : in out Conference_Room_Phone;
- CI : in Indicator_Type := Modem)is
- begin
- CP.Status := Conference;
- CP.Indicator := CI;
- end Answer;
-
-
- function TC_Get_Display (C: Alarm_Clock) return Display_Kind is
- begin
- return C.Display;
- end TC_Get_Display;
-
-
- function TC_Get_Display_Illumination (C: Alarm_Clock)
- return Illumination_Type is
- begin
- return C.Illumination;
- end TC_Get_Display_Illumination;
-
-end C730001_2;
-
-
- --==================================================================--
-
-
-with C730001_0; use C730001_0;
-with C730001_1; use C730001_1;
-with C730001_2; use C730001_2;
-
-package C730001_3 is
-
- -- Types extended from the ancestor (Phone) type in the specification.
-
- type Secure_Phone_Type is new Phone with private;
- type Auditorium_Phone_Type is new Phone with private;
- -- Inherit versions of Answer from ancestor (Phone).
-
- function TC_Get_Phone_Status (P : Phone'Class) return Capability_Type;
- function TC_Get_Indicator (P : Phone'Class) return Indicator_Type;
-
-private
-
- -- Types extended from descendents of Phone_Type in the private part.
-
- type Secure_Phone_Type is new Office_Phone with record
- Scrambled_Communication : Boolean := True;
- end record;
-
- type Auditorium_Phone_Type is new Conference_Room_Phone with record
- Volume_Control : Boolean := True;
- end record;
-
-end C730001_3;
-
- --==================================================================--
-
-package body C730001_3 is
-
- function TC_Get_Phone_Status (P : Phone'Class) return Capability_Type is
- begin
- return P.Status;
- end TC_Get_Phone_Status;
-
- function TC_Get_Indicator (P : Phone'Class) return Indicator_Type is
- begin
- return P.Indicator;
- end TC_Get_Indicator;
-
-end C730001_3;
-
- --==================================================================--
-
-with C730001_0; use C730001_0;
-with C730001_1; use C730001_1;
-with C730001_2; use C730001_2;
-with C730001_3; use C730001_3;
-
-with Report;
-
-procedure C730001 is
-begin
-
- Report.Test ("C730001","Check that the full view of a private extension " &
- "may be derived indirectly from the ancestor " &
- "type. Check that, for a primitive subprogram " &
- "of the private extension that is inherited from " &
- "the ancestor type and not overridden, the " &
- "formal parameter names and default expressions " &
- "come from the corresponding primitive " &
- "subprogram of the ancestor type, while the body " &
- "comes from that of the parent type");
-
- Test_Block:
- declare
-
- Alarm : Alarm_Clock;
- Hot_Line : Secure_Phone_Type;
- TeleConference_Phone : Auditorium_Phone_Type;
-
- begin
-
- -- Evaluate non-dispatching case:
-
- -- Call Set_Display using formal parameter name from
- -- C730001_0.Set_Display.
- -- Give no 2nd parameter so that default expression must be used.
-
- Set_Display (C => Alarm);
-
- -- The value of the Display component should equal Digital, which is
- -- the default value from the ancestor's version of Set_Display,
- -- and not the default value from the parent's version of Set_Display.
-
- if TC_Get_Display (Alarm) /= Digital then
- Report.Failed ("Default expression for ancestor op not used " &
- "in non-dispatching case");
- end if;
-
- -- However, the value of the Illumination component should equal
- -- Phosphorescence, which is assigned in the parent type's version of
- -- the body of Set_Display.
-
- if TC_Get_Display_Illumination (Alarm) /= Phosphorescence then
- Report.Failed ("Wrong body was executed in non-dispatching case");
- end if;
-
-
- -- Evaluate dispatching case:
- declare
-
- Hot_Line : Secure_Phone_Type;
- TeleConference_Phone : Auditorium_Phone_Type;
-
- procedure Answer_The_Phone (P : in out Phone'Class) is
- begin
- -- Give no 2nd parameter so that default expression must be used.
- Answer (P);
- end Answer_The_Phone;
-
- begin
-
- Answer_The_Phone (Hot_Line);
- Answer_The_Phone (TeleConference_Phone);
-
- -- The value of the Indicator field shold equal "Light", the default
- -- value from the ancestor's version of Answer, and not the default
- -- from either of the parent versions of Answer.
-
- if TC_Get_Indicator(Hot_Line) /= Light or
- TC_Get_Indicator(TeleConference_Phone) /= Light
- then
- Report.Failed("Default expression from ancestor operation " &
- "not used in dispatching case");
- end if;
-
- -- However, the value of the Status component should equal
- -- Call_Waiting or Conference respectively, based on the assignment
- -- in the parent type's version of the body of Answer.
-
- if TC_Get_Phone_Status(Hot_Line) /= Call_Waiting then
- Report.Failed("Wrong body executed in dispatching case - 1");
- end if;
-
- if TC_Get_Phone_Status(TeleConference_Phone) /= Conference then
- Report.Failed("Wrong body executed in dispatching case - 2");
- end if;
-
- end;
-
- exception
- when others => Report.Failed ("Exception raised in Test_Block");
- end Test_Block;
-
-
- Report.Result;
-
-end C730001;
diff --git a/gcc/testsuite/ada/acats/tests/c7/c730002.a b/gcc/testsuite/ada/acats/tests/c7/c730002.a
deleted file mode 100644
index 9213a7d92d3..00000000000
--- a/gcc/testsuite/ada/acats/tests/c7/c730002.a
+++ /dev/null
@@ -1,383 +0,0 @@
--- C730002.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that the full view of a private extension may be derived
--- indirectly from the ancestor type (i.e., the parent type of the full
--- type may be any descendant of the ancestor type). Check that, for
--- a primitive subprogram of the private extension that is inherited from
--- the ancestor type and not overridden, the formal parameter names and
--- default expressions come from the corresponding primitive subprogram
--- of the ancestor type, while the body comes from that of the parent
--- type.
--- Check for a case where the parent type is derived from the ancestor
--- type through a series of types produced by generic instantiations.
--- Examine both the static and dynamic binding cases.
---
--- TEST DESCRIPTION:
--- Consider:
---
--- package P is
--- type Ancestor is tagged ...
--- procedure Op (P1: Ancestor; P2: Boolean := True);
--- end P;
---
--- with P;
--- generic
--- type T is new P.Ancestor with private;
--- package Gen1 is
--- type Enhanced is new T with private;
--- procedure Op (A: Enhanced; B: Boolean := True);
--- -- other specific procedures...
--- private
--- type Enhanced is new T with ...
--- end Gen1;
---
--- with P, Gen1;
--- package N is new Gen1 (P.Ancestor);
---
--- with N;
--- generic
--- type T is new N.Enhanced with private;
--- package Gen2 is
--- type Enhanced_Again is new T with private;
--- procedure Op (X: Enhanced_Again; Y: Boolean := False);
--- -- other specific procedures...
--- private
--- type Enhanced_Again is new T with ...
--- end Gen2;
---
--- with N, Gen2;
--- package Q is new Gen2 (N.Enhanced);
---
--- with P, Q;
--- package R is
--- type Priv_Ext is new P.Ancestor with private; -- (A)
--- -- Inherits procedure Op (P1: Priv_Ext; P2: Boolean := True);
--- -- But body executed is that of Q.Op.
--- private
--- type Priv_Ext is new Q.Enhanced_Again with record ... -- (B)
--- end R;
---
--- The ancestor type in (A) differs from the parent type in (B); the
--- parent of the full type is descended from the ancestor type of the
--- private extension, in this case through a series of types produced
--- by generic instantiations. Gen1 redefines the implementation of Op
--- for any type that has one. N is an instance of Gen1 for the ancestor
--- type. Gen2 again redefines the implementation of Op for any type that
--- has one. Q is an instance of Gen2 for the extension of the P.Ancestor
--- declared in N. Both N and Q could define other operations which we
--- don't want to be available in R. For a call to Op (from outside the
--- scope of the full view) with an operand of type R.Priv_Ext, the body
--- executed will be that of Q.Op (the parent type's version), but the
--- formal parameter names and default expression come from that of P.Op
--- (the ancestor type's version).
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 27 Feb 97 CTA.PWB Added elaboration pragmas.
---!
-
-package C730002_0 is
-
- type Hours_Type is range 0..1000;
- type Personnel_Type is range 0..10;
- type Specialist_ID is (Manny, Moe, Jack, Curly, Joe, Larry);
-
- type Engine_Type is tagged record
- Ave_Repair_Time : Hours_Type := 0; -- Default init. for
- Personnel_Required : Personnel_Type := 0; -- component fields.
- Specialist : Specialist_ID := Manny;
- end record;
-
- procedure Routine_Maintenance (Engine : in out Engine_Type ;
- Specialist : in Specialist_ID := Moe);
-
- -- The Routine_Maintenance procedure implements the processing required
- -- for an engine.
-
-end C730002_0;
-
- --==================================================================--
-
-package body C730002_0 is
-
- procedure Routine_Maintenance (Engine : in out Engine_Type ;
- Specialist : in Specialist_ID := Moe) is
- begin
- Engine.Ave_Repair_Time := 3;
- Engine.Personnel_Required := 1;
- Engine.Specialist := Specialist;
- end Routine_Maintenance;
-
-end C730002_0;
-
- --==================================================================--
-
-with C730002_0; use C730002_0;
-generic
- type T is new C730002_0.Engine_Type with private;
-package C730002_1 is
-
- -- This generic package contains types/procedures specific to engines
- -- of the diesel variety.
-
- type Repair_Facility_Type is (On_Site, Repair_Shop, Factory);
-
- type Diesel_Series is new T with private;
-
- procedure Routine_Maintenance (Eng : in out Diesel_Series;
- Spec_Req : in Specialist_ID := Jack);
-
- -- Other diesel specific operations... (not required in this test).
-
-private
-
- type Diesel_Series is new T with record
- Repair_Facility_Required : Repair_Facility_Type := On_Site;
- end record;
-
-end C730002_1;
-
- --==================================================================--
-
-package body C730002_1 is
-
- procedure Routine_Maintenance (Eng : in out Diesel_Series;
- Spec_Req : in Specialist_ID := Jack) is
- begin
- Eng.Ave_Repair_Time := 6;
- Eng.Personnel_Required := 2;
- Eng.Specialist := Spec_Req;
- Eng.Repair_Facility_Required := On_Site;
- end Routine_Maintenance;
-
-end C730002_1;
-
- --==================================================================--
-
-with C730002_0;
-with C730002_1;
-pragma Elaborate (C730002_1);
-package C730002_2 is new C730002_1 (C730002_0.Engine_Type);
-
- --==================================================================--
-
-with C730002_0; use C730002_0;
-with C730002_2; use C730002_2;
-generic
- type T is new C730002_2.Diesel_Series with private;
-package C730002_3 is
-
- type Time_Of_Operation_Type is range 0..100_000;
-
- type Electric_Series is new T with private;
-
- procedure Routine_Maintenance (E : in out Electric_Series;
- SR : in Specialist_ID := Curly);
-
- -- Other electric specific operations... (not required in this test).
-
-private
-
- type Electric_Series is new T with record
- Mean_Time_Between_Repair : Time_Of_Operation_Type := 0;
- end record;
-
-end C730002_3;
-
- --==================================================================--
-
-package body C730002_3 is
-
- procedure Routine_Maintenance (E : in out Electric_Series;
- SR : in Specialist_ID := Curly) is
- begin
- E.Ave_Repair_Time := 9;
- E.Personnel_Required := 3;
- E.Specialist := SR;
- E.Mean_Time_Between_Repair := 1000;
- end Routine_Maintenance;
-
-end C730002_3;
-
- --==================================================================--
-
-with C730002_2;
-with C730002_3;
-pragma Elaborate (C730002_3);
-package C730002_4 is new C730002_3 (C730002_2.Diesel_Series);
-
- --==================================================================--
-
-with C730002_0; use C730002_0;
-with C730002_4; use C730002_4;
-
-package C730002_5 is
-
- type Inspection_Type is (AAA, MIL_STD, NRC);
-
- type Nuclear_Series is new Engine_Type with private; -- (A)
-
- -- Inherits procedure Routine_Maintenance from ancestor; does not override.
- -- (Engine : in out Nuclear_Series;
- -- Specialist : in Specialist_ID := Moe);
- -- But body executed will be that of C730002_4.Routine_Maintenance,
- -- the parent type.
-
- function TC_Specialist (E : Nuclear_Series) return Specialist_ID;
- function TC_Personnel_Required (E : Nuclear_Series) return Personnel_Type;
- function TC_Time_Required (E : Nuclear_Series) return Hours_Type;
-
- -- Dispatching subprogram.
- procedure Maintain_The_Engine (The_Engine : in out Engine_Type'Class);
-
-private
-
- type Nuclear_Series is new Electric_Series with record -- (B)
- Inspector_Rep : Inspection_Type := NRC;
- end record;
-
- -- The ancestor type is used in the type extension (A), while the parent
- -- of the full type (B) is a descendent of the ancestor type, through a
- -- series of types produced by generic instantiation.
-
-end C730002_5;
-
- --==================================================================--
-
-package body C730002_5 is
-
- function TC_Specialist (E : Nuclear_Series) return Specialist_ID is
- begin
- return E.Specialist;
- end TC_Specialist;
-
- function TC_Personnel_Required (E : Nuclear_Series)
- return Personnel_Type is
- begin
- return E.Personnel_Required;
- end TC_Personnel_Required;
-
- function TC_Time_Required (E : Nuclear_Series) return Hours_Type is
- begin
- return E.Ave_Repair_Time;
- end TC_Time_Required;
-
- -- Dispatching subprogram.
- procedure Maintain_The_Engine (The_Engine : in out Engine_Type'Class) is
- begin
- Routine_Maintenance (The_Engine);
- end Maintain_The_Engine;
-
-
-end C730002_5;
-
- --==================================================================--
-
-with Report;
-with C730002_0; use C730002_0;
-with C730002_2; use C730002_2;
-with C730002_4; use C730002_4;
-with C730002_5; use C730002_5;
-
-procedure C730002 is
-begin
-
- Report.Test ("C730002", "Check that the full view of a private " &
- "extension may be derived indirectly from " &
- "the ancestor type. Check for a case where " &
- "the parent type is derived from the ancestor " &
- "type through a series of types produced by " &
- "generic instantiations");
-
- Test_Block:
- declare
- Nuclear_Drive : Nuclear_Series;
- Warp_Drive : Nuclear_Series;
- begin
-
- -- Non-Dispatching Case:
- -- Call Routine_Maintenance using formal parameter name from
- -- C730002_0.Routine_Maintenance (ancestor version).
- -- Give no second parameter so that the default expression must be
- -- used.
-
- Routine_Maintenance (Engine => Nuclear_Drive);
-
- -- The value of the Specialist component should equal "Moe",
- -- which is the default value from the ancestor's version of
- -- Routine_Maintenance, and not the default value from the parent's
- -- version of Routine_Maintenance.
-
- if TC_Specialist (Nuclear_Drive) /= Moe then
- Report.Failed
- ("Default expression for ancestor op not used " &
- " - non-dispatching case");
- end if;
-
- -- However the value of the Ave_Repair_Time and Personnel_Required
- -- components should be those assigned in the parent type's version
- -- of the body of Routine_Maintenance.
- -- Note: Only components associated with the ancestor type are
- -- evaluated for the purposes of this test.
-
- if TC_Personnel_Required (Nuclear_Drive) /= 3 or
- TC_Time_Required (Nuclear_Drive) /= 9
- then
- Report.Failed("Wrong body was executed - non-dispatching case");
- end if;
-
- -- Dispatching Case:
- -- Use a dispatching subprogram to ensure that the correct body is
- -- used at runtime.
-
- Maintain_The_Engine (Warp_Drive);
-
- -- The resulting assignments to the fields of the Warp_Drive variable
- -- should be the same as those of the Nuclear_Drive above, indicating
- -- that the body of the parent version of the inherited subprogram
- -- was used.
-
- if TC_Specialist (Warp_Drive) /= Moe then
- Report.Failed
- ("Default expression for ancestor op not used - dispatching case");
- end if;
-
- if TC_Personnel_Required (Nuclear_Drive) /= 3 or
- TC_Time_Required (Nuclear_Drive) /= 9
- then
- Report.Failed("Wrong body was executed - dispatching case");
- end if;
-
-
- exception
- when others => Report.Failed("Exception raised in Test_Block");
- end Test_Block;
-
- Report.Result;
-
-end C730002;
diff --git a/gcc/testsuite/ada/acats/tests/c7/c730003.a b/gcc/testsuite/ada/acats/tests/c7/c730003.a
deleted file mode 100644
index 47002f3aa8b..00000000000
--- a/gcc/testsuite/ada/acats/tests/c7/c730003.a
+++ /dev/null
@@ -1,283 +0,0 @@
--- C730003.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687 and
--- F08630-91-C-0015, the U.S. Government obtained unlimited rights in the
--- software and documentation contained herein. Unlimited rights are
--- defined in DFAR 252.227-7013(a)(19). By making this public release,
--- the Government intends to confer upon all recipients unlimited rights
--- equal to those held by the Government. These rights include rights to
--- use, duplicate, release or disclose the released technical data and
--- computer software in whole or in part, in any manner and for any purpose
--- whatsoever, and to have or permit others to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that the characteristics of a type derived from a private
--- extension (outside the scope of the full view) are those defined by
--- the partial view of the private extension.
--- In particular, check that a component of the derived type may be
--- explicitly declared with the same name as a component declared for
--- the full view of the private extension.
--- Check that a component defined in the private extension of a type
--- may be updated through a view conversion of a type derived from
--- the type.
---
--- TEST DESCRIPTION:
--- Consider:
---
--- package Parent is
--- type T is tagged record
--- ...
--- end record;
---
--- type DT is new T with private;
--- procedure Op1 (P: in out DT);
---
--- private
--- type DT is new T with record
--- Y: ...; -- (A)
--- end record;
--- end Parent;
---
--- package body Parent is
--- function Op1 (P: in DT) return ... is
--- begin
--- return P.Y;
--- end Op1;
--- end Parent;
---
--- package Unrelated is
--- type Intermediate is new DT with record
--- Y: ...; -- Note: same name as component of -- (B)
--- -- parent's full view.
--- end record;
--- end Unrelated;
---
--- package Parent.Child is
--- type DDT is new Intermediate with null record;
--- -- Implicit declared Op1 (P.DDT); -- (C)
---
--- procedure Op2 (P: in out DDT);
--- end Parent.Child;
---
--- package body Parent.Child is
--- procedure Op2 (P: in out DDT) is
--- Obj : DT renames DT(P);
--- begin
--- ...
--- P.Y := ...; -- Updates DDT's Y. -- (D)
--- DT(P).Y := ...; -- Updates DT's Y. -- (E)
--- Obj.Y := ...; -- Updates DT's Y. -- (F)
--- end Op2;
--- end Parent.Child;
---
--- Types DT and DDT both declare a component Y at (A) and (B),
--- respectively. The component Y of the full view of DT is not visible
--- at the place where DDT is declared. Therefore, it is invisible for
--- all views of DDT (although it still exists for objects of DDT), and
--- it is legal to declare another component for DDT with the same name.
---
--- DDT inherits the primitive subprogram Op1 from DT at (C). Op1 returns
--- the component Y; for calls with an operand of type DDT, Op1 returns
--- the Y inherited from DT, not the new Y explicitly declared for DDT,
--- even though the inherited Y is not visible for any view of DDT.
---
--- Within the body of Op2, the assignment statement at (D) updates the
--- Y explicitly declared for DDT. At (E) and (F), however, a view
--- conversion denotes a new view of P as an object of type DT, which
--- enables access to the Y from the full view of DT. Thus, the
--- assignment statements at (E) and (F) update the (invisible) Y from DT.
---
--- Note that the above analysis would be wrong if the new component Y
--- were declared directly in Child. In that case, the two same-named
--- components would be illegal -- see AI-150.
---
---
--- CHANGE HISTORY:
--- 06 Dec 1994 SAIC ACVC 2.0
--- 29 JUN 1999 RAD Declare same-named component in an
--- unrelated package -- see AI-150.
---
---!
-
-package C730003_0 is
-
- type Suit_Kind is (Clubs, Diamonds, Hearts, Spades);
- type Face_Kind is (Up, Down);
-
- type Playing_Card is tagged record
- Face: Face_Kind;
- Suit: Suit_Kind;
- end record;
-
- procedure Turn_Over_Card (Card : in out Playing_Card);
-
- type Disp_Card is new Playing_Card with private;
-
- subtype ASCII_Representation is Natural range 1..14;
-
- function Get_Private_View (A_Card : Disp_Card) return ASCII_Representation;
-
-private
-
- type Disp_Card is new Playing_Card with record
- View: ASCII_Representation; -- (A)
- end record;
-
-end C730003_0;
-
---==================================================================--
-
-package body C730003_0 is
-
- procedure Turn_Over_Card (Card: in out Playing_Card) is
- begin
- Card.Face := Up;
- end Turn_Over_Card;
-
- function Get_Private_View (A_Card : Disp_Card)
- return ASCII_Representation is
- begin
- return A_Card.View;
- end Get_Private_View;
-
-end C730003_0;
-
---==================================================================--
-
-with C730003_0; use C730003_0;
-package C730003_1 is
-
- subtype Graphic_Representation is String (1 .. 2);
-
- type Graphic_Card is new Disp_Card with record
- View : Graphic_Representation; -- (B)
- -- "Duplicate" component field name.
- end record;
-
-end C730003_1;
-
---==================================================================--
-
-with C730003_1; use C730003_1;
-package C730003_0.C730003_2 is
-
- Queen_Of_Spades : constant C730003_0.ASCII_Representation := 12;
- Ace_Of_Hearts : constant String := "AH";
- Close_To_The_Vest : constant C730003_0.ASCII_Representation := 14;
- Read_Em_And_Weep : constant String := "AA";
-
- type Graphic_Card is new C730003_1.Graphic_Card with null record;
-
- -- Implicit function Get_Private_View -- (C)
- -- (A_Card : Graphic_Card) return C730003_0.ASCII_Representation;
-
- function Get_View (Card : Graphic_Card) return String;
- procedure Update_View (Card : in out Graphic_Card);
- procedure Hide_From_View (Card : in out Graphic_Card);
-
-end C730003_0.C730003_2;
-
---==================================================================--
-
-package body C730003_0.C730003_2 is
-
- function Get_View (Card : Graphic_Card) return String is
- begin
- return Card.View;
- end Get_View;
-
- procedure Update_View (Card : in out Graphic_Card) is
- ASCII_View : Disp_Card renames Disp_Card(Card); -- View conversion.
- begin
- ASCII_View.View := Queen_Of_Spades; -- (F)
- -- Assignment to "hidden" field.
- Card.View := Ace_Of_Hearts; -- (D)
- -- Assignment to Graphic_Card declared field.
- end Update_View;
-
- procedure Hide_From_View (Card : in out Graphic_Card) is
- begin
- -- Update both of Card's View components.
- Disp_Card(Card).View := Close_To_The_Vest; -- (E)
- -- Assignment to "hidden" field.
- Card.View := Read_Em_And_Weep; -- (D)
- -- Assignment to Graphic_Card declared field.
- end Hide_From_View;
-
-end C730003_0.C730003_2;
-
---==================================================================--
-
-with C730003_0;
-with C730003_0.C730003_2;
-with Report;
-
-procedure C730003 is
-begin
-
- Report.Test ("C730003", "Check that the characteristics of a type " &
- "derived from a private extension (outside " &
- "the scope of the full view) are those " &
- "defined by the partial view of the private " &
- "extension");
-
- Check_Your_Cards:
- declare
- use C730003_0;
- use C730003_0.C730003_2;
-
- Top_Card_On_The_Deck : Graphic_Card;
-
- begin
-
- -- Update value in the components of the card. There are two
- -- component fields named View, although one is not visible for
- -- any view of a Graphic_Card.
-
- Update_View(Top_Card_On_The_Deck);
-
- -- Verify that both "View" components of the card have been updated.
-
- if Get_View(Top_Card_On_The_Deck) /= Ace_Of_Hearts then
- Report.Failed ("Incorrect value in visible component - 1");
- end if;
-
- if Get_Private_View(Top_Card_On_The_Deck) /= Queen_Of_Spades
- then
- Report.Failed ("Incorrect value in non-visible component - 1");
- end if;
-
- -- Again, update the components of the card (to blank values).
-
- Hide_From_View(Top_Card_On_The_Deck);
-
- -- Verify that both components have been updated.
-
- if Get_View(Top_Card_On_The_Deck) /= Read_Em_And_Weep then
- Report.Failed ("Incorrect value in visible component - 2");
- end if;
-
- if Get_Private_View(Top_Card_On_The_Deck) /= Close_To_The_Vest
- then
- Report.Failed ("Incorrect value in non-visible component - 2");
- end if;
-
- exception
- when others => Report.Failed("Exception raised in test block");
- end Check_Your_Cards;
-
- Report.Result;
-
-end C730003;
diff --git a/gcc/testsuite/ada/acats/tests/c7/c730004.a b/gcc/testsuite/ada/acats/tests/c7/c730004.a
deleted file mode 100644
index c2a23230ad2..00000000000
--- a/gcc/testsuite/ada/acats/tests/c7/c730004.a
+++ /dev/null
@@ -1,327 +0,0 @@
--- C730004.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that for a type declared in a package, descendants of the package
--- use the full view of type. Specifically check that full view of the
--- limited type is visible only in private descendants (children) and in
--- the private parts and bodies of public descendants (children).
--- Check that a limited type may be used as an out parameter outside
--- the package that defines the type.
---
--- TEST DESCRIPTION:
--- This test defines a parent package containing limited private type
--- definitions. Children packages are defined (one public, one private)
--- that use the nonlimited full view of the types defined in the private
--- part of the parent specification.
--- The main declares a procedure with an out parameter that was defined
--- as limited in the specification of the parent package.
---
---
--- CHANGE HISTORY:
--- 15 Sep 95 SAIC Initial prerelease version.
--- 23 Apr 96 SAIC Added prefix for parameter in Call_Modify_File.
--- 02 Nov 96 SAIC ACVC 2.1: Modified prologue and Test.Report.
---
---!
-
-package C730004_0 is
-
- -- Full views of File_Descriptor, File_Mode, File_Name, and File_Type are
- -- are nonlimited.
-
- type File_Descriptor is limited private;
-
- type File_Mode is limited private;
-
- Active_Mode : constant File_Mode;
-
- type File_Name is limited private;
-
- type File_Type is limited private;
-
- function Next_Available_File return File_Descriptor;
-
-private
-
- type File_Descriptor is new Integer;
-
- Null_File : constant File_Descriptor := 0;
- First_File : constant File_Descriptor := 1;
-
- type File_Mode is
- (Read_Only, Write_Only, Read_Write, Archived, Corrupt, Lost);
-
- Default_Mode : constant File_Mode := Read_Only;
- Active_Mode : constant File_Mode := Read_Write;
-
- type File_Name is array (1 .. 6) of Character;
-
- Null_String : File_Name := " ";
- String1 : File_Name := "ACVC ";
- String2 : File_Name := " 1995";
-
- type File_Type is
- record
- Descriptor : File_Descriptor := Null_File;
- Mode : File_Mode := Default_Mode;
- Name : File_Name := Null_String;
- end record;
-
-end C730004_0;
-
- --=================================================================--
-
-package body C730004_0 is
-
- File_Count : Integer := 0;
-
- function Next_Available_File return File_Descriptor is
- begin
- File_Count := File_Count + 1;
- return (File_Descriptor(File_Count)); -- Type conversion.
- end Next_Available_File;
-
-end C730004_0;
-
- --=================================================================--
-
-private
-package C730004_0.C730004_1 is -- private child
-
- -- Since full view of the nontagged File_Name is nonlimited in the parent
- -- package, it is not limited in the private child, so concatenation is
- -- available.
-
- System_File_Name : constant File_Name
- := String1(1..4) & String2(5..6);
-
- -- Since full view of the nontagged File_Type is nonlimited in the parent
- -- package, it is not limited in the private child, so a default expression
- -- is available.
-
- function New_File_Validated (File : File_Type
- := (Descriptor => First_File,
- Mode => Active_Mode,
- Name => System_File_Name))
- return Boolean;
-
- -- Since full view of the nontagged File_Type is nonlimited in the parent
- -- package, it is not limited in the private child, so initialization
- -- expression in an object declaration is available.
-
- System_File : File_Type
- := (Null_File, Read_Only, System_File_Name);
-
-
-end C730004_0.C730004_1;
-
- --=================================================================--
-
-package body C730004_0.C730004_1 is
-
- function New_File_Validated (File : File_Type
- := (Descriptor => First_File,
- Mode => Active_Mode,
- Name => System_File_Name))
- return Boolean is
- Result : Boolean := False;
- begin
- if (File.Descriptor > System_File.Descriptor) and
- (File.Mode in Read_Only .. Read_Write) and (File.Name = "ACVC95")
- then
- Result := True;
- end if;
-
- return (Result);
-
- end New_File_Validated;
-
-end C730004_0.C730004_1;
-
- --=================================================================--
-
-package C730004_0.C730004_2 is -- public child
-
- -- File_Type is limited here.
-
- procedure Create_File (File : out File_Type);
-
- procedure Modify_File (File : out File_Type);
-
- type File_Dir is limited private;
-
- -- The following three validation functions provide the capability to
- -- check the limited private types defined in the parent and the
- -- private child package from within the client program.
-
- function Validate_Create (File : in File_Type) return Boolean;
-
- function Validate_Modification (File : in File_Type)
- return Boolean;
-
- function Validate_Dir (Dir : in File_Dir) return Boolean;
-
-private
-
- -- Since full view of the nontagged File_Type is nonlimited in the parent
- -- package, it is not limited in the private part of the public child, so
- -- aggregates are available.
-
- Child_File : File_Type
- := File_Type'(Descriptor => Null_File,
- Mode => Write_Only,
- Name => String2);
-
- -- Since full view of the nontagged component File_Type is nonlimited in
- -- the parent package, it is not limited in the private part of the public
- -- child, so default expressions are available.
-
- type File_Dir is
- record
- Comp : File_Type := Child_File;
- end record;
-
-end C730004_0.C730004_2;
-
- --=================================================================--
-
-with C730004_0.C730004_1;
-
-package body C730004_0.C730004_2 is
-
- procedure Create_File (File : out File_Type) is
- New_File : File_Type;
-
- begin
- New_File.Descriptor := Next_Available_File;
- New_File.Mode := Default_Mode;
- New_File.Name := C730004_0.C730004_1.System_File_Name;
-
- if C730004_0.C730004_1.New_File_Validated (New_File) then
- File := New_File;
- else
- File := (Null_File, Lost, "MISSED");
- end if;
-
- end Create_File;
-
- --------------------------------------------------------------
- procedure Modify_File (File : out File_Type) is
- begin
- File.Descriptor := Next_Available_File;
- File.Mode := Active_Mode;
- File.Name := String1;
- end Modify_File;
-
- --------------------------------------------------------------
- function Validate_Create (File : in File_Type) return Boolean is
- begin
- if ((File.Descriptor /= Child_File.Descriptor) and
- (File.Mode = Read_Only) and (File.Name = "ACVC95"))
- then
- return True;
- else
- return False;
- end if;
- end Validate_Create;
-
- ------------------------------------------------------------------------
- function Validate_Modification (File : in File_Type)
- return Boolean is
- begin
- if ((File.Descriptor /= C730004_0.C730004_1.System_File.Descriptor) and
- (File.Mode = Read_Write) and (File.Name = "ACVC "))
- then
- return True;
- else
- return False;
- end if;
- end Validate_Modification;
-
- ------------------------------------------------------------------------
- function Validate_Dir (Dir : in File_Dir) return Boolean is
- begin
- if ((Dir.Comp.Descriptor = C730004_0.C730004_1.System_File.Descriptor)
- and (Dir.Comp.Mode = Write_Only) and (Dir.Comp.Name = String2))
- then
- return True;
- else
- return False;
- end if;
- end Validate_Dir;
-
-end C730004_0.C730004_2;
-
- --=================================================================--
-
-with C730004_0.C730004_2;
-with Report;
-
-procedure C730004 is
-
- package File renames C730004_0;
- package File_Ops renames C730004_0.C730004_2;
-
- Validation_File : File.File_Type;
-
- Validation_Dir : File_Ops.File_Dir;
-
- ------------------------------------------------------------------------
- -- Limited File_Type is allowed as an out parameter outside package File.
-
- procedure Call_Modify_File (Modified_File : out File.File_Type) is
- begin
- File_Ops.Modify_File (Modified_File);
- end Call_Modify_File;
-
-begin
-
- Report.Test ("C730004", "Check that for a type declared in a package, " &
- "descendants of the package use the full view " &
- "of the type. Specifically check that full " &
- "view of the limited type is visible only in " &
- "private children and in the private parts and " &
- "bodies of public children");
-
- File_Ops.Create_File (Validation_File);
-
- if not File_Ops.Validate_Create (Validation_File) then
- Report.Failed ("Incorrect creation of file");
- end if;
-
- Call_Modify_File (Validation_File);
-
- if not File_Ops.Validate_Modification (Validation_File) then
- Report.Failed ("Incorrect modification of file");
- end if;
-
- if not File_Ops.Validate_Dir (Validation_Dir) then
- Report.Failed ("Incorrect creation of directory");
- end if;
-
- Report.Result;
-
-end C730004;
diff --git a/gcc/testsuite/ada/acats/tests/c7/c730a01.a b/gcc/testsuite/ada/acats/tests/c7/c730a01.a
deleted file mode 100644
index 43f16f92889..00000000000
--- a/gcc/testsuite/ada/acats/tests/c7/c730a01.a
+++ /dev/null
@@ -1,176 +0,0 @@
--- C730A01.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that a tagged type declared in a package specification
--- may be passed as a generic formal (tagged) private type to a generic
--- package declaration. Check that the formal type may be extended with
--- a private extension in the generic package.
---
--- Check that, in the instance, the private extension inherits the
--- user-defined primitive subprograms of the tagged actual.
---
--- TEST DESCRIPTION:
--- Declare a tagged type and an associated primitive subprogram in a
--- package specification (foundation code). Declare a generic package
--- which takes a tagged type as a formal parameter, and then extends
--- it with a private extension (foundation code).
---
--- Instantiate the generic package with the tagged type from the first
--- package (the "generic" extension should now have inherited
--- the primitive subprogram of the tagged type from the first
--- package).
---
--- In the main program, call the primitive subprogram inherited by the
--- "generic" extension, and verify the correctness of the components.
---
--- TEST FILES:
--- The following files comprise this test:
---
--- F730A000.A
--- F730A001.A
--- => C730A01.A
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
---
---!
-
-
-with F730A001; -- Book definitions.
-package C730A01_0 is -- Raw data to be used in creating book elements.
-
-
- Book_Count : constant := 3;
-
- subtype Number_Of_Books is Integer range 1 .. Book_Count;
-
- type Data_List is array (Number_Of_Books) of F730A001.Text_Ptr;
-
- Title_List : Data_List := (new String'("Wuthering Heights"),
- new String'("Heart of Darkness"),
- new String'("Ulysses"));
-
- Author_List : Data_List := (new String'("Bronte, Emily"),
- new String'("Conrad, Joseph"),
- new String'("Joyce, James"));
-
-end C730A01_0;
-
-
- --==================================================================--
-
-
-
-
- --==================================================================--
-
-
--- Library-level instantiation. Actual parameter is tagged record.
-
-with F730A001; -- Book definitions.
-with F730A000; -- Singly-linked list abstraction.
-package C730A01_1 is new F730A000 (Parent_Type => F730A001.Book_Type);
-
-
- --==================================================================--
-
-
-with Report;
-
-with F730A001; -- Book definitions.
-with C730A01_0; -- Raw book data.
-with C730A01_1; -- Instance.
-
-use F730A001; -- Primitive operations of Book_Type directly visible.
-use C730A01_1; -- Operations inherited by Node_Type directly visible.
-
-procedure C730A01 is
-
-
- List_Of_Books : Priv_Node_Ptr := null; -- Head of linked list of books.
-
-
- --========================================================--
-
-
- procedure Create_List (Title, Author : in C730A01_0.Data_List;
- Head : in out Priv_Node_Ptr) is
-
- Book : Priv_Node_Type; -- Object of extended type.
- Book_Ptr : Priv_Node_Ptr;
-
- begin
- for I in C730A01_0.Number_Of_Books loop
- Create_Book (Title (I), Author (I), Book); -- Call inherited
- -- operation.
- Book_Ptr := new Priv_Node_Type'(Book);
- Add (Book_Ptr, Head);
- end loop;
- end Create_List;
-
-
- --========================================================--
-
-
- function Bad_List_Contents return Boolean is
- Book1_Ptr : Priv_Node_Ptr;
- Book2_Ptr : Priv_Node_Ptr;
- Book3_Ptr : Priv_Node_Ptr;
- begin
- Remove (List_Of_Books, Book1_Ptr);
- Remove (List_Of_Books, Book2_Ptr);
- Remove (List_Of_Books, Book3_Ptr);
- return (Book1_Ptr.Title.all /= "Ulysses" or -- Inherited
- Book1_Ptr.Author.all /= "Joyce, James" or -- components
- Book2_Ptr.Title.all /= "Heart of Darkness" or -- should still
- Book2_Ptr.Author.all /= "Conrad, Joseph" or -- be visible in
- Book3_Ptr.Title.all /= "Wuthering Heights" or -- private
- Book3_Ptr.Author.all /= "Bronte, Emily"); -- extension.
-
- end Bad_List_Contents;
-
-
- --========================================================--
-
-
-begin -- Main program.
-
- Report.Test ("C730A01", "Inheritance of primitive operations: private " &
- "extension of formal tagged private type; actual is " &
- "an ultimate ancestor type");
-
- -- Create linked list using inherited operation:
- Create_List (C730A01_0.Title_List, C730A01_0.Author_List, List_Of_Books);
-
- -- Verify results:
- if Bad_List_Contents then
- Report.Failed ("Wrong values after call to inherited operation");
- end if;
-
- Report.Result;
-
-end C730A01;
diff --git a/gcc/testsuite/ada/acats/tests/c7/c730a02.a b/gcc/testsuite/ada/acats/tests/c7/c730a02.a
deleted file mode 100644
index 97d04b6dbc2..00000000000
--- a/gcc/testsuite/ada/acats/tests/c7/c730a02.a
+++ /dev/null
@@ -1,252 +0,0 @@
--- C730A02.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that a private extension (declared in a package specification) of
--- a tagged type (declared in a different package specification) may be
--- passed as a generic formal (tagged) private type to a generic package
--- declaration. Check that the formal type may be further extended with a
--- private extension in the generic package.
---
--- Check that the (visible) components inherited by the "generic"
--- extension are visible outside the generic package.
---
--- Check that, in the instance, the private extension inherits the
--- user-defined primitive subprograms of the tagged actual, including
--- those inherited by the actual from its parent.
---
--- TEST DESCRIPTION:
--- Declare a tagged type and an associated primitive subprogram in a
--- package specification (foundation code). Declare a private extension
--- of the tagged type and an associated primitive subprogram in a second
--- package specification. Declare a generic package which takes a tagged
--- type as a formal parameter, and then extends it with a private
--- extension (foundation code).
---
--- Instantiate the generic package with the private extension from the
--- second package (the "generic" extension should now have inherited
--- the primitive subprograms of the private extension from the second
--- package).
---
--- In the main program, call the primitive subprograms inherited by the
--- "generic" extension. There are two: (1) Create_Book, declared for
--- the root tagged type in the first package (inherited by the private
--- extension of the second package, and then in turn by the "generic"
--- extension), and (2) Update_Pages, declared for the private extension
--- in the second package. Verify the correctness of the components.
---
--- TEST FILES:
--- The following files comprise this test:
---
--- F730A000.A
--- F730A001.A
--- => C730A02.A
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
---
---!
-
-with F730A001; -- Book definitions.
-package C730A02_0 is -- Extended book abstraction.
-
-
- type Detailed_Book_Type is new F730A001.Book_Type -- Private ext.
- with private; -- of root tagged
- -- type.
-
- -- Inherits Create_Book from Book_Type.
-
- procedure Update_Pages (Book : in out Detailed_Book_Type; -- Primitive op.
- Pages : in Natural); -- of extension.
-
-
- -- The following function is needed to verify the value of the
- -- extension's private component. It will be inherited by extensions
- -- of Detailed_Book_Type.
-
- function Get_Pages (Book : in Detailed_Book_Type) return Natural;
-
-private
-
- type Detailed_Book_Type is new F730A001.Book_Type with record
- Pages : Natural;
- end record;
-
-end C730A02_0;
-
-
- --==================================================================--
-
-
-package body C730A02_0 is
-
-
- procedure Update_Pages (Book : in out Detailed_Book_Type;
- Pages : in Natural) is
- begin
- Book.Pages := Pages;
- end Update_Pages;
-
-
- function Get_Pages (Book : in Detailed_Book_Type) return Natural is
- begin
- return (Book.Pages);
- end Get_Pages;
-
-
-end C730A02_0;
-
-
- --==================================================================--
-
-
-with F730A001; -- Book definitions.
-package C730A02_1 is -- Raw data to be used in creating book elements.
-
-
- Book_Count : constant := 3;
-
- subtype Number_Of_Books is Integer range 1 .. Book_Count;
-
- type Data_List is array (Number_Of_Books) of F730A001.Text_Ptr;
- type Page_Counts is array (Number_Of_Books) of Natural;
-
- Title_List : Data_List := (new String'("Wuthering Heights"),
- new String'("Heart of Darkness"),
- new String'("Ulysses"));
-
- Author_List : Data_List := (new String'("Bronte, Emily"),
- new String'("Conrad, Joseph"),
- new String'("Joyce, James"));
-
- Page_List : Page_Counts := (237, 215, 456);
-
-end C730A02_1;
-
-
--- No body for C730A02_1.
-
-
- --==================================================================--
-
-
--- Library-level instantiation. Actual parameter is private extension.
-
-with C730A02_0; -- Extended book abstraction.
-with F730A000; -- Singly-linked list abstraction.
-package C730A02_2 is new F730A000
- (Parent_Type => C730A02_0.Detailed_Book_Type);
-
-
- --==================================================================--
-
-
-with Report;
-
-with C730A02_0; -- Extended book abstraction.
-with C730A02_1; -- Raw book data.
-with C730A02_2; -- Instance.
-
-use C730A02_0; -- Primitive operations of Detailed_Book_Type directly visible.
-use C730A02_2; -- Operations inherited by Priv_Node_Type directly visible.
-
-procedure C730A02 is
-
-
- List_Of_Books : Priv_Node_Ptr := null; -- Head of linked list of books.
-
-
- --========================================================--
-
-
- procedure Create_List (Title, Author : in C730A02_1.Data_List;
- Pages : in C730A02_1.Page_Counts;
- Head : in out Priv_Node_Ptr) is
-
- Book : Priv_Node_Type; -- Object of extended type.
- Book_Ptr : Priv_Node_Ptr;
-
- begin
- for I in C730A02_1.Number_Of_Books loop
- Create_Book (Title (I), Author (I), Book); -- Call twice-inherited
- -- operation.
- Update_Pages (Book, Pages (I)); -- Call inherited op.
- Book_Ptr := new Priv_Node_Type'(Book);
- Add (Book_Ptr, Head);
- end loop;
- end Create_List;
-
-
- --========================================================--
-
-
- function Bad_List_Contents return Boolean is
- Book1_Ptr : Priv_Node_Ptr;
- Book2_Ptr : Priv_Node_Ptr;
- Book3_Ptr : Priv_Node_Ptr;
- begin
-
- Remove (List_Of_Books, Book1_Ptr);
- Remove (List_Of_Books, Book2_Ptr);
- Remove (List_Of_Books, Book3_Ptr);
-
- return (Book1_Ptr.Title.all /= "Ulysses" or -- Inherited
- Book1_Ptr.Author.all /= "Joyce, James" or -- components
- Book2_Ptr.Title.all /= "Heart of Darkness" or -- should still
- Book2_Ptr.Author.all /= "Conrad, Joseph" or -- be visible
- Book3_Ptr.Title.all /= "Wuthering Heights" or -- in private
- Book3_Ptr.Author.all /= "Bronte, Emily" or -- "generic"
- -- extension.
- -- Call inherited operations using dereferenced pointers.
- Get_Pages (Book1_Ptr.all) /= 456 or
- Get_Pages (Book2_Ptr.all) /= 215 or
- Get_Pages (Book3_Ptr.all) /= 237);
-
- end Bad_List_Contents;
-
-
- --========================================================--
-
-
-begin -- Main program.
-
- Report.Test ("C730A02", "Inheritance of primitive operations: private " &
- "extension of formal tagged private type; actual is " &
- "a private extension");
-
- -- Create linked list using inherited operation:
- Create_List (C730A02_1.Title_List, C730A02_1.Author_List,
- C730A02_1.Page_List, List_Of_Books);
-
- -- Verify results:
- if Bad_List_Contents then
- Report.Failed ("Wrong values after call to inherited operations");
- end if;
-
- Report.Result;
-
-end C730A02;
diff --git a/gcc/testsuite/ada/acats/tests/c7/c731001.a b/gcc/testsuite/ada/acats/tests/c7/c731001.a
deleted file mode 100644
index 0cfce32bc95..00000000000
--- a/gcc/testsuite/ada/acats/tests/c7/c731001.a
+++ /dev/null
@@ -1,407 +0,0 @@
--- C731001.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687 and
--- F08630-91-C-0015, the U.S. Government obtained unlimited rights in the
--- software and documentation contained herein. Unlimited rights are
--- defined in DFAR 252.227-7013(a)(19). By making this public release,
--- the Government intends to confer upon all recipients unlimited rights
--- equal to those held by the Government. These rights include rights to
--- use, duplicate, release or disclose the released technical data and
--- computer software in whole or in part, in any manner and for any purpose
--- whatsoever, and to have or permit others to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE
--- Check that inherited operations can be overridden, even when they are
--- inherited in a body.
--- The test cases here are inspired by the AARM examples given in
--- the discussion of AARM-7.3.1(7.a-7.v).
--- This discussion was confirmed by AI95-00035.
---
--- TEST DESCRIPTION
--- See AARM-7.3.1.
---
--- CHANGE HISTORY:
--- 29 JUN 1999 RAD Initial Version
--- 23 SEP 1999 RLB Improved comments, renamed, issued.
--- 20 AUG 2001 RLB Corrected 'verbose' flag.
---
---!
-
-with Report; use Report; pragma Elaborate_All(Report);
-package C731001_1 is
- pragma Elaborate_Body;
-private
- procedure Check_String(X, Y: String);
- function Check_String(X, Y: String) return String;
- -- This one is a function, so we can call it in package specs.
-end C731001_1;
-
-package body C731001_1 is
-
- Verbose: Boolean := False;
-
- procedure Check_String(X, Y: String) is
- begin
- if Verbose then
- Comment("""" & X & """ = """ & Y & """?");
- end if;
- if X /= Y then
- Failed("""" & X & """ should be """ & Y & """");
- end if;
- end Check_String;
-
- function Check_String(X, Y: String) return String is
- begin
- Check_String(X, Y);
- return X;
- end Check_String;
-
-end C731001_1;
-
-private package C731001_1.Parent is
-
- procedure Call_Main;
-
- type Root is tagged null record;
- subtype Renames_Root is Root;
- subtype Root_Class is Renames_Root'Class;
- function Make return Root;
- function Op1(X: Root) return String;
- function Call_Op2(X: Root'Class) return String;
-private
- function Op2(X: Root) return String;
-end C731001_1.Parent;
-
-procedure C731001_1.Parent.Main;
-
-with C731001_1.Parent.Main;
-package body C731001_1.Parent is
-
- procedure Call_Main is
- begin
- Main;
- end Call_Main;
-
- function Make return Root is
- Result: Root;
- begin
- return Result;
- end Make;
-
- function Op1(X: Root) return String is
- begin
- return "Parent.Op1 body";
- end Op1;
-
- function Op2(X: Root) return String is
- begin
- return "Parent.Op2 body";
- end Op2;
-
- function Call_Op2(X: Root'Class) return String is
- begin
- return Op2(X);
- end Call_Op2;
-
-begin
-
- Check_String(Op1(Root'(Make)), "Parent.Op1 body");
- Check_String(Op1(Root_Class(Root'(Make))), "Parent.Op1 body");
-
- Check_String(Op2(Root'(Make)), "Parent.Op2 body");
- Check_String(Op2(Root_Class(Root'(Make))), "Parent.Op2 body");
-
-end C731001_1.Parent;
-
-with C731001_1.Parent; use C731001_1.Parent;
-private package C731001_1.Unrelated is
-
- type T2 is new Root with null record;
- subtype T2_Class is T2'Class;
- function Make return T2;
- function Op2(X: T2) return String;
-end C731001_1.Unrelated;
-
-with C731001_1.Parent; use C731001_1.Parent;
- pragma Elaborate(C731001_1.Parent);
-package body C731001_1.Unrelated is
-
- function Make return T2 is
- Result: T2;
- begin
- return Result;
- end Make;
-
- function Op2(X: T2) return String is
- begin
- return "Unrelated.Op2 body";
- end Op2;
-begin
-
- Check_String(Op1(T2'(Make)), "Parent.Op1 body");
- Check_String(Op1(T2_Class(T2'(Make))), "Parent.Op1 body");
- Check_String(Op1(Root_Class(T2'(Make))), "Parent.Op1 body");
-
- Check_String(Op2(T2'(Make)), "Unrelated.Op2 body");
- Check_String(Op2(T2_Class(T2'(Make))), "Unrelated.Op2 body");
- Check_String(Call_Op2(T2'(Make)), "Parent.Op2 body");
- Check_String(Call_Op2(T2_Class(T2'(Make))), "Parent.Op2 body");
- Check_String(Call_Op2(Root_Class(T2'(Make))), "Parent.Op2 body");
-
-end C731001_1.Unrelated;
-
-package C731001_1.Parent.Child is
- pragma Elaborate_Body;
-
- type T3 is new Root with null record;
- subtype T3_Class is T3'Class;
- function Make return T3;
-
- T3_Obj: T3;
- T3_Class_Obj: T3_Class := T3_Obj;
- T3_Root_Class_Obj: Root_Class := T3_Obj;
-
- X3: constant String :=
- Check_String(Op1(T3_Obj), "Parent.Op1 body") &
- Check_String(Op1(T3_Class_Obj), "Parent.Op1 body") &
- Check_String(Op1(T3_Root_Class_Obj), "Parent.Op1 body") &
-
- Check_String(Call_Op2(T3_Obj), "Parent.Op2 body") &
- Check_String(Call_Op2(T3_Class_Obj), "Parent.Op2 body") &
- Check_String(Call_Op2(T3_Root_Class_Obj), "Parent.Op2 body");
-
- package Nested is
- type T4 is new Root with null record;
- subtype T4_Class is T4'Class;
- function Make return T4;
-
- T4_Obj: T4;
- T4_Class_Obj: T4_Class := T4_Obj;
- T4_Root_Class_Obj: Root_Class := T4_Obj;
-
- X4: constant String :=
- Check_String(Op1(T4_Obj), "Parent.Op1 body") &
- Check_String(Op1(T4_Class_Obj), "Parent.Op1 body") &
- Check_String(Op1(T4_Root_Class_Obj), "Parent.Op1 body") &
-
- Check_String(Call_Op2(T4_Obj), "Parent.Op2 body") &
- Check_String(Call_Op2(T4_Class_Obj), "Parent.Op2 body") &
- Check_String(Call_Op2(T4_Root_Class_Obj), "Parent.Op2 body");
-
- private
-
- XX4: constant String :=
- Check_String(Op1(T4_Obj), "Parent.Op1 body") &
- Check_String(Op1(T4_Class_Obj), "Parent.Op1 body") &
- Check_String(Op1(T4_Root_Class_Obj), "Parent.Op1 body") &
-
- Check_String(Call_Op2(T4_Obj), "Parent.Op2 body") &
- Check_String(Call_Op2(T4_Class_Obj), "Parent.Op2 body") &
- Check_String(Call_Op2(T4_Root_Class_Obj), "Parent.Op2 body");
-
- end Nested;
-
- use Nested;
-
- XXX4: constant String :=
- Check_String(Op1(T4_Obj), "Parent.Op1 body") &
- Check_String(Op1(T4_Class_Obj), "Parent.Op1 body") &
- Check_String(Op1(T4_Root_Class_Obj), "Parent.Op1 body") &
-
- Check_String(Call_Op2(T4_Obj), "Parent.Op2 body") &
- Check_String(Call_Op2(T4_Class_Obj), "Parent.Op2 body") &
- Check_String(Call_Op2(T4_Root_Class_Obj), "Parent.Op2 body");
-
-private
-
- XX3: constant String :=
- Check_String(Op1(T3_Obj), "Parent.Op1 body") &
- Check_String(Op1(T3_Class_Obj), "Parent.Op1 body") &
- Check_String(Op1(T3_Root_Class_Obj), "Parent.Op1 body") &
-
- Check_String(Call_Op2(T3_Obj), "Parent.Op2 body") &
- Check_String(Call_Op2(T3_Class_Obj), "Parent.Op2 body") &
- Check_String(Call_Op2(T3_Root_Class_Obj), "Parent.Op2 body") &
-
- Check_String(Op2(T3_Obj), "Parent.Op2 body") &
- Check_String(Op2(T3_Class_Obj), "Parent.Op2 body") &
- Check_String(Op2(T3_Root_Class_Obj), "Parent.Op2 body");
-
- XXXX4: constant String :=
- Check_String(Op1(T4_Obj), "Parent.Op1 body") &
- Check_String(Op1(T4_Class_Obj), "Parent.Op1 body") &
- Check_String(Op1(T4_Root_Class_Obj), "Parent.Op1 body") &
-
- Check_String(Call_Op2(T4_Obj), "Parent.Op2 body") &
- Check_String(Call_Op2(T4_Class_Obj), "Parent.Op2 body") &
- Check_String(Call_Op2(T4_Root_Class_Obj), "Parent.Op2 body") &
-
- Check_String(Op2(T4_Root_Class_Obj), "Parent.Op2 body");
-
-end C731001_1.Parent.Child;
-
-with C731001_1.Unrelated; use C731001_1.Unrelated;
- pragma Elaborate(C731001_1.Unrelated);
-package body C731001_1.Parent.Child is
-
- XXX3: constant String :=
- Check_String(Op1(T3_Obj), "Parent.Op1 body") &
- Check_String(Op1(T3_Class_Obj), "Parent.Op1 body") &
- Check_String(Op1(T3_Root_Class_Obj), "Parent.Op1 body") &
-
- Check_String(Call_Op2(T3_Obj), "Parent.Op2 body") &
- Check_String(Call_Op2(T3_Class_Obj), "Parent.Op2 body") &
- Check_String(Call_Op2(T3_Root_Class_Obj), "Parent.Op2 body") &
-
- Check_String(Op2(T3_Obj), "Parent.Op2 body") &
- Check_String(Op2(T3_Class_Obj), "Parent.Op2 body") &
- Check_String(Op2(T3_Root_Class_Obj), "Parent.Op2 body");
-
- XXXXX4: constant String :=
- Check_String(Op1(T4_Obj), "Parent.Op1 body") &
- Check_String(Op1(T4_Class_Obj), "Parent.Op1 body") &
- Check_String(Op1(T4_Root_Class_Obj), "Parent.Op1 body") &
-
- Check_String(Call_Op2(T4_Obj), "Parent.Op2 body") &
- Check_String(Call_Op2(T4_Class_Obj), "Parent.Op2 body") &
- Check_String(Call_Op2(T4_Root_Class_Obj), "Parent.Op2 body") &
-
- Check_String(Op2(T4_Root_Class_Obj), "Parent.Op2 body");
-
- function Make return T3 is
- Result: T3;
- begin
- return Result;
- end Make;
-
- package body Nested is
- function Make return T4 is
- Result: T4;
- begin
- return Result;
- end Make;
-
- XXXXXX4: constant String :=
- Check_String(Op1(T4_Obj), "Parent.Op1 body") &
- Check_String(Op1(T4_Class_Obj), "Parent.Op1 body") &
- Check_String(Op1(T4_Root_Class_Obj), "Parent.Op1 body") &
-
- Check_String(Call_Op2(T4_Obj), "Parent.Op2 body") &
- Check_String(Call_Op2(T4_Class_Obj), "Parent.Op2 body") &
- Check_String(Call_Op2(T4_Root_Class_Obj), "Parent.Op2 body") &
-
- Check_String(Op2(T4_Obj), "Parent.Op2 body") &
- Check_String(Op2(T4_Class_Obj), "Parent.Op2 body") &
- Check_String(Op2(T4_Root_Class_Obj), "Parent.Op2 body");
-
- end Nested;
-
- type T5 is new T2 with null record;
- subtype T5_Class is T5'Class;
- function Make return T5;
-
- function Make return T5 is
- Result: T5;
- begin
- return Result;
- end Make;
-
- XXXXXXX4: constant String :=
- Check_String(Op1(T4_Obj), "Parent.Op1 body") &
- Check_String(Op1(T4_Class_Obj), "Parent.Op1 body") &
- Check_String(Op1(T4_Root_Class_Obj), "Parent.Op1 body") &
-
- Check_String(Call_Op2(T4_Obj), "Parent.Op2 body") &
- Check_String(Call_Op2(T4_Class_Obj), "Parent.Op2 body") &
- Check_String(Call_Op2(T4_Root_Class_Obj), "Parent.Op2 body") &
-
- Check_String(Op2(T4_Root_Class_Obj), "Parent.Op2 body");
-
-end C731001_1.Parent.Child;
-
-procedure C731001_1.Main;
-
-with C731001_1.Parent;
-procedure C731001_1.Main is
-begin
- C731001_1.Parent.Call_Main;
-end C731001_1.Main;
-
-with C731001_1.Parent.Child;
- use C731001_1.Parent;
- use C731001_1.Parent.Child;
- use C731001_1.Parent.Child.Nested;
-with C731001_1.Unrelated; use C731001_1.Unrelated;
-procedure C731001_1.Parent.Main is
-
- Root_Obj: Root := Make;
- Root_Class_Obj: Root_Class := Root'(Make);
-
- T2_Obj: T2 := Make;
- T2_Class_Obj: T2_Class := T2_Obj;
- T2_Root_Class_Obj: Root_Class := T2_Class_Obj;
-
- T3_Obj: T3 := Make;
- T3_Class_Obj: T3_Class := T3_Obj;
- T3_Root_Class_Obj: Root_Class := T3_Obj;
-
- T4_Obj: T4 := Make;
- T4_Class_Obj: T4_Class := T4_Obj;
- T4_Root_Class_Obj: Root_Class := T4_Obj;
-
-begin
- Test("C731001_1", "Check that inherited operations can be overridden, even"
- & " when they are inherited in a body");
-
- Check_String(Op1(Root_Obj), "Parent.Op1 body");
- Check_String(Op1(Root_Class_Obj), "Parent.Op1 body");
-
- Check_String(Call_Op2(Root_Obj), "Parent.Op2 body");
- Check_String(Call_Op2(Root_Class_Obj), "Parent.Op2 body");
-
- Check_String(Op1(T2_Obj), "Parent.Op1 body");
- Check_String(Op1(T2_Class_Obj), "Parent.Op1 body");
- Check_String(Op1(T2_Root_Class_Obj), "Parent.Op1 body");
-
- Check_String(Op2(T2_Obj), "Unrelated.Op2 body");
- Check_String(Op2(T2_Class_Obj), "Unrelated.Op2 body");
- Check_String(Call_Op2(T2_Obj), "Parent.Op2 body");
- Check_String(Call_Op2(T2_Class_Obj), "Parent.Op2 body");
- Check_String(Call_Op2(T2_Root_Class_Obj), "Parent.Op2 body");
-
- Check_String(Op1(T3_Obj), "Parent.Op1 body");
- Check_String(Op1(T3_Class_Obj), "Parent.Op1 body");
- Check_String(Op1(T3_Root_Class_Obj), "Parent.Op1 body");
-
- Check_String(Call_Op2(T3_Obj), "Parent.Op2 body");
- Check_String(Call_Op2(T3_Class_Obj), "Parent.Op2 body");
- Check_String(Call_Op2(T3_Root_Class_Obj), "Parent.Op2 body");
-
- Check_String(Op1(T4_Obj), "Parent.Op1 body");
- Check_String(Op1(T4_Class_Obj), "Parent.Op1 body");
- Check_String(Op1(T4_Root_Class_Obj), "Parent.Op1 body");
-
- Check_String(Call_Op2(T4_Obj), "Parent.Op2 body");
- Check_String(Call_Op2(T4_Class_Obj), "Parent.Op2 body");
- Check_String(Call_Op2(T4_Root_Class_Obj), "Parent.Op2 body");
-
- Result;
-end C731001_1.Parent.Main;
-
-with C731001_1.Main;
-procedure C731001 is
-begin
- C731001_1.Main;
-end C731001;
diff --git a/gcc/testsuite/ada/acats/tests/c7/c760001.a b/gcc/testsuite/ada/acats/tests/c7/c760001.a
deleted file mode 100644
index be9ff81946c..00000000000
--- a/gcc/testsuite/ada/acats/tests/c7/c760001.a
+++ /dev/null
@@ -1,390 +0,0 @@
--- C760001.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that Initialize is called for objects and components of
--- a controlled type when the objects and components are not
--- assigned explicit initial values. Check this for "simple" controlled
--- objects, controlled record components and arrays with controlled
--- components.
---
--- Check that if an explicit initial value is assigned to an object
--- or component of a controlled type then Initialize is not called.
---
--- TEST DESCRIPTION:
--- This test derives a type for Ada.Finalization.Controlled, and
--- overrides the Initialize and Adjust operations for the type. The
--- intent of the type is that it should carry incremental values
--- indicating the ordering of events with respect to these (and default
--- initialization) operations. The body of the test uses these values
--- to determine that the implicit calls to these subprograms happen
--- (or don't) at the appropriate times.
---
--- The test further derives types from this "root" type, which are the
--- actual types used in the test. One of the types is "simply" derived
--- from the "root" type, the other contains a component of the first
--- type, thus nesting a controlled object as a record component in
--- controlled objects.
---
--- The main program declares objects of these types and checks the
--- values of the components to ascertain that they have been touched
--- as expected.
---
--- Note that Finalization procedures are provided. This test does not
--- test that the calls to Finalization are made correctly. The
--- Finalization procedures are provided to catch an implementation that
--- calls Finalization at an incorrect time.
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 10 Oct 95 SAIC Update and repair for ACVC 2.0.1
---
---!
-
----------------------------------------------------------------- C760001_0
-
-with Ada.Finalization;
-package C760001_0 is
- subtype Unique_ID is Natural;
- function Unique_Value return Unique_ID;
- -- increments each time it's called
-
- function Most_Recent_Unique_Value return Unique_ID;
- -- returns the same value as the most recent call to Unique_Value
-
- type Root_Controlled is new Ada.Finalization.Controlled with record
- My_ID : Unique_ID := Unique_Value;
- My_Init_ID : Unique_ID := Unique_ID'First;
- My_Adj_ID : Unique_ID := Unique_ID'First;
- end record;
-
- procedure Initialize( R: in out Root_Controlled );
- procedure Adjust ( R: in out Root_Controlled );
-
- TC_Initialize_Calls_Is_Failing : Boolean := False;
-
-end C760001_0;
-
--- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
-
-with Report;
-package body C760001_0 is
-
- Global_Unique_Counter : Unique_ID := 0;
-
- function Unique_Value return Unique_ID is
- begin
- Global_Unique_Counter := Global_Unique_Counter +1;
- return Global_Unique_Counter;
- end Unique_Value;
-
- function Most_Recent_Unique_Value return Unique_ID is
- begin
- return Global_Unique_Counter;
- end Most_Recent_Unique_Value;
-
- procedure Initialize( R: in out Root_Controlled ) is
- begin
- if TC_Initialize_Calls_Is_Failing then
- Report.Failed("Initialized incorrectly called");
- end if;
- R.My_Init_ID := Unique_Value;
- end Initialize;
-
- procedure Adjust( R: in out Root_Controlled ) is
- begin
- R.My_Adj_ID := Unique_Value;
- end Adjust;
-
-end C760001_0;
-
----------------------------------------------------------------- C760001_1
-
-with Ada.Finalization;
-with C760001_0;
-package C760001_1 is
-
- type Proc_ID is (None, Init, Adj, Fin);
-
- type Test_Controlled is new C760001_0.Root_Controlled with record
- Last_Proc_Called: Proc_ID := None;
- end record;
-
- procedure Initialize( TC: in out Test_Controlled );
- procedure Adjust ( TC: in out Test_Controlled );
- procedure Finalize ( TC: in out Test_Controlled );
-
- type Nested_Controlled is new C760001_0.Root_Controlled with record
- Nested : C760001_0.Root_Controlled;
- Last_Proc_Called: Proc_ID := None;
- end record;
-
- procedure Initialize( TC: in out Nested_Controlled );
- procedure Adjust ( TC: in out Nested_Controlled );
- procedure Finalize ( TC: in out Nested_Controlled );
-
-end C760001_1;
-
--- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
-
-with Report;
-package body C760001_1 is
-
- procedure Initialize( TC: in out Test_Controlled ) is
- begin
- if TC.Last_Proc_Called /= None then
- Report.Failed("Initialize for Test_Controlled");
- end if;
- TC.Last_Proc_Called := Init;
- C760001_0.Initialize(C760001_0.Root_Controlled(TC));
- end Initialize;
-
- procedure Adjust ( TC: in out Test_Controlled ) is
- begin
- TC.Last_Proc_Called := Adj;
- C760001_0.Adjust(C760001_0.Root_Controlled(TC));
- end Adjust;
-
- procedure Finalize ( TC: in out Test_Controlled ) is
- begin
- TC.Last_Proc_Called := Fin;
- end Finalize;
-
- procedure Initialize( TC: in out Nested_Controlled ) is
- begin
- if TC.Last_Proc_Called /= None then
- Report.Failed("Initialize for Nested_Controlled");
- end if;
- TC.Last_Proc_Called := Init;
- C760001_0.Initialize(C760001_0.Root_Controlled(TC));
- end Initialize;
-
- procedure Adjust ( TC: in out Nested_Controlled ) is
- begin
- TC.Last_Proc_Called := Adj;
- C760001_0.Adjust(C760001_0.Root_Controlled(TC));
- end Adjust;
-
- procedure Finalize ( TC: in out Nested_Controlled ) is
- begin
- TC.Last_Proc_Called := Fin;
- end Finalize;
-
-end C760001_1;
-
----------------------------------------------------------------- C760001
-
-with Report;
-with TCTouch;
-with C760001_0;
-with C760001_1;
-with Ada.Finalization;
-procedure C760001 is
-
- use type C760001_1.Proc_ID;
-
- -- in the first test, test the simple case. Check that a controlled object
- -- causes a call to the procedure Initialize.
- -- Also check that assignment causes a call to Adjust.
-
- procedure Check_Simple_Objects is
- S,T : C760001_1.Test_Controlled;
- begin
- TCTouch.Assert(S.My_ID < S.My_Init_ID,"Default before dispatch");
- TCTouch.Assert((S.Last_Proc_Called = C760001_1.Init) and
- (T.Last_Proc_Called = C760001_1.Init),
- "Initialize for simple object");
- S := T;
- TCTouch.Assert((S.Last_Proc_Called = C760001_1.Adj),
- "Adjust for simple object");
- TCTouch.Assert((S.My_ID = T.My_ID),
- "Simple object My_ID's don't match");
- TCTouch.Assert((S.My_Init_ID = T.My_Init_ID),
- "Simple object My_Init_ID's don't match");
- TCTouch.Assert((S.My_Adj_ID > T.My_Adj_ID),
- "Simple object My_Adj_ID's in wrong order");
- end Check_Simple_Objects;
-
- -- in the second test, test a more complex case, check that a controlled
- -- component of a controlled object gets processed correctly
-
- procedure Check_Nested_Objects is
- NO1 : C760001_1.Nested_Controlled;
- begin
- TCTouch.Assert((NO1.My_ID < NO1.My_Init_Id),
- "Default value order incorrect");
- TCTouch.Assert((NO1.My_Init_Id > NO1.Nested.My_Init_ID),
- "Initialization call order incorrect");
- end Check_Nested_Objects;
-
- -- check that objects assigned an initial value at declaration are Adjusted
- -- and NOT Initialized
-
- procedure Check_Objects_With_Initial_Values is
-
- TC_Now : constant C760001_0.Unique_ID := C760001_0.Unique_Value;
-
- A: C760001_1.Test_Controlled :=
- ( Ada.Finalization.Controlled
- with TC_Now,
- TC_Now,
- TC_Now,
- C760001_1.None);
-
- B: C760001_1.Nested_Controlled :=
- ( Ada.Finalization.Controlled
- with TC_Now,
- TC_Now,
- TC_Now,
- C760001_0.Root_Controlled(A),
- C760001_1.None);
-
- begin
- -- the implementation may or may not call Adjust for the values
- -- assigned into A and B,
- -- but should NOT call Initialize.
- -- if the value used in the aggregate is overwritten by Initialize,
- -- this indicates failure
- TCTouch.Assert(A.My_Init_Id = TC_Now,
- "Initialize was called for A with initial value");
- TCTouch.Assert(B.My_Init_Id = TC_Now,
- "Initialize was called for B with initial value");
- TCTouch.Assert(B.Nested.My_Init_ID = TC_Now,
- "Initialize was called for B.Nested initial value");
- end Check_Objects_With_Initial_Values;
-
- procedure Check_Array_Case is
- type Array_Simple is array(1..4) of C760001_1.Test_Controlled;
- type Array_Nested is array(1..4) of C760001_1.Nested_Controlled;
-
- Simple_Array_Default : Array_Simple;
-
- Nested_Array_Default : Array_Nested;
-
- TC_A_Bit_Later : C760001_0.Unique_ID;
-
- begin
- TC_A_Bit_Later := C760001_0.Unique_Value;
- for N in 1..4 loop
- TCTouch.Assert(Simple_Array_Default(N).Last_Proc_Called
- = C760001_1.Init,
- "Initialize for array initial value");
-
- TCTouch.Assert( (Simple_Array_Default(N).My_Init_ID
- > C760001_0.Unique_ID'First)
- and (Simple_Array_Default(N).My_Init_ID
- < TC_A_Bit_Later),
- "Initialize timing for simple array");
-
- TCTouch.Assert( (Nested_Array_Default(N).My_Init_ID
- > C760001_0.Unique_ID'First)
- and (Nested_Array_Default(N).My_Init_ID
- < TC_A_Bit_Later),
- "Initialize timing for container array");
-
- TCTouch.Assert(Nested_Array_Default(N).Last_Proc_Called
- = C760001_1.Init,
- "Initialize for nested array (outer) initial value");
-
- TCTouch.Assert( (Nested_Array_Default(N).Nested.My_Init_ID
- > C760001_0.Unique_ID'First)
- and (Nested_Array_Default(N).Nested.My_Init_ID
- < Nested_Array_Default(N).My_Init_ID),
- "Initialize timing for array content");
- end loop;
- end Check_Array_Case;
-
- procedure Check_Array_Case_With_Initial_Values is
-
- TC_Now : constant C760001_0.Unique_ID := C760001_0.Unique_Value;
-
- type Array_Simple is array(1..4) of C760001_1.Test_Controlled;
- type Array_Nested is array(1..4) of C760001_1.Nested_Controlled;
-
- Simple_Array_Explicit : Array_Simple := ( 1..4 => (
- Ada.Finalization.Controlled
- with TC_Now,
- TC_Now,
- TC_Now,
- C760001_1.None ) );
-
- A : constant C760001_0.Root_Controlled :=
- ( Ada.Finalization.Controlled
- with others => TC_Now);
-
- Nested_Array_Explicit : Array_Nested := ( 1..4 => (
- Ada.Finalization.Controlled
- with TC_Now,
- TC_Now,
- TC_Now,
- A,
- C760001_1.None ) );
-
- begin
- -- the implementation may or may not call Adjust for the values
- -- assigned into Simple_Array_Explicit and Nested_Array_Explicit,
- -- but should NOT call Initialize.
- -- if the value used in the aggregate is overwritten by Initialize,
- -- this indicates failure
- for N in 1..4 loop
- TCTouch.Assert(Simple_Array_Explicit(N).My_Init_ID
- = TC_Now,
- "Initialize was called for array with initial value");
- TCTouch.Assert(Nested_Array_Explicit(N).My_Init_ID
- = TC_Now,
- "Initialize was called for nested array (outer) with initial value");
- TCTouch.Assert(Nested_Array_Explicit(N).Nested.My_Init_ID = TC_Now,
- "Initialize was called for nested array (inner) with initial value");
- end loop;
- end Check_Array_Case_With_Initial_Values;
-
--- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
-
-begin -- Main test procedure.
-
- Report.Test ("C760001", "Check that Initialize is called for objects " &
- "and components of a controlled type when the " &
- "objects and components are not assigned " &
- "explicit initial values. Check that if an " &
- "explicit initial value is assigned to an " &
- "object or component of a controlled type " &
- "then Initialize is not called" );
-
- Check_Simple_Objects;
-
- Check_Nested_Objects;
-
- Check_Array_Case;
-
- C760001_0.TC_Initialize_Calls_Is_Failing := True;
-
- Check_Objects_With_Initial_Values;
-
- Check_Array_Case_With_Initial_Values;
-
- Report.Result;
-
-end C760001;
diff --git a/gcc/testsuite/ada/acats/tests/c7/c760002.a b/gcc/testsuite/ada/acats/tests/c7/c760002.a
deleted file mode 100644
index 4601873be04..00000000000
--- a/gcc/testsuite/ada/acats/tests/c7/c760002.a
+++ /dev/null
@@ -1,489 +0,0 @@
--- C760002.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that assignment to an object of a (non-limited) controlled
--- type causes the Adjust operation of the type to be called.
--- Check that Adjust is called after copying the value of the
--- source expression to the target object.
---
--- Check that Adjust is called for all controlled components when
--- the containing object is assigned. (Test this for the cases
--- where the type of the containing object is controlled and
--- noncontrolled; test this for initialization as well as
--- assignment statements.)
---
--- Check that for an object of a controlled type with controlled
--- components, Adjust for each of the components is called before
--- the containing object is adjusted.
---
--- Check that an Adjust procedure for a Limited_Controlled type is
--- not called by the implementation.
---
--- TEST DESCRIPTION:
--- This test is loosely "derived" from C760001.
---
--- Visit Tags:
--- D - Default value at declaration
--- d - Default value at declaration, limited root
--- I - initialize at root controlled
--- i - initialize at root limited controlled
--- A - adjust at root controlled
--- X,Y,Z,x,y,z - used in test body
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 19 Dec 94 SAIC Correct test assertion logic for Sinister case
---
---!
-
----------------------------------------------------------------- C760002_0
-
-with Ada.Finalization;
-package C760002_0 is
- subtype Unique_ID is Natural;
- function Unique_Value return Unique_ID;
- -- increments each time it's called
-
- function Most_Recent_Unique_Value return Unique_ID;
- -- returns the same value as the most recent call to Unique_Value
-
- type Root is tagged record
- My_ID : Unique_ID := Unique_Value;
- Visit_Tag : Character := 'D'; -- Default
- end record;
-
- procedure Initialize( R: in out Root );
- procedure Adjust ( R: in out Root );
-
- type Root_Controlled is new Ada.Finalization.Controlled with record
- My_ID : Unique_ID := Unique_Value;
- Visit_Tag : Character := 'D'; ---------------------------------------- D
- end record;
-
- procedure Initialize( R: in out Root_Controlled );
- procedure Adjust ( R: in out Root_Controlled );
-
- type Root_Limited_Controlled is
- new Ada.Finalization.Limited_Controlled with record
- My_ID : Unique_ID := Unique_Value;
- Visit_Tag : Character := 'd'; ---------------------------------------- d
- end record;
-
- procedure Initialize( R: in out Root_Limited_Controlled );
- procedure Adjust ( R: in out Root_Limited_Controlled );
-
-end C760002_0;
-
-with Report;
-package body C760002_0 is
-
- Global_Unique_Counter : Unique_ID := 0;
-
- function Unique_Value return Unique_ID is
- begin
- Global_Unique_Counter := Global_Unique_Counter +1;
- return Global_Unique_Counter;
- end Unique_Value;
-
- function Most_Recent_Unique_Value return Unique_ID is
- begin
- return Global_Unique_Counter;
- end Most_Recent_Unique_Value;
-
- procedure Initialize( R: in out Root ) is
- begin
- Report.Failed("Initialize called for Non_Controlled type");
- end Initialize;
-
- procedure Adjust ( R: in out Root ) is
- begin
- Report.Failed("Adjust called for Non_Controlled type");
- end Adjust;
-
- procedure Initialize( R: in out Root_Controlled ) is
- begin
- R.Visit_Tag := 'I'; --------------------------------------------------- I
- end Initialize;
-
- procedure Adjust( R: in out Root_Controlled ) is
- begin
- R.Visit_Tag := 'A'; --------------------------------------------------- A
- end Adjust;
-
- procedure Initialize( R: in out Root_Limited_Controlled ) is
- begin
- R.Visit_Tag := 'i'; --------------------------------------------------- i
- end Initialize;
-
- procedure Adjust( R: in out Root_Limited_Controlled ) is
- begin
- Report.Failed("Adjust called for Limited_Controlled type");
- end Adjust;
-
-end C760002_0;
-
----------------------------------------------------------------- C760002_1
-
-with Ada.Finalization;
-with C760002_0;
-package C760002_1 is
-
- type Proc_ID is (None, Init, Adj, Fin);
-
- type Test_Controlled is new C760002_0.Root_Controlled with record
- Last_Proc_Called: Proc_ID := None;
- end record;
-
- procedure Initialize( TC: in out Test_Controlled );
- procedure Adjust ( TC: in out Test_Controlled );
- procedure Finalize ( TC: in out Test_Controlled );
-
- type Nested_Controlled is new C760002_0.Root_Controlled with record
- Nested : C760002_0.Root_Controlled;
- Last_Proc_Called: Proc_ID := None;
- end record;
-
- procedure Initialize( TC: in out Nested_Controlled );
- procedure Adjust ( TC: in out Nested_Controlled );
- procedure Finalize ( TC: in out Nested_Controlled );
-
- type Test_Limited_Controlled is
- new C760002_0.Root_Limited_Controlled with record
- Last_Proc_Called: Proc_ID := None;
- end record;
-
- procedure Initialize( TC: in out Test_Limited_Controlled );
- procedure Adjust ( TC: in out Test_Limited_Controlled );
- procedure Finalize ( TC: in out Test_Limited_Controlled );
-
- type Nested_Limited_Controlled is
- new C760002_0.Root_Limited_Controlled with record
- Nested : C760002_0.Root_Limited_Controlled;
- Last_Proc_Called: Proc_ID := None;
- end record;
-
- procedure Initialize( TC: in out Nested_Limited_Controlled );
- procedure Adjust ( TC: in out Nested_Limited_Controlled );
- procedure Finalize ( TC: in out Nested_Limited_Controlled );
-
-end C760002_1;
-
-with Report;
-package body C760002_1 is
-
- procedure Initialize( TC: in out Test_Controlled ) is
- begin
- TC.Last_Proc_Called := Init;
- C760002_0.Initialize(C760002_0.Root_Controlled(TC));
- end Initialize;
-
- procedure Adjust ( TC: in out Test_Controlled ) is
- begin
- TC.Last_Proc_Called := Adj;
- C760002_0.Adjust(C760002_0.Root_Controlled(TC));
- end Adjust;
-
- procedure Finalize ( TC: in out Test_Controlled ) is
- begin
- TC.Last_Proc_Called := Fin;
- end Finalize;
-
- procedure Initialize( TC: in out Nested_Controlled ) is
- begin
- TC.Last_Proc_Called := Init;
- C760002_0.Initialize(C760002_0.Root_Controlled(TC));
- end Initialize;
-
- procedure Adjust ( TC: in out Nested_Controlled ) is
- begin
- TC.Last_Proc_Called := Adj;
- C760002_0.Adjust(C760002_0.Root_Controlled(TC));
- end Adjust;
-
- procedure Finalize ( TC: in out Nested_Controlled ) is
- begin
- TC.Last_Proc_Called := Fin;
- end Finalize;
-
- procedure Initialize( TC: in out Test_Limited_Controlled ) is
- begin
- TC.Last_Proc_Called := Init;
- C760002_0.Initialize(C760002_0.Root_Limited_Controlled(TC));
- end Initialize;
-
- procedure Adjust ( TC: in out Test_Limited_Controlled ) is
- begin
- Report.Failed("Adjust called for Test_Limited_Controlled");
- end Adjust;
-
- procedure Finalize ( TC: in out Test_Limited_Controlled ) is
- begin
- TC.Last_Proc_Called := Fin;
- end Finalize;
-
- procedure Initialize( TC: in out Nested_Limited_Controlled ) is
- begin
- TC.Last_Proc_Called := Init;
- C760002_0.Initialize(C760002_0.Root_Limited_Controlled(TC));
- end Initialize;
-
- procedure Adjust ( TC: in out Nested_Limited_Controlled ) is
- begin
- Report.Failed("Adjust called for Nested_Limited_Controlled");
- end Adjust;
-
- procedure Finalize ( TC: in out Nested_Limited_Controlled ) is
- begin
- TC.Last_Proc_Called := Fin;
- end Finalize;
-
-end C760002_1;
-
----------------------------------------------------------------- C760002
-
-with Report;
-with TCTouch;
-with C760002_0;
-with C760002_1;
-with Ada.Finalization;
-procedure C760002 is
-
- use type C760002_1.Proc_ID;
-
- -- in the first test, test the simple cases.
- -- Also check that assignment causes a call to Adjust for a controlled
- -- object. Check that assignment of a non-controlled object does not call
- -- an Adjust procedure.
-
- procedure Check_Simple_Objects is
-
- A,B : C760002_0.Root;
- S,T : C760002_1.Test_Controlled;
- Q : C760002_1.Test_Limited_Controlled; -- Adjust call shouldn't happen
- begin
-
- S := T;
-
- TCTouch.Assert((S.Last_Proc_Called = C760002_1.Adj),
- "Adjust for simple object");
- TCTouch.Assert((S.My_ID = T.My_ID),
- "Assignment failed for simple object");
-
- -- Check that adjust was called
- TCTouch.Assert((S.Visit_Tag = 'A'), "Adjust timing incorrect");
-
- -- Check that Adjust has not been called
- TCTouch.Assert_Not((T.Visit_Tag = 'A'), "Adjust incorrectly called");
-
- -- Check that Adjust does not get called
- A.My_ID := A.My_ID +1;
- B := A; -- see: Adjust: Report.Failed
-
- end Check_Simple_Objects;
-
- -- in the second test, test a more complex case, check that a controlled
- -- component of a controlled object gets processed correctly
-
- procedure Check_Nested_Objects is
- NO1 : C760002_1.Nested_Controlled;
- NO2 : C760002_1.Nested_Controlled := NO1;
-
- begin
-
- -- NO2 should be flagged with adjust markers
- TCTouch.Assert((NO2.Last_Proc_Called = C760002_1.Adj),
- "Adjust not called for NO2 enclosure declaration");
- TCTouch.Assert((NO2.Nested.Visit_Tag = 'A'),
- "Adjust not called for NO2 enclosed declaration");
-
- NO2.Visit_Tag := 'x';
- NO2.Nested.Visit_Tag := 'y';
-
- NO1 := NO2;
-
- -- NO1 should be flagged with adjust markers
- TCTouch.Assert((NO1.Visit_Tag = 'A'),
- "Adjust not called for NO1 enclosure declaration");
- TCTouch.Assert((NO1.Nested.Visit_Tag = 'A'),
- "Adjust not called for NO1 enclosed declaration");
-
- end Check_Nested_Objects;
-
- procedure Check_Array_Case is
- type Array_Simple is array(1..4) of C760002_1.Test_Controlled;
- type Array_Nested is array(1..4) of C760002_1.Nested_Controlled;
-
- Left,Right : Array_Simple;
- Overlap : Array_Simple := Left;
-
- Sinister,Dexter : Array_Nested;
- Underlap : Array_Nested := Sinister;
-
- Now : Natural;
-
- begin
-
- -- get a current unique value since initializations
- Now := C760002_0.Unique_Value;
-
- -- check results of declarations
- for N in 1..4 loop
- TCTouch.Assert(Left(N).My_Id < Now,
- "Initialize for array initial value");
- TCTouch.Assert(Overlap(N).My_Id < Now,
- "Adjust for nested array (outer) initial value");
- TCTouch.Assert(Sinister(N).Nested.My_Id < Now,
- "Initialize for nested array (inner) initial value");
- TCTouch.Assert(Sinister(N).My_Id < Sinister(N).Nested.My_Id,
- "Initialize for enclosure should be after enclosed");
- TCTouch.Assert(Overlap(N).Visit_Tag = 'A',"Adjust at declaration");
- TCTouch.Assert(Underlap(N).Nested.Visit_Tag = 'A',
- "Adjust at declaration, nested object");
- end loop;
-
- -- set visit tags
- for O in 1..4 loop
- Overlap(O).Visit_Tag := 'X';
- Underlap(O).Visit_Tag := 'Y';
- Underlap(O).Nested.Visit_Tag := 'y';
- end loop;
-
- -- check that overlapping assignments don't cause odd grief
- Overlap(1..3) := Overlap(2..4);
- Underlap(2..4) := Underlap(1..3);
-
- for M in 2..3 loop
- TCTouch.Assert(Overlap(M).Last_Proc_Called = C760002_1.Adj,
- "Adjust for overlap");
- TCTouch.Assert(Overlap(M).Visit_Tag = 'A',
- "Adjust for overlap ID");
- TCTouch.Assert(Underlap(M).Last_Proc_Called = C760002_1.Adj,
- "Adjust for Underlap");
- TCTouch.Assert(Underlap(M).Nested.Visit_Tag = 'A',
- "Adjust for Underlaps nested ID");
- end loop;
-
- end Check_Array_Case;
-
- procedure Check_Access_Case is
- type TC_Ref is access C760002_1.Test_Controlled;
- type NC_Ref is access C760002_1.Nested_Controlled;
- type TL_Ref is access C760002_1.Test_Limited_Controlled;
- type NL_Ref is access C760002_1.Nested_Limited_Controlled;
-
- A,B : TC_Ref;
- C,D : NC_Ref;
- E : TL_Ref;
- F : NL_Ref;
-
- begin
-
- A := new C760002_1.Test_Controlled;
- B := new C760002_1.Test_Controlled'( A.all );
-
- C := new C760002_1.Nested_Controlled;
- D := new C760002_1.Nested_Controlled'( C.all );
-
- E := new C760002_1.Test_Limited_Controlled;
- F := new C760002_1.Nested_Limited_Controlled;
-
- TCTouch.Assert(A.Visit_Tag = 'I',"TC Allocation");
- TCTouch.Assert(B.Visit_Tag = 'A',"TC Allocation, with value");
-
- TCTouch.Assert(C.Visit_Tag = 'I',"NC Allocation");
- TCTouch.Assert(C.Nested.Visit_Tag = 'I',"NC Allocation, Nested");
- TCTouch.Assert(D.Visit_Tag = 'A',"NC Allocation, with value");
- TCTouch.Assert(D.Nested.Visit_Tag = 'A',
- "NC Allocation, Nested, with value");
-
- TCTouch.Assert(E.Visit_Tag = 'i',"TL Allocation");
- TCTouch.Assert(F.Visit_Tag = 'i',"NL Allocation");
-
- A.all := B.all;
- C.all := D.all;
-
- TCTouch.Assert(A.Visit_Tag = 'A',"TC Assignment");
- TCTouch.Assert(C.Visit_Tag = 'A',"NC Assignment");
- TCTouch.Assert(C.Nested.Visit_Tag = 'A',"NC Assignment, Nested");
-
- end Check_Access_Case;
-
- procedure Check_Access_Limited_Array_Case is
- type Array_Simple is array(1..4) of C760002_1.Test_Limited_Controlled;
- type AS_Ref is access Array_Simple;
- type Array_Nested is array(1..4) of C760002_1.Nested_Limited_Controlled;
- type AN_Ref is access Array_Nested;
-
- Simple_Array_Limited : AS_Ref;
-
- Nested_Array_Limited : AN_Ref;
-
- begin
-
- Simple_Array_Limited := new Array_Simple;
-
- Nested_Array_Limited := new Array_Nested;
-
- for N in 1..4 loop
- TCTouch.Assert(Simple_Array_Limited(N).Last_Proc_Called
- = C760002_1.Init,
- "Initialize for array initial value");
- TCTouch.Assert(Nested_Array_Limited(N).Last_Proc_Called
- = C760002_1.Init,
- "Initialize for nested array (outer) initial value");
- TCTouch.Assert(Nested_Array_Limited(N).Nested.Visit_Tag = 'i',
- "Initialize for nested array (inner) initial value");
- end loop;
- end Check_Access_Limited_Array_Case;
-
-begin -- Main test procedure.
-
- Report.Test ("C760002", "Check that assignment causes the Adjust " &
- "operation of the type to be called. Check " &
- "that Adjust is called after copying the " &
- "value of the source expression to the target " &
- "object. Check that Adjust is called for all " &
- "controlled components when the containing " &
- "object is assigned. Check that Adjust is " &
- "called for components before the containing " &
- "object is adjusted. Check that Adjust is not " &
- "called for a Limited_Controlled type by the " &
- "implementation" );
-
- Check_Simple_Objects;
-
- Check_Nested_Objects;
-
- Check_Array_Case;
-
- Check_Access_Case;
-
- Check_Access_Limited_Array_Case;
-
- Report.Result;
-
-end C760002;
diff --git a/gcc/testsuite/ada/acats/tests/c7/c760007.a b/gcc/testsuite/ada/acats/tests/c7/c760007.a
deleted file mode 100644
index c1ddfcb9345..00000000000
--- a/gcc/testsuite/ada/acats/tests/c7/c760007.a
+++ /dev/null
@@ -1,247 +0,0 @@
--- C760007.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that Adjust is called for the execution of a return
--- statement for a function returning a result of a (non-limited)
--- controlled type.
---
--- Check that Adjust is called when evaluating an aggregate
--- component association for a controlled component.
---
--- Check that Adjust is called for the assignment of the ancestor
--- expression of an extension aggregate when the type of the
--- aggregate is controlled.
---
--- TEST DESCRIPTION:
--- A type is derived from Ada.Finalization.Controlled; the dispatching
--- procedure Adjust is defined for the new type. Structures and
--- subprograms to model the test objectives are used to check that
--- Adjust is called at the right time. For the sake of simplicity,
--- globally accessible data is used to check that the calls are made.
---
---
--- CHANGE HISTORY:
--- 06 DEC 94 SAIC ACVC 2.0
--- 14 OCT 95 SAIC Update and repair for ACVC 2.0.1
--- 05 APR 96 SAIC Add RM reference
--- 06 NOV 96 SAIC Reduce adjust requirement
--- 25 NOV 97 EDS Allowed zero calls to adjust at line 144
---!
-
----------------------------------------------------------------- C760007_0
-
-with Ada.Finalization;
-package C760007_0 is
-
- type Controlled is new Ada.Finalization.Controlled with record
- TC_ID : Natural := Natural'Last;
- end record;
- procedure Adjust( Object: in out Controlled );
-
- type Structure is record
- Controlled_Component : Controlled;
- end record;
-
- type Child is new Controlled with record
- TC_XX : Natural := Natural'Last;
- end record;
- procedure Adjust( Object: in out Child );
-
- Adjust_Count : Natural := 0;
- Child_Adjust_Count : Natural := 0;
-
-end C760007_0;
-
-package body C760007_0 is
-
- procedure Adjust( Object: in out Controlled ) is
- begin
- Adjust_Count := Adjust_Count +1;
- end Adjust;
-
- procedure Adjust( Object: in out Child ) is
- begin
- Child_Adjust_Count := Child_Adjust_Count +1;
- end Adjust;
-
-end C760007_0;
-
------------------------------------------------------------------- C760007
-
-with Report;
-with C760007_0;
-procedure C760007 is
-
- procedure Check_Adjust_Count(Message: String;
- Min: Natural := 1;
- Max: Natural := 2) is
- begin
-
- -- in order to allow for the anonymous objects referred to in
- -- the reference manual, the check for calls to Adjust must be
- -- in a range. This number must then be further adjusted
- -- to allow for the optimization that does not call for an adjust
- -- of an aggregate initial value built directly in the object
-
- if C760007_0.Adjust_Count not in Min..Max then
- Report.Failed(Message
- & " = " & Natural'Image(C760007_0.Adjust_Count));
- end if;
- C760007_0.Adjust_Count := 0;
- end Check_Adjust_Count;
-
- procedure Check_Child_Adjust_Count(Message: String;
- Min: Natural := 1;
- Max: Natural := 2) is
- begin
- -- ditto above
-
- if C760007_0.Child_Adjust_Count not in Min..Max then
- Report.Failed(Message
- & " = " & Natural'Image(C760007_0.Child_Adjust_Count));
- end if;
- C760007_0.Child_Adjust_Count := 0;
- end Check_Child_Adjust_Count;
-
- Object : C760007_0.Controlled;
-
--- Check that Adjust is called for the execution of a return
--- statement for a function returning a result of a (non-limited)
--- controlled type or a result of a noncontrolled type with
--- controlled components.
-
- procedure Subtest_1 is
- function Create return C760007_0.Controlled is
- New_Object : C760007_0.Controlled;
- begin
- return New_Object;
- end Create;
-
- procedure Examine( Thing : in C760007_0.Controlled ) is
- begin
- Check_Adjust_Count("Function call passed as parameter",0);
- end Examine;
-
- begin
- -- this assignment must call Adjust:
- -- 1: on the value resulting from the function
- -- ** unless this is optimized out by building the result directly
- -- in the target object.
- -- 2: on Object once it's been assigned
- -- may call adjust
- -- 1: for a anonymous object created in the evaluation of the function
- -- 2: for a anonymous object created in the assignment operation
-
- Object := Create;
-
- Check_Adjust_Count("Function call",1,4);
-
- Examine( Create );
-
- end Subtest_1;
-
--- Check that Adjust is called when evaluating an aggregate
--- component association for a controlled component.
-
- procedure Subtest_2 is
- S : C760007_0.Structure;
-
- procedure Examine( Thing : in C760007_0.Structure ) is
- begin
- Check_Adjust_Count("Aggregate passed as parameter");
- end Examine;
-
- begin
- -- this assignment must call Adjust:
- -- 1: on the value resulting from the aggregate
- -- ** unless this is optimized out by building the result directly
- -- in the target object.
- -- 2: on Object once it's been assigned
- -- may call adjust
- -- 1: for a anonymous object created in the evaluation of the aggregate
- -- 2: for a anonymous object created in the assignment operation
- S := ( Controlled_Component => Object );
- Check_Adjust_Count("Aggregate and Assignment", 1, 4);
-
- Examine( C760007_0.Structure'(Controlled_Component => Object) );
- end Subtest_2;
-
--- Check that Adjust is called for the assignment of the ancestor
--- expression of an extension aggregate when the type of the
--- aggregate is controlled.
-
- procedure Subtest_3 is
- Bambino : C760007_0.Child;
-
- procedure Examine( Thing : in C760007_0.Child ) is
- begin
- Check_Adjust_Count("Extension aggregate as parameter (ancestor)", 0, 2);
- Check_Child_Adjust_Count("Extension aggregate as parameter", 0, 4);
- end Examine;
-
- begin
- -- implementation permissions make all of the following calls to adjust
- -- optional:
- -- these assignments may call Adjust:
- -- 1: on the value resulting from the aggregate
- -- 2: on Object once it's been assigned
- -- 3: for a anonymous object created in the evaluation of the aggregate
- -- 4: for a anonymous object created in the assignment operation
- Bambino := ( Object with TC_XX => 10 );
- Check_Adjust_Count("Ancestor (expression) part of aggregate", 0, 2);
- Check_Child_Adjust_Count("Child aggregate assignment 1", 0, 4 );
-
- Bambino := ( C760007_0.Controlled with TC_XX => 11 );
- Check_Adjust_Count("Ancestor (subtype_mark) part of aggregate", 0, 2);
- Check_Child_Adjust_Count("Child aggregate assignment 2", 0, 4 );
-
- Examine( ( Object with TC_XX => 21 ) );
-
- Examine( ( C760007_0.Controlled with TC_XX => 37 ) );
-
- end Subtest_3;
-
-begin -- Main test procedure.
-
- Report.Test ("C760007", "Check that Adjust is called for the " &
- "execution of a return statement for a " &
- "function returning a result containing a " &
- "controlled type. Check that Adjust is " &
- "called when evaluating an aggregate " &
- "component association for a controlled " &
- "component. " &
- "Check that Adjust is called for the " &
- "assignment of the ancestor expression of an " &
- "extension aggregate when the type of the " &
- "aggregate is controlled" );
-
- Subtest_1;
- Subtest_2;
- Subtest_3;
-
- Report.Result;
-
-end C760007;
diff --git a/gcc/testsuite/ada/acats/tests/c7/c760009.a b/gcc/testsuite/ada/acats/tests/c7/c760009.a
deleted file mode 100644
index 8c3b80b3625..00000000000
--- a/gcc/testsuite/ada/acats/tests/c7/c760009.a
+++ /dev/null
@@ -1,533 +0,0 @@
--- C760009.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that for an extension_aggregate whose ancestor_part is a
--- subtype_mark (i.e. Typemark'( Subtype with Field => x, etc.) )
--- Initialize is called on all controlled subcomponents of the
--- ancestor part; if the type of the ancestor part is itself controlled,
--- the Initialize procedure of the ancestor type is called, unless that
--- Initialize procedure is abstract.
---
--- Check that the utilization of a controlled type for a generic actual
--- parameter supports the correct behavior in the instantiated package.
---
--- TEST DESCRIPTION:
--- Declares a generic package instantiated to check that controlled
--- types are not impacted by the "generic boundary."
--- This instance is then used to perform the tests of various
--- aggregate formations of the controlled type. After each operation
--- in the main program that should cause implicit calls, the "state" of
--- the software is checked. The "state" of the software is maintained in
--- several variables which count the calls to the Initialize, Adjust and
--- Finalize procedures in each context. Given the nature of the
--- language rules, the test specifies a minimum number of times that
--- these subprograms should have been called. The test also checks cases
--- where the subprograms should not have been called.
---
--- As per the example in AARM 7.6(11a..d);6.0, the distinctions between
--- the presence/absence of default values is tested.
---
--- DATA STRUCTURES
---
--- C760009_3.Master_Control is derived from
--- C760009_2.Control is derived from
--- Ada.Finalization.Controlled
---
--- C760009_1.Simple_Control is derived from
--- Ada.Finalization.Controlled
---
--- C760009_3.Master_Control contains
--- Standard.Integer
---
--- C760009_2.Control contains
--- C760009_1.Simple_Control (default value)
--- C760009_1.Simple_Control (default initialized)
---
---
--- CHANGE HISTORY:
--- 01 MAY 95 SAIC Initial version
--- 19 FEB 96 SAIC Fixed elaboration Initialize count
--- 14 NOV 96 SAIC Allowed for 7.6(21) optimizations
--- 13 FEB 97 PWB.CTA Initialized counters at lines 127-129
--- 26 JUN 98 EDS Added pragma Elaborate_Body to C760009_0
--- to avoid possible instantiation error
---!
-
----------------------------------------------------------------- C760009_0
-
-with Ada.Finalization;
-generic
-
- type Private_Formal is private;
-
- with procedure TC_Validate( APF: in out Private_Formal );
-
-package C760009_0 is -- Check_1
-
- pragma Elaborate_Body;
- procedure TC_Check_1( APF: in Private_Formal );
- procedure TC_Check_2( APF: out Private_Formal );
- procedure TC_Check_3( APF: in out Private_Formal );
-
-end C760009_0;
-
--- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
-
-with Report;
-package body C760009_0 is -- Check_1
-
- procedure TC_Check_1( APF: in Private_Formal ) is
- Local : Private_Formal;
- begin
- Local := APF;
- TC_Validate( Local );
- end TC_Check_1;
-
- procedure TC_Check_2( APF: out Private_Formal ) is
- Local : Private_Formal; -- initialized by virtue of actual being
- -- Controlled
- begin
- APF := Local;
- TC_Validate( APF );
- end TC_Check_2;
-
- procedure TC_Check_3( APF: in out Private_Formal ) is
- Local : Private_Formal;
- begin
- Local := APF;
- TC_Validate( Local );
- end TC_Check_3;
-
-end C760009_0;
-
----------------------------------------------------------------- C760009_1
-
-with Ada.Finalization;
-package C760009_1 is
-
- Initialize_Called : Natural := 0;
- Adjust_Called : Natural := 0;
- Finalize_Called : Natural := 0;
-
- procedure Reset_Counters;
-
- type Simple_Control is new Ada.Finalization.Controlled with private;
-
- procedure Initialize( AV: in out Simple_Control );
- procedure Adjust ( AV: in out Simple_Control );
- procedure Finalize ( AV: in out Simple_Control );
- procedure Validate ( AV: in out Simple_Control );
-
- function Item( AV: Simple_Control'Class ) return String;
-
- Empty : constant Simple_Control;
-
- procedure TC_Trace( Message: String );
-
-private
- type Simple_Control is new Ada.Finalization.Controlled with record
- Item: Natural;
- end record;
-
- Empty : constant Simple_Control := ( Ada.Finalization.Controlled with 0 );
-
-end C760009_1;
-
--- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
-
-with Report;
-package body C760009_1 is
-
- -- Maintenance_Mode and TC_Trace are for the test writers and compiler
- -- developers to get more information from this test as it executes.
- -- Maintenance_Mode is always False for validation purposes.
-
- Maintenance_Mode : constant Boolean := False;
-
- procedure TC_Trace( Message: String ) is
- begin
- if Maintenance_Mode then
- Report.Comment( Message );
- end if;
- end TC_Trace;
-
- procedure Reset_Counters is
- begin
- Initialize_Called := 0;
- Adjust_Called := 0;
- Finalize_Called := 0;
- end Reset_Counters;
-
- Master_Count : Natural := 100; -- Help distinguish values
-
- procedure Initialize( AV: in out Simple_Control ) is
- begin
- Initialize_Called := Initialize_Called +1;
- AV.Item := Master_Count;
- Master_Count := Master_Count +100;
- TC_Trace( "Initialize _1.Simple_Control" );
- end Initialize;
-
- procedure Adjust ( AV: in out Simple_Control ) is
- begin
- Adjust_Called := Adjust_Called +1;
- AV.Item := AV.Item +1;
- TC_Trace( "Adjust _1.Simple_Control" );
- end Adjust;
-
- procedure Finalize ( AV: in out Simple_Control ) is
- begin
- Finalize_Called := Finalize_Called +1;
- AV.Item := AV.Item +1;
- TC_Trace( "Finalize _1.Simple_Control" );
- end Finalize;
-
- procedure Validate ( AV: in out Simple_Control ) is
- begin
- Report.Failed("Attempt to Validate at Simple_Control level");
- end Validate;
-
- function Item( AV: Simple_Control'Class ) return String is
- begin
- return Natural'Image(AV.Item);
- end Item;
-
-end C760009_1;
-
----------------------------------------------------------------- C760009_2
-
-with C760009_1;
-with Ada.Finalization;
-package C760009_2 is
-
- type Control is new Ada.Finalization.Controlled with record
- Element_1 : C760009_1.Simple_Control;
- Element_2 : C760009_1.Simple_Control := C760009_1.Empty;
- end record;
-
- procedure Initialize( AV: in out Control );
- procedure Finalize ( AV: in out Control );
-
- Initialized : Natural := 0;
- Finalized : Natural := 0;
-
-end C760009_2;
-
--- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
-
-package body C760009_2 is
-
- procedure Initialize( AV: in out Control ) is
- begin
- Initialized := Initialized +1;
- C760009_1.TC_Trace( "Initialize _2.Control" );
- end Initialize;
-
- procedure Finalize ( AV: in out Control ) is
- begin
- Finalized := Finalized +1;
- C760009_1.TC_Trace( "Finalize _2.Control" );
- end Finalize;
-
-end C760009_2;
-
----------------------------------------------------------------- C760009_3
-
-with C760009_0;
-with C760009_2;
-package C760009_3 is
-
- type Master_Control is new C760009_2.Control with record
- Data: Integer;
- end record;
-
- procedure Initialize( AC: in out Master_Control );
- -- calls C760009_2.Initialize
- -- embedded data causes 1 call to C760009_1.Initialize
-
- -- Adjusting operation will
- -- make 1 call to C760009_2.Adjust
- -- make 2 call to C760009_1.Adjust
-
- -- Finalize operation will
- -- make 1 call to C760009_2.Finalize
- -- make 2 call to C760009_1.Finalize
-
- procedure Validate( AC: in out Master_Control );
-
- package Check_1 is
- new C760009_0(Master_Control, Validate);
-
-end C760009_3;
-
--- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
-
-with Report;
-with C760009_1;
-package body C760009_3 is
-
- procedure Initialize( AC: in out Master_Control ) is
- begin
- AC.Data := 42;
- C760009_2.Initialize(C760009_2.Control(AC));
- C760009_1.TC_Trace( "Initialize Master_Control" );
- end Initialize;
-
- procedure Validate( AC: in out Master_Control ) is
- begin
- if AC.Data not in 0..1000 then
- Report.Failed("C760009_3.Control did not Initialize" );
- end if;
- end Validate;
-
-end C760009_3;
-
---------------------------------------------------------------------- C760009
-
-with Report;
-with C760009_1;
-with C760009_2;
-with C760009_3;
-procedure C760009 is
-
- -- Comment following declaration indicates expected calls in the order:
- -- Initialize of a C760009_2 value
- -- Finalize of a C760009_2 value
- -- Initialize of a C760009_1 value
- -- Adjust of a C760009_1 value
- -- Finalize of a C760009_1 value
-
- Global_Control : C760009_3.Master_Control;
- -- 1, 0, 1, 1, 0
-
- Parent_Control : C760009_2.Control;
- -- 1, 0, 1, 1, 0
-
- -- Global_Control is a derived tagged type, the parent type
- -- of Master_Control, Control, is derived from Controlled, and contains
- -- two components of a Controlled type, Simple_Control. One of these
- -- components has a default value, the other does not.
-
- procedure Fail( Which: String; Expect, Got: Natural ) is
- begin
- Report.Failed(Which & " Expected" & Natural'Image(Expect)
- & " got" & Natural'Image(Got) );
- end Fail;
-
- procedure Master_Assertion( Layer_2_Inits : Natural;
- Layer_2_Finals : Natural;
- Layer_1_Inits : Natural;
- Layer_1_Adjs : Natural;
- Layer_1_Finals : Natural;
- Failing_Message : String ) is
-
- begin
-
-
-
- if C760009_2.Initialized /= Layer_2_Inits then
- Fail("C760009_2.Initialize " & Failing_Message,
- Layer_2_Inits, C760009_2.Initialized );
- end if;
-
- if C760009_2.Finalized not in Layer_2_Finals..Layer_2_Finals*2 then
- Fail("C760009_2.Finalize " & Failing_Message,
- Layer_2_Finals, C760009_2.Finalized );
- end if;
-
- if C760009_1.Initialize_Called /= Layer_1_Inits then
- Fail("C760009_1.Initialize " & Failing_Message,
- Layer_1_Inits,
- C760009_1.Initialize_Called );
- end if;
-
- if C760009_1.Adjust_Called not in Layer_1_Adjs..Layer_1_Adjs*2 then
- Fail("C760009_1.Adjust " & Failing_Message,
- Layer_1_Adjs, C760009_1.Adjust_Called );
- end if;
-
- if C760009_1.Finalize_Called not in Layer_1_Finals..Layer_1_Finals*2 then
- Fail("C760009_1.Finalize " & Failing_Message,
- Layer_1_Finals, C760009_1.Finalize_Called );
- end if;
-
- C760009_1.Reset_Counters;
- C760009_2.Initialized := 0;
- C760009_2.Finalized := 0;
-
- end Master_Assertion;
-
- procedure Lesser_Assertion( Layer_2_Inits : Natural;
- Layer_2_Finals : Natural;
- Layer_1_Inits : Natural;
- Layer_1_Adjs : Natural;
- Layer_1_Finals : Natural;
- Failing_Message : String ) is
- begin
-
-
- if C760009_2.Initialized > Layer_2_Inits then
- Fail("C760009_2.Initialize " & Failing_Message,
- Layer_2_Inits, C760009_2.Initialized );
- end if;
-
- if C760009_2.Finalized < Layer_2_Inits
- or C760009_2.Finalized > Layer_2_Finals*2 then
- Fail("C760009_2.Finalize " & Failing_Message,
- Layer_2_Finals, C760009_2.Finalized );
- end if;
-
- if C760009_1.Initialize_Called > Layer_1_Inits then
- Fail("C760009_1.Initialize " & Failing_Message,
- Layer_1_Inits,
- C760009_1.Initialize_Called );
- end if;
-
- if C760009_1.Adjust_Called > Layer_1_Adjs*2 then
- Fail("C760009_1.Adjust " & Failing_Message,
- Layer_1_Adjs, C760009_1.Adjust_Called );
- end if;
-
- if C760009_1.Finalize_Called < Layer_1_Inits
- or C760009_1.Finalize_Called > Layer_1_Finals*2 then
- Fail("C760009_1.Finalize " & Failing_Message,
- Layer_1_Finals, C760009_1.Finalize_Called );
- end if;
-
- C760009_1.Reset_Counters;
- C760009_2.Initialized := 0;
- C760009_2.Finalized := 0;
-
- end Lesser_Assertion;
-
-begin -- Main test procedure.
-
- Report.Test ("C760009", "Check that for an extension_aggregate whose " &
- "ancestor_part is a subtype_mark, Initialize " &
- "is called on all controlled subcomponents of " &
- "the ancestor part. Also check that the " &
- "utilization of a controlled type for a generic " &
- "actual parameter supports the correct behavior " &
- "in the instantiated software" );
-
- C760009_1.TC_Trace( "=====> Case 0 <=====" );
-
- C760009_1.Reset_Counters;
- C760009_2.Initialized := 0;
- C760009_2.Finalized := 0;
-
- C760009_3.Validate( Global_Control ); -- check that it Initialized correctly
-
- C760009_1.TC_Trace( "=====> Case 1 <=====" );
-
- C760009_3.Check_1.TC_Check_1( ( C760009_2.Control with Data => 1 ) );
- Lesser_Assertion( 2, 3, 2, 3, 6, "Check_1.TC_Check_1" );
- -- | | | | + Finalize 2 embedded in aggregate
- -- | | | | + Finalize 2 at assignment in TC_Check_1
- -- | | | | + Finalize 2 embedded in local variable
- -- | | | + Adjust 2 caused by assignment in TC_Check_1
- -- | | | + Adjust at declaration in TC_Check_1
- -- | | + Initialize at declaration in TC_Check_1
- -- | | + Initialize of aggregate object
- -- | + Finalize of assignment target
- -- | + Finalize of local variable
- -- | + Finalize of aggregate object
- -- + Initialize of aggregate object
- -- + Initialize of local variable
-
-
- C760009_1.TC_Trace( "=====> Case 2 <=====" );
-
- C760009_3.Check_1.TC_Check_2( Global_Control );
- Master_Assertion( 1, 2, 1, 3, 4, "Check_1.TC_Check_2" );
- -- | | | | + Finalize 2 at assignment in TC_Check_2
- -- | | | | + Finalize 2 embedded in local variable
- -- | | | + Adjust 2 caused by assignment in TC_Check_2
- -- | | | + Adjust at declaration in TC_Check_2
- -- | | + Initialize at declaration in TC_Check_2
- -- | + Finalize of assignment target
- -- | + Finalize of local variable
- -- + Initialize of local variable
-
-
- C760009_1.TC_Trace( "=====> Case 3 <=====" );
-
- Global_Control := ( C760009_2.Control with Data => 2 );
- Lesser_Assertion( 1, 1, 1, 3, 2, "Aggregate -> object" );
- -- | | | | + Finalize 2 by assignment
- -- | | | + Adjust 2 caused by assignment
- -- | | | + Adjust in aggregate creation
- -- | | + Initialize of aggregate object
- -- | + Finalize of assignment target
- -- + Initialize of aggregate object
-
-
- C760009_1.TC_Trace( "=====> Case 4 <=====" );
-
- C760009_3.Check_1.TC_Check_3( Global_Control );
- Master_Assertion( 1, 2, 1, 3, 4, "Check_1.TC_Check_3" );
- -- | | | | + Finalize 2 at assignment in TC_Check_3
- -- | | | | + Finalize 2 embedded in local variable
- -- | | | + Adjust 2 at assignment in TC_Check_3
- -- | | | + Adjust in local variable creation
- -- | | + Initialize of local variable in TC_Check_3
- -- | + Finalize of assignment target
- -- | + Finalize of local variable
- -- + Initialize of local variable
-
-
- C760009_1.TC_Trace( "=====> Case 5 <=====" );
-
- Global_Control := ( Parent_Control with Data => 3 );
- Lesser_Assertion( 1, 1, 1, 3, 2, "Object Aggregate -> object" );
- -- | | | | + Finalize 2 by assignment
- -- | | | + Adjust 2 caused by assignment
- -- | | | + Adjust in aggregate creation
- -- | | + Initialize of aggregate object
- -- | + Finalize of assignment target
- -- + Initialize of aggregate object
-
-
-
- C760009_1.TC_Trace( "=====> Case 6 <=====" );
-
- -- perform this check a second time to make sure nothing is "remembered"
-
- C760009_3.Check_1.TC_Check_3( Global_Control );
- Master_Assertion( 1, 2, 1, 3, 4, "Check_1.TC_Check_3 second time" );
- -- | | | | + Finalize 2 at assignment in TC_Check_3
- -- | | | | + Finalize 2 embedded in local variable
- -- | | | + Adjust 2 at assignment in TC_Check_3
- -- | | | + Adjust in local variable creation
- -- | | + Initialize of local variable in TC_Check_3
- -- | + Finalize of assignment target
- -- | + Finalize of local variable
- -- + Initialize of local variable
-
-
- Report.Result;
-
-end C760009;
diff --git a/gcc/testsuite/ada/acats/tests/c7/c760010.a b/gcc/testsuite/ada/acats/tests/c7/c760010.a
deleted file mode 100644
index 08fe62b9fa4..00000000000
--- a/gcc/testsuite/ada/acats/tests/c7/c760010.a
+++ /dev/null
@@ -1,418 +0,0 @@
--- C760010.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that explicit calls to Initialize, Adjust and Finalize
--- procedures that raise exceptions propagate the exception raised,
--- not Program_Error. Check this for both a user defined exception
--- and a language defined exception. Check that implicit calls to
--- initialize procedures that raise an exception propagate the
--- exception raised, not Program_Error;
---
--- Check that the utilization of a controlled type as the actual for
--- a generic formal tagged private parameter supports the correct
--- behavior in the instantiated software.
---
--- TEST DESCRIPTION:
--- Declares a generic package instantiated to check that controlled
--- types are not impacted by the "generic boundary."
--- This instance is then used to perform the tests of various calls to
--- the procedures. After each operation in the main program that should
--- cause implicit calls where an exception is raised, the program handles
--- Program_Error. After each explicit call, the program handles the
--- Expected_Error. Handlers for the opposite exception are provided to
--- catch the obvious failure modes. The predefined exception
--- Tasking_Error is used to be certain that some other reason has not
--- raised a predefined exception.
---
---
--- DATA STRUCTURES
---
--- C760010_1.Simple_Control is derived from
--- Ada.Finalization.Controlled
---
--- C760010_2.Embedded_Derived is derived from C760010_1.Simple_Control
--- by way of generic instantiation
---
---
--- CHANGE HISTORY:
--- 01 MAY 95 SAIC Initial version
--- 23 APR 96 SAIC Fix visibility problem for 2.1
--- 14 NOV 96 SAIC Revisit for 2.1 release
--- 26 JUN 98 EDS Added pragma Elaborate_Body to
--- package C760010_0.Check_Formal_Tagged
--- to avoid possible instantiation error
---!
-
----------------------------------------------------------------- C760010_0
-
-package C760010_0 is
-
- User_Defined_Exception : exception;
-
- type Actions is ( No_Action,
- Init_Raise_User_Defined, Init_Raise_Standard,
- Adj_Raise_User_Defined, Adj_Raise_Standard,
- Fin_Raise_User_Defined, Fin_Raise_Standard );
-
- Action : Actions := No_Action;
-
- function Unique return Natural;
-
-end C760010_0;
-
--- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
-
-package body C760010_0 is
-
- Value : Natural := 101;
-
- function Unique return Natural is
- begin
- Value := Value +1;
- return Value;
- end Unique;
-
-end C760010_0;
-
----------------------------------------------------------------- C760010_0
------------------------------------------------------- Check_Formal_Tagged
-
-generic
-
- type Formal_Tagged is tagged private;
-
-package C760010_0.Check_Formal_Tagged is
-
- pragma Elaborate_Body;
-
- type Embedded_Derived is new Formal_Tagged with record
- TC_Meaningless_Value : Natural := Unique;
- end record;
-
- procedure Initialize( ED: in out Embedded_Derived );
- procedure Adjust ( ED: in out Embedded_Derived );
- procedure Finalize ( ED: in out Embedded_Derived );
-
-end C760010_0.Check_Formal_Tagged;
-
-
--- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
-
-with Report;
-package body C760010_0.Check_Formal_Tagged is
-
-
- procedure Initialize( ED: in out Embedded_Derived ) is
- begin
- ED.TC_Meaningless_Value := Unique;
- case Action is
- when Init_Raise_User_Defined => raise User_Defined_Exception;
- when Init_Raise_Standard => raise Tasking_Error;
- when others => null;
- end case;
- end Initialize;
-
- procedure Adjust ( ED: in out Embedded_Derived ) is
- begin
- ED.TC_Meaningless_Value := Unique;
- case Action is
- when Adj_Raise_User_Defined => raise User_Defined_Exception;
- when Adj_Raise_Standard => raise Tasking_Error;
- when others => null;
- end case;
- end Adjust;
-
- procedure Finalize ( ED: in out Embedded_Derived ) is
- begin
- ED.TC_Meaningless_Value := Unique;
- case Action is
- when Fin_Raise_User_Defined => raise User_Defined_Exception;
- when Fin_Raise_Standard => raise Tasking_Error;
- when others => null;
- end case;
- end Finalize;
-
-end C760010_0.Check_Formal_Tagged;
-
----------------------------------------------------------------- C760010_1
-
-with Ada.Finalization;
-package C760010_1 is
-
- procedure Check_Counters(Init,Adj,Fin : Natural; Message: String);
- procedure Reset_Counters;
-
- type Simple_Control is new Ada.Finalization.Controlled with record
- Item: Integer;
- end record;
- procedure Initialize( AV: in out Simple_Control );
- procedure Adjust ( AV: in out Simple_Control );
- procedure Finalize ( AV: in out Simple_Control );
-
-end C760010_1;
-
--- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
-
-with Report;
-package body C760010_1 is
-
- Initialize_Called : Natural;
- Adjust_Called : Natural;
- Finalize_Called : Natural;
-
- procedure Check_Counters(Init,Adj,Fin : Natural; Message: String) is
- begin
- if Init /= Initialize_Called then
- Report.Failed("Initialize mismatch " & Message);
- end if;
- if Adj /= Adjust_Called then
- Report.Failed("Adjust mismatch " & Message);
- end if;
- if Fin /= Finalize_Called then
- Report.Failed("Finalize mismatch " & Message);
- end if;
- end Check_Counters;
-
- procedure Reset_Counters is
- begin
- Initialize_Called := 0;
- Adjust_Called := 0;
- Finalize_Called := 0;
- end Reset_Counters;
-
- procedure Initialize( AV: in out Simple_Control ) is
- begin
- Initialize_Called := Initialize_Called +1;
- AV.Item := 0;
- end Initialize;
-
- procedure Adjust ( AV: in out Simple_Control ) is
- begin
- Adjust_Called := Adjust_Called +1;
- AV.Item := AV.Item +1;
- end Adjust;
-
- procedure Finalize ( AV: in out Simple_Control ) is
- begin
- Finalize_Called := Finalize_Called +1;
- AV.Item := AV.Item +1;
- end Finalize;
-
-end C760010_1;
-
----------------------------------------------------------------- C760010_2
-
-with C760010_0.Check_Formal_Tagged;
-with C760010_1;
-package C760010_2 is
- new C760010_0.Check_Formal_Tagged(C760010_1.Simple_Control);
-
----------------------------------------------------------------------------
-
-with Report;
-with C760010_0;
-with C760010_1;
-with C760010_2;
-procedure C760010 is
-
- use type C760010_0.Actions;
-
- procedure Case_Failure(Message: String) is
- begin
- Report.Failed(Message & " for case "
- & C760010_0.Actions'Image(C760010_0.Action) );
- end Case_Failure;
-
- procedure Check_Implicit_Initialize is
- Item : C760010_2.Embedded_Derived; -- exception here propagates to
- Gadget : C760010_2.Embedded_Derived; -- caller
- begin
- if C760010_0.Action
- in C760010_0.Init_Raise_User_Defined..C760010_0.Init_Raise_Standard
- then
- Case_Failure("Anticipated exception at implicit init");
- end if;
- begin
- Item := Gadget; -- exception here handled locally
- if C760010_0.Action in C760010_0.Adj_Raise_User_Defined
- .. C760010_0.Fin_Raise_Standard then
- Case_Failure ("Anticipated exception at assignment");
- end if;
- exception
- when Program_Error =>
- if C760010_0.Action not in C760010_0.Adj_Raise_User_Defined
- .. C760010_0.Fin_Raise_Standard then
- Report.Failed("Program_Error in Check_Implicit_Initialize");
- end if;
- when Tasking_Error =>
- Report.Failed("Tasking_Error in Check_Implicit_Initialize");
- when C760010_0.User_Defined_Exception =>
- Report.Failed("User_Error in Check_Implicit_Initialize");
- when others =>
- Report.Failed("Wrong exception Check_Implicit_Initialize");
- end;
- end Check_Implicit_Initialize;
-
----------------------------------------------------------------------------
-
- Global_Item : C760010_2.Embedded_Derived;
-
----------------------------------------------------------------------------
-
- procedure Check_Explicit_Initialize is
- begin
- begin
- C760010_2.Initialize( Global_Item );
- if C760010_0.Action
- in C760010_0.Init_Raise_User_Defined..C760010_0.Init_Raise_Standard
- then
- Case_Failure("Anticipated exception at explicit init");
- end if;
- exception
- when Program_Error =>
- Report.Failed("Program_Error in Check_Explicit_Initialize");
- when Tasking_Error =>
- if C760010_0.Action /= C760010_0.Init_Raise_Standard then
- Report.Failed("Tasking_Error in Check_Explicit_Initialize");
- end if;
- when C760010_0.User_Defined_Exception =>
- if C760010_0.Action /= C760010_0.Init_Raise_User_Defined then
- Report.Failed("User_Error in Check_Explicit_Initialize");
- end if;
- when others =>
- Report.Failed("Wrong exception in Check_Explicit_Initialize");
- end;
- end Check_Explicit_Initialize;
-
----------------------------------------------------------------------------
-
- procedure Check_Explicit_Adjust is
- begin
- begin
- C760010_2.Adjust( Global_Item );
- if C760010_0.Action
- in C760010_0.Adj_Raise_User_Defined..C760010_0.Adj_Raise_Standard
- then
- Case_Failure("Anticipated exception at explicit Adjust");
- end if;
- exception
- when Program_Error =>
- Report.Failed("Program_Error in Check_Explicit_Adjust");
- when Tasking_Error =>
- if C760010_0.Action /= C760010_0.Adj_Raise_Standard then
- Report.Failed("Tasking_Error in Check_Explicit_Adjust");
- end if;
- when C760010_0.User_Defined_Exception =>
- if C760010_0.Action /= C760010_0.Adj_Raise_User_Defined then
- Report.Failed("User_Error in Check_Explicit_Adjust");
- end if;
- when others =>
- Report.Failed("Wrong exception in Check_Explicit_Adjust");
- end;
- end Check_Explicit_Adjust;
-
----------------------------------------------------------------------------
-
- procedure Check_Explicit_Finalize is
- begin
- begin
- C760010_2.Finalize( Global_Item );
- if C760010_0.Action
- in C760010_0.Fin_Raise_User_Defined..C760010_0.Fin_Raise_Standard
- then
- Case_Failure("Anticipated exception at explicit Finalize");
- end if;
- exception
- when Program_Error =>
- Report.Failed("Program_Error in Check_Explicit_Finalize");
- when Tasking_Error =>
- if C760010_0.Action /= C760010_0.Fin_Raise_Standard then
- Report.Failed("Tasking_Error in Check_Explicit_Finalize");
- end if;
- when C760010_0.User_Defined_Exception =>
- if C760010_0.Action /= C760010_0.Fin_Raise_User_Defined then
- Report.Failed("User_Error in Check_Explicit_Finalize");
- end if;
- when others =>
- Report.Failed("Wrong exception in Check_Explicit_Finalize");
- end;
- end Check_Explicit_Finalize;
-
----------------------------------------------------------------------------
-
-begin -- Main test procedure.
-
- Report.Test ("C760010", "Check that explicit calls to finalization " &
- "procedures that raise exceptions propagate " &
- "the exception raised. Check the utilization " &
- "of a controlled type as the actual for a " &
- "generic formal tagged private parameter" );
-
- for Act in C760010_0.Actions loop
- C760010_1.Reset_Counters;
- C760010_0.Action := Act;
-
- begin
- Check_Implicit_Initialize;
- if Act in
- C760010_0.Init_Raise_User_Defined..C760010_0.Init_Raise_Standard then
- Case_Failure("No exception at Check_Implicit_Initialize");
- end if;
- exception
- when Tasking_Error =>
- if Act /= C760010_0.Init_Raise_Standard then
- Case_Failure("Tasking_Error at Check_Implicit_Initialize");
- end if;
- when C760010_0.User_Defined_Exception =>
- if Act /= C760010_0.Init_Raise_User_Defined then
- Case_Failure("User_Error at Check_Implicit_Initialize");
- end if;
- when Program_Error =>
- -- If finalize raises an exception, all other object are finalized
- -- first and Program_Error is raised upon leaving the master scope.
- -- 7.6.1:14
- if Act not in C760010_0.Fin_Raise_User_Defined..
- C760010_0.Fin_Raise_Standard then
- Case_Failure("Program_Error at Check_Implicit_Initialize");
- end if;
- when others =>
- Case_Failure("Wrong exception at Check_Implicit_Initialize");
- end;
-
- Check_Explicit_Initialize;
- Check_Explicit_Adjust;
- Check_Explicit_Finalize;
-
- C760010_1.Check_Counters(0,0,0, C760010_0.Actions'Image(Act));
-
- end loop;
-
- -- Set to No_Action to avoid exception in finalizing Global_Item
- C760010_0.Action := C760010_0.No_Action;
-
- Report.Result;
-
-end C760010;
diff --git a/gcc/testsuite/ada/acats/tests/c7/c760011.a b/gcc/testsuite/ada/acats/tests/c7/c760011.a
deleted file mode 100644
index 8df37fa3c8b..00000000000
--- a/gcc/testsuite/ada/acats/tests/c7/c760011.a
+++ /dev/null
@@ -1,291 +0,0 @@
--- C760011.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that the anonymous objects of a controlled type associated with
--- function results and aggregates are finalized no later than the
--- end of the innermost enclosing declarative_item or statement. Also
--- check this for function calls and aggregates of a noncontrolled type
--- with controlled components.
---
--- TEST DESCRIPTION:
--- This test defines a controlled type with a discriminant, the
--- discriminant is use as an index into a global table to indicate that
--- the object has been finalized. The controlled type is used as the
--- component of a non-controlled type, and the non-controlled type is
--- used for the same set of tests. Following is a table of the tests
--- performed and their associated tag character.
---
--- 7.6(21) allows for the optimizations that remove these temporary
--- objects from ever existing. As such this test checks that in the
--- case the object was initialized (the only access we have to
--- determining if it ever existed) it must subsequently be finalized.
---
--- CASE TABLE:
--- A - aggregate test, controlled
--- B - aggregate test, controlled
--- C - aggregate test, non_controlled
--- D - function test, controlled
--- E - function test, non_controlled
--- F - formal parameter function test, controlled
--- G - formal parameter aggregate test, controlled
--- H - formal parameter function test, non_controlled
--- I - formal parameter aggregate test, non_controlled
---
--- X - scratch object, not consequential to the objective
--- Y - scratch object, not consequential to the objective
--- Z - scratch object, not consequential to the objective
---
---
--- CHANGE HISTORY:
--- 22 MAY 95 SAIC Initial version
--- 24 APR 96 SAIC Minor doc fixes, visibility patch
--- 14 NOV 96 SAIC Revised for release 2.1
---
---!
-
-------------------------------------------------------------------- C760011_0
-
-with Ada.Finalization;
-package C760011_0 is
- type Tracking_Array is array(Character range 'A'..'Z') of Boolean;
-
- Initialized : Tracking_Array := (others => False);
- Finalized : Tracking_Array := (others => False);
-
- type Controlled_Type(Tag : Character) is
- new Ada.Finalization.Controlled with record
- TC_Component : String(1..4) := "ACVC";
- end record;
- procedure Initialize( It: in out Controlled_Type );
- procedure Finalize ( It: in out Controlled_Type );
- function Create(With_Tag: Character) return Controlled_Type;
-
- type Non_Controlled(Tag : Character := 'Y') is record
- Controlled_Component : Controlled_Type(Tag);
- end record;
- procedure Initialize( It: in out Non_Controlled );
- procedure Finalize ( It: in out Non_Controlled );
- function Create(With_Tag: Character) return Non_Controlled;
-
- Under_Debug : constant Boolean := False; -- construction lines
-
-end C760011_0;
-
--- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
-
-with Report;
-package body C760011_0 is
-
- procedure Initialize( It: in out Controlled_Type ) is
- begin
- It.TC_Component := (others => It.Tag);
- if It.Tag in Tracking_Array'Range then
- Initialized(It.Tag) := True;
- end if;
- if Under_Debug then
- Report.Comment("Initializing Tag: " & It.Tag );
- end if;
- end Initialize;
-
- procedure Finalize( It: in out Controlled_Type ) is
- begin
- if Under_Debug then
- Report.Comment("Finalizing for Tag: " & It.Tag );
- end if;
- if It.Tag in Finalized'Range then
- Finalized(It.Tag) := True;
- end if;
- end Finalize;
-
- function Create(With_Tag: Character) return Controlled_Type is
- begin
- return Controlled_Type'(Ada.Finalization.Controlled
- with Tag => With_Tag,
- TC_Component => "*CON" );
- end Create;
-
- procedure Initialize( It: in out Non_Controlled ) is
- begin
- Report.Failed("Called Initialize for Non_Controlled");
- end Initialize;
-
- procedure Finalize( It: in out Non_Controlled ) is
- begin
- Report.Failed("Called Finalize for Non_Controlled");
- end Finalize;
-
- function Create(With_Tag: Character) return Non_Controlled is
- begin
- return Non_Controlled'(Tag => With_Tag, Controlled_Component => (
- Ada.Finalization.Controlled
- with Tag => With_Tag,
- TC_Component => "#NON" ) );
- end Create;
-
-end C760011_0;
-
---------------------------------------------------------------------- C760011
-
-with Report;
-with TCTouch;
-with C760011_0;
-with Ada.Finalization; -- needed to be able to create extension aggregates
-procedure C760011 is
-
- use type C760011_0.Controlled_Type;
- use type C760011_0.Controlled_Type'Class;
- use type C760011_0.Non_Controlled;
-
- subtype AFC is Ada.Finalization.Controlled;
-
- procedure Check_Result( Tag : Character; Message : String ) is
- -- make allowance for 7.6(21) optimizations
- begin
- if C760011_0.Initialized(Tag) then
- TCTouch.Assert(C760011_0.Finalized(Tag),Message);
- elsif C760011_0.Under_Debug then
- Report.Comment("Optimized away: " & Tag );
- end if;
- end Check_Result;
-
- procedure Subtest_1 is
-
-
- procedure Subtest_1_Local_1 is
- An_Object : C760011_0.Controlled_Type'Class
- := C760011_0.Controlled_Type'(AFC with 'X', "ONE*");
- -- initialize An_Object
- begin
- if C760011_0.Controlled_Type(An_Object)
- = C760011_0.Controlled_Type'(AFC with 'A', "ONE*") then
- Report.Failed("Comparison bad"); -- A = X !!!
- end if;
- end Subtest_1_Local_1;
- -- An_Object must be Finalized by this point.
-
- procedure Subtest_1_Local_2 is
- An_Object : C760011_0.Controlled_Type('B');
- begin
- An_Object := (AFC with 'B', "TWO!" );
- if Report.Ident_Char(An_Object.Tag) /= 'B' then
- Report.Failed("Subtest_1_Local_2 Optimization Foil: Bad Data!");
- end if;
- exception
- when others => Report.Failed("Bad controlled assignment");
- end Subtest_1_Local_2;
- -- An_Object must be Finalized by this point.
-
- procedure Subtest_1_Local_3 is
- An_Object : C760011_0.Non_Controlled('C');
- begin
- TCTouch.Assert_Not(C760011_0.Finalized('C'),
- "Non_Controlled declaration C");
- An_Object := C760011_0.Non_Controlled'('C', Controlled_Component
- => (AFC with 'C', "TEE!"));
- if Report.Ident_Char(An_Object.Tag) /= 'C' then
- Report.Failed("Subtest_1_Local_3 Optimization Foil: Bad Data!");
- end if;
- end Subtest_1_Local_3;
- -- Only controlled components of An_Object must be finalized; it is an
- -- error to call Finalize for An_Object
-
- begin
- Subtest_1_Local_1;
- Check_Result( 'A', "Aggregate in subprogram 1" );
-
- Subtest_1_Local_2;
- Check_Result( 'B', "Aggregate in subprogram 2" );
-
- Subtest_1_Local_3;
- Check_Result( 'C', "Embedded aggregate in subprogram 3" );
- end Subtest_1;
-
-
- procedure Subtest_2 is
- -- using 'Z' for both evades order issues
- Con_Object : C760011_0.Controlled_Type('Z');
- Non_Object : C760011_0.Non_Controlled('Z');
- begin
- if Report.Ident_Bool( Con_Object = C760011_0.Create('D') ) then
- Report.Failed("Con_Object catastrophe");
- end if;
- -- Controlled function result should be finalized by now
- Check_Result( 'D', "Function Result" );
-
- if Report.Ident_Bool( Non_Object = C760011_0.Create('E') ) then
- Report.Failed("Non_Object catastrophe");
- end if;
- -- Controlled component of function result should be finalized by now
- Check_Result( 'E', "Function Result" );
- end Subtest_2;
-
-
- procedure Subtest_3(Con : in C760011_0.Controlled_Type) is
- begin
- if Con.Tag not in 'F'..'G' then
- Report.Failed("Bad value passed to subtest 3 " & Con.Tag & ' '
- & Report.Ident_Str(Con.TC_Component));
- end if;
- end Subtest_3;
-
-
- procedure Subtest_4(Non : in C760011_0.Non_Controlled) is
- begin
- if Non.Tag not in 'H'..'I' then
- Report.Failed("Bad value passed to subtest 4 "
- & Non.Tag & ' '
- & Report.Ident_Str(Non.Controlled_Component.TC_Component));
- end if;
- end Subtest_4;
-
-
-begin -- Main test procedure.
-
- Report.Test ("C760011", "Check that anonymous objects of controlled " &
- "types or types containing controlled types " &
- "are finalized no later than the end of the " &
- "innermost enclosing declarative_item or " &
- "statement" );
-
- Subtest_1;
-
- Subtest_2;
-
- Subtest_3(C760011_0.Create('F'));
- Check_Result( 'F', "Function as formal F" );
-
- Subtest_3(C760011_0.Controlled_Type'(AFC with 'G',"GIGI"));
- Check_Result( 'G', "Aggregate as formal G" );
-
- Subtest_4(C760011_0.Create('H'));
- Check_Result( 'H', "Function as formal H" );
-
- Subtest_4(C760011_0.Non_Controlled'('I', (AFC with 'I',"IAGO")));
- Check_Result( 'I', "Aggregate as formal I" );
-
- Report.Result;
-
-end C760011;
diff --git a/gcc/testsuite/ada/acats/tests/c7/c760012.a b/gcc/testsuite/ada/acats/tests/c7/c760012.a
deleted file mode 100644
index 08986a838c4..00000000000
--- a/gcc/testsuite/ada/acats/tests/c7/c760012.a
+++ /dev/null
@@ -1,256 +0,0 @@
--- C760012.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that record components that have per-object access discriminant
--- constraints are initialized in the order of their component
--- declarations, and after any components that are not so constrained.
---
--- Check that record components that have per-object access discriminant
--- constraints are finalized in the reverse order of their component
--- declarations, and before any components that are not so constrained.
---
--- TEST DESCRIPTION:
--- The type List_Item is the "container" type. It holds two fields that
--- have per-object access discriminant constraints, and two fields that
--- are not discriminated. These four fields are all controlled types.
--- A fifth field is a pointer used to maintain a linked list of these
--- data objects. Each component is of a unique type which allows for
--- the test to simply track the order of initialization and finalization.
---
--- The types and their purpose are:
--- Constrained_First - a controlled discriminated type
--- Constrained_Second - a controlled discriminated type
--- Simple_First - a controlled type with no discriminant
--- Simple_Second - a controlled type with no discriminant
---
--- The required order of operations:
--- Initialize
--- ( Simple_First | Simple_Second ) -- no "internal order" required
--- Constrained_First
--- Constrained_Second
--- Finalize
--- Constrained_Second
--- Constrained_First
--- ( Simple_First | Simple_Second ) -- must be inverse of init.
---
---
--- CHANGE HISTORY:
--- 23 MAY 95 SAIC Initial version
--- 02 MAY 96 SAIC Reorganized for 2.1
--- 05 DEC 96 SAIC Simplified for 2.1; added init/fin ordering check
--- 31 DEC 97 EDS Remove references to and uses of
--- Initialization_Sequence
---!
-
----------------------------------------------------------------- C760012_0
-
-with Ada.Finalization;
-with Ada.Unchecked_Deallocation;
-package C760012_0 is
-
- type List_Item;
-
- type List is access all List_Item;
-
- package Firsts is -- distinguish first from second
- type Constrained_First(Container : access List_Item) is
- new Ada.Finalization.Limited_Controlled with null record;
- procedure Initialize( T : in out Constrained_First );
- procedure Finalize ( T : in out Constrained_First );
-
- type Simple_First is new Ada.Finalization.Controlled with
- record
- My_Init_Seq_Number : Natural;
- end record;
- procedure Initialize( T : in out Simple_First );
- procedure Finalize ( T : in out Simple_First );
-
- end Firsts;
-
- type Constrained_Second(Container : access List_Item) is
- new Ada.Finalization.Limited_Controlled with null record;
- procedure Initialize( T : in out Constrained_Second );
- procedure Finalize ( T : in out Constrained_Second );
-
- type Simple_Second is new Ada.Finalization.Controlled with
- record
- My_Init_Seq_Number : Natural;
- end record;
- procedure Initialize( T : in out Simple_Second );
- procedure Finalize ( T : in out Simple_Second );
-
- -- by 3.8(18);6.0 the following type contains components constrained
- -- by per-object expressions
-
-
- type List_Item is new Ada.Finalization.Limited_Controlled
- with record
- ContentA : Firsts.Constrained_First( List_Item'Access ); -- C S
- SimpleA : Firsts.Simple_First; -- A T
- SimpleB : Simple_Second; -- A T
- ContentB : Constrained_Second( List_Item'Access ); -- D R
- Next : List; -- | |
- end record; -- | |
- procedure Initialize( L : in out List_Item ); ------------------+ |
- procedure Finalize ( L : in out List_Item ); --------------------+
-
- -- the tags are the same for SimpleA and SimpleB due to the fact that
- -- the language does not specify an ordering with respect to this
- -- component pair. 7.6(12) does specify the rest of the ordering.
-
- procedure Deallocate is new Ada.Unchecked_Deallocation(List_Item,List);
-
-end C760012_0;
-
--- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
-
-with TCTouch;
-package body C760012_0 is
-
- package body Firsts is
-
- procedure Initialize( T : in out Constrained_First ) is
- begin
- TCTouch.Touch('C'); ----------------------------------------------- C
- end Initialize;
-
- procedure Finalize ( T : in out Constrained_First ) is
- begin
- TCTouch.Touch('S'); ----------------------------------------------- S
- end Finalize;
-
- procedure Initialize( T : in out Simple_First ) is
- begin
- T.My_Init_Seq_Number := 0;
- TCTouch.Touch('A'); ----------------------------------------------- A
- end Initialize;
-
- procedure Finalize ( T : in out Simple_First ) is
- begin
- TCTouch.Touch('T'); ----------------------------------------------- T
- end Finalize;
-
- end Firsts;
-
- procedure Initialize( T : in out Constrained_Second ) is
- begin
- TCTouch.Touch('D'); ------------------------------------------------- D
- end Initialize;
-
- procedure Finalize ( T : in out Constrained_Second ) is
- begin
- TCTouch.Touch('R'); ------------------------------------------------- R
- end Finalize;
-
-
- procedure Initialize( T : in out Simple_Second ) is
- begin
- T.My_Init_Seq_Number := 0;
- TCTouch.Touch('A'); ------------------------------------------------- A
- end Initialize;
-
- procedure Finalize ( T : in out Simple_Second ) is
- begin
- TCTouch.Touch('T'); ------------------------------------------------- T
- end Finalize;
-
- procedure Initialize( L : in out List_Item ) is
- begin
- TCTouch.Touch('F'); ------------------------------------------------- F
- end Initialize;
-
- procedure Finalize ( L : in out List_Item ) is
- begin
- TCTouch.Touch('Q'); ------------------------------------------------- Q
- end Finalize;
-
-end C760012_0;
-
---------------------------------------------------------------------- C760012
-
-with Report;
-with TCTouch;
-with C760012_0;
-procedure C760012 is
-
- use type C760012_0.List;
-
- procedure Subtest_1 is
- -- by 3.8(18);6.0 One_Of_Them is constrained by per-object constraints
- -- 7.6.1(9);6.0 dictates the order of finalization of the components
-
- One_Of_Them : C760012_0.List_Item;
- begin
- if One_Of_Them.Next /= null then -- just to hold the subtest in place
- Report.Failed("No default value for Next");
- end if;
- end Subtest_1;
-
- List : C760012_0.List;
-
- procedure Subtest_2 is
- begin
-
- List := new C760012_0.List_Item;
-
- List.Next := new C760012_0.List_Item;
-
- end Subtest_2;
-
- procedure Subtest_3 is
- begin
-
- C760012_0.Deallocate( List.Next );
-
- C760012_0.Deallocate( List );
-
- end Subtest_3;
-
-begin -- Main test procedure.
-
- Report.Test ("C760012", "Check that record components that have " &
- "per-object access discriminant constraints " &
- "are initialized in the order of their " &
- "component declarations, and after any " &
- "components that are not so constrained. " &
- "Check that record components that have " &
- "per-object access discriminant constraints " &
- "are finalized in the reverse order of their " &
- "component declarations, and before any " &
- "components that are not so constrained" );
-
- Subtest_1;
- TCTouch.Validate("AACDFQRSTT", "One object");
-
- Subtest_2;
- TCTouch.Validate("AACDFAACDF", "Two objects dynamically allocated");
-
- Subtest_3;
- TCTouch.Validate("QRSTTQRSTT", "Two objects deallocated");
-
- Report.Result;
-
-end C760012;
diff --git a/gcc/testsuite/ada/acats/tests/c7/c760013.a b/gcc/testsuite/ada/acats/tests/c7/c760013.a
deleted file mode 100644
index 6921bf02764..00000000000
--- a/gcc/testsuite/ada/acats/tests/c7/c760013.a
+++ /dev/null
@@ -1,108 +0,0 @@
--- C760013.A
---
--- Grant of Unlimited Rights
---
--- The Ada Conformity Assessment Authority (ACAA) holds unlimited
--- rights in the software and documentation contained herein. Unlimited
--- rights are the same as those granted by the U.S. Government for older
--- parts of the Ada Conformity Assessment Test Suite, and are defined
--- in DFAR 252.227-7013(a)(19). By making this public release, the ACAA
--- intends to confer upon all recipients unlimited rights equal to those
--- held by the ACAA. These rights include rights to use, duplicate,
--- release or disclose the released technical data and computer software
--- in whole or in part, in any manner and for any purpose whatsoever, and
--- to have or permit others to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that Initialize is not called for default-initialized subcomponents
--- of the ancestor type of an extension aggregate. (Defect Report
--- 8652/0021, Technical Corrigendum 7.6(11/1)).
---
--- CHANGE HISTORY:
--- 25 JAN 2001 PHL Initial version.
--- 29 JUN 2001 RLB Reformatted for ACATS.
---
---!
-with Ada.Finalization;
-use Ada.Finalization;
-package C760013_0 is
-
- type Ctrl1 is new Controlled with
- record
- C : Integer := 0;
- end record;
- type Ctrl2 is new Controlled with
- record
- C : Integer := 0;
- end record;
-
- procedure Initialize (Obj1 : in out Ctrl1);
- procedure Initialize (Obj2 : in out Ctrl2);
-
-end C760013_0;
-
-with Report;
-use Report;
-package body C760013_0 is
-
- procedure Initialize (Obj1 : in out Ctrl1) is
- begin
- Obj1.C := Ident_Int (47);
- end Initialize;
-
- procedure Initialize (Obj2 : in out Ctrl2) is
- begin
- Failed ("Initialize called for type Ctrl2");
- end Initialize;
-
-end C760013_0;
-
-with Ada.Finalization;
-with C760013_0;
-use C760013_0;
-with Report;
-use Report;
-procedure C760013 is
-
- type T is tagged
- record
- C1 : Ctrl1;
- C2 : Ctrl2 := (Ada.Finalization.Controlled with
- C => Ident_Int (23));
- end record;
-
- type Nt is new T with
- record
- C3 : Float;
- end record;
-
- X : Nt;
-
-begin
- Test ("C760013",
- "Check that Initialize is not called for " &
- "default-initialized subcomponents of the ancestor type of an " &
- "extension aggregate");
-
- X := (T with C3 => 5.0);
-
- if X.C1.C /= Ident_Int (47) then
- Failed ("Initialize not called for type Ctrl1");
- end if;
- if X.C2.C /= Ident_Int (23) then
- Failed ("Initial value not assigned for type Ctrl2");
- end if;
-
- Result;
-end C760013;
-
diff --git a/gcc/testsuite/ada/acats/tests/c7/c761001.a b/gcc/testsuite/ada/acats/tests/c7/c761001.a
deleted file mode 100644
index 7be1ee07a93..00000000000
--- a/gcc/testsuite/ada/acats/tests/c7/c761001.a
+++ /dev/null
@@ -1,117 +0,0 @@
--- C761001.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that controlled objects declared immediately within a library
--- package are finalized following the completion of the environment
--- task (and prior to termination of the program).
---
--- TEST DESCRIPTION:
--- This test derives a type from Ada.Finalization.Controlled, and
--- declares an object of that type in the body of a library package.
--- The dispatching procedure Finalize is redefined for the derived
--- type to perform a check that it has been called only once, and in
--- turn calls Report.Result. This test may fail by not calling
--- Report.Result. This test may also fail by calling Report.Result
--- twice, the first call will report a false pass.
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 13 Nov 95 SAIC Updated for ACVC 2.0.1
---
---!
-
-with Ada.Finalization;
-package C761001_0 is
-
- type Global is new Ada.Finalization.Controlled with null record;
- procedure Finalize( It: in out Global );
-
-end C761001_0;
-
-package C761001_1 is
-
- task Library_Task is
- entry Never_Called;
- end Library_Task;
-
-end C761001_1;
-
-with Report;
-with C761001_1;
-package body C761001_0 is
-
- My_Object : Global;
-
- Done : Boolean := False;
-
- procedure Finalize( It: in out Global ) is
- begin
- if not C761001_1.Library_Task'Terminated then
- Report.Failed("Library task not terminated before finalize");
- end if;
- if Done then -- checking included "just in case"
- Report.Comment("Test FAILED, even if previously reporting passed");
- Report.Failed("Unwarranted multiple call to finalize");
- end if;
- Report.Result;
- Done := True;
- end Finalize;
-
-end C761001_0;
-
-with Report;
-package body C761001_1 is
-
- task body Library_Task is
- begin
- if Report.Ident_Int( 1 ) /= 1 then
- Report.Failed( "Baseline failure in Library_Task");
- end if;
- end Library_Task;
-
-end C761001_1;
-
-with Report;
-with C761001_0;
-
-procedure C761001 is
-
-begin -- Main test procedure.
-
- Report.Test ("C761001", "Check that controlled objects declared "
- & "immediately within a library package are "
- & "finalized following the completion of the "
- & "environment task (and prior to termination "
- & "of the program)");
-
- -- note that if the test DOES call report twice, the first will report a
- -- false pass, the second call will correctly fail the test.
-
- -- not calling Report.Result;
- -- Result is called as part of the finalization of C761001_0.My_Object.
-
-end C761001;
diff --git a/gcc/testsuite/ada/acats/tests/c7/c761002.a b/gcc/testsuite/ada/acats/tests/c7/c761002.a
deleted file mode 100644
index 5b807bba720..00000000000
--- a/gcc/testsuite/ada/acats/tests/c7/c761002.a
+++ /dev/null
@@ -1,245 +0,0 @@
--- C761002.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that objects of a controlled type that are created
--- by an allocator are finalized at the appropriate time. In
--- particular, check that such objects are not finalized due to
--- completion of the master in which they were allocated if the
--- corresponding access type is declared outside of that master.
---
--- Check that Unchecked_Deallocation of a controlled
--- object causes finalization of that object.
---
--- TEST DESCRIPTION:
--- This test derives a type from Ada.Finalization.Controlled, and
--- declares access types to that type in various scope scenarios.
--- The dispatching procedure Finalize is redefined for the derived
--- type to perform a check that it has been called at the
--- correct time. This is accomplished using a global variable
--- which indicates what state the software is currently
--- executing. The test utilizes the TCTouch facilities to
--- verify that Finalize is called the correct number of times, at
--- the correct times. Several calls are made to validate passing
--- the null string to check that Finalize has NOT been called at
--- that point.
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
---
---!
-
-with Ada.Finalization;
-package C761002_0 is
- type Global is new Ada.Finalization.Controlled with null record;
- procedure Finalize( It: in out Global );
-
- type Second is new Ada.Finalization.Limited_Controlled with null record;
- procedure Finalize( It: in out Second );
-end C761002_0;
-
-with Report;
-with TCTouch;
-package body C761002_0 is
-
- procedure Finalize( It: in out Global ) is
- begin
- TCTouch.Touch('F'); ------------------------------------------------- F
- end Finalize;
-
- procedure Finalize( It: in out Second ) is
- begin
- TCTouch.Touch('S'); ------------------------------------------------- S
- end Finalize;
-end C761002_0;
-
-with Report;
-with TCTouch;
-with C761002_0;
-with Unchecked_Deallocation;
-procedure C761002 is
-
- -- check the straightforward case
- procedure Subtest_1 is
- type Access_1 is access C761002_0.Global;
- V1 : Access_1;
- procedure Allocate is
- V2 : Access_1;
- begin
- V2 := new C761002_0.Global;
- V1 := V2; -- "dead" assignment must not be optimized away due to
- -- finalization "side effects", many more of these follow
- end Allocate;
- begin
- Allocate;
- -- no calls to Finalize should have occurred at this point
- TCTouch.Validate("","Allocated nested, retained");
- end Subtest_1;
-
- -- check Unchecked_Deallocation
- procedure Subtest_2 is
- type Access_2 is access C761002_0.Global;
- procedure Free is
- new Unchecked_Deallocation(C761002_0.Global, Access_2);
- V1 : Access_2;
- V2 : Access_2;
-
- procedure Allocate is
- begin
- V1 := new C761002_0.Global;
- V2 := new C761002_0.Global;
- end Allocate;
-
- begin
- Allocate;
- -- no calls to Finalize should have occurred at this point.
- TCTouch.Validate("","Allocated nested, non-local");
-
- Free(V1); -- instance of Unchecked_Deallocation
- -- should cause the finalization of V1.all
- TCTouch.Validate("F","Unchecked Deallocation");
- end Subtest_2; -- leaving this scope should cause the finalization of V2.all
-
- -- check various master-exit scenarios
- -- the "Fake" parameters are used to avoid unwanted optimizations
- procedure Subtest_3 is
- procedure With_Local_Block is
- type Access_3 is access C761002_0.Global;
- V1 : Access_3;
- begin
- declare
- V2 : Access_3 := new C761002_0.Global;
- begin
- V1 := V2;
- end;
- TCTouch.Validate("","Local Block, normal exit");
- -- the allocated object should be finalized on leaving this scope
- end With_Local_Block;
-
- procedure With_Local_Block_Return(Fake: Integer) is
- type Access_4 is access C761002_0.Global;
- V1 : Access_4 := new C761002_0.Global;
- begin
- if Fake = 0 then
- declare
- V2 : Access_4;
- begin
- V2 := new C761002_0.Global;
- return; -- the two allocated objects should be finalized
- end; -- upon leaving this scope
- else
- V1 := null;
- end if;
- end With_Local_Block_Return;
-
- procedure With_Goto(Fake: Integer) is
- type Access_5 is access C761002_0.Global;
- V1 : Access_5 := new C761002_0.Global;
- V2 : Access_5;
- V3 : Access_5;
- begin
- if Fake = 0 then
- declare
- type Access_6 is access C761002_0.Second;
- V6 : Access_6;
- begin
- V6 := new C761002_0.Second;
- goto check;
- end;
- else
- V2 := V1;
- end if;
- V3 := V2;
-<<check>>
- TCTouch.Validate("S","goto past master end");
- end With_Goto;
-
- begin
- With_Local_Block;
- TCTouch.Validate("F","Local Block, normal exit, after master");
-
- With_Local_Block_Return( Report.Ident_Int(0) );
- TCTouch.Validate("FF","Local Block, return from block");
-
- With_Goto( Report.Ident_Int(0) );
- TCTouch.Validate("F","With Goto");
-
- end Subtest_3;
-
- procedure Subtest_4 is
-
- Oops : exception;
-
- procedure Alley( Fake: Integer ) is
- type Access_1 is access C761002_0.Global;
- V1 : Access_1;
- begin
- V1 := new C761002_0.Global;
- if Fake = 1 then
- raise Oops;
- end if;
- V1 := null;
- end Alley;
-
- begin
- Catch: begin
- Alley( Report.Ident_Int(1) );
- exception
- when Oops => TCTouch.Validate("F","leaving via exception");
- when others => Report.Failed("Wrong exception");
- end Catch;
- end Subtest_4;
-
-begin -- Main test procedure.
-
- Report.Test ("C761002", "Check that objects of a controlled type created "
- & "by an allocator are finalized appropriately. "
- & "Check that Unchecked_Deallocation of a "
- & "controlled object causes finalization "
- & "of that object" );
-
- Subtest_1;
- -- leaving the scope of the access type should finalize the
- -- collection
- TCTouch.Validate("F","Allocated nested, Subtest 1");
-
- Subtest_2;
- -- Unchecked_Deallocation already finalized one of the two
- -- objects allocated, the other should be the only one finalized
- -- at leaving the scope of the access type.
- TCTouch.Validate("F","Allocated non-local");
-
- Subtest_3;
- -- there should be no remaining finalizations from this subtest
- TCTouch.Validate("","Localized objects");
-
- Subtest_4;
- -- there should be no remaining finalizations from this subtest
- TCTouch.Validate("","Exception testing");
-
- Report.Result;
-
-end C761002;
diff --git a/gcc/testsuite/ada/acats/tests/c7/c761003.a b/gcc/testsuite/ada/acats/tests/c7/c761003.a
deleted file mode 100644
index 77051ee4a93..00000000000
--- a/gcc/testsuite/ada/acats/tests/c7/c761003.a
+++ /dev/null
@@ -1,447 +0,0 @@
--- C761003.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that an object of a controlled type is finalized when the
--- enclosing master is complete.
--- Check this for controlled types where the derived type has a
--- discriminant.
--- Check this for subprograms of abstract types derived from the
--- types in Ada.Finalization.
---
--- Check that finalization of controlled objects is
--- performed in the correct order. In particular, check that if
--- multiple objects of controlled types are declared immediately
--- within the same declarative part then type are finalized in the
--- reverse order of their creation.
---
--- TEST DESCRIPTION:
--- This test checks these conditions for subprograms and
--- block statements; both variables and constants of controlled
--- types; cases of a controlled component of a record type, as
--- well as an array with controlled components.
---
--- The base controlled types used for the test are defined
--- with a character discriminant. The initialize procedure for
--- the types will record the order of creation in a globally
--- accessible array, the finalize procedure for the types will call
--- TCTouch with that tag character. The test can then check that
--- the order of finalization is indeed the reverse of the order of
--- creation (assuming that the implementation calls Initialize in
--- the order that the objects are created).
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 02 Nov 95 SAIC ACVC 2.0.1
---
---!
-
------------------------------------------------------------- C761003_Support
-
-package C761003_Support is
-
- function Pick_Char return Character;
- -- successive calls to Pick_Char return distinct characters which may
- -- be assigned to objects to track an order sequence. These characters
- -- are then used in calls to TCTouch.Touch.
-
- procedure Validate(Initcount : Natural;
- Testnumber : Natural;
- Check_Order : Boolean := True);
- -- does a little extra processing prior to calling TCTouch.Validate,
- -- specifically, it reverses the stored string of characters, and checks
- -- for a correct count.
-
- Inits_Order : String(1..255);
- Inits_Called : Natural := 0;
-
-end C761003_Support;
-
--- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
-
-with Report;
-with TCTouch;
-package body C761003_Support is
- type Pick_Rotation is mod 52;
- type Pick_String is array(Pick_Rotation) of Character;
-
- From : constant Pick_String := "ABCDEFGHIJKLMNOPQRSTUVWXYZ"
- & "abcdefghijklmnopqrstuvwxyz";
- Recent_Pick : Pick_Rotation := Pick_Rotation'Last;
-
- function Pick_Char return Character is
- begin
- Recent_Pick := Recent_Pick +1;
- return From(Recent_Pick);
- end Pick_Char;
-
- function Invert(S:String) return String is
- T: String(1..S'Length);
- begin
- for SI in reverse S'Range loop
- T(S'Last - SI + 1) := S(SI);
- end loop;
- return T;
- end Invert;
-
- procedure Validate(Initcount : Natural;
- Testnumber : Natural;
- Check_Order : Boolean := True) is
- Number : constant String := Natural'Image(Testnumber);
- begin
- if Inits_Called /= Initcount then
- Report.Failed("Got" & Natural'Image(Inits_Called) & " inits, expected"
- & Natural'Image(Initcount) & ", Subtest " & Number);
- TCTouch.Flush;
- else
- TCTouch.Validate(
- Invert(Inits_Order(1..Inits_Called)),
- "Subtest " & Number, Order_Meaningful => Check_Order );
- end if;
- Inits_Called := 0; -- reset for the next batch
- end Validate;
-
-end C761003_Support;
-
------------------------------------------------------------------- C761003_0
-
-with Ada.Finalization;
-package C761003_0 is
-
- type Global(Tag: Character) is new Ada.Finalization.Controlled
- with null record;
-
- procedure Initialize( It: in out Global );
- procedure Finalize ( It: in out Global );
-
- Null_Global : Global('1') := (Ada.Finalization.Controlled with Tag => '1');
-
- type Second(Tag: Character) is new Ada.Finalization.Limited_Controlled
- with null record;
-
- procedure Initialize( It: in out Second );
- procedure Finalize ( It: in out Second );
-
-end C761003_0;
-
------------------------------------------------------------------- C761003_1
-
-with Ada.Finalization;
-package C761003_1 is
-
- type Global is abstract new Ada.Finalization.Controlled with record
- Tag: Character;
- end record;
-
- procedure Initialize( It: in out Global );
- procedure Finalize ( It: in out Global );
-
- type Second is abstract new Ada.Finalization.Limited_Controlled with record
- Tag: Character;
- end record;
-
- procedure Initialize( It: in out Second );
- procedure Finalize ( It: in out Second );
-
-end C761003_1;
-
------------------------------------------------------------------- C761003_2
-
-with C761003_1;
-package C761003_2 is
-
- type Global is new C761003_1.Global with null record;
- -- inherits Initialize and Finalize
-
- type Second is new C761003_1.Second with null record;
- -- inherits Initialize and Finalize
-
-end C761003_2;
-
--- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- C761003_0
-
-with TCTouch;
-with C761003_Support;
-package body C761003_0 is
-
- package Sup renames C761003_Support;
-
- procedure Initialize( It: in out Global ) is
- begin
- Sup.Inits_Called := Sup.Inits_Called +1;
- Sup.Inits_Order(Sup.Inits_Called) := It.Tag;
- end Initialize;
-
- procedure Finalize( It: in out Global ) is
- begin
- TCTouch.Touch(It.Tag); --------------------------------------------- Tag
- end Finalize;
-
- procedure Initialize( It: in out Second ) is
- begin
- Sup.Inits_Called := Sup.Inits_Called +1;
- Sup.Inits_Order(Sup.Inits_Called) := It.Tag;
- end Initialize;
-
- procedure Finalize( It: in out Second ) is
- begin
- TCTouch.Touch(It.Tag); --------------------------------------------- Tag
- end Finalize;
-
-end C761003_0;
-
--- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- C761003_1
-
-with TCTouch;
-with C761003_Support;
-package body C761003_1 is
-
- package Sup renames C761003_Support;
-
- procedure Initialize( It: in out Global ) is
- begin
- Sup.Inits_Called := Sup.Inits_Called +1;
- It.Tag := Sup.Pick_Char;
- Sup.Inits_Order(Sup.Inits_Called) := It.Tag;
- end Initialize;
-
- procedure Finalize( It: in out Global ) is
- begin
- TCTouch.Touch(It.Tag); --------------------------------------------- Tag
- end Finalize;
-
- procedure Initialize( It: in out Second ) is
- begin
- Sup.Inits_Called := Sup.Inits_Called +1;
- It.Tag := Sup.Pick_Char;
- Sup.Inits_Order(Sup.Inits_Called) := It.Tag;
- end Initialize;
-
- procedure Finalize( It: in out Second ) is
- begin
- TCTouch.Touch(It.Tag); --------------------------------------------- Tag
- end Finalize;
-
-end C761003_1;
-
--------------------------------------------------------------------- C761003
-
-with Report;
-with TCTouch;
-with C761003_0;
-with C761003_2;
-with C761003_Support;
-procedure C761003 is
-
- package Sup renames C761003_Support;
-
----------------------------------------------------------------- Subtest_1
-
- Subtest_1_Inits_Expected : constant := 5; -- includes 1 previous
-
- procedure Subtest_1 is
-
- -- the constant will take its constraint from the value.
- -- must be declared first to be finalized last (and take the
- -- initialize from before calling subtest_1)
- Item_1 : constant C761003_0.Global := C761003_0.Null_Global;
-
- -- Item_2, declared second, should be finalized second to last.
- Item_2 : C761003_0.Global(Sup.Pick_Char);
-
- -- Item_3 and Item_4 will be created in the order of the
- -- list.
- Item_3, Item_4 : C761003_0.Global(Sup.Pick_Char);
-
- -- Item_5 will be finalized first.
- Item_5 : C761003_0.Second(Sup.Pick_Char);
-
- begin
- if Item_3.Tag >= Item_4.Tag then
- Report.Failed("Controlled objects created by list in wrong order");
- end if;
- -- check that nothing has happened yet!
- TCTouch.Validate("","Subtest 1 body");
- end Subtest_1;
-
----------------------------------------------------------------- Subtest_2
-
- -- These declarations should cause calls to initialize and
- -- finalize. The expected operations are the subprograms associated
- -- with the abstract types. Note that for these objects, the
- -- Initialize and Finalize are visible only by inheritance.
-
- Subtest_2_Inits_Expected : constant := 4;
-
- procedure Subtest_2 is
-
- Item_1 : C761003_2.Global;
- Item_2, Item_3 : C761003_2.Global;
- Item_4 : C761003_2.Second;
-
- begin
- -- check that nothing has happened yet!
- TCTouch.Validate("","Subtest 2 body");
- end Subtest_2;
-
----------------------------------------------------------------- Subtest_3
-
- -- Test for controlled objects embedded in arrays. Using structures
- -- that will cause a checkable order.
-
- Subtest_3_Inits_Expected : constant := 8;
-
- procedure Subtest_3 is
-
- type Global_List is array(Natural range <>)
- of C761003_0.Global(Sup.Pick_Char);
-
- Items : Global_List(1..4); -- components have the same tag
-
- type Second_List is array(Natural range <>)
- of C761003_0.Second(Sup.Pick_Char);
-
- Second_Items : Second_List(1..4); -- components have the same tag,
- -- distinct from the tag used in Items
-
- begin
- -- check that nothing has happened yet!
- TCTouch.Validate("","Subtest 3 body");
- end Subtest_3;
-
----------------------------------------------------------------- Subtest_4
-
- -- These declarations should cause dispatching calls to initialize and
- -- finalize. The expected operations are the subprograms associated
- -- with the abstract types.
-
- Subtest_4_Inits_Expected : constant := 2;
-
- procedure Subtest_4 is
-
- type Global_Rec is record
- Item1: C761003_0.Global(Sup.Pick_Char);
- end record;
-
- type Second_Rec is record
- Item2: C761003_2.Second;
- end record;
-
- G : Global_Rec;
- S : Second_Rec;
-
- begin
- -- check that nothing has happened yet!
- TCTouch.Validate("","Subtest 4 body");
- end Subtest_4;
-
----------------------------------------------------------------- Subtest_5
-
- -- Test for controlled objects embedded in arrays. In these cases, the
- -- order of the finalization of the components is not defined by the
- -- language.
-
- Subtest_5_Inits_Expected : constant := 8;
-
- procedure Subtest_5 is
-
-
- type Another_Global_List is array(Natural range <>)
- of C761003_2.Global;
-
- More_Items : Another_Global_List(1..4);
-
- type Another_Second_List is array(Natural range <>)
- of C761003_2.Second;
-
- Second_More_Items : Another_Second_List(1..4);
-
- begin
- -- check that nothing has happened yet!
- TCTouch.Validate("","Subtest 5 body");
- end Subtest_5;
-
----------------------------------------------------------------- Subtest_6
-
- -- These declarations should cause dispatching calls to initialize and
- -- finalize. The expected operations are the subprograms associated
- -- with the abstract types.
-
- Subtest_6_Inits_Expected : constant := 2;
-
- procedure Subtest_6 is
-
- type Global_Rec is record
- Item2: C761003_2.Global;
- end record;
-
- type Second_Rec is record
- Item1: C761003_0.Second(Sup.Pick_Char);
- end record;
-
- G : Global_Rec;
- S : Second_Rec;
-
- begin
- -- check that nothing has happened yet!
- TCTouch.Validate("","Subtest 6 body");
- end Subtest_6;
-
-begin -- Main test procedure.
-
- Report.Test ("C761003", "Check that an object of a controlled type "
- & "is finalized when the enclosing master is "
- & "complete, left by a transfer of control, "
- & "and performed in the correct order" );
-
- -- adjust for optional adjusts and initializes for C761003_0.Null_Global
- TCTouch.Flush; -- clear the optional adjust
- if Sup.Inits_Called /= 1 then
- -- C761003_0.Null_Global did not get "initialized"
- C761003_0.Initialize(C761003_0.Null_Global); -- prime the pump
- end if;
-
- Subtest_1;
- Sup.Validate(Subtest_1_Inits_Expected, 1);
-
- Subtest_2;
- Sup.Validate(Subtest_2_Inits_Expected, 2);
-
- Subtest_3;
- Sup.Validate(Subtest_3_Inits_Expected, 3);
-
- Subtest_4;
- Sup.Validate(Subtest_4_Inits_Expected, 4);
-
- Subtest_5;
- Sup.Validate(Subtest_5_Inits_Expected, 5, Check_Order => False);
-
- Subtest_6;
- Sup.Validate(Subtest_6_Inits_Expected, 6);
-
- Report.Result;
-
-end C761003;
diff --git a/gcc/testsuite/ada/acats/tests/c7/c761004.a b/gcc/testsuite/ada/acats/tests/c7/c761004.a
deleted file mode 100644
index 9b88382b44f..00000000000
--- a/gcc/testsuite/ada/acats/tests/c7/c761004.a
+++ /dev/null
@@ -1,305 +0,0 @@
--- C761004.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that an object of a controlled type is finalized with the
--- enclosing master is complete.
--- Check that finalization occurs in the case where the master is
--- left by a transfer of control.
--- Specifically check for types where the derived types do not have
--- discriminants.
---
--- Check that finalization of controlled objects is
--- performed in the correct order. In particular, check that if
--- multiple objects of controlled types are declared immediately
--- within the same declarative part then they are finalized in the
--- reverse order of their creation.
---
--- TEST DESCRIPTION:
--- This test checks these conditions for subprograms and
--- block statements; both variables and constants of controlled
--- types; cases of a controlled component of a record type, as
--- well as an array with controlled components.
---
--- The base controlled types used for the test are defined
--- with a character discriminant. The initialize procedure for
--- the types will record the order of creation in a globally
--- accessible array, the finalize procedure for the types will call
--- TCTouch with that tag character. The test can then check that
--- the order of finalization is indeed the reverse of the order of
--- creation (assuming that the implementation calls Initialize in
--- the order that the objects are created).
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 04 Nov 95 SAIC Fixed bugs for ACVC 2.0.1
---
---!
-
-package C761004_Support is
-
- function Pick_Char return Character;
- -- successive calls to Pick_Char return distinct characters which may
- -- be assigned to objects to track an order sequence. These characters
- -- are then used in calls to TCTouch.Touch.
-
- procedure Validate(Initcount: Natural; Testnumber:Natural);
- -- does a little extra processing prior to calling TCTouch.Validate,
- -- specifically, it reverses the stored string of characters, and checks
- -- for a correct count.
-
- Inits_Order : String(1..255);
- Inits_Called : Natural := 0;
-
-end C761004_Support;
-
-with Report;
-with TCTouch;
-package body C761004_Support is
- type Pick_Rotation is mod 52;
- type Pick_String is array(Pick_Rotation) of Character;
-
- From : constant Pick_String := "ABCDEFGHIJKLMNOPQRSTUVWXYZ"
- & "abcdefghijklmnopqrstuvwxyz";
- Recent_Pick : Pick_Rotation := Pick_Rotation'Last;
-
- function Pick_Char return Character is
- begin
- Recent_Pick := Recent_Pick +1;
- return From(Recent_Pick);
- end Pick_Char;
-
- function Invert(S:String) return String is
- T: String(1..S'Length);
- TI: Positive := 1;
- begin
- for SI in reverse S'Range loop
- T(TI) := S(SI);
- TI := TI +1;
- end loop;
- return T;
- end Invert;
-
- procedure Validate(Initcount: Natural; Testnumber:Natural) is
- Number : constant String := Natural'Image(Testnumber);
- begin
- if Inits_Called /= Initcount then
- Report.Failed("Wrong number of inits, Subtest " & Number);
- TCTouch.Flush;
- else
- TCTouch.Validate(
- Invert(Inits_Order(1..Inits_Called)),
- "Subtest " & Number, True);
- end if;
- end Validate;
-
-end C761004_Support;
-
------------------------------------------------------------------ C761004_0
-
-with Ada.Finalization;
-package C761004_0 is
- type Global is new Ada.Finalization.Controlled with record
- Tag : Character;
- end record;
- procedure Initialize( It: in out Global );
- procedure Finalize ( It: in out Global );
-
- type Second is new Ada.Finalization.Limited_Controlled with record
- Tag : Character;
- end record;
- procedure Initialize( It: in out Second );
- procedure Finalize ( It: in out Second );
-
-end C761004_0;
-
-with TCTouch;
-with C761004_Support;
-package body C761004_0 is
-
- package Sup renames C761004_Support;
-
- procedure Initialize( It: in out Global ) is
- begin
- Sup.Inits_Called := Sup.Inits_Called +1;
- It.Tag := Sup.Pick_Char;
- Sup.Inits_Order(Sup.Inits_Called) := It.Tag;
- end Initialize;
-
- procedure Finalize( It: in out Global ) is
- begin
- TCTouch.Touch(It.Tag); --------------------------------------------- Tag
- end Finalize;
-
- procedure Initialize( It: in out Second ) is
- begin
- Sup.Inits_Called := Sup.Inits_Called +1;
- It.Tag := Sup.Pick_Char;
- Sup.Inits_Order(Sup.Inits_Called) := It.Tag;
- end Initialize;
-
- procedure Finalize( It: in out Second ) is
- begin
- TCTouch.Touch(It.Tag); --------------------------------------------- Tag
- end Finalize;
-end C761004_0;
-
-------------------------------------------------------------------- C761004
-
-with Report;
-with TCTouch;
-with C761004_0;
-with C761004_Support;
-with Ada.Finalization; -- needed to be able to create extension aggregates
-procedure C761004 is
-
- Verbose : constant Boolean := False;
-
- package Sup renames C761004_Support;
-
- -- Subtest 1, general case. Check that several objects declared in a
- -- subprogram are created, and finalized in opposite order.
-
- Subtest_1_Expected_Inits : constant := 3;
-
- procedure Subtest_1 is
- Item_1 : C761004_0.Global;
- Item_2, Item_3 : C761004_0.Global;
- begin
- if Item_2.Tag = Item_3.Tag then -- not germane to the test
- Report.Failed("Duplicate tag");-- but helps prevent code elimination
- end if;
- end Subtest_1;
-
- -- Subtest 2, extension of the general case. Check that several objects
- -- created identically on the stack (via a recursive procedure) are
- -- finalized in the opposite order of their creation.
- Subtest_2_Expected_Inits : constant := 12;
- User_Exception : exception;
-
- procedure Subtest_2 is
-
- Item_1 : C761004_0.Global;
-
- -- combine recursion and exit by exception:
-
- procedure Nested(Recurs: Natural) is
- Item_3 : C761004_0.Global;
- begin
- if Verbose then
- Report.Comment("going in: " & Item_3.Tag);
- end if;
- if Recurs = 1 then
- raise User_Exception;
- else
- Nested(Recurs -1);
- end if;
- end Nested;
-
- Item_2 : C761004_0.Global;
-
- begin
- Nested(10);
- end Subtest_2;
-
- -- subtest 3, check the case of objects embedded in structures:
- -- an array
- -- a record
- Subtest_3_Expected_Inits : constant := 3;
- procedure Subtest_3 is
- type G_List is array(Positive range <>) of C761004_0.Global;
- type Pandoras_Box is record
- G : G_List(1..1);
- end record;
-
- procedure Nested(Recursions: Natural) is
- Merlin : Pandoras_Box;
- begin
- if Recursions > 1 then
- Nested(Recursions-1);
- else
- TCTouch.Validate("","Final Nested call");
- end if;
- end Nested;
-
- begin
- Nested(3);
- end Subtest_3;
-
- -- subtest 4, check the case of objects embedded in structures:
- -- an array
- -- a record
- Subtest_4_Expected_Inits : constant := 3;
- procedure Subtest_4 is
- type S_List is array(Positive range <>) of C761004_0.Second;
- type Pandoras_Box is record
- S : S_List(1..1);
- end record;
-
- procedure Nested(Recursions: Natural) is
- Merlin : Pandoras_Box;
- begin
- if Recursions > 1 then
- Nested(Recursions-1);
- else
- TCTouch.Validate("","Final Nested call");
- end if;
- end Nested;
-
- begin
- Nested(3);
- end Subtest_4;
-
-begin -- Main test procedure.
-
- Report.Test ("C761004", "Check that an object of a controlled type "
- & "is finalized when the enclosing master is "
- & "complete, left by a transfer of control, "
- & "and performed in the correct order" );
-
- Subtest_1;
- Sup.Validate(Subtest_1_Expected_Inits,1);
-
- Subtest_2_Frame: begin
- Sup.Inits_Called := 0;
- Subtest_2;
- exception
- when User_Exception => null;
- when others => Report.Failed("Wrong Exception, Subtest 2");
- end Subtest_2_Frame;
- Sup.Validate(Subtest_2_Expected_Inits,2);
-
- Sup.Inits_Called := 0;
- Subtest_3;
- Sup.Validate(Subtest_3_Expected_Inits,3);
-
- Sup.Inits_Called := 0;
- Subtest_4;
- Sup.Validate(Subtest_4_Expected_Inits,4);
-
- Report.Result;
-
-end C761004;
diff --git a/gcc/testsuite/ada/acats/tests/c7/c761005.a b/gcc/testsuite/ada/acats/tests/c7/c761005.a
deleted file mode 100644
index acac59b48c6..00000000000
--- a/gcc/testsuite/ada/acats/tests/c7/c761005.a
+++ /dev/null
@@ -1,288 +0,0 @@
--- C761005.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that deriving abstract types from the types in Ada.Finalization
--- does not negatively impact the implicit operations.
--- Check that an object of a controlled type is finalized when the
--- enclosing master is complete.
--- Check that finalization occurs in the case where the master is
--- left by a transfer of control.
--- Check this for controlled types where the derived type has a
--- discriminant.
--- Check this for cases where the type is defined as private,
--- and the full type is derived from the types in Ada.Finalization.
---
--- Check that finalization of controlled objects is
--- performed in the correct order. In particular, check that if
--- multiple objects of controlled types are declared immediately
--- within the same declarative part then type are finalized in the
--- reverse order of their creation.
---
--- TEST DESCRIPTION:
--- This test checks these conditions for subprograms and
--- block statements; both variables and constants of controlled
--- types; cases of a controlled component of a record type, as
--- well as an array with controlled components.
---
--- The base controlled types used for the test are defined
--- with a character discriminant. The initialize procedure for
--- the types will record the order of creation in a globally
--- accessible array, the finalize procedure for the types will call
--- TCTouch with that tag character. The test can then check that
--- the order of finalization is indeed the reverse of the order of
--- creation (assuming that the implementation calls Initialize in
--- the order that the objects are created).
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 10 Oct 95 SAIC Fixed bugs for ACVC 2.0.1
---
---!
-
-package C761005_Support is
-
- function Pick_Char return Character;
- procedure Validate(Initcount: Natural; Testnumber:Natural);
-
- Inits_Order : String(1..255);
- Inits_Called : Natural := 0;
-
-end C761005_Support;
-
-with Report;
-with TCTouch;
-package body C761005_Support is
- type Pick_Rotation is mod 52;
- type Pick_String is array(Pick_Rotation) of Character;
-
- From : constant Pick_String := "ABCDEFGHIJKLMNOPQRSTUVWXYZ"
- & "abcdefghijklmnopqrstuvwxyz";
- Recent_Pick : Pick_Rotation := Pick_Rotation'Last;
-
- function Pick_Char return Character is
- begin
- Recent_Pick := Recent_Pick +1;
- return From(Recent_Pick);
- end Pick_Char;
-
- function Invert(S:String) return String is
- T: String(1..S'Length);
- TI: Positive := 1;
- begin
- for SI in reverse S'Range loop
- T(TI) := S(SI);
- TI := TI +1;
- end loop;
- return T;
- end Invert;
-
- procedure Validate(Initcount: Natural; Testnumber:Natural) is
- Number : constant String := Natural'Image(Testnumber);
- begin
- if Inits_Called /= Initcount then
- Report.Failed("Wrong number of inits, Subtest " & Number);
- else
- TCTouch.Validate(
- Invert(Inits_Order(1..Inits_Called)),
- "Subtest " & Number, True);
- end if;
- Inits_Called := 0;
- end Validate;
-
-end C761005_Support;
-
------------------------------------------------------------------------------
-with Ada.Finalization;
-package C761005_0 is
- type Final_Root(Tag: Character) is private;
-
- type Ltd_Final_Root(Tag: Character) is limited private;
-
- Inits_Order : String(1..255);
- Inits_Called : Natural := 0;
-private
- type Final_Root(Tag: Character) is new Ada.Finalization.Controlled
- with null record;
- procedure Initialize( It: in out Final_Root );
- procedure Finalize ( It: in out Final_Root );
-
- type Ltd_Final_Root(Tag: Character) is new
-Ada.Finalization.Limited_Controlled
- with null record;
- procedure Initialize( It: in out Ltd_Final_Root );
- procedure Finalize ( It: in out Ltd_Final_Root );
-end C761005_0;
-
------------------------------------------------------------------------------
-with Ada.Finalization;
-package C761005_1 is
- type Final_Abstract is abstract tagged private;
-
- type Ltd_Final_Abstract_Child is abstract tagged limited private;
-
- Inits_Order : String(1..255);
- Inits_Called : Natural := 0;
-
-private
- type Final_Abstract is abstract new Ada.Finalization.Controlled with record
- Tag: Character;
- end record;
- procedure Initialize( It: in out Final_Abstract );
- procedure Finalize ( It: in out Final_Abstract );
-
- type Ltd_Final_Abstract_Child is
- abstract new Ada.Finalization.Limited_Controlled with record
- Tag: Character;
- end record;
- procedure Initialize( It: in out Ltd_Final_Abstract_Child );
- procedure Finalize ( It: in out Ltd_Final_Abstract_Child );
-
-end C761005_1;
-
------------------------------------------------------------------------------
-with C761005_1;
-package C761005_2 is
-
- type Final_Child is new C761005_1.Final_Abstract with null record;
- type Ltd_Final_Child is
- new C761005_1.Ltd_Final_Abstract_Child with null record;
-
-end C761005_2;
-
------------------------------------------------------------------------------
-with Report;
-with TCTouch;
-with C761005_Support;
-package body C761005_0 is
-
- package Sup renames C761005_Support;
-
- procedure Initialize( It: in out Final_Root ) is
- begin
- Sup.Inits_Called := Sup.Inits_Called +1;
- Sup.Inits_Order(Sup.Inits_Called) := It.Tag;
- end Initialize;
-
- procedure Finalize( It: in out Final_Root ) is
- begin
- TCTouch.Touch(It.Tag);
- end Finalize;
-
- procedure Initialize( It: in out Ltd_Final_Root ) is
- begin
- Sup.Inits_Called := Sup.Inits_Called +1;
- Sup.Inits_Order(Sup.Inits_Called) := It.Tag;
- end Initialize;
-
- procedure Finalize( It: in out Ltd_Final_Root ) is
- begin
- TCTouch.Touch(It.Tag);
- end Finalize;
-end C761005_0;
-
------------------------------------------------------------------------------
-with Report;
-with TCTouch;
-with C761005_Support;
-package body C761005_1 is
-
- package Sup renames C761005_Support;
-
- procedure Initialize( It: in out Final_Abstract ) is
- begin
- Sup.Inits_Called := Sup.Inits_Called +1;
- It.Tag := Sup.Pick_Char;
- Sup.Inits_Order(Sup.Inits_Called) := It.Tag;
- end Initialize;
-
- procedure Finalize( It: in out Final_Abstract ) is
- begin
- TCTouch.Touch(It.Tag);
- end Finalize;
-
- procedure Initialize( It: in out Ltd_Final_Abstract_Child ) is
- begin
- Sup.Inits_Called := Sup.Inits_Called +1;
- It.Tag := Sup.Pick_Char;
- Sup.Inits_Order(Sup.Inits_Called) := It.Tag;
- end Initialize;
-
- procedure Finalize( It: in out Ltd_Final_Abstract_Child ) is
- begin
- TCTouch.Touch(It.Tag);
- end Finalize;
-end C761005_1;
-
------------------------------------------------------------------------------
-with Report;
-with TCTouch;
-with C761005_0;
-with C761005_2;
-with C761005_Support;
-procedure C761005 is
-
- package Sup renames C761005_Support;
-
- Subtest_1_Inits_Expected : constant := 4;
- procedure Subtest_1 is
- Item_1 : C761005_0.Final_Root(Sup.Pick_Char);
- Item_2, Item_3 : C761005_0.Final_Root(Sup.Pick_Char);
- Item_4 : C761005_0.Ltd_Final_Root(Sup.Pick_Char);
- begin
- -- check that nothing has happened yet!
- TCTouch.Validate("","Subtest 1 body");
- end Subtest_1;
-
- -- These declarations should cause calls to initialize and
- -- finalize. The expected operations are the subprograms associated
- -- with the abstract types.
- Subtest_2_Inits_Expected : constant := 4;
- procedure Subtest_2 is
- Item_1 : C761005_2.Final_Child;
- Item_2, Item_3 : C761005_2.Final_Child;
- Item_4 : C761005_2.Ltd_Final_Child;
- begin
- -- check that nothing has happened yet!
- TCTouch.Validate("","Subtest 2 body");
- end Subtest_2;
-
-begin -- Main test procedure.
-
- Report.Test ("C761005", "Check that an object of a controlled type "
- & "is finalized when the enclosing master is "
- & "complete, left by a transfer of control, "
- & "and performed in the correct order" );
-
- Subtest_1;
- Sup.Validate(Subtest_1_Inits_Expected,1);
-
- Subtest_2;
- Sup.Validate(Subtest_2_Inits_Expected,2);
-
- Report.Result;
-
-end C761005;
diff --git a/gcc/testsuite/ada/acats/tests/c7/c761006.a b/gcc/testsuite/ada/acats/tests/c7/c761006.a
deleted file mode 100644
index 771e625d10f..00000000000
--- a/gcc/testsuite/ada/acats/tests/c7/c761006.a
+++ /dev/null
@@ -1,425 +0,0 @@
--- C761006.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that Program_Error is raised when:
--- * an exception is raised if Finalize invoked as part of an
--- assignment operation; or
--- * an exception is raised if Adjust invoked as part of an assignment
--- operation, after any other adjustment due to be performed are
--- performed; or
--- * an exception is raised if Finalize invoked as part of a call on
--- Unchecked_Deallocation, after any other finalizations to be
--- performed are performed.
---
--- TEST DESCRIPTION:
--- This test defines these four controlled types:
--- Good
--- Bad_Initialize
--- Bad_Adjust
--- Bad_Finalize
--- The type name conveys the associated failure. The operations in type
--- good will "touch" the boolean array indicating correct path
--- utilization for the purposes of checking "other <operations> are
--- performed", where <operations> ::= initialization, adjusting, and
--- finalization
---
---
---
--- CHANGE HISTORY:
--- 12 APR 94 SAIC Initial version
--- 02 MAY 96 SAIC Visibility fixed for 2.1
--- 13 FEB 97 PWB.CTA Corrected value of Events_Occurring at line 286
--- 01 DEC 97 EDS Made correction wrt RM 7.6(21)
--- 16 MAR 01 RLB Corrected Adjust cases to avoid problems with
--- RM 7.6.1(16/1) from Technical Corrigendum 1.
---
---!
-
-------------------------------------------------------------- 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
deleted file mode 100644
index 7b3dbfb9b6e..00000000000
--- a/gcc/testsuite/ada/acats/tests/c7/c761007.a
+++ /dev/null
@@ -1,419 +0,0 @@
--- C761007.A
---
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that if a finalize procedure invoked by a transfer of control
--- due to selection of a terminate alternative attempts to propagate an
--- exception, the exception is ignored, but any other finalizations due
--- to be performed are performed.
---
---
--- TEST DESCRIPTION:
--- This test declares a nested controlled data type, and embeds an object
--- of that type within a protected type. Objects of the protected type
--- are created and destroyed, and the actions of the embedded controlled
--- object are checked. The container controlled type causes an exception
--- as the last part of it's finalization operation.
---
--- This test utilizes several tasks to accomplish the objective. The
--- tasks contain delays to ensure that the expected order of processing
--- is indeed accomplished.
---
--- Subtest 1:
--- local task object runs to normal completion
---
--- Subtest 2:
--- local task aborts a nested task to cause finalization
---
--- Subtest 3:
--- local task sleeps long enough to allow procedure started
--- asynchronously to go into infinite loop. Procedure is then aborted
--- via ATC, causing finalization of objects.
---
--- Subtest 4:
--- local task object takes terminate alternative, causing finalization
---
---
--- CHANGE HISTORY:
--- 06 JUN 95 SAIC Initial version
--- 05 APR 96 SAIC Documentation changes
--- 03 MAR 97 PWB.CTA Allowed two finalization orders for ATC test
--- 02 DEC 97 EDS Remove duplicate characters from check string.
---!
-
----------------------------------------------------------------- C761007_0
-
-with Ada.Finalization;
-package C761007_0 is
-
- type Internal is new Ada.Finalization.Controlled
- with record
- Effect : Character;
- end record;
-
- procedure Finalize( I: in out Internal );
-
- Side_Effect : String(1..80); -- way bigger than needed
- Side_Effect_Finger : Natural := 0;
-
-end C761007_0;
-
--- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
-
-with TCTouch;
-package body C761007_0 is
-
- procedure Finalize( I : in out Internal ) is
- Previous_Side_Effect : Boolean := False;
- begin
- -- look to see if this character has been finalized yet
- for SEI in 1..Side_Effect_Finger loop
- Previous_Side_Effect := Previous_Side_Effect
- or Side_Effect(Side_Effect_Finger) = I.Effect;
- end loop;
-
- -- if not, then tack it on to the string, and touch the character
- if not Previous_Side_Effect then
- Side_Effect_Finger := Side_Effect_Finger +1;
- Side_Effect(Side_Effect_Finger) := I.Effect;
- TCTouch.Touch(I.Effect);
- end if;
-
- end Finalize;
-
-end C761007_0;
-
----------------------------------------------------------------- C761007_1
-
-with C761007_0;
-with Ada.Finalization;
-package C761007_1 is
-
- type Container is new Ada.Finalization.Controlled
- with record
- Effect : Character;
- Content : C761007_0.Internal;
- end record;
-
- procedure Finalize( C: in out Container );
-
- Side_Effect : String(1..80); -- way bigger than needed
- Side_Effect_Finger : Natural := 0;
-
- This_Exception_Is_Supposed_To_Be_Ignored : exception;
-
-end C761007_1;
-
--- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
-
-with TCTouch;
-package body C761007_1 is
-
- procedure Finalize( C: in out Container ) is
- Previous_Side_Effect : Boolean := False;
- begin
- -- look to see if this character has been finalized yet
- for SEI in 1..Side_Effect_Finger loop
- Previous_Side_Effect := Previous_Side_Effect
- or Side_Effect(Side_Effect_Finger) = C.Effect;
- end loop;
-
- -- if not, then tack it on to the string, and touch the character
- if not Previous_Side_Effect then
- Side_Effect_Finger := Side_Effect_Finger +1;
- Side_Effect(Side_Effect_Finger) := C.Effect;
- TCTouch.Touch(C.Effect);
- end if;
-
- raise This_Exception_Is_Supposed_To_Be_Ignored;
-
- end Finalize;
-
-end C761007_1;
-
----------------------------------------------------------------- C761007_2
-with C761007_1;
-package C761007_2 is
-
- protected type Prot_W_Fin_Obj is
- procedure Set_Effects( Container, Filling: Character );
- private
- The_Data_Under_Test : C761007_1.Container;
- -- finalization for this will occur when the Prot_W_Fin_Obj object
- -- "goes out of existence" for whatever reason.
- end Prot_W_Fin_Obj;
-
-end C761007_2;
-
--- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
-
-package body C761007_2 is
-
- protected body Prot_W_Fin_Obj is
- procedure Set_Effects( Container, Filling: Character ) is
- begin
- The_Data_Under_Test.Effect := Container; -- A, etc.
- The_Data_Under_Test.Content.Effect := Filling; -- B, etc.
- end Set_Effects;
- end Prot_W_Fin_Obj;
-
-end C761007_2;
-
------------------------------------------------------------------- C761007
-
-with Report;
-with Impdef;
-with TCTouch;
-with C761007_0;
-with C761007_1;
-with C761007_2;
-procedure C761007 is
-
- task type Subtests( Outer, Inner : Character) is
- entry Ready;
- entry Complete;
- end Subtests;
-
- task body Subtests is
- Local_Prot_W_Fin_Obj : C761007_2.Prot_W_Fin_Obj;
- begin
- Local_Prot_W_Fin_Obj.Set_Effects( Outer, Inner );
-
- accept Ready;
-
- select
- accept Complete;
- or terminate; -- used in Subtest 4
- end select;
- exception
- -- the exception caused by the finalization of Local_Prot_W_Fin_Obj
- -- should never be visible to this scope.
- when others => Report.Failed("Exception in a Subtest object "
- & Outer & Inner);
- end Subtests;
-
- procedure Subtest_1 is
- -- check the case where "nothing special" happens.
-
- This_Subtest : Subtests( 'A', 'B' );
- begin
-
- This_Subtest.Ready;
- This_Subtest.Complete;
-
- while not This_Subtest'Terminated loop -- wait for finalization
- delay Impdef.Clear_Ready_Queue;
- end loop;
-
- -- in the finalization of This_Subtest, the controlled object embedded in
- -- the Prot_W_Fin_Obj will finalize. An exception is raised in the
- -- container object, after "touching" it's tag character.
- -- The finalization of the contained controlled object must be performed.
-
-
- TCTouch.Validate( "AB", "Item embedded in task" );
-
-
- exception
- when others => Report.Failed("Undesirable exception in Subtest_1");
-
- end Subtest_1;
-
- procedure Subtest_2 is
- -- check for explicit abort
-
- task Subtest_Task is
- entry Complete;
- end Subtest_Task;
-
- task body Subtest_Task is
-
- task Nesting;
- task body Nesting is
- Deep_Nesting : Subtests( 'E', 'F' );
- begin
- if Report.Ident_Bool( True ) then
- -- controlled objects have been created in the elaboration of
- -- Deep_Nesting. Deep_Nesting must call the Set_Effects operation
- -- in the Prot_W_Fin_Obj, and then hang waiting for the Complete
- -- entry call.
- Deep_Nesting.Ready;
- abort Deep_Nesting;
- else
- Report.Failed("Dead code in Nesting");
- end if;
- exception
- when others => Report.Failed("Exception in Subtest_Task.Nesting");
- end Nesting;
-
- Local_2 : C761007_2.Prot_W_Fin_Obj;
-
- begin
- -- Nesting has activated at this point, which implies the activation
- -- of Deep_Nesting as well.
-
- Local_2.Set_Effects( 'C', 'D' );
-
- -- wait for Nesting to terminate
-
- while not Nesting'Terminated loop
- delay Impdef.Clear_Ready_Queue;
- end loop;
-
- accept Complete;
-
- exception
- when others => Report.Failed("Exception in Subtest_Task");
- end Subtest_Task;
-
- begin
-
- -- wait for everything in Subtest_Task to happen
- Subtest_Task.Complete;
-
- while not Subtest_Task'Terminated loop -- wait for finalization
- delay Impdef.Clear_Ready_Queue;
- end loop;
-
- TCTouch.Validate( "EFCD", "Aborted nested task" );
-
- exception
- when others => Report.Failed("Undesirable exception in Subtest_2");
- end Subtest_2;
-
- procedure Subtest_3 is
- -- check abort caused by asynchronous transfer of control
-
- task Subtest_3_Task is
- entry Complete;
- end Subtest_3_Task;
-
- procedure Check_Atc_Operation is
- Check_Atc : C761007_2.Prot_W_Fin_Obj;
- begin
-
- Check_Atc.Set_Effects( 'G', 'H' );
-
-
- while Report.Ident_Bool( True ) loop -- wait to be aborted
- if Report.Ident_Bool( True ) then
- Impdef.Exceed_Time_Slice;
- delay Impdef.Switch_To_New_Task;
- else
- Report.Failed("Optimization prevention");
- end if;
- end loop;
-
- Report.Failed("Check_Atc_Operation loop completed");
-
- end Check_Atc_Operation;
-
- task body Subtest_3_Task is
- task Nesting is
- entry Complete;
- end Nesting;
-
- task body Nesting is
- Nesting_3 : C761007_2.Prot_W_Fin_Obj;
- begin
- Nesting_3.Set_Effects( 'G', 'H' );
-
- -- give Check_Atc_Operation sufficient time to perform it's
- -- Set_Effects on it's local Prot_W_Fin_Obj object
- delay Impdef.Clear_Ready_Queue;
-
- accept Complete;
- exception
- when others => Report.Failed("Exception in Subtest_3_Task.Nesting");
- end Nesting;
-
- Local_3 : C761007_2.Prot_W_Fin_Obj;
-
- begin -- Subtest_3_Task
-
- Local_3.Set_Effects( 'I', 'J' );
-
- select
- Nesting.Complete;
- then abort ---------------------------------------------------- cause KL
- Check_ATC_Operation;
- end select;
-
- accept Complete;
-
- exception
- when others => Report.Failed("Exception in Subtest_3_Task");
- end Subtest_3_Task;
-
- begin -- Subtest_3
- Subtest_3_Task.Complete;
-
- while not Subtest_3_Task'Terminated loop -- wait for finalization
- delay Impdef.Clear_Ready_Queue;
- end loop;
-
- TCTouch.Validate( "GHIJ", "Asynchronously aborted operation" );
-
- exception
- when others => Report.Failed("Undesirable exception in Subtest_3");
- end Subtest_3;
-
- procedure Subtest_4 is
- -- check the case where transfer is caused by terminate alternative
- -- highly similar to Subtest_1
-
- This_Subtest : Subtests( 'M', 'N' );
- begin
-
- This_Subtest.Ready;
- -- don't call This_Subtest.Complete;
-
- exception
- when others => Report.Failed("Undesirable exception in Subtest_4");
-
- end Subtest_4;
-
-begin -- Main test procedure.
-
- Report.Test ("C761007", "Check that if a finalize procedure invoked by " &
- "a transfer of control or selection of a " &
- "terminate alternative attempts to propagate " &
- "an exception, the exception is ignored, but " &
- "any other finalizations due to be performed " &
- "are performed" );
-
- Subtest_1; -- checks internal
-
- Subtest_2; -- checks internal
-
- Subtest_3; -- checks internal
-
- Subtest_4;
- TCTouch.Validate( "MN", "transfer due to terminate alternative" );
-
- Report.Result;
-
-end C761007;
diff --git a/gcc/testsuite/ada/acats/tests/c7/c761010.a b/gcc/testsuite/ada/acats/tests/c7/c761010.a
deleted file mode 100644
index 7784c6da517..00000000000
--- a/gcc/testsuite/ada/acats/tests/c7/c761010.a
+++ /dev/null
@@ -1,447 +0,0 @@
--- C761010.A
---
--- Grant of Unlimited Rights
---
--- The Ada Conformity Assessment Authority (ACAA) holds unlimited
--- rights in the software and documentation contained herein. Unlimited
--- rights are the same as those granted by the U.S. Government for older
--- parts of the Ada Conformity Assessment Test Suite, and are defined
--- in DFAR 252.227-7013(a)(19). By making this public release, the ACAA
--- intends to confer upon all recipients unlimited rights equal to those
--- held by the ACAA. These rights include rights to use, duplicate,
--- release or disclose the released technical data and computer software
--- in whole or in part, in any manner and for any purpose whatsoever, and
--- to have or permit others to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE
--- Check the requirements of the new 7.6(17.1/1) from Technical
--- Corrigendum 1 (originally discussed as AI95-00083).
--- This new paragraph requires that the initialization of an object with
--- an aggregate does not involve calls to Adjust.
---
--- TEST DESCRIPTION
--- We include several cases of initialization:
--- - Explicit initialization of an object declared by an
--- object declaration.
--- - Explicit initialization of a heap object.
--- - Default initialization of a record component.
--- - Initialization of a formal parameter during a call.
--- - Initialization of a formal parameter during a call with
--- a defaulted parameter.
--- - Lots of nested records, arrays, and pointers.
--- In this test, Initialize should never be called, because we
--- never declare a default-initialized controlled object (although
--- we do declare default-initialized records containing controlled
--- objects, with default expressions for the components).
--- Adjust should never be called, because every initialization
--- is via an aggregate. Finalize is called, because the objects
--- themselves need to be finalized.
--- Thus, Initialize and Adjust call Failed.
--- In some of the cases, these procedures will not yet be elaborated,
--- anyway.
---
--- CHANGE HISTORY:
--- 29 JUN 1999 RAD Initial Version
--- 23 SEP 1999 RLB Improved comments, renamed, issued.
--- 10 APR 2000 RLB Corrected errors in comments and text, fixed
--- discriminant error. Fixed so that Report.Test
--- is called before any Report.Failed call. Added
--- a marker so that the failed subtest can be
--- determined.
--- 26 APR 2000 RAD Try to defeat optimizations.
--- 04 AUG 2000 RLB Corrected error in Check_Equal.
--- 18 AUG 2000 RLB Removed dubious main subprogram renames (see AI-172).
--- 19 JUL 2002 RLB Fixed to avoid calling comment after Report.Result.
---
---!
-
-with Ada; use Ada;
-with Report; use Report; pragma Elaborate_All(Report);
-with Ada.Finalization;
-package C761010_1 is
- pragma Elaborate_Body;
- function Square(X: Integer) return Integer;
-private
- type TC_Control is new Ada.Finalization.Limited_Controlled with null record;
- procedure Initialize (Object : in out TC_Control);
- procedure Finalize (Object : in out TC_Control);
- TC_Finalize_Called : Boolean := False;
-end C761010_1;
-
-package body C761010_1 is
- function Square(X: Integer) return Integer is
- begin
- return X**2;
- end Square;
-
- procedure Initialize (Object : in out TC_Control) is
- begin
- Test("C761010_1",
- "Check that Adjust is not called"
- & " when aggregates are used to initialize objects");
- end Initialize;
-
- procedure Finalize (Object : in out TC_Control) is
- begin
- if not TC_Finalize_Called then
- Failed("Var_Strings Finalize never called");
- end if;
- Result;
- end Finalize;
-
- TC_Test : TC_Control; -- Starts test; finalization ends test.
-end C761010_1;
-
-with Ada.Finalization;
-package C761010_1.Var_Strings is
- type Var_String(<>) is private;
-
- Some_String: constant Var_String;
-
- function "=" (X, Y: Var_String) return Boolean;
-
- procedure Check_Equal(X, Y: Var_String);
- -- Calls to this are used to defeat optimizations
- -- that might otherwise defeat the purpose of the
- -- test. I'm talking about the optimization of removing
- -- unused controlled objects.
-
-private
-
- type String_Ptr is access constant String;
-
- type Var_String(Length: Natural) is new Finalization.Controlled with
- record
- Comp_1: String_Ptr := new String'(2..Square(Length)-1 => 'x');
- Comp_2: String_Ptr(1..Length) := null;
- Comp_3: String(Length..Length) := (others => '.');
- TC_Lab: Character := '1';
- end record;
- procedure Initialize(X: in out Var_String);
- procedure Adjust(X: in out Var_String);
- procedure Finalize(X: in out Var_String);
-
- Some_String: constant Var_String
- := (Finalization.Controlled with Length => 1,
- Comp_1 => null,
- Comp_2 => null,
- Comp_3 => "x",
- TC_Lab => 'A');
-
- Another_String: constant Var_String
- := (Finalization.Controlled with Length => 10,
- Comp_1 => Some_String.Comp_2,
- Comp_2 => new String'("1234567890"),
- Comp_3 => "x",
- TC_Lab => 'B');
-
-end C761010_1.Var_Strings;
-
-package C761010_1.Var_Strings.Types is
-
- type Ptr is access all Var_String;
- Ptr_Const: constant Ptr;
-
- type Ptr_Arr is array(Positive range <>) of Ptr;
- Ptr_Arr_Const: constant Ptr_Arr;
-
- type Ptr_Rec(N_Strings: Natural) is
- record
- Ptrs: Ptr_Arr(1..N_Strings);
- end record;
- Ptr_Rec_Const: constant Ptr_Rec;
-
-private
-
- Ptr_Const: constant Ptr := new Var_String'
- (Finalization.Controlled with
- Length => 1,
- Comp_1 => null,
- Comp_2 => null,
- Comp_3 => (others => ' '),
- TC_Lab => 'C');
-
- Ptr_Arr_Const: constant Ptr_Arr :=
- (1 => new Var_String'
- (Finalization.Controlled with
- Length => 1,
- Comp_1 => new String'("abcdefghij"),
- Comp_2 => null,
- Comp_3 => (2..2 => ' '),
- TC_Lab => 'D'));
-
- Ptr_Rec_Var: Ptr_Rec :=
- (3,
- (1..2 => null,
- 3 => new Var_String'
- (Finalization.Controlled with
- Length => 2,
- Comp_1 => new String'("abcdefghij"),
- Comp_2 => null,
- Comp_3 => (2..2 => ' '),
- TC_Lab => 'E')));
-
- Ptr_Rec_Const: constant Ptr_Rec :=
- (3,
- (1..2 => null,
- 3 => new Var_String'
- (Finalization.Controlled with
- Length => 2,
- Comp_1 => new String'("abcdefghij"),
- Comp_2 => null,
- Comp_3 => (2..2 => ' '),
- TC_Lab => 'F')));
-
- type Arr is array(Positive range <>) of Var_String(Length => 2);
-
- Arr_Var: Arr :=
- (1 => (Finalization.Controlled with
- Length => 2,
- Comp_1 => new String'("abcdefghij"),
- Comp_2 => null,
- Comp_3 => (2..2 => ' '),
- TC_Lab => 'G'));
-
- type Rec(N_Strings: Natural) is
- record
- Ptrs: Ptr_Rec(N_Strings);
- Strings: Arr(1..N_Strings) :=
- (others =>
- (Finalization.Controlled with
- Length => 2,
- Comp_1 => new String'("abcdefghij"),
- Comp_2 => null,
- Comp_3 => (2..2 => ' '),
- TC_Lab => 'H'));
- end record;
-
- Default_Init_Rec_Var: Rec(N_Strings => 10);
- Empty_Default_Init_Rec_Var: Rec(N_Strings => 0);
-
- Rec_Var: Rec(N_Strings => 2) :=
- (N_Strings => 2,
- Ptrs =>
- (2,
- (1..1 => null,
- 2 => new Var_String'
- (Finalization.Controlled with
- Length => 2,
- Comp_1 => new String'("abcdefghij"),
- Comp_2 => null,
- Comp_3 => (2..2 => ' '),
- TC_Lab => 'J'))),
- Strings =>
- (1 =>
- (Finalization.Controlled with
- Length => 2,
- Comp_1 => new String'("abcdefghij"),
- Comp_2 => null,
- Comp_3 => (2..2 => ' '),
- TC_Lab => 'K'),
- others =>
- (Finalization.Controlled with
- Length => 2,
- Comp_1 => new String'("abcdefghij"),
- Comp_2 => null,
- Comp_3 => (2..2 => ' '),
- TC_Lab => 'L')));
-
- procedure Check_Equal(X, Y: Rec);
-
-end C761010_1.Var_Strings.Types;
-
-package body C761010_1.Var_Strings.Types is
-
- -- Check that parameter passing doesn't create new objects,
- -- and therefore doesn't need extra Adjusts or Finalizes.
-
- procedure Check_Equal(X, Y: Rec) is
- -- We assume that the arguments should be equal.
- -- But we cannot assume that pointer values are the same.
- begin
- if X.N_Strings /= Y.N_Strings then
- Failed("Records should be equal (1)");
- else
- for I in 1 .. X.N_Strings loop
- if X.Ptrs.Ptrs(I) /= Y.Ptrs.Ptrs(I) then
- if X.Ptrs.Ptrs(I) = null or else
- Y.Ptrs.Ptrs(I) = null or else
- X.Ptrs.Ptrs(I).all /= Y.Ptrs.Ptrs(I).all then
- Failed("Records should be equal (2)");
- end if;
- end if;
- if X.Strings(I) /= Y.Strings(I) then
- Failed("Records should be equal (3)");
- end if;
- end loop;
- end if;
- end Check_Equal;
-
- procedure My_Check_Equal
- (X: Rec := Rec_Var;
- Y: Rec :=
- (N_Strings => 2,
- Ptrs =>
- (2,
- (1..1 => null,
- 2 => new Var_String'
- (Finalization.Controlled with
- Length => 2,
- Comp_1 => new String'("abcdefghij"),
- Comp_2 => null,
- Comp_3 => (2..2 => ' '),
- TC_Lab => 'M'))),
- Strings =>
- (1 =>
- (Finalization.Controlled with
- Length => 2,
- Comp_1 => new String'("abcdefghij"),
- Comp_2 => null,
- Comp_3 => (2..2 => ' '),
- TC_Lab => 'N'),
- others =>
- (Finalization.Controlled with
- Length => 2,
- Comp_1 => new String'("abcdefghij"),
- Comp_2 => null,
- Comp_3 => (2..2 => ' '),
- TC_Lab => 'O'))))
- renames Check_Equal;
-begin
-
- My_Check_Equal;
-
- Check_Equal(Rec_Var,
- (N_Strings => 2,
- Ptrs =>
- (2,
- (1..1 => null,
- 2 => new Var_String'
- (Finalization.Controlled with
- Length => 2,
- Comp_1 => new String'("abcdefghij"),
- Comp_2 => null,
- Comp_3 => (2..2 => ' '),
- TC_Lab => 'P'))),
- Strings =>
- (1 =>
- (Finalization.Controlled with
- Length => 2,
- Comp_1 => new String'("abcdefghij"),
- Comp_2 => null,
- Comp_3 => (2..2 => ' '),
- TC_Lab => 'Q'),
- others =>
- (Finalization.Controlled with
- Length => 2,
- Comp_1 => new String'("abcdefghij"),
- Comp_2 => null,
- Comp_3 => (2..2 => ' '),
- TC_Lab => 'R'))));
-
- -- Use the objects to avoid optimizations.
-
- Check_Equal(Ptr_Const.all, Ptr_Const.all);
- Check_Equal(Ptr_Arr_Const(1).all, Ptr_Arr_Const(1).all);
- Check_Equal(Ptr_Rec_Const.Ptrs(Ptr_Rec_Const.N_Strings).all,
- Ptr_Rec_Const.Ptrs(Ptr_Rec_Const.N_Strings).all);
- Check_Equal(Ptr_Rec_Var.Ptrs(Ptr_Rec_Var.N_Strings).all,
- Ptr_Rec_Var.Ptrs(Ptr_Rec_Var.N_Strings).all);
-
- if Report.Equal (3, 2) then
- -- Can't get here.
- Check_Equal (Arr_Var(1), Default_Init_Rec_Var.Strings(1));
- Check_Equal (Arr_Var(1), Empty_Default_Init_Rec_Var.Strings(1));
- end if;
-
-end C761010_1.Var_Strings.Types;
-
-with C761010_1.Var_Strings;
-with C761010_1.Var_Strings.Types;
-procedure C761010_1.Main is
-begin
- -- Report.Test is called by the elaboration of C761010_1, and
- -- Report.Result is called by the finalization of C761010_1.
- -- This will happen before any objects are created, and after any
- -- are finalized.
- null;
-end C761010_1.Main;
-
-with C761010_1.Main;
-procedure C761010 is
-begin
- C761010_1.Main;
-end C761010;
-
-package body C761010_1.Var_Strings is
-
- Some_Error: exception;
-
- procedure Initialize(X: in out Var_String) is
- begin
- Failed("Initialize should never be called");
- raise Some_Error;
- end Initialize;
-
- procedure Adjust(X: in out Var_String) is
- begin
- Failed("Adjust should never be called - case " & X.TC_Lab);
- raise Some_Error;
- end Adjust;
-
- procedure Finalize(X: in out Var_String) is
- begin
- Comment("Finalize called - case " & X.TC_Lab);
- C761010_1.TC_Finalize_Called := True;
- end Finalize;
-
- function "=" (X, Y: Var_String) return Boolean is
- -- Don't check the TC_Lab component, but do check the contents of the
- -- access values.
- begin
- if X.Length /= Y.Length then
- return False;
- end if;
- if X.Comp_3 /= Y.Comp_3 then
- return False;
- end if;
- if X.Comp_1 /= Y.Comp_1 then
- -- Still OK if the values are the same.
- if X.Comp_1 = null or else
- Y.Comp_1 = null or else
- X.Comp_1.all /= Y.Comp_1.all then
- return False;
- --else OK.
- end if;
- end if;
- if X.Comp_2 /= Y.Comp_2 then
- -- Still OK if the values are the same.
- if X.Comp_2 = null or else
- Y.Comp_2 = null or else
- X.Comp_2.all /= Y.Comp_2.all then
- return False;
- end if;
- end if;
- return True;
- end "=";
-
- procedure Check_Equal(X, Y: Var_String) is
- begin
- if X /= Y then
- Failed("Check_Equal of Var_String");
- end if;
- end Check_Equal;
-
-begin
- Check_Equal(Another_String, Another_String);
-end C761010_1.Var_Strings;
diff --git a/gcc/testsuite/ada/acats/tests/c7/c761011.a b/gcc/testsuite/ada/acats/tests/c7/c761011.a
deleted file mode 100644
index 1d447c755a9..00000000000
--- a/gcc/testsuite/ada/acats/tests/c7/c761011.a
+++ /dev/null
@@ -1,410 +0,0 @@
--- C761011.A
---
--- Grant of Unlimited Rights
---
--- The Ada Conformity Assessment Authority (ACAA) holds unlimited
--- rights in the software and documentation contained herein. Unlimited
--- rights are the same as those granted by the U.S. Government for older
--- parts of the Ada Conformity Assessment Test Suite, and are defined
--- in DFAR 252.227-7013(a)(19). By making this public release, the ACAA
--- intends to confer upon all recipients unlimited rights equal to those
--- held by the ACAA. These rights include rights to use, duplicate,
--- release or disclose the released technical data and computer software
--- in whole or in part, in any manner and for any purpose whatsoever, and
--- to have or permit others to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that if a Finalize propagates an exception, other Finalizes due
--- to be performed are performed.
--- Case 1: A Finalize invoked due to the end of execution of
--- a master. (Defect Report 8652/0023, as reflected in Technical
--- Corrigendum 1).
--- Case 2: A Finalize invoked due to finalization of an anonymous
--- object. (Defect Report 8652/0023, as reflected in Technical
--- Corrigendum 1).
--- Case 3: A Finalize invoked due to the transfer of control
--- due to an exit statement.
--- Case 4: A Finalize invoked due to the transfer of control
--- due to a goto statement.
--- Case 5: A Finalize invoked due to the transfer of control
--- due to a return statement.
--- Case 6: A Finalize invoked due to the transfer of control
--- due to raises an exception.
---
---
--- CHANGE HISTORY:
--- 29 JAN 2001 PHL Initial version
--- 15 MAR 2001 RLB Readied for release; added optimization blockers.
--- Added test cases for paragraphs 18 and 19 of the
--- standard (the previous tests were withdrawn).
---
---!
-with Ada.Finalization;
-use Ada.Finalization;
-package C761011_0 is
-
- type Ctrl (D : Boolean) is new Ada.Finalization.Controlled with
- record
- Finalized : Boolean := False;
- case D is
- when False =>
- C1 : Integer;
- when True =>
- C2 : Float;
- end case;
- end record;
-
- function Create (Id : Integer) return Ctrl;
- procedure Finalize (Obj : in out Ctrl);
- function Was_Finalized (Id : Integer) return Boolean;
- procedure Use_It (Obj : in Ctrl);
- -- Use Obj to prevent optimization.
-
-end C761011_0;
-
-with Report;
-use Report;
-package body C761011_0 is
-
- User_Error : exception;
-
- Finalize_Called : array (0 .. 50) of Boolean := (others => False);
-
- function Create (Id : Integer) return Ctrl is
- Obj : Ctrl (Boolean'Val (Id mod Ident_Int (2)));
- begin
- case Obj.D is
- when False =>
- Obj.C1 := Ident_Int (Id);
- when True =>
- Obj.C2 := Float (Ident_Int (Id + Ident_Int (Id)));
- end case;
- return Obj;
- end Create;
-
- procedure Finalize (Obj : in out Ctrl) is
- begin
- if not Obj.Finalized then
- Obj.Finalized := True;
- if Obj.D then
- if Integer (Obj.C2 / 2.0) mod Ident_Int (10) =
- Ident_Int (3) then
- raise User_Error;
- else
- Finalize_Called (Integer (Obj.C2) / 2) := True;
- end if;
- else
- if Obj.C1 mod Ident_Int (10) = Ident_Int (0) then
- raise Tasking_Error;
- else
- Finalize_Called (Obj.C1) := True;
- end if;
- end if;
- end if;
- end Finalize;
-
- function Was_Finalized (Id : Integer) return Boolean is
- begin
- return Finalize_Called (Ident_Int (Id));
- end Was_Finalized;
-
- procedure Use_It (Obj : in Ctrl) is
- -- Use Obj to prevent optimization.
- begin
- case Obj.D is
- when True =>
- if not Equal (Boolean'Pos(Obj.Finalized),
- Boolean'Pos(Obj.Finalized)) then
- Failed ("Identity check - 1");
- end if;
- when False =>
- if not Equal (Obj.C1, Obj.C1) then
- Failed ("Identity check - 2");
- end if;
- end case;
- end Use_It;
-
-end C761011_0;
-
-with Ada.Exceptions;
-use Ada.Exceptions;
-with Ada.Finalization;
-with C761011_0;
-use C761011_0;
-with Report;
-use Report;
-procedure C761011 is
-begin
- Test
- ("C761011",
- " Check that if a finalize propagates an exception, other finalizes " &
- "due to be performed are performed");
-
- Normal: -- Case 1
- begin
- declare
- Obj1 : Ctrl := Create (Ident_Int (1));
- Obj2 : constant Ctrl := (Ada.Finalization.Controlled with
- D => False,
- Finalized => Ident_Bool (False),
- C1 => Ident_Int (2));
- Obj3 : Ctrl :=
- (Ada.Finalization.Controlled with
- D => True,
- Finalized => Ident_Bool (False),
- C2 => 2.0 * Float (Ident_Int
- (3))); -- Finalization: User_Error
- Obj4 : Ctrl := Create (Ident_Int (4));
- begin
- Comment ("Finalization of normal object");
- Use_It (Obj1); -- Prevent optimization of Objects.
- Use_It (Obj2); -- (Critical if AI-147 is adopted.)
- Use_It (Obj3);
- Use_It (Obj4);
- end;
- Failed ("No exception raised by finalization of normal object");
- exception
- when Program_Error =>
- if not Was_Finalized (Ident_Int (1)) or
- not Was_Finalized (Ident_Int (2)) or
- not Was_Finalized (Ident_Int (4)) then
- Failed ("Missing finalizations - 1");
- end if;
- when E: others =>
- Failed ("Exception " & Exception_Name (E) &
- " raised - " & Exception_Message (E) & " - 1");
- end Normal;
-
- Anon: -- Case 2
- begin
- declare
- Obj1 : Ctrl := (Ada.Finalization.Controlled with
- D => True,
- Finalized => Ident_Bool (False),
- C2 => 2.0 * Float (Ident_Int (5)));
- Obj2 : constant Ctrl := (Ada.Finalization.Controlled with
- D => False,
- Finalized => Ident_Bool (False),
- C1 => Ident_Int (6));
- Obj3 : Ctrl := (Ada.Finalization.Controlled with
- D => True,
- Finalized => Ident_Bool (False),
- C2 => 2.0 * Float (Ident_Int (7)));
- Obj4 : Ctrl := Create (Ident_Int (8));
- begin
- Comment ("Finalization of anonymous object");
-
- -- The finalization of the anonymous object below will raise
- -- Tasking_Error.
- if Create (Ident_Int (10)).C1 /= Ident_Int (10) then
- Failed ("Incorrect construction of an anonymous object");
- end if;
- Failed ("Anonymous object not finalized at the end of the " &
- "enclosing statement");
- Use_It (Obj1); -- Prevent optimization of Objects.
- Use_It (Obj2); -- (Critical if AI-147 is adopted.)
- Use_It (Obj3);
- Use_It (Obj4);
- end;
- Failed ("No exception raised by finalization of an anonymous " &
- "object of a function");
- exception
- when Program_Error =>
- if not Was_Finalized (Ident_Int (5)) or
- not Was_Finalized (Ident_Int (6)) or
- not Was_Finalized (Ident_Int (7)) or
- not Was_Finalized (Ident_Int (8)) then
- Failed ("Missing finalizations - 2");
- end if;
- when E: others =>
- Failed ("Exception " & Exception_Name (E) &
- " raised - " & Exception_Message (E) & " - 2");
- end Anon;
-
- An_Exit: -- Case 3
- begin
- for Counter in 1 .. 4 loop
- declare
- Obj1 : Ctrl := Create (Ident_Int (11));
- Obj2 : constant Ctrl := (Ada.Finalization.Controlled with
- D => False,
- Finalized => Ident_Bool (False),
- C1 => Ident_Int (12));
- Obj3 : Ctrl :=
- (Ada.Finalization.Controlled with
- D => True,
- Finalized => Ident_Bool (False),
- C2 => 2.0 * Float (
- Ident_Int(13))); -- Finalization: User_Error
- Obj4 : Ctrl := Create (Ident_Int (14));
- begin
- Comment ("Finalization because of exit of loop");
-
- Use_It (Obj1); -- Prevent optimization of Objects.
- Use_It (Obj2); -- (Critical if AI-147 is adopted.)
- Use_It (Obj3);
- Use_It (Obj4);
-
- exit when not Ident_Bool (Obj2.D);
-
- Failed ("Exit not taken");
- end;
- end loop;
- Failed ("No exception raised by finalization on exit");
- exception
- when Program_Error =>
- if not Was_Finalized (Ident_Int (11)) or
- not Was_Finalized (Ident_Int (12)) or
- not Was_Finalized (Ident_Int (14)) then
- Failed ("Missing finalizations - 3");
- end if;
- when E: others =>
- Failed ("Exception " & Exception_Name (E) &
- " raised - " & Exception_Message (E) & " - 3");
- end An_Exit;
-
- A_Goto: -- Case 4
- begin
- declare
- Obj1 : Ctrl := Create (Ident_Int (15));
- Obj2 : constant Ctrl := (Ada.Finalization.Controlled with
- D => False,
- Finalized => Ident_Bool (False),
- C1 => Ident_Int (0));
- -- Finalization: Tasking_Error
- Obj3 : Ctrl := Create (Ident_Int (16));
- Obj4 : Ctrl := (Ada.Finalization.Controlled with
- D => True,
- Finalized => Ident_Bool (False),
- C2 => 2.0 * Float (Ident_Int (17)));
- begin
- Comment ("Finalization because of goto statement");
-
- Use_It (Obj1); -- Prevent optimization of Objects.
- Use_It (Obj2); -- (Critical if AI-147 is adopted.)
- Use_It (Obj3);
- Use_It (Obj4);
-
- if Ident_Bool (Obj4.D) then
- goto Continue;
- end if;
-
- Failed ("Goto not taken");
- end;
- <<Continue>>
- Failed ("No exception raised by finalization on goto");
- exception
- when Program_Error =>
- if not Was_Finalized (Ident_Int (15)) or
- not Was_Finalized (Ident_Int (16)) or
- not Was_Finalized (Ident_Int (17)) then
- Failed ("Missing finalizations - 4");
- end if;
- when E: others =>
- Failed ("Exception " & Exception_Name (E) &
- " raised - " & Exception_Message (E) & " - 4");
- end A_Goto;
-
- A_Return: -- Case 5
- declare
- procedure Do_Something is
- Obj1 : Ctrl := Create (Ident_Int (18));
- Obj2 : Ctrl := (Ada.Finalization.Controlled with
- D => True,
- Finalized => Ident_Bool (False),
- C2 => 2.0 * Float (Ident_Int (19)));
- Obj3 : constant Ctrl := (Ada.Finalization.Controlled with
- D => False,
- Finalized => Ident_Bool (False),
- C1 => Ident_Int (20));
- -- Finalization: Tasking_Error
- begin
- Comment ("Finalization because of return statement");
-
- Use_It (Obj1); -- Prevent optimization of Objects.
- Use_It (Obj2); -- (Critical if AI-147 is adopted.)
- Use_It (Obj3);
-
- if not Ident_Bool (Obj3.D) then
- return;
- end if;
-
- Failed ("Return not taken");
- end Do_Something;
- begin
- Do_Something;
- Failed ("No exception raised by finalization on return statement");
- exception
- when Program_Error =>
- if not Was_Finalized (Ident_Int (18)) or
- not Was_Finalized (Ident_Int (19)) then
- Failed ("Missing finalizations - 5");
- end if;
- when E: others =>
- Failed ("Exception " & Exception_Name (E) &
- " raised - " & Exception_Message (E) & " - 5");
- end A_Return;
-
- Except: -- Case 6
- declare
- Funky_Error : exception;
-
- procedure Do_Something is
- Obj1 : Ctrl :=
- (Ada.Finalization.Controlled with
- D => True,
- Finalized => Ident_Bool (False),
- C2 => 2.0 * Float (
- Ident_Int(23))); -- Finalization: User_Error
- Obj2 : Ctrl := Create (Ident_Int (24));
- Obj3 : Ctrl := Create (Ident_Int (25));
- Obj4 : constant Ctrl := (Ada.Finalization.Controlled with
- D => False,
- Finalized => Ident_Bool (False),
- C1 => Ident_Int (26));
- begin
- Comment ("Finalization because of exception propagation");
-
- Use_It (Obj1); -- Prevent optimization of Objects.
- Use_It (Obj2); -- (Critical if AI-147 is adopted.)
- Use_It (Obj3);
- Use_It (Obj4);
-
- if not Ident_Bool (Obj4.D) then
- raise Funky_Error;
- end if;
-
- Failed ("Exception not raised");
- end Do_Something;
- begin
- Do_Something;
- Failed ("No exception raised by finalization on exception " &
- "propagation");
- exception
- when Program_Error =>
- if not Was_Finalized (Ident_Int (24)) or
- not Was_Finalized (Ident_Int (25)) or
- not Was_Finalized (Ident_Int (26)) then
- Failed ("Missing finalizations - 6");
- end if;
- when Funky_Error =>
- Failed ("Wrong exception propagated");
- -- Should be Program_Error (7.6.1(19)).
- when E: others =>
- Failed ("Exception " & Exception_Name (E) &
- " raised - " & Exception_Message (E) & " - 6");
- end Except;
-
- Result;
-end C761011;
-
diff --git a/gcc/testsuite/ada/acats/tests/c7/c761012.a b/gcc/testsuite/ada/acats/tests/c7/c761012.a
deleted file mode 100644
index 77b9e2253bf..00000000000
--- a/gcc/testsuite/ada/acats/tests/c7/c761012.a
+++ /dev/null
@@ -1,151 +0,0 @@
--- C761012.A
---
--- Grant of Unlimited Rights
---
--- The Ada Conformity Assessment Authority (ACAA) holds unlimited
--- rights in the software and documentation contained herein. Unlimited
--- rights are the same as those granted by the U.S. Government for older
--- parts of the Ada Conformity Assessment Test Suite, and are defined
--- in DFAR 252.227-7013(a)(19). By making this public release, the ACAA
--- intends to confer upon all recipients unlimited rights equal to those
--- held by the ACAA. These rights include rights to use, duplicate,
--- release or disclose the released technical data and computer software
--- in whole or in part, in any manner and for any purpose whatsoever, and
--- to have or permit others to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that an anonymous object is finalized with its enclosing master if
--- a transfer of control or exception occurs prior to performing its normal
--- finalization. (Defect Report 8652/0023, as reflected in
--- Technical Corrigendum 1, RM95 7.6.1(13.1/1)).
---
--- CHANGE HISTORY:
--- 29 JAN 2001 PHL Initial version.
--- 5 DEC 2001 RLB Reformatted for ACATS.
---
---!
-with Ada.Finalization;
-use Ada.Finalization;
-package C761012_0 is
-
- type Ctrl (D : Boolean) is new Controlled with
- record
- case D is
- when False =>
- C1 : Integer;
- when True =>
- C2 : Float;
- end case;
- end record;
-
- function Create return Ctrl;
- procedure Finalize (Obj : in out Ctrl);
- function Finalize_Was_Called return Boolean;
-
-end C761012_0;
-
-with Report;
-use Report;
-package body C761012_0 is
-
- Finalization_Flag : Boolean := False;
-
- function Create return Ctrl is
- Obj : Ctrl (Ident_Bool (True));
- begin
- Obj.C2 := 3.0;
- return Obj;
- end Create;
-
- procedure Finalize (Obj : in out Ctrl) is
- begin
- Finalization_Flag := True;
- end Finalize;
-
- function Finalize_Was_Called return Boolean is
- begin
- if Finalization_Flag then
- Finalization_Flag := False;
- return True;
- else
- return False;
- end if;
- end Finalize_Was_Called;
-
-end C761012_0;
-
-with Ada.Exceptions;
-use Ada.Exceptions;
-with C761012_0;
-use C761012_0;
-with Report;
-use Report;
-procedure C761012 is
-begin
- Test ("C761012",
- "Check that an anonymous object is finalized with its enclosing " &
- "master if a transfer of control or exception occurs prior to " &
- "performing its normal finalization");
-
- Excep:
- begin
-
- declare
- I : Integer := Create.C1; -- Raises Constraint_Error
- begin
- Failed
- ("Improper component selection did not raise Constraint_Error, I =" &
- Integer'Image (I));
- exception
- when Constraint_Error =>
- Failed ("Constraint_Error caught by the wrong handler");
- end;
-
- Failed ("Transfer of control did not happen correctly");
-
- exception
- when Constraint_Error =>
- if not Finalize_Was_Called then
- Failed ("Finalize wasn't called when the master was left " &
- "- Constraint_Error");
- end if;
- when E: others =>
- Failed ("Exception " & Exception_Name (E) &
- " raised - " & Exception_Information (E));
- end Excep;
-
- Transfer:
- declare
- Finalize_Was_Called_Before_Leaving_Exit : Boolean;
- begin
-
- begin
- loop
- exit when Create.C2 = 3.0;
- end loop;
- Finalize_Was_Called_Before_Leaving_Exit := Finalize_Was_Called;
- if Finalize_Was_Called_Before_Leaving_Exit then
- Comment ("Finalize called before the transfer of control");
- end if;
- end;
-
- if not Finalize_Was_Called and then
- not Finalize_Was_Called_Before_Leaving_Exit then
- Failed ("Finalize wasn't called when the master was left " &
- "- transfer of control");
- end if;
- end Transfer;
-
- Result;
-end C761012;
-
diff --git a/gcc/testsuite/ada/acats/tests/c8/c840001.a b/gcc/testsuite/ada/acats/tests/c8/c840001.a
deleted file mode 100644
index 2a1df16409a..00000000000
--- a/gcc/testsuite/ada/acats/tests/c8/c840001.a
+++ /dev/null
@@ -1,257 +0,0 @@
--- C840001.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that, for the type determined by the subtype mark of a use type
--- clause, the declaration of each primitive operator is use-visible
--- within the scope of the clause, even if explicit operators with the
--- same names as the type's operators are declared for the subtype. Check
--- that a call to such an operator executes the body of the type's
--- operation.
---
--- TEST DESCRIPTION:
--- A type may declare a primitive operator, and a subtype of that type
--- may overload the operator. If a use type clause names the subtype,
--- it is the primitive operator of the type (not the subtype) which
--- is made directly visible, and the primitive operator may be called
--- unambiguously. Such a call executes the body of the type's operation.
---
--- In a package, declare a type for which a predefined operator is
--- overridden. In another package, declare a subtype of the type in the
--- previous package. Declare another version of the predefined operator
--- for the subtype.
---
--- The main program declares objects of both the type and the explicit
--- subtype, and uses the "**" operator for both. In all cases, the
--- operator declared for the 1st subtype should be the one executed,
--- since it is the primitive operators of the *type* that are made
--- visible; the operators which were declared for the explicit subtype
--- are not primitive operators of the type, since they were declared in
--- a separate package from the original type.
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 23 Sep 99 RLB Added test case where operator made visible is
--- not visible by selection (as in AI-00122).
---
---!
-
-package C840001_0 is
--- Usage scenario: the predefined operators for a floating point type
--- are overridden in order to take advantage of improved algorithms.
-
- type Precision_Float is new Float range -100.0 .. 100.0;
- -- Implicit: function "**" (Left: Precision_Float; Right: Integer'Base)
- -- return Precision_Float;
-
- function "**" (Left: Precision_Float; Right: Integer'Base)
- return Precision_Float;
- -- Overrides predefined operator.
-
- function "+" (Right: Precision_Float)
- return Precision_Float;
- -- Overrides predefined operator.
-
- -- ... Other overridden operations.
-
- TC_Expected : constant Precision_Float := 68.0;
-
-end C840001_0;
-
-
- --==================================================================--
-
-package body C840001_0 is
-
- function "**" (Left: Precision_Float; Right: Integer'Base)
- return Precision_Float is
- begin
- -- ... Utilize desired algorithm.
- return (TC_Expected); -- Artificial for testing purposes.
- end "**";
-
- function "+" (Right: Precision_Float)
- return Precision_Float is
- -- Overrides predefined operator.
- begin
- return Right*2.0;
- end "+";
-
-end C840001_0;
-
-
- --==================================================================--
-
--- Take advantage of some even better algorithms designed for positive
--- floating point values.
-
-with C840001_0;
-package C840001_1 is
-
- subtype Precision_Pos_Float is C840001_0.Precision_Float
- range 0.0 .. 100.0;
-
--- This is not a new type, so it has no primitives of it own. However, it
--- can declare another version of the operator and call it as long as both it
--- and the corresponding operator of the 1st subtype are not directly visible
--- in the same place.
-
- function "**" (Left: Precision_Pos_Float; Right: Natural'Base)
- return Precision_Pos_Float; -- Accepts only positive exponent.
-
-end C840001_1;
-
-
- --==================================================================--
-
-package body C840001_1 is
-
- function "**" (Left: Precision_Pos_Float; Right: Natural'Base)
- return Precision_Pos_Float is
- begin
- -- ... Utilize some other algorithms.
- return 57.0; -- Artificial for testing purposes.
- end "**";
-
-end C840001_1;
-
-
- --==================================================================--
-
-with Report;
-with C840001_1;
-procedure C840001_2 is
-
- -- Note that C840001_0 and it's contents is not visible in any form here.
-
- TC_Operand : C840001_1.Precision_Pos_Float := 41.0;
-
- TC_Operand2 : C840001_1.Precision_Pos_Float;
-
- use type C840001_1.Precision_Pos_Float;
- -- Makes the operators of its parent type directly visible, even though
- -- the parent type and operators are not otherwise visible at all.
-
-begin
-
- TC_Operand2 := +TC_Operand; -- Overridden operator is visible and called.
-
- if TC_Operand2 /= 82.0 then -- Predefined equality.
- Report.Failed ("3rd test: type's overridden operation not called for " &
- "operand of 1st subtype");
- end if;
- if TC_Operand + 3.0 >= TC_Operand2 - 13.0 then -- Various predefined operators.
- Report.Failed ("3rd test: wrong result from predefined operators");
- end if;
-
-end C840001_2;
-
- --==================================================================--
-
-
-with C840001_0;
-with C840001_1;
-with C840001_2;
-
-with Report;
-
-procedure C840001 is
-
-begin
- Report.Test ("C840001", "Check that, for the type determined by the " &
- "subtype mark of a use type clause, the declaration of " &
- "each primitive operator is use-visible within the scope " &
- "of the clause, even if explicit operators with the same " &
- "names as the type's operators are declared for the subtype");
-
-
- Use_Type_Precision_Pos_Float:
- declare
- TC_Operand : C840001_0.Precision_Float
- := C840001_0.Precision_Float(-2.0);
- TC_Positive_Operand : C840001_1.Precision_Pos_Float := 6.0;
-
- TC_Actual_Type : C840001_0.Precision_Float;
- TC_Actual_Subtype : C840001_1.Precision_Pos_Float;
-
- use type C840001_1.Precision_Pos_Float;
- -- Both calls to "**" should return 68.0 (that is, Precision_Float's
- -- operation should be called).
-
- begin
-
- TC_Actual_Type := TC_Operand**2;
-
- if C840001_0."/="(TC_Actual_Type, C840001_0.TC_Expected) then
- Report.Failed ("1st block: type's operation not called for " &
- "operand of 1st subtype");
- end if;
-
- TC_Actual_Subtype := TC_Positive_Operand**2;
-
- if not (C840001_0."="
- (TC_Actual_Subtype, C840001_0.TC_Expected)) then
- Report.Failed ("1st block: type's operation not called for " &
- "operand of explicit subtype");
- end if;
-
- end Use_Type_Precision_Pos_Float;
-
- Use_Type_Precision_Float:
- declare
- TC_Operand : C840001_0.Precision_Float
- := C840001_0.Precision_Float(4.0);
- TC_Positive_Operand : C840001_1.Precision_Pos_Float := 7.0;
-
- TC_Actual_Type : C840001_0.Precision_Float;
- TC_Actual_Subtype : C840001_1.Precision_Pos_Float;
-
- use type C840001_0.Precision_Float;
- -- Again, both calls to "**" should return 68.0.
-
- begin
-
- TC_Actual_Type := TC_Operand**2;
-
- if C840001_0."/="(TC_Actual_Type, C840001_0.TC_Expected) then
- Report.Failed ("2nd block: type's operation not called for " &
- "operand of 1st subtype");
- end if;
-
- TC_Actual_Subtype := TC_Positive_Operand**2;
-
- if not C840001_0."=" (TC_Actual_Subtype, C840001_0.TC_Expected) then
- Report.Failed ("2nd block: type's operation not called for " &
- "operand of explicit subtype");
- end if;
-
- end Use_Type_Precision_Float;
-
- C840001_2; -- 3rd test.
-
- Report.Result;
-
-end C840001;
diff --git a/gcc/testsuite/ada/acats/tests/c8/c854001.a b/gcc/testsuite/ada/acats/tests/c8/c854001.a
deleted file mode 100644
index 5a128ba69b1..00000000000
--- a/gcc/testsuite/ada/acats/tests/c8/c854001.a
+++ /dev/null
@@ -1,277 +0,0 @@
--- C854001.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that a subprogram declaration can be completed by a
--- subprogram renaming declaration. In particular, check that such a
--- renaming-as-body can be given in a package body to complete a
--- subprogram declared in the package specification. Check that calls
--- to the subprogram invoke the body of the renamed subprogram. Check
--- that a renaming allows a copy of an inherited or predefined subprogram
--- before overriding it later. Check that renaming a dispatching
--- operation calls the correct body in case of overriding.
---
--- TEST DESCRIPTION:
--- This test declares a record type, an integer type, and a tagged type
--- with a set of operations in a package. A renaming of a predefined
--- equality operation of a tagged type is also defined in this package.
--- The predefined operation is overridden in the private part. In a
--- separate package, a subtype of the record type and integer type
--- are declared. Subset of the full set of operations for the record
--- and types is reexported using renamings-as-bodies. Other operations
--- are given explicit bodies. The test verifies that the appropriate
--- body is executed for each operation on the subtype.
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 07 Nov 95 SAIC Update and repair for ACVC 2.0.1
---
---!
-
-package C854001_0 is
-
- type Component is (Op_Of_Type, Op_Of_Subtype, Initial_Value);
-
- type Root is record
- Called : Component := Op_Of_Subtype;
- end record;
-
- procedure Root_Proc (P: in out Root);
- procedure Over_Proc (P: in out Root);
-
- function Root_Func return Root;
- function Over_Func return Root;
-
- type Short_Int is range 1 .. 98;
-
- function "+" (P1, P2 : Short_Int) return Short_Int;
- function Name (P1, P2 : Short_Int) return Short_Int;
-
- type Tag_Type is tagged record
- C : Component := Initial_Value;
- end record;
- -- Inherits predefined operator "=" and others.
-
- function Predefined_Equal (P1, P2 : Tag_Type) return Boolean
- renames "=";
- -- Renames predefined operator "=" before overriding.
-
-private
- function "=" (P1, P2 : Tag_Type)
- return Boolean; -- Overrides predefined operator "=".
-
-
-end C854001_0;
-
-
- --==================================================================--
-
-
-package body C854001_0 is
-
- procedure Root_Proc (P: in out Root) is
- begin
- P.Called := Initial_Value;
- end Root_Proc;
-
- ---------------------------------------
- procedure Over_Proc (P: in out Root) is
- begin
- P.Called := Op_Of_Type;
- end Over_Proc;
-
- ---------------------------------------
- function Root_Func return Root is
- begin
- return (Called => Op_Of_Type);
- end Root_Func;
-
- ---------------------------------------
- function Over_Func return Root is
- begin
- return (Called => Initial_Value);
- end Over_Func;
-
- ---------------------------------------
- function "+" (P1, P2 : Short_Int) return Short_Int is
- begin
- return 15;
- end "+";
-
- ---------------------------------------
- function Name (P1, P2 : Short_Int) return Short_Int is
- begin
- return 47;
- end Name;
-
- ---------------------------------------
- function "=" (P1, P2 : Tag_Type) return Boolean is
- begin
- return False;
- end "=";
-
-end C854001_0;
-
- --==================================================================--
-
-
-with C854001_0;
-package C854001_1 is
-
- subtype Root_Subtype is C854001_0.Root;
- subtype Short_Int_Subtype is C854001_0.Short_Int;
-
- procedure Ren_Proc (P: in out Root_Subtype);
- procedure Same_Proc (P: in out Root_Subtype);
-
- function Ren_Func return Root_Subtype;
- function Same_Func return Root_Subtype;
-
- function Other_Name (P1, P2 : Short_Int_Subtype) return Short_Int_Subtype;
- function "-" (P1, P2 : Short_Int_Subtype) return Short_Int_Subtype;
-
- function User_Defined_Equal (P1, P2 : C854001_0.Tag_Type) return Boolean
- renames C854001_0."="; -- Executes body of the
- -- overriding declaration in
- -- the private part.
-end C854001_1;
-
-
- --==================================================================--
-
-
-with C854001_0;
-package body C854001_1 is
-
- --
- -- Renaming-as-body for procedure:
- --
-
- procedure Ren_Proc (P: in out Root_Subtype)
- renames C854001_0.Root_Proc;
- procedure Same_Proc (P: in out Root_Subtype)
- renames C854001_0.Over_Proc;
-
- --
- -- Renaming-as-body for function:
- --
-
- function Ren_Func return Root_Subtype renames C854001_0.Root_Func;
- function Same_Func return Root_Subtype renames C854001_0.Over_Func;
-
- function Other_Name (P1, P2 : Short_Int_Subtype) return Short_Int_Subtype
- renames C854001_0."+";
- function "-" (P1, P2 : Short_Int_Subtype) return Short_Int_Subtype
- renames C854001_0.Name;
-
-end C854001_1;
-
-
- --==================================================================--
-
-with C854001_0;
-with C854001_1; -- Subtype and associated operations.
-use C854001_1;
-
-with Report;
-
-procedure C854001 is
- Operand1 : Root_Subtype;
- Operand2 : Root_Subtype;
- Operand3 : Root_Subtype;
- Operand4 : Root_Subtype;
- Operand5 : Short_Int_Subtype := 55;
- Operand6 : Short_Int_Subtype := 46;
- Operand7 : Short_Int_Subtype;
- Operand8 : C854001_0.Tag_Type; -- Both Operand8 & Operand9 have
- Operand9 : C854001_0.Tag_Type; -- the same default values.
-
- -- Direct visibility to operator symbols
- use type C854001_0.Component;
- use type C854001_0.Short_Int;
-
-begin
- Report.Test ("C854001", "Check that a renaming-as-body can be given " &
- "in a package body to complete a subprogram " &
- "declared in the package specification. " &
- "Check that calls to the subprogram invoke " &
- "the body of the renamed subprogram");
-
- --
- -- Only operations of the subtype are available.
- --
-
- Ren_Proc (Operand1);
- if Operand1.Called /= C854001_0.Initial_Value then
- Report.Failed ("Error calling procedure Ren_Proc");
- end if;
-
- ---------------------------------------
- Same_Proc (Operand2);
- if Operand2.Called /= C854001_0.Op_Of_Type then
- Report.Failed ("Error calling procedure Same_Proc");
- end if;
-
- ---------------------------------------
- Operand3 := Ren_Func;
- if Operand3.Called /= C854001_0.Op_Of_Type then
- Report.Failed ("Error calling function Ren_Func");
- end if;
-
- ---------------------------------------
- Operand4 := Same_Func;
- if Operand4.Called /= C854001_0.Initial_Value then
- Report.Failed ("Error calling function Same_Func");
- end if;
-
- ---------------------------------------
- Operand7 := C854001_1."-" (Operand5, Operand6);
- if Operand7 /= 47 then
- Report.Failed ("Error calling function & ""-""");
- end if;
-
- ---------------------------------------
- Operand7 := Other_Name (Operand5, Operand6);
- if Operand7 /= 15 then
- Report.Failed ("Error calling function Other_Name");
- end if;
-
- ---------------------------------------
- -- Executes body of the overriding declaration in the private part
- -- of C854001_0.
- if User_Defined_Equal (Operand8, Operand9) then
- Report.Failed ("Error calling function User_Defined_Equal");
- end if;
-
- ---------------------------------------
- -- Executes predefined operation.
- if not C854001_0.Predefined_Equal (Operand8, Operand9) then
- Report.Failed ("Error calling function Predefined_Equal");
- end if;
-
- Report.Result;
-
-end C854001;
diff --git a/gcc/testsuite/ada/acats/tests/c8/c854002.a b/gcc/testsuite/ada/acats/tests/c8/c854002.a
deleted file mode 100644
index 19bca35984e..00000000000
--- a/gcc/testsuite/ada/acats/tests/c8/c854002.a
+++ /dev/null
@@ -1,185 +0,0 @@
--- C854002.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687 and
--- F08630-91-C-0015, the U.S. Government obtained unlimited rights in the
--- software and documentation contained herein. Unlimited rights are
--- defined in DFAR 252.227-7013(a)(19). By making this public release,
--- the Government intends to confer upon all recipients unlimited rights
--- equal to those held by the Government. These rights include rights to
--- use, duplicate, release or disclose the released technical data and
--- computer software in whole or in part, in any manner and for any purpose
--- whatsoever, and to have or permit others to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE
--- Check the requirements of the new 8.5.4(8.A) from Technical
--- Corrigendum 1 (originally discussed as AI95-00064).
--- This paragraph requires an elaboration check on renamings-as-body:
--- even if the body of the ultimately-called subprogram has been
--- elaborated, the check should fail if the renaming-as-body
--- itself has not yet been elaborated.
---
--- TEST DESCRIPTION
--- We declare two functions F and G, and ensure that they are
--- elaborated before anything else, by using pragma Pure. Then we
--- declare two renamings-as-body: the renaming of F is direct, and
--- the renaming of G is via an access-to-function object. We call
--- the renamings during elaboration, and check that they raise
--- Program_Error. We then call them again after elaboration; this
--- time, they should work.
---
--- CHANGE HISTORY:
--- 29 JUN 1999 RAD Initial Version
--- 23 SEP 1999 RLB Improved comments, renamed, issued.
--- 28 JUN 2002 RLB Added pragma Elaborate_All for Report.
---!
-
-package C854002_1 is
- pragma Pure;
- -- Empty.
-end C854002_1;
-
-package C854002_1.Pure is
- pragma Pure;
- function F return String;
- function G return String;
-end C854002_1.Pure;
-
-with C854002_1.Pure;
-package C854002_1.Renamings is
-
- F_Result: constant String := C854002_1.Pure.F; -- Make sure we can call F.
- function Renamed_F return String;
-
- G_Result: constant String := C854002_1.Pure.G;
- type String_Function is access function return String;
- G_Pointer: String_Function := null;
- -- Will be set to C854002_1.Pure.G'Access in the body.
- function Renamed_G return String;
-
-end C854002_1.Renamings;
-
-package C854002_1.Caller is
-
- -- These procedures call the renamings; when called during elaboration,
- -- we pass Should_Fail => True, which checks that Program_Error is
- -- raised. Later, we use Should_Fail => False.
-
- procedure Call_Renamed_F(Should_Fail: Boolean);
- procedure Call_Renamed_G(Should_Fail: Boolean);
-
-end C854002_1.Caller;
-
-with Report; use Report; pragma Elaborate_All (Report);
-with C854002_1.Renamings;
-package body C854002_1.Caller is
-
- Some_Error: exception;
-
- procedure Call_Renamed_F(Should_Fail: Boolean) is
- begin
- if Should_Fail then
- begin
- Failed(C854002_1.Renamings.Renamed_F);
- raise Some_Error;
- -- This raise statement is necessary, because the
- -- Report package has a bug -- if Failed is called
- -- before Test, then the failure is ignored, and the
- -- test prints "PASSED".
- -- Presumably, this raise statement will cause the
- -- program to crash, thus avoiding the PASSED message.
- exception
- when Program_Error =>
- Comment("Program_Error -- OK");
- end;
- else
- if C854002_1.Renamings.F_Result /= C854002_1.Renamings.Renamed_F then
- Failed("Bad result from renamed F");
- end if;
- end if;
- end Call_Renamed_F;
-
- procedure Call_Renamed_G(Should_Fail: Boolean) is
- begin
- if Should_Fail then
- begin
- Failed(C854002_1.Renamings.Renamed_G);
- raise Some_Error;
- exception
- when Program_Error =>
- Comment("Program_Error -- OK");
- end;
- else
- if C854002_1.Renamings.G_Result /= C854002_1.Renamings.Renamed_G then
- Failed("Bad result from renamed G");
- end if;
- end if;
- end Call_Renamed_G;
-
-begin
- -- At this point, the bodies of Renamed_F and Renamed_G have not yet
- -- been elaborated, so calling them should raise Program_Error:
- Call_Renamed_F(Should_Fail => True);
- Call_Renamed_G(Should_Fail => True);
-end C854002_1.Caller;
-
-package body C854002_1.Pure is
-
- function F return String is
- begin
- return "This is function F";
- end F;
-
- function G return String is
- begin
- return "This is function G";
- end G;
-
-end C854002_1.Pure;
-
-with C854002_1.Pure;
-with C854002_1.Caller; pragma Elaborate(C854002_1.Caller);
- -- This pragma ensures that this package body (Renamings)
- -- will be elaborated after Caller, so that when Caller calls
- -- the renamings during its elaboration, the renamings will
- -- not have been elaborated (although what the rename have been).
-package body C854002_1.Renamings is
-
- function Renamed_F return String renames C854002_1.Pure.F;
-
- package Dummy is end; -- So we can insert statements here.
- package body Dummy is
- begin
- G_Pointer := C854002_1.Pure.G'Access;
- end Dummy;
-
- function Renamed_G return String renames G_Pointer.all;
-
-end C854002_1.Renamings;
-
-with Report; use Report;
-with C854002_1.Caller;
-procedure C854002 is
-begin
- Test("C854002",
- "An elaboration check is performed for a call to a subprogram"
- & " whose body is given as a renaming-as-body");
-
- -- By the time we get here, all library units have been elaborated,
- -- so the following calls should not raise Program_Error:
- C854002_1.Caller.Call_Renamed_F(Should_Fail => False);
- C854002_1.Caller.Call_Renamed_G(Should_Fail => False);
-
- Result;
-end C854002;
diff --git a/gcc/testsuite/ada/acats/tests/c8/c854003.a b/gcc/testsuite/ada/acats/tests/c8/c854003.a
deleted file mode 100644
index 9ab2364a92c..00000000000
--- a/gcc/testsuite/ada/acats/tests/c8/c854003.a
+++ /dev/null
@@ -1,64 +0,0 @@
--- C854003.A
---
--- Grant of Unlimited Rights
---
--- The Ada Conformity Assessment Authority (ACAA) holds unlimited
--- rights in the software and documentation contained herein. Unlimited
--- rights are the same as those granted by the U.S. Government for older
--- parts of the Ada Conformity Assessment Test Suite, and are defined
--- in DFAR 252.227-7013(a)(19). By making this public release, the ACAA
--- intends to confer upon all recipients unlimited rights equal to those
--- held by the ACAA. These rights include rights to use, duplicate,
--- release or disclose the released technical data and computer software
--- in whole or in part, in any manner and for any purpose whatsoever, and
--- to have or permit others to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that a renaming-as-body used before the subprogram is frozen only
--- requires mode conformance. (Defect Report 8652/0028, as reflected in
--- Technical Corrigendum 1, RM95 8.5.4(5/1)).
---
--- CHANGE HISTORY:
--- 29 JAN 2001 PHL Initial version.
--- 5 DEC 2001 RLB Reformatted for ACATS.
---
---!
-with Report;
-use Report;
-procedure C854003 is
-
- package P is
- type T is private;
- C1 : constant T;
- C2 : constant T;
- private
- type T is new Integer'Base;
- C1 : constant T := T (Ident_Int (1));
- C2 : constant T := T (Ident_Int (1));
- end P;
-
- function Equals (X, Y : P.T) return Boolean;
- function Equals (X, Y : P.T) return Boolean renames P."=";
-
-begin
- Test ("C854003",
- "Check that a renaming-as-body used before the subprogram " &
- "is frozen only requires mode conformance");
-
- if not Equals (P.C1, P.C2) then
- Failed ("Equality returned an unexpected result");
- end if;
-
- Result;
-end C854003;
-
diff --git a/gcc/testsuite/ada/acats/tests/c9/c910001.a b/gcc/testsuite/ada/acats/tests/c9/c910001.a
deleted file mode 100644
index 416e13ca8fb..00000000000
--- a/gcc/testsuite/ada/acats/tests/c9/c910001.a
+++ /dev/null
@@ -1,224 +0,0 @@
--- C910001.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that tasks may have discriminants. Specifically, check where
--- the subtype of the discriminant is a discrete subtype and where it is
--- an access subtype. Check the case where the default values of the
--- discriminants are used.
---
--- TEST DESCRIPTION:
--- A task is defined with two discriminants, one a discrete subtype and
--- another that is an access subtype. Tasks are created with various
--- values for discriminants and code within the task checks that these
--- are passed in correctly. One instance of a default is used. The
--- values passed to the task as the discriminants are taken from an
--- array of test data and the values received are checked against the
--- same array.
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
---
---!
-
-with Report;
-
-procedure C910001 is
-
-
- type App_Priority is range 1..10;
- Default_Priority : App_Priority := 5;
-
- type Message_ID is range 1..10_000;
-
- type TC_Number_of_Messages is range 1..5;
-
- type TC_rec is record
- TC_ID : Message_ID;
- A_Priority : App_Priority;
- TC_Checked : Boolean;
- end record;
-
- -- This table is used to create the messages and to check them
- TC_table : array (1..TC_Number_of_Messages'Last) of TC_Rec :=
- ( ( 10, 6, false ),
- ( 20, 2, false ),
- ( 30, 9, false ),
- ( 40, 1, false ),
- ( 50, Default_Priority, false ) );
-
-begin -- C910001
-
- Report.Test ("C910001", "Check that tasks may have discriminants");
-
-
- declare -- encapsulate the test
-
- type Transaction_Record is
- record
- ID : Message_ID;
- Account_Number : integer := 0;
- Stock_Number : integer := 0;
- Quantity : integer := 0;
- Return_Value : integer := 0;
- end record;
- --
- type acc_Transaction_Record is access Transaction_Record;
-
-
- task type Message_Task
- (In_Message : acc_Transaction_Record := null;
- In_Priority : App_Priority := Default_Priority) is
- entry Start;
- end Message_Task;
- type acc_Message_Task is access Message_Task;
- --
- --
- task body Message_Task is
- This_Message : acc_Transaction_Record := In_Message;
- This_Priority : App_Priority := In_Priority;
- TC_Match_Found : Boolean := false;
- begin
- accept Start;
- -- In the example envisioned this task would then queue itself
- -- upon some Distributor task which would send it off (requeue) to
- -- the message processing tasks according to the priority of the
- -- message and the current load on the system. For the test we
- -- just verify the data passed in as discriminants and exit the task
- --
- -- Check for the special case of default discriminants
- if This_Message = null then
- -- The default In_Message has been passed, check that the
- -- default priority was also passed
- if This_Priority /= Default_Priority then
- Report.Failed ("Incorrect Default Priority");
- end if;
- if TC_Table (TC_Number_of_Messages'Last).TC_Checked then
- Report.Failed ("Duplicate Default messages");
- else
- -- Mark that default has been seen
- TC_Table (TC_Number_of_Messages'Last).TC_Checked := True;
- end if;
- TC_Match_Found := true;
- else
- -- Check the data against the table
- for i in TC_Number_of_Messages loop
- if TC_Table(i).TC_ID = This_Message.ID then
- -- this is the right slot in the table
- if TC_Table(i).TC_checked then
- -- Already checked
- Report.Failed ("Duplicate Data");
- else
- TC_Table(i).TC_checked := true;
- end if;
- TC_Match_Found := true;
- if TC_Table(i).A_Priority /= This_Priority then
- Report.Failed ("ID/Priority mismatch");
- end if;
- exit;
- end if;
- end loop;
- end if;
-
- if not TC_Match_Found then
- Report.Failed ("No ID match in table");
- end if;
-
- -- Allow the task to terminate
-
- end Message_Task;
-
-
- -- The Line Driver task accepts data from an external source and
- -- builds them into a transaction record. It then generates a
- -- message task. This message "contains" the record and is given
- -- a priority according to the contents of the message. The priority
- -- and transaction records are passed to the task as discriminants.
- -- In this test we use a dummy record. Only the ID is of interest
- -- so we pick that and the required priority from an array of
- -- test data. We artificially limit the endless driver-loop to
- -- the number of messages required for the test and add a special
- -- case to check the defaults.
- --
- task Driver_Task;
- --
- task body Driver_Task is
- begin
-
- -- Create all but one of the required tasks
- --
- for i in 1..TC_Number_of_Messages'Last - 1 loop
- declare
- -- Create a record for the next message
- Next_Transaction : acc_Transaction_Record :=
- new Transaction_Record;
- -- Create a task for the next message
- Next_Message_Task : acc_Message_Task :=
- new Message_Task( Next_Transaction,
- TC_Table(i).A_Priority );
-
- begin
- -- Artificially plug the ID with the next from the table
- -- In reality the whole record would be built here
- Next_Transaction.ID := TC_Table(i).TC_ID;
-
- -- Ensure the task does not start executing till the
- -- transaction record is properly constructed
- Next_Message_Task.Start;
-
- end; -- declare
- end loop;
-
- -- For this subtest create one task with the default discriminants
- --
- declare
-
- -- Create the task
- Next_Message_Task : acc_Message_Task := new Message_Task;
-
- begin
-
- Next_Message_Task.Start;
-
- end; -- declare
-
-
- end Driver_Task;
-
- begin
- null;
- end; -- encapsulation
-
- -- Now verify that all the tasks executed and checked in
- for i in TC_Number_of_Messages loop
- if not TC_Table(i).TC_Checked then
- Report.Failed
- ("Task" & integer'image(integer (i) ) & " did not verify");
- end if;
- end loop;
- Report.Result;
-
-end C910001;
diff --git a/gcc/testsuite/ada/acats/tests/c9/c910002.a b/gcc/testsuite/ada/acats/tests/c9/c910002.a
deleted file mode 100644
index dc0b9b36bba..00000000000
--- a/gcc/testsuite/ada/acats/tests/c9/c910002.a
+++ /dev/null
@@ -1,143 +0,0 @@
--- C910002.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that the contents of a task object include the values
--- of its discriminants.
--- Check that selected_component notation can be used to
--- denote a discriminant of a task.
---
--- TEST DESCRIPTION:
--- This test declares a task type that contains discriminants.
--- Objects of the task type are created with different values.
--- The task type has nested tasks that are used to check that
--- the discriminate values are the expected values.
--- Note that the names of the discriminants in the body of task
--- type DTT denote the current instance of the unit.
---
---
--- CHANGE HISTORY:
--- 12 OCT 95 SAIC Initial release for 2.1
--- 8 MAY 96 SAIC Incorporated Reviewer comments.
---
---!
-
-
-with Report;
-procedure C910002 is
- Verbose : constant Boolean := False;
-begin
- Report.Test ("C910002",
- "Check that selected_component notation can be" &
- " used to access task discriminants");
- declare
-
- task type DTT
- (IA, IB : Integer;
- CA, CB : Character) is
- entry Check_Values (First_Int : Integer;
- First_Char : Character);
- end DTT;
-
- task body DTT is
- Int1 : Integer;
- Char1 : Character;
-
- -- simple nested task to check the character values
- task Check_Chars is
- entry Start_Check;
- end Check_Chars;
- task body Check_Chars is
- begin
- accept Start_Check;
- if DTT.CA /= Char1 or
- DTT.CB /= Character'Succ (Char1) then
- Report.Failed ("character check failed. Expected: '" &
- Char1 & Character'Succ (Char1) &
- "' but found '" &
- DTT.CA & DTT.CB & "'");
- elsif Verbose then
- Report.Comment ("char check for " & Char1);
- end if;
- exception
- when others => Report.Failed ("exception in Check_Chars");
- end Check_Chars;
-
- -- use a discriminated task to check the integer values
- task type Check_Ints (First : Integer);
- task body Check_Ints is
- begin
- if DTT.IA /= Check_Ints.First or
- IB /= First+1 then
- Report.Failed ("integer check failed. Expected:" &
- Integer'Image (Check_Ints.First) &
- Integer'Image (First+1) &
- " but found" &
- Integer'Image (DTT.IA) & Integer'Image (IB) );
- elsif Verbose then
- Report.Comment ("int check for" & Integer'Image (First));
- end if;
- exception
- when others => Report.Failed ("exception in Check_Ints");
- end Check_Ints;
- begin
- accept Check_Values (First_Int : Integer;
- First_Char : Character) do
- Int1 := First_Int;
- Char1 := First_Char;
- end Check_Values;
-
- -- kick off the character check
- Check_Chars.Start_Check;
-
- -- do the integer check
- declare
- Int_Checker : Check_Ints (Int1);
- begin
- null; -- let task do its thing
- end;
-
- -- do one test here too
- if DTT.IA /= Int1 then
- Report.Failed ("DTT check failed. Expected:" &
- Integer'Image (Int1) &
- " but found:" &
- Integer'Image (DTT.IA));
- elsif Verbose then
- Report.Comment ("DTT check for" & Integer'Image (Int1));
- end if;
- exception
- when others => Report.Failed ("exception in DTT");
- end DTT;
-
- T1a : DTT (1, 2, 'a', 'b');
- T9C : DTT (9, 10, 'C', 'D');
- begin -- test encapsulation
- T1a.Check_Values (1, 'a');
- T9C.Check_Values (9, 'C');
- end;
-
- Report.Result;
-end C910002;
diff --git a/gcc/testsuite/ada/acats/tests/c9/c910003.a b/gcc/testsuite/ada/acats/tests/c9/c910003.a
deleted file mode 100644
index b2e11cef826..00000000000
--- a/gcc/testsuite/ada/acats/tests/c9/c910003.a
+++ /dev/null
@@ -1,185 +0,0 @@
--- C910003.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687 and
--- F08630-91-C-0015, the U.S. Government obtained unlimited rights in the
--- software and documentation contained herein. Unlimited rights are
--- defined in DFAR 252.227-7013(a)(19). By making this public release,
--- the Government intends to confer upon all recipients unlimited rights
--- equal to those held by the Government. These rights include rights to
--- use, duplicate, release or disclose the released technical data and
--- computer software in whole or in part, in any manner and for any purpose
--- whatsoever, and to have or permit others to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that task discriminants that have an access subtype may be
--- dereferenced.
---
--- Note that discriminants in Ada 83 never can be dereferenced with
--- selection or indexing, as they cannot have an access type.
---
--- TEST DESCRIPTION:
--- A protected object is defined to create a simple buffer.
--- Two task types are defined, one to put values into the buffer,
--- and one to remove them. The tasks are passed a buffer object as
--- a discriminant with an access subtype. The producer task type includes
--- a discriminant to determine the values to product. The consumer task
--- type includes a value to save the results.
--- Two producer and one consumer tasks are declared, and the results
--- are checked.
---
--- CHANGE HISTORY:
--- 10 Mar 99 RLB Created test.
---
---!
-
-package C910003_Pack is
-
- type Item_Type is range 1 .. 100; -- In a real application, this probably
- -- would be a record type.
-
- type Item_Array is array (Positive range <>) of Item_Type;
-
- protected type Buffer is
- entry Put (Item : in Item_Type);
- entry Get (Item : out Item_Type);
- function TC_Items_Buffered return Item_Array;
- private
- Saved_Item : Item_Type;
- Empty : Boolean := True;
- TC_Items : Item_Array (1 .. 10);
- TC_Last : Natural := 0;
- end Buffer;
-
- type Buffer_Access_Type is access Buffer;
-
- PRODUCE_COUNT : constant := 2; -- Number of items to produce.
-
- task type Producer (Buffer_Access : Buffer_Access_Type;
- Start_At : Item_Type);
- -- Produces PRODUCE_COUNT items. Starts when activated.
-
- type TC_Item_Array_Access_Type is access Item_Array (1 .. PRODUCE_COUNT*2);
-
- task type Consumer (Buffer_Access : Buffer_Access_Type;
- Results : TC_Item_Array_Access_Type) is
- -- Stores PRODUCE_COUNT*2 items consumed in Results. Starts when
- -- activated.
- entry Wait_until_Done;
- end Consumer;
-
-end C910003_Pack;
-
-
-with Report;
-package body C910003_Pack is
-
- protected body Buffer is
- entry Put (Item : in Item_Type) when Empty is
- begin
- Empty := False;
- Saved_Item := Item;
- TC_Last := TC_Last + 1;
- TC_Items(TC_Last) := Item;
- end Put;
-
- entry Get (Item : out Item_Type) when not Empty is
- begin
- Empty := True;
- Item := Saved_Item;
- end Get;
-
- function TC_Items_Buffered return Item_Array is
- begin
- return TC_Items(1..TC_Last);
- end TC_Items_Buffered;
-
- end Buffer;
-
-
- task body Producer is
- -- Produces PRODUCE_COUNT items. Starts when activated.
- begin
- for I in 1 .. Report.Ident_Int(PRODUCE_COUNT) loop
- Buffer_Access.Put (Start_At + (Item_Type(I)-1)*2);
- end loop;
- end Producer;
-
-
- task body Consumer is
- -- Stores PRODUCE_COUNT*2 items consumed in Results. Starts when
- -- activated.
- begin
- for I in 1 .. Report.Ident_Int(PRODUCE_COUNT*2) loop
- Buffer_Access.Get (Results (I));
- -- Buffer_Access and Results are both dereferenced.
- end loop;
-
- -- Check the results (and function call with a prefix dereference).
- if Results.all(Report.Ident_Int(1)) /= Buffer_Access.all.TC_Items_Buffered(Report.Ident_Int(1)) then
- Report.Failed ("First item mismatch");
- end if;
- if Results(Report.Ident_Int(2)) /= Buffer_Access.TC_Items_Buffered(Report.Ident_Int(2)) then
- Report.Failed ("Second item mismatch");
- end if;
- accept Wait_until_Done; -- Tell main that we're done.
- end Consumer;
-
-end C910003_Pack;
-
-
-with Report;
-with C910003_Pack;
-
-procedure C910003 is
-
-begin -- C910003
-
- Report.Test ("C910003", "Check that tasks discriminants of access types can be dereferenced");
-
-
- declare -- encapsulate the test
-
- Buffer_Access : C910003_Pack.Buffer_Access_Type :=
- new C910003_Pack.Buffer;
-
- TC_Results : C910003_Pack.TC_Item_Array_Access_Type :=
- new C910003_Pack.Item_Array (1 .. C910003_Pack.PRODUCE_COUNT*2);
-
- Producer_1 : C910003_Pack.Producer (Buffer_Access, 12);
- Producer_2 : C910003_Pack.Producer (Buffer_Access, 23);
-
- Consumer : C910003_Pack.Consumer (Buffer_Access, TC_Results);
-
- use type C910003_Pack.Item_Array; -- For /=.
-
- begin
- Consumer.Wait_until_Done;
- if TC_Results.all /= Buffer_Access.TC_Items_Buffered then
- Report.Failed ("Different items buffered than returned - Main");
- end if;
- if (TC_Results.all /= (12, 14, 23, 25) and
- TC_Results.all /= (12, 23, 14, 25) and
- TC_Results.all /= (12, 23, 25, 14) and
- TC_Results.all /= (23, 12, 14, 25) and
- TC_Results.all /= (23, 12, 25, 14) and
- TC_Results.all /= (23, 25, 12, 14)) then
- -- Above are the only legal results.
- Report.Failed ("Wrong results");
- end if;
- end; -- encapsulation
-
- Report.Result;
-
-end C910003;
diff --git a/gcc/testsuite/ada/acats/tests/c9/c930001.a b/gcc/testsuite/ada/acats/tests/c9/c930001.a
deleted file mode 100644
index 87451899021..00000000000
--- a/gcc/testsuite/ada/acats/tests/c9/c930001.a
+++ /dev/null
@@ -1,153 +0,0 @@
--- C930001.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- TEST OBJECTIVE:
--- Check when a dependent task and its master both
--- terminate as a result of a terminate alternative that
--- finalization is performed and that the finalization is
--- performed in the proper order.
---
--- TEST DESCRIPTION:
--- A controlled type with finalization is used to determine
--- the order in which finalization occurs. The finalization
--- procedure records the identity of the object being
--- finalized.
--- Two tasks, one nested inside the other, both contain
--- objects of the above finalization type. These tasks
--- cooperatively terminate so the termination and finalization
--- order can be noted.
---
---
--- CHANGE HISTORY:
--- 08 Jan 96 SAIC ACVC 2.1
--- 09 May 96 SAIC Addressed Reviewer comments.
---
---!
-
-
-with Ada.Finalization;
-package C930001_0 is
- Verbose : constant Boolean := False;
-
- type Ids is range 0..10;
- Finalization_Order : array (Ids) of Ids := (Ids => 0);
- Finalization_Cnt : Ids := 0;
-
- protected Note is
- -- serializes concurrent access to Finalization_* above
- procedure Done (Id : Ids);
- end Note;
-
- -- Objects of the following type are used to note the order in
- -- which finalization occurs.
- type Has_Finalization is new Ada.Finalization.Limited_Controlled with
- record
- Id : Ids;
- end record;
- procedure Finalize (Object : in out Has_Finalization);
-end C930001_0;
-
-
-with Report;
-package body C930001_0 is
-
- protected body Note is
- procedure Done (Id : Ids) is
- begin
- Finalization_Cnt := Finalization_Cnt + 1;
- Finalization_Order (Finalization_Cnt) := Id;
- end Done;
- end Note;
-
- procedure Finalize (Object : in out Has_Finalization) is
- begin
- Note.Done (Object.Id);
- if Verbose then
- Report.Comment ("in Finalize for" & Ids'Image (Object.Id));
- end if;
- end Finalize;
-end C930001_0;
-
-
-with Report;
-with ImpDef;
-with C930001_0; use C930001_0;
-procedure C930001 is
-begin
-
- Report.Test ("C930001", "Check that dependent tasks are terminated" &
- " before the remaining finalization");
-
- declare
- task Level_1;
- task body Level_1 is
- V1a : C930001_0.Has_Finalization; -------> 4
- task Level_2 is
- entry Not_Taken;
- end Level_2;
- task body Level_2 is
- V2 : C930001_0.Has_Finalization; -------> 2
- begin
- V2.Id := 2;
- C930001_0.Note.Done (1); -------> 1
- select
- accept Not_Taken;
- or
- terminate;
- -- cooperative termination at this point of
- -- both tasks
- end select;
- end Level_2;
-
- -- 7.6.1(11) requires that V1b be finalized before V1a
- V1b : C930001_0.Has_Finalization; -------> 3
- begin
- V1a.Id := 4;
- V1b.Id := 3;
- end Level_1;
- begin -- declare
- while not Level_1'Terminated loop
- delay ImpDef.Switch_To_New_Task;
- end loop;
- C930001_0.Note.Done (5); -------> 5
-
- -- now check the order
- for I in Ids range 1..5 loop
- if Verbose then
- Report.Comment (Ids'Image (I) &
- Ids'Image (Finalization_Order (I)));
- end if;
- if Finalization_Order (I) /= I then
- Report.Failed ("Finalization occurred out of order" &
- " expected:" &
- Ids'Image (I) &
- " actual:" &
- Ids'Image (Finalization_Order (I)));
- end if;
- end loop;
- end;
-
- Report.Result;
-end C930001;
diff --git a/gcc/testsuite/ada/acats/tests/c9/c940001.a b/gcc/testsuite/ada/acats/tests/c9/c940001.a
deleted file mode 100644
index 2bc1a9ffd03..00000000000
--- a/gcc/testsuite/ada/acats/tests/c9/c940001.a
+++ /dev/null
@@ -1,212 +0,0 @@
--- C940001.A
---
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that a protected object provides coordinated access to
--- shared data. Check that it can be used to sequence a number of tasks.
--- Use the protected object to control a single token for which three
--- tasks compete. Check that only one task is running at a time and that
--- all tasks get a chance to run sometime.
---
--- TEST DESCRIPTION:
--- Declare a protected type with two entries. A task may call the Take
--- entry to get a token which allows it to continue processing. If it
--- has the token, it may call the Give entry to return it. The tasks
--- implement a discipline whereby only the task with the token may be
--- active. The test does not require any specific order for the tasks
--- to run.
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 07 Jul 96 SAIC Fixed spelling nits.
---
---!
-
-package C940001_0 is
-
- type Token_Type is private;
- True_Token : constant Token_Type; -- Create a deferred constant in order
- -- to provide a component init for the
- -- protected object
-
- protected type Token_Mgr_Prot_Unit is
- entry Take (T : out Token_Type);
- entry Give (T : in out Token_Type);
- private
- Token : Token_Type := True_Token;
- end Token_Mgr_Prot_Unit;
-
- function Init_Token return Token_Type; -- call to initialize an
- -- object of Token_Type
- function Token_Value (T : Token_Type) return Boolean;
- -- call to inspect the value of an
- -- object of Token_Type
-private
- type Token_Type is new boolean;
- True_Token : constant Token_Type := true;
-end C940001_0;
-
---=================================================================--
-
-package body C940001_0 is
- protected body Token_Mgr_Prot_Unit is
- entry Take (T : out Token_Type) when Token = true is
- begin -- Calling task will Take the token, so
- T := Token; -- check first that token_mgr owns the
- Token := false; -- token to give, then give it to caller
- end Take;
-
- entry Give (T : in out Token_Type) when Token = false is
- begin -- Calling task will Give the token back,
- if T = true then -- so first check that token_mgr does not
- Token := T; -- own the token, then check that the task has
- T := false; -- the token to give, then take it from the
- end if; -- task
- -- if caller does not own the token, then
- end Give; -- it falls out of the entry body with no
- end Token_Mgr_Prot_Unit; -- action
-
- function Init_Token return Token_Type is
- begin
- return false;
- end Init_Token;
-
- function Token_Value (T : Token_Type) return Boolean is
- begin
- return Boolean (T);
- end Token_Value;
-
-end C940001_0;
-
---===============================================================--
-
-with Report;
-with ImpDef;
-with C940001_0;
-
-procedure C940001 is
-
- type TC_Int_Type is range 0..2;
- -- range is very narrow so that erroneous execution may
- -- raise Constraint_Error
-
- type TC_Artifact_Type is record
- TC_Int : TC_Int_Type := 1;
- Number_of_Accesses : integer := 0;
- end record;
-
- TC_Artifact : TC_Artifact_Type;
-
- Sequence_Mgr : C940001_0.Token_Mgr_Prot_Unit;
-
- procedure Bump (Item : in out TC_Int_Type) is
- begin
- Item := Item + 1;
- exception
- when Constraint_Error =>
- Report.Failed ("Incremented without corresponding decrement");
- when others =>
- Report.Failed ("Bump raised Unexpected Exception");
- end Bump;
-
- procedure Decrement (Item : in out TC_Int_Type) is
- begin
- Item := Item - 1;
- exception
- when Constraint_Error =>
- Report.Failed ("Decremented without corresponding increment");
- when others =>
- Report.Failed ("Decrement raised Unexpected Exception");
- end Decrement;
-
- --==============--
-
- task type Network_Node_Type;
-
- task body Network_Node_Type is
-
- Slot_for_Token : C940001_0.Token_Type := C940001_0.Init_Token;
-
- begin
-
- -- Ask for token - if request is not granted, task will be queued
- Sequence_Mgr.Take (Slot_for_Token);
-
- -- Task now has token and may perform its work
-
- --==========================--
- -- in this case, the work is to ensure that the test results
- -- are the expected ones!
- --==========================--
- Bump (TC_Artifact.TC_Int); -- increment when request is granted
- TC_Artifact.Number_Of_Accesses :=
- TC_Artifact.Number_Of_Accesses + 1;
- if not C940001_0.Token_Value ( Slot_for_Token) then
- Report.Failed ("Incorrect results from entry Take");
- end if;
-
- -- give a chance for other tasks to (incorrectly) run
- delay ImpDef.Minimum_Task_Switch;
-
- Decrement (TC_Artifact.TC_Int); -- prepare to return token
-
- -- Task has completed its work and will return token
-
- Sequence_Mgr.Give (Slot_for_Token); -- return token to sequence manager
-
- if c940001_0.Token_Value (Slot_for_Token) then
- Report.Failed ("Incorrect results from entry Give");
- end if;
-
- exception
- when others => Report.Failed ("Unexpected exception raised in task");
-
- end Network_Node_Type;
-
- --==============--
-
-begin
-
- Report.Test ("C940001", "Check that a protected object can control " &
- "tasks by coordinating access to shared data");
-
- declare
- Node_1, Node_2, Node_3 : Network_Node_Type;
- -- declare three tasks which will compete for
- -- a single token, managed by Sequence Manager
-
- begin -- tasks start
- null;
- end; -- wait for all tasks to terminate before reporting result
-
- if TC_Artifact.Number_of_Accesses /= 3 then
- Report.Failed ("Not all tasks got through");
- end if;
-
- Report.Result;
-
-end C940001;
diff --git a/gcc/testsuite/ada/acats/tests/c9/c940002.a b/gcc/testsuite/ada/acats/tests/c9/c940002.a
deleted file mode 100644
index 420f54440ed..00000000000
--- a/gcc/testsuite/ada/acats/tests/c9/c940002.a
+++ /dev/null
@@ -1,309 +0,0 @@
--- C940002.A
---
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that a protected object provides coordinated access to shared
--- data. Check that it can implement a semaphore-like construct using a
--- parameterless procedure which allows a specific maximum number of tasks
--- to run and excludes all others
---
--- TEST DESCRIPTION:
--- Implement a counting semaphore type that can be initialized to a
--- specific number of available resources. Declare an entry for
--- requesting a resource and a procedure for releasing it. Declare an
--- object of this type, initialized to two resources. Declare and start
--- three tasks each of which asks for a resource. Verify that only two
--- resources are granted and that the last task in is queued.
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
---
---!
-
-
-package C940002_0 is
- -- Semaphores
-
- protected type Semaphore_Type (Resources_Available : Integer :=1) is
- entry Request;
- procedure Release;
- function Available return Integer;
- private
- Currently_Available : Integer := Resources_Available;
- end Semaphore_Type;
-
- Max_Resources : constant Integer := 2;
- Resource : Semaphore_Type (Max_Resources);
-
-end C940002_0;
- -- Semaphores;
-
-
- --========================================================--
-
-
-package body C940002_0 is
- -- Semaphores
-
- protected body Semaphore_Type is
-
- entry Request when Currently_Available >0 is -- when granted, secures
- begin -- a resource
- Currently_Available := Currently_Available - 1;
- end Request;
-
- procedure Release is -- when called, releases
- begin -- a resource
- Currently_Available := Currently_Available + 1;
- end Release;
-
- function Available return Integer is -- returns number of
- begin -- available resources
- return Currently_Available;
- end Available;
-
- end Semaphore_Type;
-
-end C940002_0;
- -- Semaphores;
-
-
- --========================================================--
-
-
-package C940002_1 is
- -- Task_Pkg
-
- task type Requesting_Task is
- entry Done; -- call on Done instructs the task
- end Requesting_Task; -- to release resource
-
- type Task_Ptr is access Requesting_Task;
-
- protected Counter is
- procedure Increment;
- procedure Decrement;
- function Number return integer;
- private
- Count : Integer := 0;
- end Counter;
-
- protected Hold_Lock is
- procedure Lock;
- procedure Unlock;
- function Locked return Boolean;
- private
- Lock_State : Boolean := true; -- starts out locked
- end Hold_Lock;
-
-
-end C940002_1;
- -- Task_Pkg
-
-
- --========================================================--
-
-
-with Report;
-with C940002_0;
- -- Semaphores;
-
-package body C940002_1 is
- -- Task_Pkg is
-
- protected body Counter is
-
- procedure Increment is
- begin
- Count := Count + 1;
- end Increment;
-
- procedure Decrement is
- begin
- Count := Count - 1;
- end Decrement;
-
- function Number return Integer is
- begin
- return Count;
- end Number;
-
- end Counter;
-
-
- protected body Hold_Lock is
-
- procedure Lock is
- begin
- Lock_State := true;
- end Lock;
-
- procedure Unlock is
- begin
- Lock_State := false;
- end Unlock;
-
- function Locked return Boolean is
- begin
- return Lock_State;
- end Locked;
-
- end Hold_Lock;
-
-
- task body Requesting_Task is
- begin
- C940002_0.Resource.Request; -- request a resource
- -- if resource is not available,
- -- task will be queued to wait
- Counter.Increment; -- add to count of resources obtained
- Hold_Lock.Unlock; -- and unlock Lock - system is stable;
- -- status may now be queried
-
- accept Done do -- hold resource until Done is called
- C940002_0.Resource.Release; -- release the resource and
- Counter.Decrement; -- note release
- end Done;
-
- exception
- when others => Report.Failed ("Unexpected Exception in Requesting_Task");
- end Requesting_Task;
-
-end C940002_1;
- -- Task_Pkg;
-
-
- --========================================================--
-
-
-with Report;
-with ImpDef;
-with C940002_0,
- -- Semaphores,
- C940002_1;
- -- Task_Pkg;
-
-procedure C940002 is
-
- package Semaphores renames C940002_0;
- package Task_Pkg renames C940002_1;
-
- Ptr1,
- Ptr2,
- Ptr3 : Task_Pkg.Task_Ptr;
- Num : Integer;
-
- procedure Spinlock is
- begin
- -- loop until unlocked
- while Task_Pkg.Hold_Lock.Locked loop
- delay ImpDef.Minimum_Task_Switch;
- end loop;
- Task_Pkg.Hold_Lock.Lock;
- end Spinlock;
-
-begin
-
- Report.Test ("C940002", "Check that a protected record can be used to " &
- "control access to resources");
-
- if (Task_Pkg.Counter.Number /=0)
- or (Semaphores.Resource.Available /= 2) then
- Report.Failed ("Wrong initial conditions");
- end if;
-
- Ptr1 := new Task_Pkg.Requesting_Task; -- newly allocated task requests
- -- resource; request for resource should
- -- be granted
- Spinlock; -- ensure that task obtains resource
-
- -- Task 1 waiting for call to Done
- -- One resource assigned to task 1
- -- One resource still available
- if (Task_Pkg.Counter.Number /= 1)
- or (Semaphores.Resource.Available /= 1) then
- Report.Failed ("Resource not assigned to task 1");
- end if;
-
- Ptr2 := new Task_Pkg.Requesting_Task; -- newly allocated task requests
- -- resource; request for resource should
- -- be granted
- Spinlock; -- ensure that task obtains resource
-
- -- Task 1 waiting for call to Done
- -- Task 2 waiting for call to Done
- -- Resources held by tasks 1 and 2
- -- No resources available
- if (Task_Pkg.Counter.Number /= 2)
- or (Semaphores.Resource.Available /= 0) then
- Report.Failed ("Resource not assigned to task 2");
- end if;
-
- Ptr3 := new Task_Pkg.Requesting_Task; -- newly allocated task requests
- -- resource; request for resource should
- -- be denied and task queued to wait for
- -- next available resource
-
-
- Ptr1.all.Done; -- Task 1 releases resource and lock
- -- Resource should be given to queued task
- Spinlock; -- ensure that resource is released
-
-
- -- Task 1 holds no resource
- -- One resource still assigned to task 2
- -- One resource assigned to task 3
- -- No resources available
- if (Task_Pkg.Counter.Number /= 2)
- or (Semaphores.Resource.Available /= 0) then
- Report.Failed ("Resource not properly released/assigned to task 3");
- end if;
-
- Ptr2.all.Done; -- Task 2 releases resource and lock
- -- No outstanding request for resource
-
- -- Tasks 1 and 2 hold no resources
- -- One resource assigned to task 3
- -- One resource available
- if (Task_Pkg.Counter.Number /= 1)
- or (Semaphores.Resource.Available /= 1) then
- Report.Failed ("Resource not properly released from task 2");
- end if;
-
- Ptr3.all.Done; -- Task 3 releases resource and lock
-
- -- All resources released
- -- All tasks terminated (or close)
- -- Two resources available
- if (Task_Pkg.Counter.Number /=0)
- or (Semaphores.Resource.Available /= 2) then
- Report.Failed ("Resource not properly released from task 3");
- end if;
-
- Report.Result;
-
-end C940002;
diff --git a/gcc/testsuite/ada/acats/tests/c9/c940004.a b/gcc/testsuite/ada/acats/tests/c9/c940004.a
deleted file mode 100644
index 059c97f41b6..00000000000
--- a/gcc/testsuite/ada/acats/tests/c9/c940004.a
+++ /dev/null
@@ -1,416 +0,0 @@
--- C940004.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- TEST OBJECTIVE:
--- Check that a protected record can be used to control access to
--- resources (data internal to the protected record).
---
--- TEST DESCRIPTION:
--- Declare a resource descriptor tagged type. Extend the type and
--- use the extended type in a protected data structure.
--- Implement a binary semaphore type. Declare an entry for
--- requesting a specific resource and an procedure for releasing the
--- same resource. Declare an object of this (protected) type.
--- Declare and start three tasks each of which asks for a resource
--- when directed to. Verify that resources are properly allocated
--- and deallocated.
---
---
--- CHANGE HISTORY:
---
--- 12 DEC 93 SAIC Initial PreRelease version
--- 23 JUL 95 SAIC Second PreRelease version
--- 16 OCT 95 SAIC ACVC 2.1
--- 13 MAR 03 RLB Fixed race condition in test.
---
---!
-
-package C940004_0 is
--- Resource_Pkg
-
- type ID_Type is new Integer range 0..10;
- type User_Descriptor_Type is tagged record
- Id : ID_Type := 0;
- end record;
-
-end C940004_0; -- Resource_Pkg
-
---============================--
--- no body for C940004_0
---=============================--
-
-with C940004_0; -- Resource_Pkg
-
--- This generic package implements a semaphore to control a single resource
-
-generic
-
- type Generic_Record_Type is new C940004_0.User_Descriptor_Type
- with private;
-
-package C940004_1 is
--- Generic_Semaphore_Pkg
- -- generic package extends the tagged formal generic
- -- type with some implementation relevant details, and
- -- it provides a semaphore with operations that work
- -- on that type
- type User_Rec_Type is new Generic_Record_Type with private;
-
- protected type Semaphore_Type is
- function TC_Count return Integer;
- entry Request (R : in out User_Rec_Type);
- procedure Release (R : in out User_Rec_Type);
- private
- In_Use : Boolean := false;
- end Semaphore_Type;
-
- function Has_Access (R : User_Rec_Type) return Boolean;
-
-private
-
- type User_Rec_Type is new Generic_Record_Type with record
- Access_To_Resource : boolean := false;
- end record;
-
-end C940004_1; -- Generic_Semaphore_Pkg
-
---===================================================--
-
-package body C940004_1 is
--- Generic_Semaphore_Pkg
-
- protected body Semaphore_Type is
-
- function TC_Count return Integer is
- begin
- return Request'Count;
- end TC_Count;
-
- entry Request (R : in out User_Rec_Type)
- when not In_Use is
- begin
- In_Use := true;
- R.Access_To_Resource := true;
- end Request;
-
- procedure Release (R : in out User_Rec_Type) is
- begin
- In_Use := false;
- R.Access_To_Resource := false;
- end Release;
-
- end Semaphore_Type;
-
- function Has_Access (R : User_Rec_Type) return Boolean is
- begin
- return R.Access_To_Resource;
- end Has_Access;
-
-end C940004_1; -- Generic_Semaphore_Pkg
-
---=============================================--
-
-with Report;
-with C940004_0; -- Resource_Pkg,
-with C940004_1; -- Generic_Semaphore_Pkg;
-
-package C940004_2 is
--- Printer_Mgr_Pkg
-
- -- Instantiate the generic to get code to manage a single printer;
- -- User processes contend for the printer, asking for it by a call
- -- to Request, and relinquishing it by a call to Release
-
- -- This package extends a tagged type to customize it for the printer
- -- in question, then it uses the type to instantiate the generic and
- -- declare a semaphore specific to the particular resource
-
- package Resource_Pkg renames C940004_0;
-
- type User_Desc_Type is new Resource_Pkg.User_Descriptor_Type with record
- New_Details : Integer := 0; -- for example
- end record;
-
- package Instantiation is new C940004_1 -- Generic_Semaphore_Pkg
- (Generic_Record_Type => User_Desc_Type);
-
- Printer_Access_Mgr : Instantiation.Semaphore_Type;
-
-
-end C940004_2; -- Printer_Mgr_Pkg
-
---============================--
--- no body for C940004_2
---============================--
-
-with C940004_0; -- Resource_Pkg,
-with C940004_2; -- Printer_Mgr_Pkg;
-
-package C940004_3 is
--- User_Task_Pkg
-
--- This package models user tasks that will request and release
--- the printer
- package Resource_Pkg renames C940004_0;
- package Printer_Mgr_Pkg renames C940004_2;
-
- task type User_Task_Type (ID : Resource_Pkg.ID_Type) is
- entry Get_Printer; -- instructs task to request resource
-
- entry Release_Printer -- instructs task to release printer
- (Descriptor : in out Printer_Mgr_pkg.Instantiation.User_Rec_Type);
-
- --==================--
- -- Test management machinery
- --==================--
- entry TC_Get_Descriptor -- returns descriptor
- (Descriptor : out Printer_Mgr_Pkg.Instantiation.User_Rec_Type);
-
- end User_Task_Type;
-
- --==================--
- -- Test management machinery
- --==================--
- TC_Times_Obtained : Integer := 0;
- TC_Times_Released : Integer := 0;
-
-end C940004_3; -- User_Task_Pkg;
-
---==============================================--
-
-with Report;
-with C940004_0; -- Resource_Pkg,
-with C940004_2; -- Printer_Mgr_Pkg,
-
-package body C940004_3 is
--- User_Task_Pkg
-
- task body User_Task_Type is
- D : Printer_Mgr_Pkg.Instantiation.User_Rec_Type;
- begin
- D.Id := ID;
- -----------------------------------
- Main:
- loop
- select
- accept Get_Printer;
- Printer_Mgr_Pkg.Printer_Access_Mgr.Request (D);
- -- request resource; if resource is not available,
- -- task will be queued to wait
- --===================--
- -- Test management machinery
- --===================--
- TC_Times_Obtained := TC_Times_Obtained + 1;
- -- when request granted, note it and post a message
-
- or
- accept Release_Printer (Descriptor : in out
- Printer_Mgr_Pkg.Instantiation.User_Rec_Type) do
-
- Printer_Mgr_Pkg.Printer_Access_Mgr.Release (D);
- -- release the resource, note its release
- TC_Times_Released := TC_Times_Released + 1;
- Descriptor := D;
- end Release_Printer;
- exit Main;
-
- or
- accept TC_Get_Descriptor (Descriptor : out
- Printer_Mgr_Pkg.Instantiation.User_Rec_Type) do
-
- Descriptor := D;
- end TC_Get_Descriptor;
-
- end select;
- end loop main;
-
- exception
- when others => Report.Failed ("exception raised in User_Task");
- end User_Task_Type;
-
-end C940004_3; -- User_Task_Pkg;
-
---==========================================================--
-
-with Report;
-with ImpDef;
-
-with C940004_0; -- Resource_Pkg,
-with C940004_2; -- Printer_Mgr_Pkg,
-with C940004_3; -- User_Task_Pkg;
-
-procedure C940004 is
- Verbose : constant Boolean := False;
- package Resource_Pkg renames C940004_0;
- package Printer_Mgr_Pkg renames C940004_2;
- package User_Task_Pkg renames C940004_3;
-
- Task1 : User_Task_Pkg.User_Task_Type (1);
- Task2 : User_Task_Pkg.User_Task_Type (2);
- Task3 : User_Task_Pkg.User_Task_Type (3);
-
- User_Rec_1,
- User_Rec_2,
- User_Rec_3 : Printer_Mgr_Pkg.Instantiation.User_Rec_Type;
-
-begin
-
- Report.Test ("C940004", "Check that a protected record can be used to " &
- "control access to resources");
-
- if (User_Task_Pkg.TC_Times_Obtained /= 0)
- or (User_Task_Pkg.TC_Times_Released /= 0)
- or Printer_Mgr_Pkg.Instantiation.Has_Access (User_Rec_1)
- or Printer_Mgr_Pkg.Instantiation.Has_Access (User_Rec_2)
- or Printer_Mgr_Pkg.Instantiation.Has_Access (User_Rec_3) then
- Report.Failed ("Wrong initial conditions");
- end if;
-
- Task1.Get_Printer; -- ask for resource
- -- request for resource should be granted
- Task1.TC_Get_Descriptor (User_Rec_1);-- wait here 'til task gets resource
-
- if (User_Task_Pkg.TC_Times_Obtained /= 1)
- or (User_Task_Pkg.TC_Times_Released /= 0)
- or not Printer_Mgr_Pkg.Instantiation.Has_Access (User_Rec_1) then
- Report.Failed ("Resource not assigned to task 1");
- end if;
-
- Task2.Get_Printer; -- ask for resource
- -- request for resource should be denied
- -- and task queued to wait
-
- -- Task 1 still waiting to accept Release_Printer, still holds resource
- -- Task 2 queued on Semaphore.Request
-
- -- Ensure that Task2 is queued before continuing to make checks and queue
- -- Task3. We use a for loop here to avoid hangs in broken implementations.
- for TC_Cnt in 1 .. 20 loop
- exit when Printer_Mgr_Pkg.Printer_Access_Mgr.TC_Count >= 1;
- delay Impdef.Minimum_Task_Switch;
- end loop;
-
- if (User_Task_Pkg.TC_Times_Obtained /= 1)
- or (User_Task_Pkg.TC_Times_Released /= 0) then
- Report.Failed ("Resource assigned to task 2");
- end if;
-
- Task3.Get_Printer; -- ask for resource
- -- request for resource should be denied
- -- and task 3 queued on Semaphore.Request
-
- Task1.Release_Printer (User_Rec_1);-- task 1 releases resource
- -- released resource should be given to
- -- queued task 2.
-
- Task2.TC_Get_Descriptor (User_Rec_2);-- wait here for task 2
-
- -- Task 1 has released resource and completed
- -- Task 2 has seized the resource
- -- Task 3 is queued on Semaphore.Request
-
- if (User_Task_Pkg.TC_Times_Obtained /= 2)
- or (User_Task_Pkg.TC_Times_Released /= 1)
- or Printer_Mgr_Pkg.Instantiation.Has_Access (User_Rec_1)
- or not Printer_Mgr_Pkg.Instantiation.Has_Access (User_Rec_2) then
- Report.Failed ("Resource not properly released/assigned" &
- " to task 2");
- if Verbose then
- Report.Comment ("TC_Times_Obtained: " &
- Integer'Image (User_Task_Pkg.TC_Times_Obtained));
- Report.Comment ("TC_Times_Released: " &
- Integer'Image (User_Task_Pkg.TC_Times_Released));
- Report.Comment ("User 1 Has_Access:" &
- Boolean'Image (Printer_Mgr_Pkg.Instantiation.
- Has_Access (User_Rec_1)));
- Report.Comment ("User 2 Has_Access:" &
- Boolean'Image (Printer_Mgr_Pkg.Instantiation.
- Has_Access (User_Rec_2)));
- end if;
- end if;
-
- Task2.Release_Printer (User_Rec_2);-- task 2 releases resource
-
- -- task 3 is released from queue, and is given resource
-
- Task3.TC_Get_Descriptor (User_Rec_3);-- wait for task 3
-
- if (User_Task_Pkg.TC_Times_Obtained /= 3)
- or (User_Task_Pkg.TC_Times_Released /= 2)
- or Printer_Mgr_Pkg.Instantiation.Has_Access (User_Rec_2)
- or not Printer_Mgr_Pkg.Instantiation.Has_Access (User_Rec_3) then
- Report.Failed ("Resource not properly released/assigned " &
- "to task 3");
- if Verbose then
- Report.Comment ("TC_Times_Obtained: " &
- Integer'Image (User_Task_Pkg.TC_Times_Obtained));
- Report.Comment ("TC_Times_Released: " &
- Integer'Image (User_Task_Pkg.TC_Times_Released));
- Report.Comment ("User 1 Has_Access:" &
- Boolean'Image (Printer_Mgr_Pkg.Instantiation.
- Has_Access (User_Rec_1)));
- Report.Comment ("User 2 Has_Access:" &
- Boolean'Image (Printer_Mgr_Pkg.Instantiation.
- Has_Access (User_Rec_2)));
- Report.Comment ("User 3 Has_Access:" &
- Boolean'Image (Printer_Mgr_Pkg.Instantiation.
- Has_Access (User_Rec_3)));
- end if;
- end if;
-
- Task3.Release_Printer (User_Rec_3);-- task 3 releases resource
-
- if (User_Task_Pkg.TC_Times_Obtained /=3)
- or (User_Task_Pkg.TC_Times_Released /=3)
- or Printer_Mgr_Pkg.Instantiation.Has_Access (User_Rec_3) then
- Report.Failed ("Resource not properly released by task 3");
- if Verbose then
- Report.Comment ("TC_Times_Obtained: " &
- Integer'Image (User_Task_Pkg.TC_Times_Obtained));
- Report.Comment ("TC_Times_Released: " &
- Integer'Image (User_Task_Pkg.TC_Times_Released));
- Report.Comment ("User 1 Has_Access:" &
- Boolean'Image (Printer_Mgr_Pkg.Instantiation.
- Has_Access (User_Rec_1)));
- Report.Comment ("User 2 Has_Access:" &
- Boolean'Image (Printer_Mgr_Pkg.Instantiation.
- Has_Access (User_Rec_2)));
- Report.Comment ("User 3 Has_Access:" &
- Boolean'Image (Printer_Mgr_Pkg.Instantiation.
- Has_Access (User_Rec_3)));
- end if;
-
- end if;
-
- -- Ensure that all tasks have terminated before reporting the result
- while not (Task1'terminated
- and Task2'terminated
- and Task3'terminated) loop
- delay ImpDef.Minimum_Task_Switch;
- end loop;
-
- Report.Result;
-
-end C940004;
diff --git a/gcc/testsuite/ada/acats/tests/c9/c940005.a b/gcc/testsuite/ada/acats/tests/c9/c940005.a
deleted file mode 100644
index adb58b18ca4..00000000000
--- a/gcc/testsuite/ada/acats/tests/c9/c940005.a
+++ /dev/null
@@ -1,370 +0,0 @@
--- C940005.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that the body of a protected function can have internal calls
--- to other protected functions and that the body of a protected
--- procedure can have internal calls to protected procedures and to
--- protected functions.
---
--- TEST DESCRIPTION:
--- Simulate a meter at a freeway on-ramp which, when real-time sensors
--- determine that the freeway is becoming saturated, triggers stop lights
--- which control the access of vehicles to prevent further saturation.
--- Each on-ramp is represented by a protected object - in this case only
--- one is shown (Test_Ramp). The routines to sample and alter the states
--- of the various sensors, to queue the vehicles on the meter and to
--- release them are all part of the protected object and can be shared
--- by various tasks. Apart from the function/procedure tests this example
--- has a mix of other tasking features.
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 13 Nov 95 SAIC Updated and fixed bugs ACVC 2.0.1
---
---!
-
-
-with Report;
-with ImpDef;
-with Ada.Calendar;
-
-procedure C940005 is
-
-begin
-
- Report.Test ("C940005", "Check internal calls of protected functions" &
- " and procedures");
-
- declare -- encapsulate the test
-
- function "+" (Left : Ada.Calendar.Time; Right: Duration)
- return Ada.Calendar.Time renames Ada.Calendar."+";
-
- -- Weighted load given to each potential problem area and accumulated
- type Load_Factor is range 0..8;
- Clear_Level : constant Load_Factor := 0;
- Minimum_Level : constant Load_Factor := 1;
- Moderate_Level : constant Load_Factor := 2;
- Serious_Level : constant Load_Factor := 4;
- Critical_Level : constant Load_Factor := 6;
-
- -- Weighted loads given to each Sample Point (pure weights, not levels)
- Local_Overload_wt : constant Load_Factor := 1;
- Next_Ramp_in_Overload_wt : constant Load_Factor := 1;
- Ramp_Junction_in_Overload_wt : constant Load_Factor :=2; --higher wght
- -- :::: other weighted loads
-
- TC_Multiplier : integer := 1; -- changed half way through
- TC_Expected_Passage_Total : constant integer := 486;
-
- -- This is the time between synchronizing pulses to the ramps.
- -- In reality one would expect a time of 5 to 10 seconds. In
- -- the interests of speeding up the test suite a shorter time
- -- is used
- Pulse_Time_Delta : constant duration := ImpDef.Switch_To_New_Task;
-
- -- control over stopping tasks
- protected Control is
- procedure Stop_Now;
- function Stop return Boolean;
- private
- Halt : Boolean := False;
- end Control;
-
- protected body Control is
- procedure Stop_Now is
- begin
- Halt := True;
- end Stop_Now;
-
- function Stop return Boolean is
- begin
- return Halt;
- end Stop;
- end Control;
-
- task Pulse_Task; -- task to generate a pulse for each ramp
-
- -- Carrier task. One is created for each vehicle arriving at the ramp
- task type Vehicle;
- type acc_Vehicle is access Vehicle;
-
- --================================================================
- protected Test_Ramp is
- function Next_Ramp_in_Overload return Load_Factor;
- function Local_Overload return Load_Factor;
- function Freeway_Overload return Load_Factor;
- function Freeway_Breakdown return Boolean;
- function Meter_in_use_State return Boolean;
- procedure Set_Local_Overload;
- procedure Add_Meter_Queue;
- procedure Subtract_Meter_Queue;
- procedure Time_Pulse_Received;
- entry Wait_at_Meter;
- procedure TC_Passage (Pass_Point : Integer);
- function TC_Get_Passage_Total return integer;
- -- ::::::::: many routines are not shown (for example none of the
- -- clears, none of the real-time-sensor handlers)
-
- private
-
- Release_One_Vehicle : Boolean := false;
- Meter_in_Use : Boolean := false;
- Fwy_Break_State : Boolean := false;
-
-
- Ramp_Count : integer range 0..20 := 0;
- Ramp_Count_Threshold : integer := 15;
-
- -- Current state of the various Sample Points
- Local_State : Load_Factor := Clear_Level;
- Next_Ramp_State : Load_Factor := Clear_Level;
- -- :::: other Sample Point states not shown
-
- TC_Passage_Total : integer := 0;
- end Test_Ramp;
- --================================================================
- protected body Test_Ramp is
-
- procedure Start_Meter is
- begin
- Meter_in_Use := True;
- null; -- stub :::: trigger the metering hardware
- end Start_Meter;
-
- -- External call for Meter_in_Use
- function Meter_in_Use_State return Boolean is
- begin
- return Meter_in_Use;
- end Meter_in_Use_State;
-
- -- Trace the paths through the various routines by totaling the
- -- weighted call parameters
- procedure TC_Passage (Pass_Point : Integer) is
- begin
- TC_Passage_Total := TC_Passage_Total+(Pass_Point*TC_Multiplier);
- end TC_Passage;
-
- -- For the final check of the whole test
- function TC_Get_Passage_Total return integer is
- begin
- return TC_Passage_Total;
- end TC_Get_Passage_Total;
-
- -- These Set/Clear routines are triggered by real-time sensors that
- -- reflect traffic state
- procedure Set_Local_Overload is
- begin
- Local_State := Local_Overload_wt;
- if not Meter_in_Use then
- Start_Meter; -- LOCAL INTERNAL PROCEDURE FROM PROCEDURE
- end if;
- end Set_Local_Overload;
-
- --::::: Set/Clear routines for all the other sensors not shown
-
- function Local_Overload return Load_Factor is
- begin
- return Local_State;
- end Local_Overload;
-
- function Next_Ramp_in_Overload return Load_Factor is
- begin
- return Next_Ramp_State;
- end Next_Ramp_in_Overload;
-
- -- :::::::: other overload factor states not shown
-
- -- return the summation of all the load factors
- function Freeway_Overload return Load_Factor is
- begin
- return Local_Overload -- EACH IS A CALL OF A
- -- + :::: others -- FUNCTION FROM WITHIN
- + Next_Ramp_in_Overload; -- A FUNCTION
- end Freeway_Overload;
-
- -- Freeway Breakdown is defined as traffic moving < 5mph
- function Freeway_Breakdown return Boolean is
- begin
- return Fwy_Break_State;
- end Freeway_Breakdown;
-
- -- Keep count of vehicles currently on meter queue - we can't use
- -- the 'count because we need the outcall trigger
- procedure Add_Meter_Queue is
- TC_Pass_Point : constant integer := 22;
- begin
- Ramp_Count := Ramp_Count + 1;
- TC_Passage ( TC_Pass_Point ); -- note passage through here
- if Ramp_Count > Ramp_Count_Threshold then
- null; -- :::: stub, trigger surface street notification
- end if;
- end Add_Meter_Queue;
- --
- procedure Subtract_Meter_Queue is
- TC_Pass_Point : constant integer := 24;
- begin
- Ramp_Count := Ramp_Count - 1;
- TC_Passage ( TC_Pass_Point ); -- note passage through here
- end Subtract_Meter_Queue;
-
- -- Here each Vehicle task queues itself awaiting release
- entry Wait_at_Meter when Release_One_Vehicle is
- -- EXAMPLE OF ENTRY WITH BARRIERS AND PERSISTENT SIGNAL
- TC_Pass_Point : constant integer := 23;
- begin
- TC_Passage ( TC_Pass_Point ); -- note passage through here
- Release_One_Vehicle := false; -- Consume the signal
- -- Decrement number of vehicles on ramp
- Subtract_Meter_Queue; -- CALL PROCEDURE FROM WITHIN ENTRY BODY
- end Wait_at_Meter;
-
-
- procedure Time_Pulse_Received is
- Load : Load_factor := Freeway_Overload; -- CALL MULTILEVEL
- -- FUNCTION
- -- FROM WITHIN PROCEDURE
- begin
- -- if broken down, no vehicles are released
- if not Freeway_Breakdown then -- CALL FUNCTION FROM A PROCEDURE
- if Load < Moderate_Level then
- Release_One_Vehicle := true;
- end if;
- null; -- stub ::: If other levels, release every other
- -- pulse, every third pulse etc.
- end if;
- end Time_Pulse_Received;
-
- end Test_Ramp;
- --================================================================
-
-
- -- Simulate the arrival of a vehicle at the Ramp_Receiver and the
- -- generation of an accompanying carrier task
- procedure New_Arrival is
- Next_Vehicle_Task: acc_Vehicle := new Vehicle;
- TC_Pass_Point : constant integer := 3;
- begin
- Test_Ramp.TC_Passage ( TC_Pass_Point ); -- Note passage through here
- null;
- end New_arrival;
-
-
- -- Carrier task. One is created for each vehicle arriving at the ramp
- task body Vehicle is
- TC_Pass_point : constant integer := 1;
- TC_Pass_Point_2 : constant integer := 21;
- TC_Pass_Point_3 : constant integer := 2;
- begin
- Test_Ramp.TC_Passage ( TC_Pass_Point ); -- note passage through here
- if Test_Ramp.Meter_in_Use_State then
- Test_Ramp.TC_Passage ( TC_Pass_Point_2 ); -- note passage
- -- Increment count of number of vehicles on ramp
- Test_Ramp.Add_Meter_Queue; -- CALL a protected PROCEDURE
- -- which is also called from within
- -- enter the meter queue
- Test_Ramp.Wait_at_Meter; -- CALL a protected ENTRY
- end if;
- Test_Ramp.TC_Passage ( TC_Pass_Point_3 ); -- note passage thru here
- null; --:::: call to the first in the series of the Ramp_Sensors
- -- this "passes" the vehicle from one sensor to the next
- exception
- when others =>
- Report.Failed ("Unexpected exception in Vehicle Task");
- end Vehicle;
-
-
- -- Task transmits a synchronizing "pulse" to all ramps
- --
- task body Pulse_Task is
- Pulse_Time : Ada.Calendar.Time := Ada.Calendar.Clock;
- begin
- While not Control.Stop loop
- delay until Pulse_Time;
- Test_Ramp.Time_Pulse_Received; -- causes INTERNAL CALLS
- -- :::::::::: and to all the others
- Pulse_Time := Pulse_Time + Pulse_Time_Delta; -- calculate next
- end loop;
- exception
- when others =>
- Report.Failed ("Unexpected exception in Pulse_Task");
- end Pulse_Task;
-
-
- begin -- declare
-
- -- Test driver. This is ALL test control code
-
- -- First simulate calls to the protected functions and procedures
- -- from without the protected object
- --
- -- CALL FUNCTIONS
- if Test_Ramp.Local_Overload /= Clear_Level then
- Report.Failed ("External Call to Local_Overload incorrect");
- end if;
- if Test_Ramp.Next_Ramp_in_Overload /= Clear_Level then
- Report.Failed ("External Call to Next_Ramp_in_Overload incorrect");
- end if;
- if Test_Ramp.Freeway_Overload /= Clear_Level then
- Report.Failed ("External Call to Freeway_Overload incorrect");
- end if;
-
- -- Now Simulate the arrival of a vehicle to verify path through test
- New_Arrival;
- delay Pulse_Time_Delta*2; -- allow it to pass through the complex
-
- TC_Multiplier := 5; -- change the weights for the paths for the next
- -- part of the test
-
- -- Simulate a real-time sensor reporting overload
- Test_Ramp.Set_Local_Overload; -- CALL A PROCEDURE (and change levels)
-
- -- CALL FUNCTIONS again
- if Test_Ramp.Local_Overload /= Minimum_Level then
- Report.Failed ("External Call to Local_Overload incorrect - 2");
- end if;
- if Test_Ramp.Freeway_Overload /= Minimum_Level then
- Report.Failed ("External Call to Freeway_Overload incorrect -2");
- end if;
-
- -- Now Simulate the arrival of another vehicle again causing
- -- INTERNAL CALLS but following different paths (queuing on the
- -- meter etc.)
- New_Arrival;
- delay Pulse_Time_Delta*2; -- allow it to pass through the complex
-
- Control.Stop_Now; -- finish test
-
- if TC_Expected_Passage_Total /= Test_Ramp.TC_Get_Passage_Total then
- Report.Failed ("Unexpected paths taken");
- end if;
-
- end; -- declare
-
- Report.Result;
-
-end C940005;
diff --git a/gcc/testsuite/ada/acats/tests/c9/c940006.a b/gcc/testsuite/ada/acats/tests/c9/c940006.a
deleted file mode 100644
index 36e6c9171a6..00000000000
--- a/gcc/testsuite/ada/acats/tests/c9/c940006.a
+++ /dev/null
@@ -1,223 +0,0 @@
--- C940006.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that the body of a protected function can have external calls
--- to other protected functions and that the body of a protected
--- procedure can have external calls to protected procedures and to
--- protected functions.
---
--- TEST DESCRIPTION:
--- Use a subset of the simulation of the freeway on-ramp described in
--- c940005. In this case two protected objects are used but only a
--- minimum of routines are shown in each. Both objects are hard coded
--- and detail two adjacent on-ramps (Ramp_31 & Ramp_32) with routines in
--- each which use external calls to the other.
-
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
---
---!
-
-with Report;
-
-procedure C940006 is
-
-begin
-
- Report.Test ("C940006", "Check external calls of protected functions" &
- " and procedures");
-
- declare -- encapsulate the test
-
- -- Weighted load given to each potential problem area and accumulated
- type Load_Factor is range 0..8;
- --
- Clear_Level : constant Load_Factor := 0;
- Minimum_Level : constant Load_Factor := 1;
- Moderate_Level : constant Load_Factor := 3;
- Serious_Level : constant Load_Factor := 4;
- Critical_Level : constant Load_Factor := 6;
-
- --================================================================
- -- Only the Routines that are used in this test are shown
- --
- protected Ramp_31 is
-
- function Local_Overload return Load_Factor;
- procedure Set_Local_Overload(Sensor_Level : Load_Factor);
- procedure Notify;
- function Next_Ramp_Overload return Load_Factor;
- function Freeway_Overload return Load_Factor;
- procedure Downstream_Ramps;
- function Get_DSR_Accumulate return Load_Factor;
-
- private
- Next_Ramp_Alert : Boolean := false; -- Next Ramp is in trouble?
-
- -- Current state of the various Sample Points
- Local_State : Load_Factor := Clear_Level;
- -- Accumulated load for next three downstream ramps
- DSR_Accumulate : Load_Factor := Clear_Level;
-
- end Ramp_31;
- --================================================================
- -- Only the Routines that are used in this test are shown
- --
- protected Ramp_32 is
-
- function Local_Overload return Load_Factor;
- procedure Set_Local_Overload (Sensor_Level : Load_Factor);
-
- private
-
- Local_State : Load_Factor := Clear_Level;
-
- end Ramp_32;
- --================================================================
- protected body Ramp_31 is
-
- -- These Set/Clear routines are triggered by real-time sensors that
- -- reflect traffic state
- procedure Set_Local_Overload (Sensor_Level : Load_Factor) is
- begin
- -- Notify "previous" ramp to check this one for current state.
- -- Subsequent changes in state will not send an alert
- null; --::::: (see Ramp_32 for this code)
- Local_State := Sensor_Level;
- null; --::::: Start local meter if not already started
- end Set_Local_Overload;
-
- function Local_Overload return Load_Factor is
- begin
- return Local_State;
- end Local_Overload;
-
- -- This is notification from the next ramp that it is in
- -- overload. With this provision we only need to sample the next
- -- ramp during adverse conditions.
- procedure Notify is
- begin
- Next_Ramp_Alert := true;
- end Notify;
-
- function Next_Ramp_Overload return Load_Factor is
- begin
- if Next_Ramp_Alert then
- -- EXTERNAL FUNCTION CALL FROM FUNCTION
- -- Get next ramp's current state
- return Ramp_32.Local_Overload;
- else
- return Clear_Level;
- end if;
- end Next_Ramp_Overload;
-
- -- return the summation of all the load factors
- function Freeway_Overload return Load_Factor is
- begin
- return Local_Overload
- -- + :::: others
- + Next_Ramp_Overload;
- end Freeway_Overload;
-
- -- Snapshot the states of the next three downstream ramps
- procedure Downstream_Ramps is
- begin
- DSR_Accumulate := Ramp_32.Local_Overload; -- EXTERNAL FUNCTION
- -- :::: + Ramp_33.Local_Overload -- FROM PROCEDURE
- -- :::: + Ramp_34.Local_Overload
- end Downstream_Ramps;
-
- -- Get last snapshot
- function Get_DSR_Accumulate return Load_Factor is
- begin
- return DSR_Accumulate;
- end Get_DSR_Accumulate;
-
- end Ramp_31;
- --================================================================
- protected body Ramp_32 is
-
- function Local_Overload return Load_Factor is
- begin
- return Local_State;
- end;
-
-
- -- These Set/Clear routines are triggered by real-time sensors that
- -- reflect traffic state
- procedure Set_Local_Overload(Sensor_Level : Load_Factor) is
- begin
- if Local_State = Clear_Level then
- -- Notify "previous" ramp to check this one for current state.
- -- Subsequent changes in state will not send an alert
- -- When the situation clears another routine performs the
- -- all_clear notification. (not shown)
- -- EXTERNAL CALL OF PROCEDURE FROM PROCEDURE
- Ramp_31.Notify;
- end if;
- Local_State := Sensor_Level;
- null; --::::: Start local meter if not already started
- end;
-
- end Ramp_32;
- --================================================================
-
-
-
- begin -- declare
-
- -- Test driver. This is ALL test control code
- -- Simulate calls to the protected functions and procedures
- -- from without the protected object, these will, in turn make the
- -- external calls.
-
- -- Check initial conditions, exercising the simple calls
- if not (Ramp_31.Local_Overload = Clear_Level and
- Ramp_31.Next_Ramp_Overload = Clear_Level and
- Ramp_31.Freeway_Overload = Clear_Level) and
- Ramp_32.Local_Overload = Clear_Level then
- Report.Failed ("Initial Calls provided unexpected Results");
- end if;
-
- -- Simulate real-time sensors reporting overloads at a hardware level
- Ramp_31.Set_Local_Overload (1);
- Ramp_32.Set_Local_Overload (3);
-
- Ramp_31.Downstream_Ramps; -- take the current snapshot
-
- if not (Ramp_31.Local_Overload = Minimum_Level and
- Ramp_31.Get_DSR_Accumulate = Moderate_Level and
- Ramp_31.Freeway_Overload = Serious_Level) then
- Report.Failed ("Secondary Calls provided unexpected Results");
- end if;
-
- end; -- declare
-
- Report.Result;
-
-end C940006;
diff --git a/gcc/testsuite/ada/acats/tests/c9/c940007.a b/gcc/testsuite/ada/acats/tests/c9/c940007.a
deleted file mode 100644
index c678463633a..00000000000
--- a/gcc/testsuite/ada/acats/tests/c9/c940007.a
+++ /dev/null
@@ -1,427 +0,0 @@
--- C940007.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that the body of a protected function declared as an object of a
--- given type can have internal calls to other protected functions and
--- that a protected procedure in such an object can have internal calls
--- to protected procedures and to protected functions.
---
--- TEST DESCRIPTION:
--- Simulate a meter at a freeway on-ramp which, when real-time sensors
--- determine that the freeway is becoming saturated, triggers stop lights
--- which control the access of vehicles to prevent further saturation.
--- Each on-ramp is represented by a protected object of the type Ramp.
--- The routines to sample and alter the states of the various sensors, to
--- queue the vehicles on the meter and to release them are all part of
--- the protected object and can be shared by various tasks. Apart from
--- the function/procedure tests this example has a mix of other tasking
--- features. In this test two objects representing two adjacent ramps
--- are created from the same type. The same "traffic" is simulated for
--- each ramp. The results should be identical.
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 13 Nov 95 SAIC Replaced shared global variable Pulse_Stop
--- with a protected object.
--- ACVC 2.0.1
---
---!
-
-
-with Report;
-with ImpDef;
-with Ada.Calendar;
-
-
-procedure C940007 is
-
-begin
-
- Report.Test ("C940007", "Check internal calls of protected functions" &
- " and procedures in objects declared as a type");
-
- declare -- encapsulate the test
-
- function "+" (Left : Ada.Calendar.Time; Right: Duration)
- return Ada.Calendar.Time renames Ada.Calendar."+";
-
- -- Weighted load given to each potential problem area and accumulated
- type Load_Factor is range 0..8;
- Clear_Level : constant Load_Factor := 0;
- Minimum_Level : constant Load_Factor := 1;
- Moderate_Level : constant Load_Factor := 2;
- Serious_Level : constant Load_Factor := 4;
- Critical_Level : constant Load_Factor := 6;
-
- -- Weighted loads given to each Sample Point (pure weights, not levels)
- Local_Overload_wt : constant Load_Factor := 1;
- Next_Ramp_in_Overload_wt : constant Load_Factor := 1;
- Ramp_Junction_in_Overload_wt : constant Load_Factor :=2; --higher wght
- -- :::: other weighted loads
-
- TC_Expected_Passage_Total : integer := 486;
-
-
- -- This is the time between synchronizing pulses to the ramps.
- -- In reality one would expect a time of 5 to 10 seconds. In
- -- the interests of speeding up the test suite a shorter time
- -- is used
- Pulse_Time_Delta : constant duration := ImpDef.Switch_To_New_Task;
-
-
- -- control over stopping tasks
- protected Control is
- procedure Stop_Now;
- function Stop return Boolean;
- private
- Halt : Boolean := False;
- end Control;
-
- protected body Control is
- procedure Stop_Now is
- begin
- Halt := True;
- end Stop_Now;
-
- function Stop return Boolean is
- begin
- return Halt;
- end Stop;
- end Control;
-
-
- task Pulse_Task; -- task to generate a pulse for each ramp
-
- -- Carrier tasks. One is created for each vehicle arriving at each ramp
- task type Vehicle_31; -- For Ramp_31
- type acc_Vehicle_31 is access Vehicle_31;
- --
- task type Vehicle_32; -- For Ramp_32
- type acc_Vehicle_32 is access Vehicle_32;
-
- --================================================================
- protected type Ramp is
- function Next_Ramp_in_Overload return Load_Factor;
- function Local_Overload return Load_Factor;
- function Freeway_Overload return Load_Factor;
- function Freeway_Breakdown return Boolean;
- function Meter_in_Use_State return Boolean;
- procedure Set_Local_Overload;
- procedure Add_Meter_Queue;
- procedure Subtract_Meter_Queue;
- procedure Time_Pulse_Received;
- entry Wait_at_Meter;
- procedure TC_Passage (Pass_Point : Integer);
- function TC_Get_Passage_Total return integer;
- -- ::::::::: many routines are not shown (for example none of the
- -- clears, none of the real-time-sensor handlers)
-
- private
-
- Release_One_Vehicle : Boolean := false;
- Meter_in_Use : Boolean := false;
- Fwy_Break_State : Boolean := false;
-
-
- Ramp_Count : integer range 0..20 := 0;
- Ramp_Count_Threshold : integer := 15;
-
- -- Current state of the various Sample Points
- Local_State : Load_Factor := Clear_Level;
- Next_Ramp_State : Load_Factor := Clear_Level;
- -- :::: other Sample Point states not shown
-
- TC_Multiplier : integer := 1; -- changed half way through
- TC_Passage_Total : integer := 0;
- end Ramp;
- --================================================================
- protected body Ramp is
-
- procedure Start_Meter is
- begin
- Meter_in_Use := True;
- null; -- stub :::: trigger the metering hardware
- end Start_Meter;
-
- function Meter_in_Use_State return Boolean is
- begin
- return Meter_in_Use;
- end Meter_in_Use_State;
-
- -- Trace the paths through the various routines by totaling the
- -- weighted call parameters
- procedure TC_Passage (Pass_Point : Integer) is
- begin
- TC_Passage_Total := TC_Passage_Total+(Pass_Point*TC_Multiplier);
- end TC_Passage;
-
- -- For the final check of the whole test
- function TC_Get_Passage_Total return integer is
- begin
- return TC_Passage_Total;
- end TC_Get_Passage_Total;
-
- -- These Set/Clear routines are triggered by real-time sensors that
- -- reflect traffic state
- procedure Set_Local_Overload is
- begin
- Local_State := Local_Overload_wt;
- if not Meter_in_Use then
- Start_Meter; -- LOCAL INTERNAL PROCEDURE FROM PROCEDURE
- end if;
- -- Change the weights for the paths for the next part of the test
- TC_Multiplier :=5;
- end Set_Local_Overload;
-
- --::::: Set/Clear routines for all the other sensors not shown
-
- function Local_Overload return Load_Factor is
- begin
- return Local_State;
- end Local_Overload;
-
- function Next_Ramp_in_Overload return Load_Factor is
- begin
- return Next_Ramp_State;
- end Next_Ramp_in_Overload;
-
- -- :::::::: other overload factor states not shown
-
- -- return the summation of all the load factors
- function Freeway_Overload return Load_Factor is
- begin
- return Local_Overload -- EACH IS A CALL OF A
- -- + :::: others -- FUNCTION FROM WITHIN
- + Next_Ramp_in_Overload; -- A FUNCTION
- end Freeway_Overload;
-
- -- Freeway Breakdown is defined as traffic moving < 5mph
- function Freeway_Breakdown return Boolean is
- begin
- return Fwy_Break_State;
- end Freeway_Breakdown;
-
- -- Keep count of vehicles currently on meter queue - we can't use
- -- the 'count because we need the outcall trigger
- procedure Add_Meter_Queue is
- TC_Pass_Point : constant integer := 22;
- begin
- Ramp_Count := Ramp_Count + 1;
- TC_Passage ( TC_Pass_Point ); -- note passage through here
- if Ramp_Count > Ramp_Count_Threshold then
- null; -- :::: stub, trigger surface street notification
- end if;
- end Add_Meter_Queue;
- --
- procedure Subtract_Meter_Queue is
- TC_Pass_Point : constant integer := 24;
- begin
- Ramp_Count := Ramp_Count - 1;
- TC_Passage ( TC_Pass_Point ); -- note passage through here
- end Subtract_Meter_Queue;
-
- -- Here each Vehicle task queues itself awaiting release
- entry Wait_at_Meter when Release_One_Vehicle is
- -- EXAMPLE OF ENTRY WITH BARRIERS AND PERSISTENT SIGNAL
- TC_Pass_Point : constant integer := 23;
- begin
- TC_Passage ( TC_Pass_Point ); -- note passage through here
- Release_One_Vehicle := false; -- Consume the signal
- -- Decrement number of vehicles on ramp
- Subtract_Meter_Queue; -- CALL PROCEDURE FROM WITHIN ENTRY BODY
- end Wait_at_Meter;
-
-
- procedure Time_Pulse_Received is
- Load : Load_factor := Freeway_Overload; -- CALL MULTILEVEL FUNCTN
- -- FROM WITHIN PROCEDURE
- begin
- -- if broken down, no vehicles are released
- if not Freeway_Breakdown then -- CALL FUNCTION FROM A PROCEDURE
- if Load < Moderate_Level then
- Release_One_Vehicle := true;
- end if;
- null; -- stub ::: If other levels, release every other
- -- pulse, every third pulse etc.
- end if;
- end Time_Pulse_Received;
-
- end Ramp;
- --================================================================
-
- -- Now create two Ramp objects from this type
- Ramp_31 : Ramp;
- Ramp_32 : Ramp;
-
-
-
- -- Simulate the arrival of a vehicle at the Ramp_Receiver of Ramp_31
- -- and the generation of an accompanying carrier task
- procedure New_Arrival_31 is
- Next_Vehicle_Task_31: acc_Vehicle_31 := new Vehicle_31;
- TC_Pass_Point : constant integer := 3;
- begin
- Ramp_31.TC_Passage ( TC_Pass_Point ); -- Note passage through here
- null; --::: stub
- end New_arrival_31;
-
-
- -- Carrier task. One is created for each vehicle arriving at Ramp_31
- task body Vehicle_31 is
- TC_Pass_point : constant integer := 1;
- TC_Pass_Point_2 : constant integer := 21;
- TC_Pass_Point_3 : constant integer := 2;
- begin
- Ramp_31.TC_Passage ( TC_Pass_Point ); -- note passage through here
- if Ramp_31.Meter_in_Use_State then
- Ramp_31.TC_Passage ( TC_Pass_Point_2 ); -- note passage
- -- Increment count of number of vehicles on ramp
- Ramp_31.Add_Meter_Queue; -- CALL a protected PROCEDURE
- -- which is also called from within
- -- enter the meter queue
- Ramp_31.Wait_at_Meter; -- CALL a protected ENTRY
- end if;
- Ramp_31.TC_Passage ( TC_Pass_Point_3 ); -- note passage through here
- null; --:::: call to the first in the series of the Ramp_Sensors
- -- this "passes" the vehicle from one sensor to the next
- exception
- when others =>
- Report.Failed ("Unexpected exception in Vehicle Task");
- end Vehicle_31;
-
-
- -- Simulate the arrival of a vehicle at the Ramp_Receiver and the
- -- generation of an accompanying carrier task
- procedure New_Arrival_32 is
- Next_Vehicle_Task_32 : acc_Vehicle_32 := new Vehicle_32;
- TC_Pass_Point : constant integer := 3;
- begin
- Ramp_32.TC_Passage ( TC_Pass_Point ); -- Note passage through here
- null; --::: stub
- end New_arrival_32;
-
-
- -- Carrier task. One is created for each vehicle arriving at Ramp_32
- task body Vehicle_32 is
- TC_Pass_point : constant integer := 1;
- TC_Pass_Point_2 : constant integer := 21;
- TC_Pass_Point_3 : constant integer := 2;
- begin
- Ramp_32.TC_Passage ( TC_Pass_Point ); -- note passage through here
- if Ramp_32.Meter_in_Use_State then
- Ramp_32.TC_Passage ( TC_Pass_Point_2 ); -- note passage
- -- Increment count of number of vehicles on ramp
- Ramp_32.Add_Meter_Queue; -- CALL a protected PROCEDURE
- -- which is also called from within
- -- enter the meter queue
- Ramp_32.Wait_at_Meter; -- CALL a protected ENTRY
- end if;
- Ramp_32.TC_Passage ( TC_Pass_Point_3 ); -- note passage through here
- null; --:::: call to the first in the series of the Ramp_Sensors
- -- this "passes" the vehicle from one sensor to the next
- exception
- when others =>
- Report.Failed ("Unexpected exception in Vehicle Task");
- end Vehicle_32;
-
-
- -- Task transmits a synchronizing "pulse" to all ramps
- --
- task body Pulse_Task is
- Pulse_Time : Ada.Calendar.Time := Ada.Calendar.Clock;
- begin
- While not Control.Stop loop
- delay until Pulse_Time;
- Ramp_31.Time_Pulse_Received; -- CALL OF PROCEDURE CAUSES
- Ramp_32.Time_Pulse_Received; -- INTERNAL CALLS
- -- :::::::::: and to all the others
- Pulse_Time := Pulse_Time + Pulse_Time_Delta; -- calculate next
- end loop;
- exception
- when others =>
- Report.Failed ("Unexpected exception in Pulse_Task");
- end Pulse_Task;
-
-
- begin -- declare
-
- -- Test driver. This is ALL test control code
-
- -- First simulate calls to the protected functions and procedures
- -- from without the protected object
- --
- -- CALL FUNCTIONS
- if not ( Ramp_31.Local_Overload = Clear_Level and
- Ramp_31.Next_Ramp_in_Overload = Clear_Level and
- Ramp_31.Freeway_Overload = Clear_Level ) then
- Report.Failed ("Initial Calls to Ramp_31 incorrect");
- end if;
- if not ( Ramp_32.Local_Overload = Clear_Level and
- Ramp_32.Next_Ramp_in_Overload = Clear_Level and
- Ramp_32.Freeway_Overload = Clear_Level ) then
- Report.Failed ("Initial Calls to Ramp_32 incorrect");
- end if;
-
- -- Now Simulate the arrival of a vehicle at each ramp to verify
- -- basic paths through the test
- New_Arrival_31;
- New_Arrival_32;
- delay Pulse_Time_Delta*2; -- allow them to pass through the complex
-
- -- Simulate real-time sensors reporting overload
- Ramp_31.Set_Local_Overload; -- CALL A PROCEDURE (and change levels)
- Ramp_32.Set_Local_Overload; -- CALL A PROCEDURE (and change levels)
-
- -- CALL FUNCTIONS again
- if not ( Ramp_31.Local_Overload = Minimum_Level and
- Ramp_31.Freeway_Overload = Minimum_Level ) then
- Report.Failed ("Secondary Calls to Ramp_31 incorrect");
- end if;
- if not ( Ramp_32.Local_Overload = Minimum_Level and
- Ramp_32.Freeway_Overload = Minimum_Level ) then
- Report.Failed ("Secondary Calls to Ramp_32 incorrect");
- end if;
-
- -- Now Simulate the arrival of another vehicle at each ramp again causing
- -- INTERNAL CALLS but following different paths (queuing on the
- -- meter etc.)
- New_Arrival_31;
- New_Arrival_32;
- delay Pulse_Time_Delta*2; -- allow them to pass through the complex
-
- Control.Stop_Now; -- finish test
-
- if not (TC_Expected_Passage_Total = Ramp_31.TC_Get_Passage_Total and
- TC_Expected_Passage_Total = Ramp_32.TC_Get_Passage_Total) then
- Report.Failed ("Unexpected paths taken");
- end if;
-
- end; -- declare
-
- Report.Result;
-
-end C940007;
diff --git a/gcc/testsuite/ada/acats/tests/c9/c940010.a b/gcc/testsuite/ada/acats/tests/c9/c940010.a
deleted file mode 100644
index c4a670552d4..00000000000
--- a/gcc/testsuite/ada/acats/tests/c9/c940010.a
+++ /dev/null
@@ -1,269 +0,0 @@
--- C940010.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that if an exception is raised during the execution of an
--- entry body it is propagated back to the caller
---
--- TEST DESCRIPTION:
--- Use a small fragment of code from the simulation of a freeway meter
--- used in c940007. Create three individual tasks which will be queued on
--- the entry as the barrier is set. Release them one at a time. A
--- procedure which is called within the entry has been modified for this
--- test to raise a different exception for each pass through. Check that
--- all expected exceptions are raised and propagated.
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
---
---!
-
-
-with Report;
-with ImpDef;
-
-procedure C940010 is
-
- TC_Failed_1 : Boolean := false;
-
-begin
-
- Report.Test ("C940010", "Check that an exception raised in an entry " &
- "body is propagated back to the caller");
-
- declare -- encapsulate the test
-
- TC_Defined_Error : Exception; -- User defined exception
- TC_Expected_Passage_Total : constant integer := 669;
- TC_Int : constant integer := 5;
-
- -- Carrier tasks. One is created for each vehicle arriving at each ramp
- task type Vehicle_31; -- For Ramp_31
- type acc_Vehicle_31 is access Vehicle_31;
-
-
- --================================================================
- protected Ramp_31 is
-
- function Meter_in_Use_State return Boolean;
- procedure Add_Meter_Queue;
- procedure Subtract_Meter_Queue;
- entry Wait_at_Meter;
- procedure Pulse;
- --
- procedure TC_Passage (Pass_Point : Integer);
- function TC_Get_Passage_Total return integer;
- function TC_Get_Current_Exception return integer;
-
- private
-
- Release_One_Vehicle : Boolean := false;
- Meter_in_Use : Boolean := true; -- TC: set true for this test
- --
- TC_Multiplier : integer := 1;
- TC_Passage_Total : integer := 0;
- -- Use this to cycle through the required exceptions
- TC_Current_Exception : integer range 0..3 := 0;
-
- end Ramp_31;
- --================================================================
- protected body Ramp_31 is
-
-
- -- Trace the paths through the various routines by totaling the
- -- weighted call parameters
- procedure TC_Passage (Pass_Point : Integer) is
- begin
- TC_Passage_Total := TC_Passage_Total+(Pass_Point*TC_Multiplier);
- end TC_Passage;
-
- -- For the final check of the whole test
- function TC_Get_Passage_Total return integer is
- begin
- return TC_Passage_Total;
- end TC_Get_Passage_Total;
-
- function TC_Get_Current_Exception return integer is
- begin
- return TC_Current_Exception;
- end TC_Get_Current_Exception;
-
-
- -----------------
-
- function Meter_in_Use_State return Boolean is
- begin
- return Meter_in_Use;
- end Meter_in_Use_State;
-
- -- Simulate the effects of the regular signal pulse
- procedure Pulse is
- begin
- Release_one_Vehicle := true;
- end Pulse;
-
- -- Keep count of vehicles currently on meter queue - we can't use
- -- the 'count because we need the outcall trigger
- procedure Add_Meter_Queue is
- begin
- null; --::: stub
- end Add_Meter_Queue;
-
- -- TC: This routine has been modified to raise the required
- -- exceptions
- procedure Subtract_Meter_Queue is
- TC_Pass_Point1 : constant integer := 10;
- TC_Pass_Point2 : constant integer := 20;
- TC_Pass_Point3 : constant integer := 30;
- TC_Pass_Point9 : constant integer := 1000; -- error
- begin
- -- Cycle through the required exceptions, one per call
- TC_Current_Exception := TC_Current_Exception + 1;
- case TC_Current_Exception is
- when 1 =>
- TC_Passage (TC_Pass_Point1); -- note passage through here
- raise Storage_Error; -- PREDEFINED EXCEPTION
- when 2 =>
- TC_Passage (TC_Pass_Point2); -- note passage through here
- raise TC_Defined_Error; -- USER DEFINED EXCEPTION
- when 3 =>
- TC_Passage (TC_Pass_Point3); -- note passage through here
- -- RUN TIME EXCEPTION (Constraint_Error)
- -- Add the value 3 to 5 then try to assign it to an object
- -- whose range is 0..3 - this causes the exception.
- -- Disguise the values which cause the Constraint_Error
- -- so that the optimizer will not eliminate this code
- -- Note: the variable is checked at the end to ensure
- -- that the actual assignment is attempted. Also note
- -- the value remains at 3 as the assignment does not
- -- take place. This is the value that is checked at
- -- the end of the test.
- -- Otherwise the optimizer could decide that the result
- -- of the assignment was not used so why bother to do it?
- TC_Current_Exception :=
- Report.Ident_Int (TC_Current_Exception) +
- Report.Ident_Int (TC_Int);
- when others =>
- -- Set flag for Report.Failed which cannot be called from
- -- within a Protected Object
- TC_Failed_1 := True;
- end case;
-
- TC_Passage ( TC_Pass_Point9 ); -- note passage through here
- end Subtract_Meter_Queue;
-
- -- Here each Vehicle task queues itself awaiting release
- entry Wait_at_Meter when Release_One_Vehicle is
- -- Example of entry with barriers and persistent signal
- TC_Pass_Point : constant integer := 2;
- begin
- TC_Passage ( TC_Pass_Point ); -- note passage through here
- Release_One_Vehicle := false; -- Consume the signal
- -- Decrement number of vehicles on ramp
- Subtract_Meter_Queue; -- Call procedure from within entry body
- end Wait_at_Meter;
-
- end Ramp_31;
- --================================================================
-
- -- Carrier task. One is created for each vehicle arriving at Ramp_31
- task body Vehicle_31 is
- TC_Pass_Point_1 : constant integer := 100;
- TC_Pass_Point_2 : constant integer := 200;
- TC_Pass_Point_3 : constant integer := 300;
- begin
- if Ramp_31.Meter_in_Use_State then
- -- Increment count of number of vehicles on ramp
- Ramp_31.Add_Meter_Queue; -- Call a protected procedure
- -- which is also called from within
- -- enter the meter queue
- Ramp_31.Wait_at_Meter; -- Call a protected entry
- Report.Failed ("Exception not propagated back");
- end if;
- null; --:::: call to the first in the series of the Ramp_Sensors
- -- this "passes" the vehicle from one sensor to the next
- exception
- when Storage_Error =>
- Ramp_31.TC_Passage ( TC_Pass_Point_1 ); -- note passage
- when TC_Defined_Error =>
- Ramp_31.TC_Passage ( TC_Pass_Point_2 ); -- note passage
- when Constraint_Error =>
- Ramp_31.TC_Passage ( TC_Pass_Point_3 ); -- note passage
- when others =>
- Report.Failed ("Unexpected exception in Vehicle Task");
- end Vehicle_31;
-
- -- Simulate the arrival of a vehicle at the Ramp_Receiver of Ramp_31
- -- and the generation of an accompanying carrier task
- procedure New_Arrival_31 is
- Next_Vehicle_Task_31: acc_Vehicle_31 := new Vehicle_31;
- TC_Pass_Point : constant integer := 1;
- begin
- Ramp_31.TC_Passage ( TC_Pass_Point ); -- Note passage through here
- null; --::: stub
- end New_arrival_31;
-
-
-
- begin -- declare
-
- -- Test driver. This is ALL test control code
-
- -- Create three independent tasks which will queue themselves on the
- -- entry. Each task will get a different exception
- New_Arrival_31;
- New_Arrival_31;
- New_Arrival_31;
-
- delay ImpDef.Clear_Ready_Queue;
-
- -- Set the barrier condition of the entry true, releasing one task
- Ramp_31.Pulse;
- delay ImpDef.Clear_Ready_Queue;
-
- Ramp_31.Pulse;
- delay ImpDef.Clear_Ready_Queue;
-
- Ramp_31.Pulse;
- delay ImpDef.Clear_Ready_Queue;
-
- if (TC_Expected_Passage_Total /= Ramp_31.TC_Get_Passage_Total) or
- -- Note: We are not really interested in this next check. It is
- -- here to ensure the earlier statements which raised the
- -- Constraint_Error are not optimized out
- (Ramp_31.TC_Get_Current_Exception /= 3) then
- Report.Failed ("Unexpected paths taken");
- end if;
-
- end; -- declare
-
- if TC_Failed_1 then
- Report.Failed ("Bad path through Subtract_Meter_Queue");
- end if;
-
- Report.Result;
-
-end C940010;
diff --git a/gcc/testsuite/ada/acats/tests/c9/c940011.a b/gcc/testsuite/ada/acats/tests/c9/c940011.a
deleted file mode 100644
index 65228666cd3..00000000000
--- a/gcc/testsuite/ada/acats/tests/c9/c940011.a
+++ /dev/null
@@ -1,175 +0,0 @@
--- C940011.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that, in the body of a protected object created by the execution
--- of an allocator, external calls to other protected objects via
--- the access type are correctly performed
---
--- TEST DESCRIPTION:
--- Use a subset of the simulation of the freeway on-ramp described in
--- c940005. In this case an array of access types is built with pointers
--- to successive ramps. The external calls within the protected
--- objects are made via the index into the array. Routines which refer
--- to the "previous" ramp and the "next" ramp are exercised. (Note: The
--- first and last ramps are assumed to be dummies and no first/last
--- condition code is included)
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
---
---!
-
-
-with Report;
-
-
-procedure C940011 is
-
- type Ramp;
- type acc_Ramp is access Ramp;
-
- subtype Ramp_Index is integer range 1..4;
-
-
- -- Weighted load given to each potential problem area and accumulated
- type Load_Factor is range 0..8;
- Clear_Level : constant Load_Factor := 0;
- Moderate_Level : constant Load_Factor := 3;
-
- --================================================================
- -- Only the Routines that are used in this test are shown
- --
- protected type Ramp is
-
- procedure Set_Index (Index : Ramp_Index);
- procedure Set_Local_Overload (Sensor_Level : Load_Factor);
- function Local_Overload return Load_Factor;
- procedure Notify;
- function Next_Ramp_Overload return Load_Factor;
-
- private
-
- This_Ramp : Ramp_Index;
-
- Next_Ramp_Alert : Boolean := false; -- Next Ramp is in trouble?
-
- -- Current state of the various Sample Points
- Local_State : Load_Factor := Clear_Level;
-
- end Ramp;
- --================================================================
-
- -- Build a set of Ramp objects and an array of pointers to them
- --
- Ramp_Array : array (Ramp_Index) of acc_Ramp := (Ramp_Index => new Ramp);
-
- --================================================================
- protected body Ramp is
-
- procedure Set_Index (Index : Ramp_Index) is
- begin
- This_Ramp := Index;
- end Set_Index;
-
- -- These Set/Clear routines are triggered by real-time sensors that
- -- reflect traffic state
- procedure Set_Local_Overload(Sensor_Level : Load_Factor) is
- begin
- if Local_State = Clear_Level then
- -- Notify "previous" ramp to check this one for current state.
- -- Subsequent changes in state will not send an alert
- -- When the situation clears another routine performs the
- -- all_clear notification. (not shown)
- -- EXTERNAL CALL OF PROCEDURE FROM PROCEDURE
- Ramp_Array(This_Ramp - 1).Notify; -- index to previous ramp
- end if;
- Local_State := Sensor_Level;
- null; --::::: Start local meter if not already started
- end Set_Local_Overload;
-
- function Local_Overload return Load_Factor is
- begin
- return Local_State;
- end Local_Overload;
-
- -- This is notification from the next ramp that it is in
- -- overload. With this provision we only need to sample the next
- -- ramp during adverse conditions.
- procedure Notify is
- begin
- Next_Ramp_Alert := true;
- end Notify;
-
- function Next_Ramp_Overload return Load_Factor is
- begin
- if Next_Ramp_Alert then
- -- EXTERNAL FUNCTION CALL FROM FUNCTION
- -- Get next ramp's current state
- return Ramp_Array(This_Ramp + 1).Local_Overload;
- else
- return Clear_Level;
- end if;
- end Next_Ramp_Overload;
- end Ramp;
-
- --================================================================
-
-
-begin
-
-
- Report.Test ("C940011", "Protected Objects created by allocators: " &
- "external calls via access types");
-
- -- Initialize each Ramp
- for i in Ramp_Index loop
- Ramp_Array(i).Set_Index (i);
- end loop;
-
- -- Test driver. This is ALL test control code
-
- -- Simulate calls to the protected functions and procedures
- -- external calls. (do not call the "dummy" end ramps)
-
- -- Simple Call
- if Ramp_Array(2).Next_Ramp_Overload /= Clear_level then
- Report.Failed ("Primary call incorrect");
- end if;
-
- -- Call which results in an external procedure call via the array
- -- index from within the protected object
- Ramp_Array(3).Set_Local_Overload (Moderate_Level);
-
- -- Call which results in an external function call via the array
- -- index from within the protected object
- if Ramp_Array(2).Next_Ramp_Overload /= Moderate_level then
- Report.Failed ("Secondary call incorrect");
- end if;
-
- Report.Result;
-
-end C940011;
diff --git a/gcc/testsuite/ada/acats/tests/c9/c940012.a b/gcc/testsuite/ada/acats/tests/c9/c940012.a
deleted file mode 100644
index d4bd2079cb2..00000000000
--- a/gcc/testsuite/ada/acats/tests/c9/c940012.a
+++ /dev/null
@@ -1,174 +0,0 @@
--- C940012.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that a protected object can have discriminants
---
--- TEST DESCRIPTION:
--- Use a subset of the simulation of the freeway on-ramp described in
--- c940005. In this case an array of access types is built with pointers
--- to successive ramps. Each ramp has its Ramp_Number specified by
--- discriminant and this corresponds to the index in the array. The test
--- checks that the ramp numbers are assigned as expected then uses calls
--- to procedures within the objects (ramps) to verify external calls to
--- ensure the structures are valid. The external references within the
--- protected objects are made via the index into the array. Routines
--- which refer to the "previous" ramp and the "next" ramp are exercised.
--- (Note: The first and last ramps are assumed to be dummies and no
--- first/last condition code is included)
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
---
---!
-
-
-with Report;
-
-
-procedure C940012 is
-
- type Ramp_Index is range 1..4;
-
- type Ramp;
- type a_Ramp is access Ramp;
-
- Ramp_Array : array (Ramp_Index) of a_Ramp;
-
- -- Weighted load given to each potential problem area and accumulated
- type Load_Factor is range 0..8;
- Clear_Level : constant Load_Factor := 0;
- Moderate_Level : constant Load_Factor := 3;
-
- --================================================================
- -- Only the Routines that are used in this test are shown
- --
- protected type Ramp (Ramp_In : Ramp_Index) is
-
- function Ramp_Number return Ramp_Index;
- function Local_Overload return Load_Factor;
- function Next_Ramp_Overload return Load_Factor;
- procedure Set_Local_Overload(Sensor_Level : Load_Factor);
- procedure Notify;
-
- private
-
- Next_Ramp_Alert : Boolean := false; -- Next Ramp is in trouble?
-
- -- Current state of the various Sample Points
- Local_State : Load_Factor := Clear_Level;
-
- end Ramp;
- --================================================================
- protected body Ramp is
-
- function Ramp_Number return Ramp_Index is
- begin
- return Ramp_In;
- end Ramp_Number;
-
- -- These Set/Clear routines are triggered by real-time sensors that
- -- reflect traffic state
- procedure Set_Local_Overload(Sensor_Level : Load_Factor) is
- begin
- if Local_State = Clear_Level then
- -- Notify "previous" ramp to check this one for current state.
- -- Subsequent changes in state will not send an alert
- -- When the situation clears another routine performs the
- -- all_clear notification. (not shown)
- Ramp_Array(Ramp_In - 1).Notify; -- index to previous ramp
- end if;
- Local_State := Sensor_Level;
- null; --::::: Start local meter if not already started
- end;
-
- function Local_Overload return Load_Factor is
- begin
- return Local_State;
- end Local_Overload;
-
- -- This is notification from the next ramp that it is in
- -- overload. With this provision we only need to sample the next
- -- ramp during adverse conditions.
- procedure Notify is
- begin
- Next_Ramp_Alert := true;
- end Notify;
-
- function Next_Ramp_Overload return Load_Factor is
- begin
- if Next_Ramp_Alert then
- -- Get next ramp's current state
- return Ramp_Array(Ramp_In + 1).Local_Overload;
- else
- return Clear_Level;
- end if;
- end Next_Ramp_Overload;
- end Ramp;
- --================================================================
-
-begin
-
-
- Report.Test ("C940012", "Check that a protected object " &
- "can have discriminants");
-
- -- Build the ramps and populate the ramp array
- for i in Ramp_Index loop
- Ramp_Array(i) := new Ramp (i);
- end loop;
-
- -- Test driver. This is ALL test control code
-
- -- Check the assignment of the index
- for i in Ramp_Index loop
- if Ramp_Array(i).Ramp_Number /= i then
- Report.Failed ("Ramp_Number assignment incorrect");
- end if;
- end loop;
-
- -- Simulate calls to the protected functions and procedures
- -- external calls. (do not call the "dummy" end ramps)
-
- -- Simple Call
- if Ramp_Array(2).Next_Ramp_Overload /= Clear_level then
- Report.Failed ("Primary call incorrect");
- end if;
-
- -- Call which results in an external procedure call via the array
- -- index from within the protected object
- Ramp_Array(3).Set_Local_Overload (Moderate_Level);
-
- -- Call which results in an external function call via the array
- -- index from within the protected object
- if Ramp_Array(2).Next_Ramp_Overload /= Moderate_level then
- Report.Failed ("Secondary call incorrect");
- end if;
-
-
- Report.Result;
-
-end C940012;
diff --git a/gcc/testsuite/ada/acats/tests/c9/c940013.a b/gcc/testsuite/ada/acats/tests/c9/c940013.a
deleted file mode 100644
index 58d34bc9697..00000000000
--- a/gcc/testsuite/ada/acats/tests/c9/c940013.a
+++ /dev/null
@@ -1,379 +0,0 @@
--- C940013.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that items queued on a protected entry are handled FIFO and that
--- the 'count attribute of that entry reflects the length of the queue.
---
--- TEST DESCRIPTION:
--- Use a small subset of the freeway ramp simulation shown in other
--- tests. With the timing pulse off (which prevents items from being
--- removed from the queue) queue up a small number of calls. Start the
--- timing pulse and, at the first execution of the entry code, check the
--- 'count attribute. Empty the queue. Pass the items being removed from
--- the queue to the Ramp_Sensor_01 task; there check that the items are
--- arriving in FIFO order. Check the final 'count value
---
--- Send another batch of items at a rate which will, if the delay timing
--- of the implementation is reasonable, cause the queue length to
--- fluctuate in both directions. Again check that all items arrive
--- FIFO. At the end check that the 'count returned to zero reflecting
--- the empty queue.
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
---
---!
-
-with Report;
-with ImpDef;
-with Ada.Calendar;
-
-procedure C940013 is
-
- TC_Failed_1 : Boolean := false;
-
-begin
-
- Report.Test ("C940013", "Check that queues on protected entries are " &
- "handled FIFO and that 'count is correct");
-
- declare -- encapsulate the test
-
- function "+" (Left : Ada.Calendar.Time; Right: Duration)
- return Ada.Calendar.Time renames Ada.Calendar."+";
-
- -- Weighted load given to each potential problem area and accumulated
- type Load_Factor is range 0..8;
- Clear_Level : constant Load_Factor := 0;
- Minimum_Level : constant Load_Factor := 1;
- Moderate_Level : constant Load_Factor := 2;
- Serious_Level : constant Load_Factor := 4;
- Critical_Level : constant Load_Factor := 6;
-
- TC_Expected_Passage_Total : constant integer := 624;
-
- -- For this test give each vehicle an integer ID incremented
- -- by one for each successive vehicle. In reality this would be
- -- a more complex alpha-numeric ID assigned at pickup time.
- type Vehicle_ID is range 1..5000;
- Next_ID : Vehicle_ID := Vehicle_ID'first;
-
- -- In reality this would be about 5 seconds. The default value of
- -- this constant in the implementation defined package is similar
- -- but could, of course be considerably different - it would not
- -- affect the test
- --
- Pulse_Time_Delta : duration := ImpDef.Clear_Ready_Queue;
-
-
- task Pulse_Task; -- task to generate a pulse for each ramp
-
- -- Carrier task. One is created for each vehicle arriving at the ramp
- task type Vehicle is
- entry Get_ID (Input_ID : in Vehicle_ID);
- end Vehicle;
- type acc_Vehicle is access Vehicle;
-
- task Ramp_Sensor_01 is
- entry Accept_Vehicle (Input_ID : in Vehicle_ID);
- entry TC_First_Three_Handled;
- entry TC_All_Done;
- end Ramp_Sensor_01;
-
- protected Pulse_State is
- procedure Start_Pulse;
- procedure Stop_Pulse;
- function Pulsing return Boolean;
- private
- State : Boolean := false; -- start test will pulse off
- end Pulse_State;
-
- protected body Pulse_State is
-
- procedure Start_Pulse is
- begin
- State := true;
- end Start_Pulse;
-
- procedure Stop_Pulse is
- begin
- State := false;
- end Stop_Pulse;
-
- function Pulsing return Boolean is
- begin
- return State;
- end Pulsing;
-
- end Pulse_State;
-
- --================================================================
- protected Test_Ramp is
-
- function Meter_in_use_State return Boolean;
- procedure Time_Pulse_Received;
- entry Wait_at_Meter;
- procedure TC_Passage (Pass_Point : Integer);
- function TC_Get_Passage_Total return integer;
- function TC_Get_Count return integer;
-
- private
-
- Release_One_Vehicle : Boolean := false;
- -- For this test have Meter_in_Use already set
- Meter_in_Use : Boolean := true;
-
- TC_Wait_at_Meter_First : Boolean := true;
- TC_Entry_Queue_Count : integer := 0; -- 'count of Wait_at_Meter
- TC_Passage_Total : integer := 0;
- TC_Pass_Point_WAM : integer := 23;
-
- end Test_Ramp;
- --================================================================
- protected body Test_Ramp is
-
- -- External call for Meter_in_Use
- function Meter_in_Use_State return Boolean is
- begin
- return Meter_in_Use;
- end Meter_in_Use_State;
-
- -- Trace the paths through the various routines by totalling the
- -- weighted call parameters
- procedure TC_Passage (Pass_Point : Integer) is
- begin
- TC_Passage_Total := TC_Passage_Total + Pass_Point;
- end TC_Passage;
-
- -- For the final check of the whole test
- function TC_Get_Passage_Total return integer is
- begin
- return TC_Passage_Total;
- end TC_Get_Passage_Total;
-
- function TC_Get_Count return integer is
- begin
- return TC_Entry_Queue_Count;
- end TC_Get_Count;
-
-
- -- Here each Vehicle task queues itself awaiting release
- --
- entry Wait_at_Meter when Release_One_Vehicle is
- -- EXAMPLE OF ENTRY WITH BARRIERS AND PERSISTENT SIGNAL
- begin
- --
- TC_Passage ( TC_Pass_Point_WAM ); -- note passage
- -- For this test three vehicles are queued before the first
- -- is released. If the queueing mechanism is working correctly
- -- the first time we pass through here the entry'count should
- -- reflect this
- if TC_Wait_at_Meter_First then
- if Wait_at_Meter'count /= 2 then
- TC_Failed_1 := true;
- end if;
- TC_Wait_at_Meter_First := false;
- end if;
- TC_Entry_Queue_Count := Wait_at_Meter'count; -- note for later
-
- Release_One_Vehicle := false; -- Consume the signal
- null; -- stub ::: Decrement count of number of vehicles on ramp
- end Wait_at_Meter;
-
-
- procedure Time_Pulse_Received is
- Load : Load_factor := Minimum_Level; -- for this version of the
- Freeway_Breakdown : Boolean := false; -- test, freeway is Minimum
- begin
- -- if broken down, no vehicles are released
- if not Freeway_Breakdown then
- if Load < Moderate_Level then
- Release_One_Vehicle := true;
- end if;
- null; -- stub ::: If other levels, release every other
- -- pulse, every third pulse etc.
- end if;
- end Time_Pulse_Received;
-
- end Test_Ramp;
- --================================================================
-
- -- Simulate the arrival of a vehicle at the Ramp_Receiver and the
- -- generation of an accompanying carrier task
- procedure New_Arrival is
- Next_Vehicle_Task: acc_Vehicle := new Vehicle;
- TC_Pass_Point : constant integer := 3;
- begin
- Next_ID := Next_ID + 1;
- Next_Vehicle_Task.Get_ID(Next_ID);
- Test_Ramp.TC_Passage ( TC_Pass_Point ); -- Note passage through here
- null;
- end New_arrival;
-
-
- -- Carrier task. One is created for each vehicle arriving at the ramp
- task body Vehicle is
- This_ID : Vehicle_ID;
- TC_Pass_Point_2 : constant integer := 21;
- begin
- accept Get_ID (Input_ID : in Vehicle_ID) do
- This_ID := Input_ID;
- end Get_ID;
-
- if Test_Ramp.Meter_in_Use_State then
- Test_Ramp.TC_Passage ( TC_Pass_Point_2 ); -- note passage
- null; -- stub::: Increment count of number of vehicles on ramp
- Test_Ramp.Wait_at_Meter; -- Queue on the meter entry
- end if;
-
- -- Call to the first in the series of the Ramp_Sensors
- -- this "passes" the vehicle from one sensor to the next
- -- Each sensor will requeue the call to the next thus this
- -- rendezvous will only be completed as the vehicle is released
- -- by the last sensor on the ramp.
- Ramp_Sensor_01.Accept_Vehicle (This_ID);
- exception
- when others =>
- Report.Failed ("Unexpected exception in Vehicle Task");
- end Vehicle;
-
- task body Ramp_Sensor_01 is
- TC_Pass_Point : constant integer := 31;
- This_ID : Vehicle_ID;
- TC_Last_ID : Vehicle_ID := Vehicle_ID'first;
- begin
- loop
- select
- accept Accept_Vehicle (Input_ID : in Vehicle_ID) do
- null; -- stub:::: match up with next Real-Time notification
- -- from the sensor. Requeue to next ramp sensor
- This_ID := Input_ID;
-
- -- The following is all Test_Control code
- Test_Ramp.TC_Passage ( TC_Pass_Point ); -- note passage
- -- The items arrive in the order they are taken from
- -- the Wait_at_Meter entry queue
- if ( This_ID - TC_Last_ID ) /= 1 then
- -- The tasks are being queued (or unqueued) in the
- -- wrong order
- Report.Failed
- ("Queueing on the Wait_at_Meter queue failed");
- end if;
- TC_Last_ID := This_ID; -- for the next check
- if TC_Last_ID = 4 then
- -- rendezvous with the test driver
- accept TC_First_Three_Handled;
- elsif TC_Last_ID = 9 then
- -- rendezvous with the test driver
- accept TC_All_Done;
- end if;
- end Accept_Vehicle;
- or
- terminate;
- end select;
- end loop;
- exception
- when others =>
- Report.Failed ("Unexpected exception in Ramp_Sensor_01");
- end Ramp_Sensor_01;
-
-
- -- Task transmits a synchronizing "pulse" to all ramps
- --
- task body Pulse_Task is
- Pulse_Time : Ada.Calendar.Time;
- begin
- While not Pulse_State.Pulsing loop
- -- Starts up in the quiescent state
- delay ImpDef.Minimum_Task_Switch;
- end loop;
- Pulse_Time := Ada.Calendar.Clock;
- While Pulse_State.Pulsing loop
- delay until Pulse_Time;
- Test_Ramp. Time_Pulse_Received; -- Transmit pulse to test_ramp
- -- :::::::::: and to all the other ramps
- Pulse_Time := Pulse_Time + Pulse_Time_Delta; -- calculate next
- end loop;
- exception
- when others =>
- Report.Failed ("Unexpected exception in Pulse_Task");
- end Pulse_Task;
-
-
- begin -- declare
-
- -- Test driver. This is ALL test control code
-
- -- Arrange to queue three vehicles on the Wait_at_Meter queue. The
- -- timing pulse is quiescent so the queue will build
- for i in 1..3 loop
- New_Arrival;
- end loop;
-
- delay Pulse_Time_Delta; -- ensure all is settled
-
- Pulse_State.Start_Pulse; -- Start the timing pulse, the queue will
- -- be serviced
-
- -- wait here until the first three are complete
- Ramp_Sensor_01.TC_First_Three_Handled;
-
- if Test_Ramp.TC_Get_Count /= 0 then
- Report.Failed ("Intermediate Wait_at_Entry'count is incorrect");
- end if;
-
- -- generate new arrivals at a rate that will make the queue increase
- -- and decrease "randomly"
- for i in 1..5 loop
- New_Arrival;
- delay Pulse_Time_Delta/2;
- end loop;
-
- -- wait here till all have been handled
- Ramp_Sensor_01.TC_All_Done;
-
- if Test_Ramp.TC_Get_Count /= 0 then
- Report.Failed ("Final Wait_at_Entry'count is incorrect");
- end if;
-
- Pulse_State.Stop_Pulse; -- finish test
-
-
- if TC_Expected_Passage_Total /= Test_Ramp.TC_Get_Passage_Total then
- Report.Failed ("Unexpected paths taken");
- end if;
-
-
- end; -- declare
-
- if TC_Failed_1 then
- Report.Failed ("Wait_at_Meter'count incorrect");
- end if;
-
- Report.Result;
-
-end C940013;
diff --git a/gcc/testsuite/ada/acats/tests/c9/c940014.a b/gcc/testsuite/ada/acats/tests/c9/c940014.a
deleted file mode 100644
index 0eb53ea5127..00000000000
--- a/gcc/testsuite/ada/acats/tests/c9/c940014.a
+++ /dev/null
@@ -1,177 +0,0 @@
--- C940014.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- TEST OBJECTIVE:
--- Check that as part of the finalization of a protected object
--- each call remaining on an entry queue of the objet is removed
--- from its queue and Program_Error is raised at the place of
--- the corresponding entry_call_statement.
---
--- TEST DESCRIPTION:
--- The example in 9.4(20a-20f);6.0 demonstrates how to cause a
--- protected object to finalize while tasks are still waiting
--- on its entry queues. The first part of this test mirrors
--- that example. The second part of the test expands upon
--- the example code to add an object with finalization code
--- to the protected object. The finalization code should be
--- executed after Program_Error is raised in the callers left
--- on the entry queues.
---
---
--- CHANGE HISTORY:
--- 08 Jan 96 SAIC Initial Release for 2.1
--- 10 Jul 96 SAIC Incorporated Reviewer comments to fix race
--- condition.
---
---!
-
-
-with Ada.Finalization;
-package C940014_0 is
- Verbose : constant Boolean := False;
- Finalization_Occurred : Boolean := False;
-
- type Has_Finalization is new Ada.Finalization.Limited_Controlled with
- record
- Placeholder : Integer;
- end record;
- procedure Finalize (Object : in out Has_Finalization);
-end C940014_0;
-
-
-with Report;
-with ImpDef;
-package body C940014_0 is
- procedure Finalize (Object : in out Has_Finalization) is
- begin
- delay ImpDef.Clear_Ready_Queue;
- Finalization_Occurred := True;
- if Verbose then
- Report.Comment ("in Finalize");
- end if;
- end Finalize;
-end C940014_0;
-
-
-
-with Report;
-with ImpDef;
-with Ada.Finalization;
-with C940014_0;
-
-procedure C940014 is
- Verbose : constant Boolean := C940014_0.Verbose;
-
-begin
-
- Report.Test ("C940014", "Check that the finalization of a protected" &
- " object results in program_error being raised" &
- " at the point of the entry call statement for" &
- " any tasks remaining on any entry queue");
-
- First_Check: declare
- -- example from ARM 9.4(20a-f);6.0 with minor mods
- task T is
- entry E;
- end T;
- task body T is
- protected PO is
- entry Ee;
- end PO;
- protected body PO is
- entry Ee when Report.Ident_Bool (False) is
- begin
- null;
- end Ee;
- end PO;
- begin
- accept E do
- requeue PO.Ee;
- end E;
- if Verbose then
- Report.Comment ("task about to terminate");
- end if;
- end T;
- begin -- First_Check
- begin
- T.E;
- delay ImpDef.Clear_Ready_Queue;
- Report.Failed ("exception not raised in First_Check");
- exception
- when Program_Error =>
- if Verbose then
- Report.Comment ("ARM Example passed");
- end if;
- when others =>
- Report.Failed ("wrong exception in First_Check");
- end;
- end First_Check;
-
-
- Second_Check : declare
- -- here we want to check that the raising of Program_Error
- -- occurs before the other finalization actions.
- task T is
- entry E;
- end T;
- task body T is
- protected PO is
- entry Ee;
- private
- Component : C940014_0.Has_Finalization;
- end PO;
- protected body PO is
- entry Ee when Report.Ident_Bool (False) is
- begin
- null;
- end Ee;
- end PO;
- begin
- accept E do
- requeue PO.Ee;
- end E;
- if Verbose then
- Report.Comment ("task about to terminate");
- end if;
- end T;
- begin -- Second_Check
- T.E;
- delay ImpDef.Clear_Ready_Queue;
- Report.Failed ("exception not raised in Second_Check");
- exception
- when Program_Error =>
- if C940014_0.Finalization_Occurred then
- Report.Failed ("wrong order for finalization");
- elsif Verbose then
- Report.Comment ("Second_Check passed");
- end if;
- when others =>
- Report.Failed ("Wrong exception in Second_Check");
- end Second_Check;
-
-
- Report.Result;
-
-end C940014;
diff --git a/gcc/testsuite/ada/acats/tests/c9/c940015.a b/gcc/testsuite/ada/acats/tests/c9/c940015.a
deleted file mode 100644
index 92a6699c3d4..00000000000
--- a/gcc/testsuite/ada/acats/tests/c9/c940015.a
+++ /dev/null
@@ -1,149 +0,0 @@
--- C940015.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- TEST OBJECTIVE:
--- Check that the component_declarations of a protected_operation
--- are elaborated in the proper order.
---
--- TEST DESCRIPTION:
--- A discriminated protected object is declared with some
--- components that depend upon the discriminant and some that
--- do not depend upon the discriminant. All the components
--- are initialized with a function call. As a side-effect of
--- the function call the parameter passed to the function is
--- recorded in an elaboration order array.
--- Two objects of the protected type are declared. The
--- elaboration order is recorded and checked against the
--- expected order.
---
---
--- CHANGE HISTORY:
--- 09 Jan 96 SAIC Initial Version for 2.1
--- 09 Jul 96 SAIC Addressed reviewer comments.
--- 13 Feb 97 PWB.CTA Removed doomed attempt to check per-object
--- constraint elaborations.
---!
-
-
-with Report;
-
-procedure C940015 is
- Verbose : constant Boolean := False;
- Do_Display : Boolean := Verbose;
-
- type Index is range 0..10;
-
- type List is array (1..10) of Integer;
- Last : Natural range 0 .. List'Last := 0;
- E_List : List := (others => 0);
-
- function Elaborate (Id : Integer) return Index is
- begin
- Last := Last + 1;
- E_List (Last) := Id;
- if Verbose then
- Report.Comment ("Elaborating" & Integer'Image (Id));
- end if;
- return Index(Id mod 10);
- end Elaborate;
-
- function Elaborate (Id, Per_Obj_Expr : Integer) return Index is
- begin
- return Elaborate (Id);
- end Elaborate;
-
-begin
-
- Report.Test ("C940015", "Check that the component_declarations of a" &
- " protected object are elaborated in the" &
- " proper order");
- declare
- -- an unprotected queue type
- type Storage is array (Index range <>) of Integer;
- type Queue (Size, Flag : Index := 1) is
- record
- Head : Index := 1;
- Tail : Index := 1;
- Count : Index := 0;
- Buffer : Storage (1..Size);
- end record;
-
- -- protected group of queues type
- protected type Prot_Queues (Size : Index := Elaborate (104)) is
- procedure Clear;
- -- other needed procedures not provided at this time
- private
- -- elaborate at type elaboration
- Fixed_Queue_1 : Queue (3,
- Elaborate (105));
- -- elaborate at type elaboration
- Fixed_Queue_2 : Queue (6,
- Elaborate (107));
- end Prot_Queues;
- protected body Prot_Queues is
- procedure Clear is
- begin
- Fixed_Queue_1.Count := 0;
- Fixed_Queue_1.Head := 1;
- Fixed_Queue_1.Tail := 1;
- Fixed_Queue_2.Count := 0;
- Fixed_Queue_2.Head := 1;
- Fixed_Queue_2.Tail := 1;
- end Clear;
- end Prot_Queues;
-
- PO1 : Prot_Queues(9);
- PO2 : Prot_Queues;
-
- Expected_Elab_Order : List := (
- -- from the elaboration of the protected type Prot_Queues
- 105, 107,
- -- from the unconstrained object PO2
- 104,
- others => 0);
- begin
- for I in List'Range loop
- if E_List (I) /= Expected_Elab_Order (I) then
- Report.Failed ("wrong elaboration order");
- Do_Display := True;
- end if;
- end loop;
- if Do_Display then
- Report.Comment ("Expected Actual");
- for I in List'Range loop
- Report.Comment (
- Integer'Image (Expected_Elab_Order(I)) &
- Integer'Image (E_List(I)));
- end loop;
- end if;
-
- -- make use of the protected objects
- PO1.Clear;
- PO2.Clear;
- end;
-
- Report.Result;
-
-end C940015;
diff --git a/gcc/testsuite/ada/acats/tests/c9/c940016.a b/gcc/testsuite/ada/acats/tests/c9/c940016.a
deleted file mode 100644
index 2226eefb40d..00000000000
--- a/gcc/testsuite/ada/acats/tests/c9/c940016.a
+++ /dev/null
@@ -1,211 +0,0 @@
--- C940016.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- TEST OBJECTIVE:
--- Check that an Unchecked_Deallocation of a protected object
--- performs the required finalization on the protected object.
---
--- TEST DESCRIPTION:
--- Test that finalization takes place when an Unchecked_Deallocation
--- deallocates a protected object with queued callers.
--- Try protected objects that have no other finalization code and
--- protected objects with user defined finalization.
---
---
--- CHANGE HISTORY:
--- 16 Jan 96 SAIC ACVC 2.1
--- 10 Jul 96 SAIC Fixed race condition noted by reviewers.
---
---!
-
-
-with Ada.Finalization;
-package C940016_0 is
- Verbose : constant Boolean := False;
- Finalization_Occurred : Boolean := False;
-
- type Has_Finalization is new Ada.Finalization.Limited_Controlled with
- record
- Placeholder : Integer;
- end record;
- procedure Finalize (Object : in out Has_Finalization);
-end C940016_0;
-
-
-with Report;
-with ImpDef;
-package body C940016_0 is
- procedure Finalize (Object : in out Has_Finalization) is
- begin
- delay ImpDef.Clear_Ready_Queue;
- Finalization_Occurred := True;
- if Verbose then
- Report.Comment ("in Finalize");
- end if;
- end Finalize;
-end C940016_0;
-
-
-
-with Report;
-with Ada.Finalization;
-with C940016_0;
-with Ada.Unchecked_Deallocation;
-with ImpDef;
-
-procedure C940016 is
- Verbose : constant Boolean := C940016_0.Verbose;
-
-begin
-
- Report.Test ("C940016", "Check that Unchecked_Deallocation of a" &
- " protected object finalizes the" &
- " protected object");
-
- First_Check: declare
- protected type Semaphore is
- entry Wait;
- procedure Signal;
- private
- Count : Integer := 0;
- end Semaphore;
- protected body Semaphore is
- entry Wait when Count > 0 is
- begin
- Count := Count - 1;
- end Wait;
-
- procedure Signal is
- begin
- Count := Count + 1;
- end Signal;
- end Semaphore;
-
- type pSem is access Semaphore;
- procedure Zap_Semaphore is new
- Ada.Unchecked_Deallocation (Semaphore, pSem);
- Sem_Ptr : pSem := new Semaphore;
-
- -- positive confirmation that Blocker got the exception
- Ok : Boolean := False;
-
- task Blocker;
-
- task body Blocker is
- begin
- Sem_Ptr.Wait;
- Report.Failed ("Program_Error not raised in waiting task");
- exception
- when Program_Error =>
- Ok := True;
- if Verbose then
- Report.Comment ("Blocker received Program_Error");
- end if;
- when others =>
- Report.Failed ("Wrong exception in Blocker");
- end Blocker;
-
- begin -- First_Check
- -- wait for Blocker to get blocked on the semaphore
- delay ImpDef.Clear_Ready_Queue;
- Zap_Semaphore (Sem_Ptr);
- -- make sure Blocker has time to complete
- delay ImpDef.Clear_Ready_Queue * 2;
- if not Ok then
- Report.Failed ("finalization not properly performed");
- -- Blocker is probably hung so kill it
- abort Blocker;
- end if;
- end First_Check;
-
-
- Second_Check : declare
- -- here we want to check that the raising of Program_Error
- -- occurs before the other finalization actions.
- protected type Semaphore is
- entry Wait;
- procedure Signal;
- private
- Count : Integer := 0;
- Component : C940016_0.Has_Finalization;
- end Semaphore;
- protected body Semaphore is
- entry Wait when Count > 0 is
- begin
- Count := Count - 1;
- end Wait;
-
- procedure Signal is
- begin
- Count := Count + 1;
- end Signal;
- end Semaphore;
-
- type pSem is access Semaphore;
- procedure Zap_Semaphore is new
- Ada.Unchecked_Deallocation (Semaphore, pSem);
- Sem_Ptr : pSem := new Semaphore;
-
- -- positive confirmation that Blocker got the exception
- Ok : Boolean := False;
-
- task Blocker;
-
- task body Blocker is
- begin
- Sem_Ptr.Wait;
- Report.Failed ("Program_Error not raised in waiting task 2");
- exception
- when Program_Error =>
- Ok := True;
- if C940016_0.Finalization_Occurred then
- Report.Failed ("wrong order for finalization 2");
- elsif Verbose then
- Report.Comment ("Blocker received Program_Error 2");
- end if;
- when others =>
- Report.Failed ("Wrong exception in Blocker 2");
- end Blocker;
-
- begin -- Second_Check
- -- wait for Blocker to get blocked on the semaphore
- delay ImpDef.Clear_Ready_Queue;
- Zap_Semaphore (Sem_Ptr);
- -- make sure Blocker has time to complete
- delay ImpDef.Clear_Ready_Queue * 2;
- if not Ok then
- Report.Failed ("finalization not properly performed 2");
- -- Blocker is probably hung so kill it
- abort Blocker;
- end if;
- if not C940016_0.Finalization_Occurred then
- Report.Failed ("user defined finalization didn't happen");
- end if;
- end Second_Check;
-
-
- Report.Result;
-
-end C940016;
diff --git a/gcc/testsuite/ada/acats/tests/c9/c940a03.a b/gcc/testsuite/ada/acats/tests/c9/c940a03.a
deleted file mode 100644
index 22876d26b18..00000000000
--- a/gcc/testsuite/ada/acats/tests/c9/c940a03.a
+++ /dev/null
@@ -1,350 +0,0 @@
--- C940A03.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that a protected object provides coordinated access to
--- shared data. Check that it can implement a semaphore-like construct
--- controlling access to shared data through procedure parameters to
--- allow a specific maximum number of tasks to run and exclude all
--- others.
---
--- TEST DESCRIPTION:
--- Declare a resource descriptor tagged type. Extend the type and
--- use the extended type in a protected data structure.
--- Implement a counting semaphore type that can be initialized to a
--- specific number of available resources. Declare an entry for
--- requesting a specific resource and an procedure for releasing the
--- same resource it. Declare an object of this (protected) type,
--- initialized to two resources. Declare and start three tasks each
--- of which asks for a resource. Verify that only two resources are
--- granted and that the last task in is queued.
---
--- This test models a multi-user operating system that allows a limited
--- number of logins. Users requesting login are modeled by tasks.
---
---
--- TEST FILES:
--- This test depends on the following foundation code:
---
--- F940A00
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 13 Nov 95 SAIC Fixed bugs for ACVC 2.0.1
---
---!
-
-package C940A03_0 is
- --Resource_Pkg
-
- -- General type declarations that will be extended to model available
- -- logins
-
- type Resource_ID_Type is range 0..10;
- type Resource_Type is tagged record
- Id : Resource_ID_Type := 0;
- end record;
-
-end C940A03_0;
- --Resource_Pkg
-
---======================================--
--- no body for C940A3_0
---======================================--
-
-with F940A00; -- Interlock_Foundation
-with C940A03_0; -- Resource_Pkg;
-
-package C940A03_1 is
- -- Semaphores
-
- -- Models a counting semaphore that will allow up to a specific
- -- number of logins
- -- Users (tasks) request a login slot by calling the Request_Login
- -- entry and logout by calling the Release_Login procedure
-
- Max_Logins : constant Integer := 2;
-
-
- type Key_Type is range 0..100;
- -- When a user requests a login, an
- -- identifying key will be returned
- Init_Key : constant Key_Type := 0;
-
- type Login_Record_Type is new C940A03_0.Resource_Type with record
- Key : Key_Type := Init_Key;
- end record;
-
-
- protected type Login_Semaphore_Type (Resources_Available : Integer :=1) is
-
- entry Request_Login (Resource_Key : in out Login_Record_Type);
- procedure Release_Login;
- function Available return Integer; -- how many logins are available?
- private
- Logins_Avail : Integer := Resources_Available;
- Next_Key : Key_Type := Init_Key;
-
- end Login_Semaphore_Type;
-
- Login_Semaphore : Login_Semaphore_Type (Max_Logins);
-
- --====== machinery for the test, not the model =====--
- TC_Control_Message : F940A00.Interlock_Type;
- function TC_Key_Val (Login_Rec : Login_Record_Type) return Integer;
-
-
-end C940A03_1;
- -- Semaphores;
-
---=========================================================--
-
-package body C940A03_1 is
- -- Semaphores is
-
- protected body Login_Semaphore_Type is
-
- entry Request_Login (Resource_Key : in out Login_Record_Type)
- when Logins_Avail > 0 is
- begin
- Next_Key := Next_Key + 1; -- login process returns a key
- Resource_Key.Key := Next_Key; -- to the requesting user
- Logins_Avail := Logins_Avail - 1;
- end Request_Login;
-
- procedure Release_Login is
- begin
- Logins_Avail := Logins_Avail + 1;
- end Release_Login;
-
- function Available return Integer is
- begin
- return Logins_Avail;
- end Available;
-
- end Login_Semaphore_Type;
-
- function TC_Key_Val (Login_Rec : Login_Record_Type) return Integer is
- begin
- return Integer (Login_Rec.Key);
- end TC_Key_Val;
-
-end C940A03_1;
- -- Semaphores;
-
---=========================================================--
-
-with C940A03_0; -- Resource_Pkg,
-with C940A03_1; -- Semaphores;
-
-package C940A03_2 is
- -- Task_Pkg
-
- package Semaphores renames C940A03_1;
-
- task type User_Task_Type is
-
- entry Login (user_id : C940A03_0.Resource_Id_Type);
- -- instructs the task to ask for a login
- entry Logout; -- instructs the task to release the login
- --=======================--
- -- this entry is used to get information to verify test operation
- entry Get_Status (User_Record : out Semaphores.Login_Record_Type);
-
- end User_Task_Type;
-
-end C940A03_2;
- -- Task_Pkg
-
---=========================================================--
-
-with Report;
-with C940A03_0; -- Resource_Pkg,
-with C940A03_1; -- Semaphores,
-with F940A00; -- Interlock_Foundation;
-
-package body C940A03_2 is
- -- Task_Pkg
-
- -- This task models a user requesting a login from the system
- -- For control of this test, we can ask the task to login, logout, or
- -- give us the current user record (containing login information)
-
- task body User_Task_Type is
- Rec : Semaphores.Login_Record_Type;
- begin
- loop
- select
- accept Login (user_id : C940A03_0.Resource_Id_Type) do
- Rec.Id := user_id;
- end Login;
-
- Semaphores.Login_Semaphore.Request_Login (Rec);
- -- request a resource; if resource is not available,
- -- task will be queued to wait
-
- --== following is test control machinery ==--
- F940A00.Counter.Increment;
- Semaphores.TC_Control_Message.Post;
- -- after resource is obtained, post message
-
- or
- accept Logout do
- Semaphores.Login_Semaphore.Release_Login;
- -- release the resource
- --== test control machinery ==--
- F940A00.Counter.Decrement;
- end Logout;
- exit;
-
- or
- accept Get_Status (User_Record : out Semaphores.Login_Record_Type) do
- User_Record := Rec;
- end Get_Status;
-
- end select;
- end loop;
-
- exception
- when others => Report.Failed ("Exception raised in model user task");
- end User_Task_Type;
-
-end C940A03_2;
- -- Task_Pkg
-
---=========================================================--
-
-with Report;
-with ImpDef;
-with C940A03_1; -- Semaphores,
-with C940A03_2; -- Task_Pkg,
-with F940A00; -- Interlock_Foundation;
-
-procedure C940A03 is
-
- package Semaphores renames C940A03_1;
- package Users renames C940A03_2;
-
- Task1, Task2, Task3 : Users.User_Task_Type;
- User_Rec : Semaphores.Login_Record_Type;
-
-begin -- Tasks start here
-
- Report.Test ("C940A03", "Check that a protected object can coordinate " &
- "shared data access using procedure parameters");
-
- if F940A00.Counter.Number /=0 then
- Report.Failed ("Wrong initial conditions");
- end if;
-
- Task1.Login (1); -- request resource; request should be granted
- Semaphores.TC_Control_Message.Consume;
- -- ensure that task obtains resource by
- -- waiting for task to post message
-
- -- Task 1 waiting for call to Logout
- -- Others still available
- Task1.Get_Status (User_Rec);
- if (F940A00.Counter.Number /= 1)
- or (Semaphores.Login_Semaphore.Available /=1)
- or (Semaphores.TC_Key_Val (User_Rec) /= 1) then
- Report.Failed ("Resource not assigned to task 1");
- end if;
-
- Task2.Login (2); -- Request for resource should be granted
- Semaphores.TC_Control_Message.Consume;
- -- ensure that task obtains resource by
- -- waiting for task to post message
-
- Task2.Get_Status (User_Rec);
- if (F940A00.Counter.Number /= 2)
- or (Semaphores.Login_Semaphore.Available /=0)
- or (Semaphores.TC_Key_Val (User_Rec) /= 2) then
- Report.Failed ("Resource not assigned to task 2");
- end if;
-
-
- Task3.Login (3); -- request for resource should be denied
- -- and task queued
-
-
- -- Tasks 1 and 2 holds resources
- -- and are waiting for a call to Logout
- -- Task 3 is queued
-
- if (F940A00.Counter.Number /= 2)
- or (Semaphores.Login_Semaphore.Available /=0) then
- Report.Failed ("Resource incorrectly assigned to task 3");
- end if;
-
- Task1.Logout; -- released resource should be given to
- -- queued task
- Semaphores.TC_Control_Message.Consume;
- -- wait for confirming message from task
-
- -- Task 1 holds no resources
- -- and is terminated (or will soon)
- -- Tasks 2 and 3 hold resources
- -- and are waiting for a call to Logout
-
- Task3.Get_Status (User_Rec);
- if (F940A00.Counter.Number /= 2)
- or (Semaphores.Login_Semaphore.Available /=0)
- or (Semaphores.TC_Key_Val (User_Rec) /= 3) then
- Report.Failed ("Resource not properly released/assigned to task 3");
- end if;
-
- Task2.Logout; -- no outstanding request for released
- -- resource
- -- Tasks 1 and 2 hold no resources
- -- Task 3 holds a resource
- -- and is waiting for a call to Logout
-
- if (F940A00.Counter.Number /= 1)
- or (Semaphores.Login_Semaphore.Available /=1) then
- Report.Failed ("Resource not properly released from task 2");
- end if;
-
- Task3.Logout;
-
- -- all resources have been returned
- -- all tasks have terminated or will soon
-
- if (F940A00.Counter.Number /=0)
- or (Semaphores.Login_Semaphore.Available /=2) then
- Report.Failed ("Resource not properly released from task 3");
- end if;
-
- -- Ensure all tasks have terminated before calling Result
- while not (Task1'terminated and
- Task2'terminated and
- Task3'terminated) loop
- delay ImpDef.Minimum_Task_Switch;
- end loop;
-
- Report.Result;
-
-end C940A03;
diff --git a/gcc/testsuite/ada/acats/tests/c9/c951001.a b/gcc/testsuite/ada/acats/tests/c9/c951001.a
deleted file mode 100644
index c1cf96593b2..00000000000
--- a/gcc/testsuite/ada/acats/tests/c9/c951001.a
+++ /dev/null
@@ -1,192 +0,0 @@
--- C951001.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that two procedures in a protected object will not be
--- executed concurrently.
---
--- TEST DESCRIPTION:
--- A very simple example of two tasks calling two procedures in the same
--- protected object is used. Test control code has been added to the
--- procedures such that, whichever gets called first executes a lengthy
--- calculation giving sufficient time (on a multiprocessor or a
--- time-slicing machine) for the other task to get control and call the
--- other procedure. The control code verifies that entry to the second
--- routine is postponed until the first is complete.
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
---
---!
-
-with Report;
-with ImpDef;
-
-procedure C951001 is
-
- protected Ramp_31 is
-
- procedure Add_Meter_Queue;
- procedure Subtract_Meter_Queue;
- function TC_Failed return Boolean;
-
- private
-
- Ramp_Count : integer range 0..20 := 4; -- Start test with some
- -- vehicles on the ramp
-
- TC_Add_Started : Boolean := false;
- TC_Subtract_Started : Boolean := false;
- TC_Add_Finished : Boolean := false;
- TC_Subtract_Finished : Boolean := false;
- TC_Concurrent_Running: Boolean := false;
-
- end Ramp_31;
-
-
- protected body Ramp_31 is
-
- function TC_Failed return Boolean is
- begin
- -- this indicator will have been set true if any instance
- -- of concurrent running has been proved
- return TC_Concurrent_Running;
- end TC_Failed;
-
-
- procedure Add_Meter_Queue is
- begin
- --==================================================
- -- This section is all Test_Control code
- TC_Add_Started := true;
- if TC_Subtract_Started then
- if not TC_Subtract_Finished then
- TC_Concurrent_Running := true;
- end if;
- else
- -- Subtract has not started.
- -- Execute a lengthy routine to give it a chance to do so
- ImpDef.Exceed_Time_Slice;
-
- if TC_Subtract_Started then
- -- Subtract was able to start so we have concurrent
- -- running and the test has failed
- TC_Concurrent_Running := true;
- end if;
- end if;
- TC_Add_Finished := true;
- --==================================================
- Ramp_Count := Ramp_Count + 1;
- end Add_Meter_Queue;
-
- procedure Subtract_Meter_Queue is
- begin
- --==================================================
- -- This section is all Test_Control code
- TC_Subtract_Started := true;
- if TC_Add_Started then
- if not TC_Add_Finished then
- -- We already have concurrent running
- TC_Concurrent_Running := true;
- end if;
- else
- -- Add has not started.
- -- Execute a lengthy routine to give it a chance to do so
- ImpDef.Exceed_Time_Slice;
-
- if TC_Add_Started then
- -- Add was able to start so we have concurrent
- -- running and the test has failed
- TC_Concurrent_Running := true;
- end if;
- end if;
- TC_Subtract_Finished := true;
- --==================================================
- Ramp_Count := Ramp_Count - 1;
- end Subtract_Meter_Queue;
-
- end Ramp_31;
-
-begin
-
- Report.Test ("C951001", "Check that two procedures in a protected" &
- " object will not be executed concurrently");
-
- declare -- encapsulate the test
-
- task Vehicle_1;
- task Vehicle_2;
-
-
- -- Vehicle_1 and Vehicle_2 are simulations of Instances of the task
- -- of type Vehicle in different stages of execution
-
- task body Vehicle_1 is
- begin
- null; -- ::::: stub. preparation code
-
- -- Add to the count of vehicles on the queue
- Ramp_31.Add_Meter_Queue;
-
- null; -- ::::: stub: wait at the meter then pass to first sensor
-
- -- Reduce the count of vehicles on the queue
- null; -- ::::: stub: Ramp_31.Subtract_Meter_Queue
- exception
- when others =>
- Report.Failed ("Unexpected Exception in Vehicle_1 task");
- end Vehicle_1;
-
-
- task body Vehicle_2 is
- begin
- null; -- ::::: stub. preparation code
-
- -- Add to the count of vehicles on the queue
- null; -- ::::: stub Ramp_31.Add_Meter_Queue;
-
- null; -- ::::: stub: wait at the meter then pass to first sensor
-
- -- Reduce the count of vehicles on the queue
- Ramp_31.Subtract_Meter_Queue;
- exception
- when others =>
- Report.Failed ("Unexpected Exception in Vehicle_2 task");
- end Vehicle_2;
-
-
-
- begin
- null;
- end; -- encapsulation
-
- if Ramp_31.TC_Failed then
- Report.Failed ("Concurrent Running detected");
- end if;
-
- Report.Result;
-
-end C951001;
diff --git a/gcc/testsuite/ada/acats/tests/c9/c951002.a b/gcc/testsuite/ada/acats/tests/c9/c951002.a
deleted file mode 100644
index 8ccb2d012fe..00000000000
--- a/gcc/testsuite/ada/acats/tests/c9/c951002.a
+++ /dev/null
@@ -1,334 +0,0 @@
--- C951002.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that an entry and a procedure within the same protected object
--- will not be executed simultaneously.
---
--- TEST DESCRIPTION:
--- Two tasks are used. The first calls an entry who's barrier is set
--- and is thus queued. The second calls a procedure in the same
--- protected object. This procedure clears the entry barrier of the
--- first then executes a lengthy compute bound procedure. This is
--- intended to allow a multiprocessor, or a time-slicing implementation
--- of a uniprocessor, to (erroneously) permit the first task to continue
--- while the second is still computing. Flags in each process in the
--- PO are checked to ensure that they do not run out of sequence or in
--- parallel.
--- In the second part of the test another entry and procedure are used
--- but in this case the procedure is started first. A different task
--- calls the entry AFTER the procedure has started. If the entry
--- completes before the procedure the test fails.
---
--- This test will not be effective on a uniprocessor without time-slicing
--- It is designed to increase the chances of failure on a multiprocessor,
--- or a uniprocessor with time-slicing, if the entry and procedure in a
--- Protected Object are not forced to acquire a single execution
--- resource. It is not guaranteed to fail.
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
---
---!
-
-with Report;
-with ImpDef;
-
-procedure C951002 is
-
- -- These global error flags are used for failure conditions within
- -- the protected object. We cannot call Report.Failed (thus Text_io)
- -- which would result in a bounded error.
- --
- TC_Error_01 : Boolean := false;
- TC_Error_02 : Boolean := false;
- TC_Error_03 : Boolean := false;
- TC_Error_04 : Boolean := false;
- TC_Error_05 : Boolean := false;
- TC_Error_06 : Boolean := false;
-
-begin
-
- Report.Test ("C951002", "Check that a procedure and an entry body " &
- "in a protected object will not run concurrently");
-
- declare -- encapsulate the test
-
- task Credit_Message is
- entry TC_Start;
- end Credit_Message;
-
- task Credit_Task is
- entry TC_Start;
- end Credit_Task;
-
- task Debit_Message is
- entry TC_Start;
- end Debit_Message;
-
- task Debit_Task is
- entry TC_Start;
- end Debit_Task;
-
- --====================================
-
- protected Hold is
-
- entry Wait_for_CR_Underload;
- procedure Clear_CR_Overload;
- entry Wait_for_DB_Underload;
- procedure Set_DB_Overload;
- procedure Clear_DB_Overload;
- --
- function TC_Message_is_Queued return Boolean;
-
- private
- Credit_Overloaded : Boolean := true; -- Test starts in overload
- Debit_Overloaded : Boolean := false;
- --
- TC_CR_Proc_Finished : Boolean := false;
- TC_CR_Entry_Finished : Boolean := false;
- TC_DB_Proc_Finished : Boolean := false;
- TC_DB_Entry_Finished : Boolean := false;
- end Hold;
- --====================
- protected body Hold is
-
- entry Wait_for_CR_Underload when not Credit_Overloaded is
- begin
- -- The barrier must only be re-evaluated at the end of the
- -- of the execution of the procedure, also while the procedure
- -- is executing this entry body must not be executed
- if not TC_CR_Proc_Finished then
- TC_Error_01 := true; -- Set error indicator
- end if;
- TC_CR_Entry_Finished := true;
- end Wait_for_CR_Underload ;
-
- -- This is the procedure which should NOT be able to run in
- -- parallel with the entry body
- --
- procedure Clear_CR_Overload is
- begin
-
- -- The entry body must not be executed until this procedure
- -- is completed.
- if TC_CR_Entry_Finished then
- TC_Error_02 := true; -- Set error indicator
- end if;
- Credit_Overloaded := false; -- clear the entry barrier
-
- -- Execute an implementation defined compute bound routine which
- -- is designed to run long enough to allow a task switch on a
- -- time-sliced uniprocessor, or for a multiprocessor to pick up
- -- another task.
- --
- ImpDef.Exceed_Time_Slice;
-
- -- Again, the entry body must not be executed until the current
- -- procedure is completed.
- --
- if TC_CR_Entry_Finished then
- TC_Error_03 := true; -- Set error indicator
- end if;
- TC_CR_Proc_Finished := true;
-
- end Clear_CR_Overload;
-
- --============
- -- The following subprogram and entry body are used in the second
- -- part of the test
-
- entry Wait_for_DB_Underload when not Debit_Overloaded is
- begin
- -- By the time the task that calls this entry is allowed access to
- -- the queue the barrier, which starts off as open, will be closed
- -- by the Set_DB_Overload procedure. It is only reopened
- -- at the end of the test
- if not TC_DB_Proc_Finished then
- TC_Error_04 := true; -- Set error indicator
- end if;
- TC_DB_Entry_Finished := true;
- end Wait_for_DB_Underload ;
-
-
- procedure Set_DB_Overload is
- begin
- -- The task timing is such that this procedure should be started
- -- before the entry is called. Thus the entry should be blocked
- -- until the end of this procedure which then sets the barrier
- --
- if TC_DB_Entry_Finished then
- TC_Error_05 := true; -- Set error indicator
- end if;
-
- -- Execute an implementation defined compute bound routine which
- -- is designed to run long enough to allow a task switch on a
- -- time-sliced uniprocessor, or for a multiprocessor to pick up
- -- another task
- --
- ImpDef.Exceed_Time_Slice;
-
- Debit_Overloaded := true; -- set the entry barrier
-
- if TC_DB_Entry_Finished then
- TC_Error_06 := true; -- Set error indicator
- end if;
- TC_DB_Proc_Finished := true;
-
- end Set_DB_Overload;
-
- procedure Clear_DB_Overload is
- begin
- Debit_Overloaded := false; -- open the entry barrier
- end Clear_DB_Overload;
-
- function TC_Message_is_Queued return Boolean is
- begin
-
- -- returns true when one message arrives on the queue
- return (Wait_for_CR_Underload'Count = 1);
-
- end TC_Message_is_Queued ;
-
- end Hold;
-
- --====================================
-
- task body Credit_Message is
- begin
- accept TC_Start;
- --:: some application processing. Part of the process finds that
- -- the Overload threshold has been exceeded for the Credit
- -- application. This message task queues itself on a queue
- -- waiting till the overload in no longer in effect
- Hold.Wait_for_CR_Underload;
- exception
- when others =>
- Report.Failed ("Unexpected Exception in Credit_Message Task");
- end Credit_Message;
-
- task body Credit_Task is
- begin
- accept TC_Start;
- -- Application code here (not shown) determines that the
- -- underload threshold has been reached
- Hold.Clear_CR_Overload;
- exception
- when others =>
- Report.Failed ("Unexpected Exception in Credit_Task");
- end Credit_Task;
-
- --==============
-
- -- The following two tasks are used in the second part of the test
-
- task body Debit_Message is
- begin
- accept TC_Start;
- --:: some application processing. Part of the process finds that
- -- the Overload threshold has been exceeded for the Debit
- -- application. This message task queues itself on a queue
- -- waiting till the overload is no longer in effect
- --
- Hold.Wait_for_DB_Underload;
- exception
- when others =>
- Report.Failed ("Unexpected Exception in Debit_Message Task");
- end Debit_Message;
-
- task body Debit_Task is
- begin
- accept TC_Start;
- -- Application code here (not shown) determines that the
- -- underload threshold has been reached
- Hold.Set_DB_Overload;
- exception
- when others =>
- Report.Failed ("Unexpected Exception in Debit_Task");
- end Debit_Task;
-
- begin -- declare
-
- Credit_Message.TC_Start;
-
- -- Wait until the message is queued on the entry before starting
- -- the Credit_Task
- while not Hold.TC_Message_is_Queued loop
- delay ImpDef.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.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.Switch_To_New_Task;
-
- Debit_Message.TC_Start;
-
- while not Debit_Task'terminated loop
- delay ImpDef.Minimum_Task_Switch;
- end loop;
-
- Hold.Clear_DB_Overload; -- Allow completion
-
- end; -- declare (encapsulation)
-
- if TC_Error_01 then
- Report.Failed ("Wait_for_CR_Underload executed out of sequence");
- end if;
- if TC_Error_02 then
- Report.Failed ("Credit: Entry executed before procedure");
- end if;
- if TC_Error_03 then
- Report.Failed ("Credit: Entry executed in parallel");
- end if;
- if TC_Error_04 then
- Report.Failed ("Wait_for_DB_Underload executed out of sequence");
- end if;
- if TC_Error_05 then
- Report.Failed ("Debit: Entry executed before procedure");
- end if;
- if TC_Error_06 then
- Report.Failed ("Debit: Entry executed in parallel");
- end if;
-
- Report.Result;
-
-end C951002;
diff --git a/gcc/testsuite/ada/acats/tests/c9/c953001.a b/gcc/testsuite/ada/acats/tests/c9/c953001.a
deleted file mode 100644
index bc9c85f302f..00000000000
--- a/gcc/testsuite/ada/acats/tests/c9/c953001.a
+++ /dev/null
@@ -1,188 +0,0 @@
--- C953001.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that if the evaluation of an entry_barrier condition
--- propagates an exception, the exception Program_Error
--- is propagated to all current callers of all entries of the
--- protected object.
---
--- TEST DESCRIPTION:
--- This test declares a protected object (PO) with two entries and
--- a 5 element entry family.
--- All the entries are always closed. However, one of the entries
--- (Oh_No) will get a constraint_error in its barrier_evaluation
--- whenever the global variable Blow_Up is true.
--- An array of tasks is created where the tasks wait on the various
--- entries of the protected object. Once all the tasks are waiting
--- the main procedure calls the entry Oh_No and causes an exception
--- to be propagated to all the tasks. The tasks record the fact
--- that they got the correct exception in global variables that
--- can be checked after the tasks complete.
---
---
--- CHANGE HISTORY:
--- 19 OCT 95 SAIC ACVC 2.1
---
---!
-
-
-with Report;
-with ImpDef;
-procedure C953001 is
- Verbose : constant Boolean := False;
- Max_Tasks : constant := 12;
-
- -- note status and error conditions
- Blocked_Entry_Taken : Boolean := False;
- In_Oh_No : Boolean := False;
- Task_Passed : array (1..Max_Tasks) of Boolean := (1..Max_Tasks => False);
-
-begin
- Report.Test ("C953001",
- "Check that an exception in an entry_barrier condition" &
- " causes Program_Error to be propagated to all current" &
- " callers of all entries of the protected object");
-
- declare -- test encapsulation
- -- miscellaneous values
- Cows : Integer := Report.Ident_Int (1);
- Came_Home : Integer := Report.Ident_Int (2);
-
- -- make the Barrier_Condition fail only when we want it to
- Blow_Up : Boolean := False;
-
- function Barrier_Condition return Boolean is
- begin
- if Blow_Up then
- return 5 mod Report.Ident_Int(0) = 1;
- else
- return False;
- end if;
- end Barrier_Condition;
-
- subtype Family_Index is Integer range 1..5;
-
- protected PO is
- entry Block1;
- entry Oh_No;
- entry Family (Family_Index);
- end PO;
-
- protected body PO is
- entry Block1 when Report.Ident_Int(0) = Report.Ident_Int(1) is
- begin
- Blocked_Entry_Taken := True;
- end Block1;
-
- -- barrier will get a Constraint_Error (divide by 0)
- entry Oh_No when Barrier_Condition is
- begin
- In_Oh_No := True;
- end Oh_No;
-
- entry Family (for Member in Family_Index) when Cows = Came_Home is
- begin
- Blocked_Entry_Taken := True;
- end Family;
- end PO;
-
-
- task type Waiter is
- entry Take_Id (Id : Integer);
- end Waiter;
-
- Bunch_of_Waiters : array (1..Max_Tasks) of Waiter;
-
- task body Waiter is
- Me : Integer;
- Action : Integer;
- begin
- accept Take_Id (Id : Integer) do
- Me := Id;
- end Take_Id;
-
- Action := Me mod (Family_Index'Last + 1);
- begin
- if Action = 0 then
- PO.Block1;
- else
- PO.Family (Action);
- end if;
- Report.Failed ("no exception for task" & Integer'Image (Me));
- exception
- when Program_Error =>
- Task_Passed (Me) := True;
- if Verbose then
- Report.Comment ("pass for task" & Integer'Image (Me));
- end if;
- when others =>
- Report.Failed ("wrong exception raised in task" &
- Integer'Image (Me));
- end;
- end Waiter;
-
-
- begin -- test encapsulation
- for I in 1..Max_Tasks loop
- Bunch_Of_Waiters(I).Take_Id (I);
- end loop;
-
- -- give all the Waiters time to get queued
- delay 2*ImpDef.Clear_Ready_Queue;
-
- -- cause the protected object to fail
- begin
- Blow_Up := True;
- PO.Oh_No;
- Report.Failed ("no exception in call to PO.Oh_No");
- exception
- when Constraint_Error =>
- Report.Failed ("Constraint_Error instead of Program_Error");
- when Program_Error =>
- if Verbose then
- Report.Comment ("main exception passed");
- end if;
- when others =>
- Report.Failed ("wrong exception in main");
- end;
- end; -- test encapsulation
-
- -- all the tasks have now completed.
- -- check the flags for pass/fail info
- if Blocked_Entry_Taken then
- Report.Failed ("blocked entry taken");
- end if;
- if In_Oh_No then
- Report.Failed ("entry taken with exception in barrier");
- end if;
- for I in 1..Max_Tasks loop
- if not Task_Passed (I) then
- Report.Failed ("task" & Integer'Image (I) & " did not pass");
- end if;
- end loop;
-
- Report.Result;
-end C953001;
diff --git a/gcc/testsuite/ada/acats/tests/c9/c953002.a b/gcc/testsuite/ada/acats/tests/c9/c953002.a
deleted file mode 100644
index d821bb24e4e..00000000000
--- a/gcc/testsuite/ada/acats/tests/c9/c953002.a
+++ /dev/null
@@ -1,242 +0,0 @@
--- C953002.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that the servicing of entry queues of a protected object
--- continues until there are no open entries with queued calls
--- and that this takes place as part of a single protected
--- operation.
---
--- TEST DESCRIPTION:
--- This test enqueues a bunch of tasks on the entries of the
--- protected object Main_PO. At the same time another bunch of
--- of tasks are queued on the single entry of protected object
--- Holding_Pen.
--- Once all the tasks have had time to block, the main procedure
--- opens all the entries for Main_PO by calling the
--- Start_Protected_Operation protected procedure. This should
--- process all the pending callers as part of a single protected
--- operation.
--- During this protected operation, the entries of Main_PO release
--- the tasks blocked on Holding_Pen by calling the protected
--- procedure Release.
--- Once released from Holding_Pen, the task immediately calls
--- an entry in Main_PO.
--- These new calls should not gain access to Main_PO until
--- the initial protected operation on that object completes.
--- The order in which the entry calls on Main_PO are taken is
--- recorded in a global array and checked after all the tasks
--- have terminated.
---
---
--- CHANGE HISTORY:
--- 25 OCT 95 SAIC ACVC 2.1
--- 15 JAN 95 SAIC Fixed deadlock problem.
---
---!
-
-with Report;
-procedure C953002 is
- Verbose : constant Boolean := False;
-
- Half_Tasks : constant := 15; -- how many tasks of each group
- Max_Tasks : constant := Half_Tasks * 2; -- total number of tasks
-
- Note_Order : array (1..Max_Tasks) of Integer := (1..Max_Tasks => 0);
- Note_Cnt : Integer := 0;
-begin
- Report.Test ("C953002",
- "Check that the servicing of entry queues handles all" &
- " open entries as part of a single protected operation");
- declare
- task type Assault_PO is
- entry Take_ID (Id : Integer);
- end Assault_PO;
-
- First_Wave : array (1 .. Half_Tasks) of Assault_PO;
- Second_Wave : array (1 .. Half_Tasks) of Assault_PO;
-
- protected Main_PO is
- entry E0 (Who : Integer);
- entry E1 (Who : Integer);
- entry E2 (Who : Integer);
- entry E3 (Who : Integer);
- entry All_Present;
- procedure Start_Protected_Operation;
- private
- Open : Boolean := False;
- end Main_PO;
-
- protected Holding_Pen is
- -- Note that Release is called by tasks executing in
- -- the protected object Main_PO.
- entry Wait (Who : Integer);
- entry All_Present;
- procedure Release;
- private
- Open : Boolean := False;
- end Holding_Pen;
-
-
- protected body Main_PO is
- procedure Start_Protected_Operation is
- begin
- Open := True;
- -- at this point all the First_Wave tasks are
- -- waiting at the entries and all of them should
- -- be processed as part of the protected operation.
- end Start_Protected_Operation;
-
- entry All_Present when E0'Count + E1'Count + E2'Count + E3'Count =
- Max_Tasks / 2 is
- begin
- null; -- all tasks are waiting
- end All_Present;
-
- entry E0 (Who : Integer) when Open is
- begin
- Holding_Pen.Release;
- -- note the order in which entry calls are handled.
- Note_Cnt := Note_Cnt + 1;
- Note_Order (Note_Cnt) := Who;
- end E0;
-
- entry E1 (Who : Integer) when Open is
- begin
- Holding_Pen.Release;
- Note_Cnt := Note_Cnt + 1;
- Note_Order (Note_Cnt) := Who;
- end E1;
-
- entry E2 (Who : Integer) when Open is
- begin
- Holding_Pen.Release;
- Note_Cnt := Note_Cnt + 1;
- Note_Order (Note_Cnt) := Who;
- end E2;
-
- entry E3 (Who : Integer) when Open is
- begin
- Holding_Pen.Release;
- Note_Cnt := Note_Cnt + 1;
- Note_Order (Note_Cnt) := Who;
- end E3;
- end Main_PO;
-
-
- protected body Holding_Pen is
- procedure Release is
- begin
- Open := True;
- end Release;
-
- entry All_Present when Wait'Count = Max_Tasks / 2 is
- begin
- null; -- all tasks waiting
- end All_Present;
-
- entry Wait (Who : Integer) when Open is
- begin
- null; -- unblock the task
- end Wait;
- end Holding_Pen;
-
- task body Assault_PO is
- Me : Integer;
- begin
- accept Take_Id (Id : Integer) do
- Me := Id;
- end Take_Id;
- if Me >= 200 then
- Holding_Pen.Wait (Me);
- end if;
- case Me mod 4 is
- when 0 => Main_PO.E0 (Me);
- when 1 => Main_PO.E1 (Me);
- when 2 => Main_PO.E2 (Me);
- when 3 => Main_PO.E3 (Me);
- when others => null; -- cant happen
- end case;
- if Verbose then
- Report.Comment ("task" & Integer'Image (Me) &
- " done");
- end if;
- exception
- when others =>
- Report.Failed ("exception in task");
- end Assault_PO;
-
- begin -- test encapsulation
- for I in First_Wave'Range loop
- First_Wave (I).Take_ID (100 + I);
- end loop;
- for I in Second_Wave'Range loop
- Second_Wave (I).Take_ID (200 + I);
- end loop;
-
- -- let all the tasks get blocked
- Main_PO.All_Present;
- Holding_Pen.All_Present;
-
- -- let the games begin
- if Verbose then
- Report.Comment ("starting protected operation");
- end if;
- Main_PO.Start_Protected_Operation;
-
- -- wait for all the tasks to complete
- if Verbose then
- Report.Comment ("waiting for tasks to complete");
- end if;
- end;
-
- -- make sure all tasks registered their order
- if Note_Cnt /= Max_Tasks then
- Report.Failed ("task registration count wrong. " &
- Integer'Image (Note_Cnt));
- end if;
-
- -- check the order in which entries were handled.
- -- all the 100 level items should be handled as part of the
- -- first protected operation and thus should be completed
- -- before any 200 level item.
-
- if Verbose then
- for I in 1..Max_Tasks loop
- Report.Comment ("order" & Integer'Image (I) & " is" &
- Integer'Image (Note_Order (I)));
- end loop;
- end if;
- for I in 2 .. Max_Tasks loop
- if Note_Order (I) < 200 and
- Note_Order (I-1) >= 200 then
- Report.Failed ("protected operation failure" &
- Integer'Image (Note_Order (I-1)) &
- Integer'Image (Note_Order (I)));
- end if;
- end loop;
-
- Report.Result;
-end C953002;
diff --git a/gcc/testsuite/ada/acats/tests/c9/c953003.a b/gcc/testsuite/ada/acats/tests/c9/c953003.a
deleted file mode 100644
index 4ac91169e21..00000000000
--- a/gcc/testsuite/ada/acats/tests/c9/c953003.a
+++ /dev/null
@@ -1,189 +0,0 @@
--- C953003.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that the servicing of entry queues of a protected object
--- continues until there are no open entries with queued (or
--- requeued) calls and that internal requeues are handled
--- as part of a single protected operation.
---
--- TEST DESCRIPTION:
--- A number of tasks are created and blocked on a protected object
--- so that they can all be released at one time. When released,
--- these tasks make an entry call to an entry in the Main_PO
--- protected object. As part of the servicing of this entry
--- call the call is passed through the remaining entries of the
--- protected object by using internal requeues. The protected
--- object checks that no other entry call is accepted until
--- after all the internal requeuing has completed.
---
---
--- CHANGE HISTORY:
--- 12 JAN 96 SAIC Initial version for 2.1
---
---!
-
-with Report;
-procedure C953003 is
- Verbose : constant Boolean := False;
-
- Order_Error : Boolean := False;
-
- Max_Tasks : constant := 10; -- total number of tasks
- Max_Entries : constant := 4; -- number of entries in Main_PO
- Note_Cnt : Integer := 0;
- Note_Order : array (1..Max_Tasks*Max_Entries) of Integer;
-begin
- Report.Test ("C953003",
- "Check that the servicing of entry queues handles all" &
- " open entries as part of a single protected operation," &
- " including those resulting from an internal requeue");
- declare
- task type Assault_PO is
- entry Take_ID (Id : Integer);
- end Assault_PO;
-
- Marines : array (1 .. Max_Tasks) of Assault_PO;
-
- protected Main_PO is
- entry E0 (Who : Integer);
- private
- entry E3 (Who : Integer);
- entry E2 (Who : Integer);
- entry E1 (Who : Integer);
- Expected_Next : Integer := 0;
- end Main_PO;
-
-
- protected body Main_PO is
-
- entry E0 (Who : Integer) when True is
- begin
- Order_Error := Order_Error or Expected_Next /= 0;
- Expected_Next := 1;
- Note_Cnt := Note_Cnt + 1;
- Note_Order (Note_Cnt) := Who;
- requeue E1;
- end E0;
-
- entry E1 (Who : Integer) when True is
- begin
- Order_Error := Order_Error or Expected_Next /= 1;
- Expected_Next := 2;
- Note_Cnt := Note_Cnt + 1;
- Note_Order (Note_Cnt) := Who;
- requeue E2;
- end E1;
-
- entry E3 (Who : Integer) when True is
- begin
- Order_Error := Order_Error or Expected_Next /= 3;
- Expected_Next := 0;
- Note_Cnt := Note_Cnt + 1;
- Note_Order (Note_Cnt) := Who;
- -- all done - return now
- end E3;
-
- entry E2 (Who : Integer) when True is
- begin
- Order_Error := Order_Error or Expected_Next /= 2;
- Expected_Next := 3;
- Note_Cnt := Note_Cnt + 1;
- Note_Order (Note_Cnt) := Who;
- requeue E3;
- end E2;
- end Main_PO;
-
- protected Holding_Pen is
- entry Wait_For_All_Present;
- entry Wait;
- private
- Open : Boolean := False;
- end Holding_Pen;
-
- protected body Holding_Pen is
- entry Wait_For_All_Present when Wait'Count = Max_Tasks is
- begin
- Open := True;
- end Wait_For_All_Present;
-
- entry Wait when Open is
- begin
- null; -- just go
- end Wait;
- end Holding_Pen;
-
-
- task body Assault_PO is
- Me : Integer;
- begin
- accept Take_Id (Id : Integer) do
- Me := Id;
- end Take_Id;
- Holding_Pen.Wait;
- Main_PO.E0 (Me);
- if Verbose then
- Report.Comment ("task" & Integer'Image (Me) &
- " done");
- end if;
- exception
- when others =>
- Report.Failed ("exception in task");
- end Assault_PO;
-
- begin -- test encapsulation
- for I in Marines'Range loop
- Marines (I).Take_ID (100 + I);
- end loop;
-
- -- let all the tasks get blocked so we can release them all
- -- at one time
- Holding_Pen.Wait_For_All_Present;
-
- -- wait for all the tasks to complete
- if Verbose then
- Report.Comment ("waiting for tasks to complete");
- end if;
- end;
-
- -- make sure all tasks registered their order
- if Note_Cnt /= Max_Tasks * Max_Entries then
- Report.Failed ("task registration count wrong. " &
- Integer'Image (Note_Cnt));
- end if;
-
- if Order_Error then
- Report.Failed ("internal requeue not handled as part of operation");
- end if;
-
- if Verbose or Order_Error then
- for I in 1..Max_Tasks * Max_Entries loop
- Report.Comment ("order" & Integer'Image (I) & " is" &
- Integer'Image (Note_Order (I)));
- end loop;
- end if;
-
- Report.Result;
-end C953003;
diff --git a/gcc/testsuite/ada/acats/tests/c9/c954001.a b/gcc/testsuite/ada/acats/tests/c9/c954001.a
deleted file mode 100644
index 3112cce2b5c..00000000000
--- a/gcc/testsuite/ada/acats/tests/c9/c954001.a
+++ /dev/null
@@ -1,273 +0,0 @@
--- C954001.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that a requeue statement within an entry_body with parameters
--- may requeue the entry call to a protected entry with a subtype-
--- conformant parameter profile. Check that, if the call is queued on the
--- new entry's queue, the original caller remains blocked after the
--- requeue, but the entry_body containing the requeue is completed.
---
--- TEST DESCRIPTION:
--- Declare a protected object which simulates a disk device. Declare an
--- entry that requeues the caller to a second entry if the disk head is
--- not in the proper location, but first sets the second entry's barrier
--- to false. Declare a procedure which sets the second entry's barrier
--- to true.
---
--- Declare a task which calls the first entry such that the requeue is
--- called. This task should be queued on the second entry and remain
--- blocked, and the first entry should be complete. Call the procedure
--- which releases the second entry's queue. The second entry should
--- complete, after which the task should complete.
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
---
---!
-
-package C954001_0 is -- Disk management abstraction.
-
-
- -- Simulate a read-only disk device with a head that may be moved to
- -- different tracks. If a read request is issued for the current
- -- track, the request can be satisfied immediately. Otherwise, the head
- -- must be moved to the correct track, during which time the calling task
- -- is blocked. When the head reaches the correct track, the disk generates
- -- an interrupt, after which the request can be satisfied, and the
- -- calling task can proceed.
-
- Buffer_Size : constant := 100;
-
- type Disk_Buffer is new String (1 .. Buffer_Size);
- type Disk_Track is new Natural;
-
- type Disk_Address is record
- Track : Disk_Track;
- -- Additional components.
- end record;
-
- Initial_Track : constant Disk_Track := 0;
- New_Track : constant Disk_Track := 5;
-
- --==============================================--
-
- protected Disk_Device is
-
- entry Read (Where : Disk_Address; -- Read data from disk
- Data : out Disk_Buffer); -- track.
-
- procedure Disk_Interrupt; -- Handle interrupt
- -- from disk.
-
- function TC_Track return Disk_Track; -- Return current track.
-
- function TC_Pending_Queued return Boolean; -- True when there is
- -- an entry in queue
-
- private
-
- entry Pending_Read (Where : Disk_Address; -- Wait for head to
- Data : out Disk_Buffer); -- move then read data.
-
- Current_Track : Disk_Track := Initial_Track; -- Current disk track.
- Operation_Pending : Boolean := False; -- Vis. entry barrier.
- Disk_Interrupted : Boolean := False; -- Priv. entry barrier.
-
- end Disk_Device;
-
-
-end C954001_0;
-
-
- --==================================================================--
-
-
-package body C954001_0 is -- Disk management abstraction.
-
-
- protected body Disk_Device is
-
- entry Read (Where : Disk_Address; Data : out Disk_Buffer)
- when not Operation_Pending is
- begin
- if (Where.Track = Current_Track) then -- If the head is over the
- -- Read data from disk... -- requested track, read
- null; -- the data.
-
- else -- Otherwise, defer read
- Operation_Pending := True; -- while head is moved to
- -- correct track (signaled
- -- -- -- by a disk interrupt).
- -- Requeue is tested here --
- -- --
-
- requeue Pending_Read;
-
- end if;
- end Read;
-
-
- procedure Disk_Interrupt is -- Called when the disk
- begin -- interrupts, indicating
- Disk_Interrupted := True; -- that the head is over
- end Disk_Interrupt; -- the correct track.
-
-
- function TC_Track return Disk_Track is -- Artifice required for
- begin -- testing purposes.
- return (Current_Track);
- end TC_Track;
-
-
- entry Pending_Read (Where : Disk_Address; Data : out Disk_Buffer)
- when Disk_Interrupted is
- begin
- Current_Track := Where.Track; -- Head is now over the
- -- Read data from disk... -- correct track; read
- Operation_Pending := False; -- the data.
- Disk_Interrupted := False;
- end Pending_Read;
-
- function TC_Pending_Queued return Boolean is
- begin
- -- Return true when there is something on the Pending_Read queue
- return (Pending_Read'Count /=0);
- end TC_Pending_Queued;
-
- end Disk_Device;
-
-
-end C954001_0;
-
-
- --==================================================================--
-
-
-with Report;
-with ImpDef;
-
-with C954001_0; -- Disk management abstraction.
-use C954001_0;
-
-procedure C954001 is
-
-
- task type Read_Task is -- an unusual (but legal) declaration
- end Read_Task;
- --
- --
- task body Read_Task is
- Location : constant Disk_Address := (Track => New_Track);
- Data : Disk_Buffer := (others => ' ');
- begin
- Disk_Device.Read (Location, Data); -- Invoke requeue statement.
- exception
- when others =>
- Report.Failed ("Exception raised in task");
- end Read_Task;
-
- --==============================================--
-
-begin -- Main program.
-
- Report.Test ("C954001", "Requeue from an entry within a P.O. " &
- "to a private entry within the same P.O.");
-
-
- declare
-
- IO_Request : Read_Task; -- Request a read from other
- -- than the current track.
- -- IO_Request will be requeued
- -- from Read to Pending_Read.
- begin
-
- -- To pass this test, the following must be true:
- --
- -- (A) The Read entry call made by the task IO_Request must be
- -- completed by the requeue.
- -- (B) IO_Request must remain blocked following the requeue.
- -- (C) IO_Request must be queued on the Pending_Read entry queue.
- -- (D) IO_Request must continue execution after the Pending_Read
- -- entry completes.
- --
- -- First, verify (A): that the Read entry call is complete.
- --
- -- Call a protected operation (Disk_Device.TC_Track). Since no two
- -- protected actions may proceed concurrently unless both are protected
- -- function calls, a call to a protected operation at this point can
- -- proceed only if the Read entry call is already complete.
- --
- -- Note that if Read is NOT complete, the test will likely hang here.
- --
- -- Next, verify (B): that IO_Request remains blocked following the
- -- requeue. Also verify that Pending_Read (the entry to which
- -- IO_Request should have been queued) has not yet executed.
-
- -- Wait until the task had made the call and the requeue has been
- -- effected.
- while not Disk_Device.TC_Pending_Queued loop
- delay ImpDef.Minimum_Task_Switch;
- end loop;
-
- if Disk_Device.TC_Track /= Initial_Track then
- Report.Failed ("Target entry of requeue executed prematurely");
- elsif IO_Request'Terminated then
- Report.Failed ("Caller did not remain blocked after " &
- "the requeue or was never requeued");
- else
-
- -- Verify (C): that IO_Request is queued on the
- -- Pending_Read entry queue.
- --
- -- Set the barrier for Pending_Read to true. Check that the
- -- current track is updated and that IO_Request terminates.
-
- Disk_Device.Disk_Interrupt; -- Simulate a disk interrupt,
- -- signaling that the head is
- -- over the correct track.
-
- -- The Pending_Read entry body will complete before the next
- -- protected action is called (Disk_Device.TC_Track).
-
- if Disk_Device.TC_Track /= New_Track then
- Report.Failed ("Caller was not requeued on target entry");
- end if;
-
- -- Finally, verify (D): that Read_Task continues after Pending_Read
- -- completes.
- --
- -- Note that the test will hang here if Read_Task does not continue
- -- executing following the completion of the requeued entry call.
-
- end if;
-
- end; -- We will not exit the declare block until the task completes
-
- Report.Result;
-
-end C954001;
diff --git a/gcc/testsuite/ada/acats/tests/c9/c954010.a b/gcc/testsuite/ada/acats/tests/c9/c954010.a
deleted file mode 100644
index ac39c89a838..00000000000
--- a/gcc/testsuite/ada/acats/tests/c9/c954010.a
+++ /dev/null
@@ -1,286 +0,0 @@
--- C954010.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that a requeue within an accept statement does not block.
--- This test uses: Requeue to an entry in a different task
--- Parameterless call
--- Requeue with abort
---
--- TEST DESCRIPTION:
--- In the Distributor task, requeue two successive calls on the entries
--- of two separate target tasks. Verify that the target tasks are
--- run in parallel proving that the first requeue does not block
--- while the first target rendezvous takes place.
---
--- This series of tests uses a simulation of a transaction driven
--- processing system. Line Drivers accept input from an external source
--- and build them into transaction records. These records are then
--- encapsulated in message tasks which remain extant for the life of the
--- transaction in the system. The message tasks put themselves on the
--- input queue of a Distributor which, from information in the
--- transaction and/or system load conditions forwards them to other
--- operating tasks. These in turn might forward the transactions to yet
--- other tasks for further action. The routing is, in real life,
--- dynamic and unpredictable at the time of message generation. All
--- rerouting in this model is done by means of requeues.
---
--- This test is directed towards the BLOCKING of the REQUEUE only
--- If the original caller does not block, the outcome of the test will
--- not be affected. If the original caller does not continue after
--- the return, the test will not pass.
--- If the requeue gets placed on the wrong entry a failing test could
--- pass (eg. if the first message is delivered to the second
--- computation task and the second message to the first) - a check for
--- this condition is made in other tests
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
---
---!
-
-with Report;
-with ImpDef;
-
-procedure C954010 is
-
- -- Mechanism to count the number of Message tasks completed
- protected TC_Tasks_Completed is
- procedure Increment;
- function Count return integer;
- private
- Number_Complete : integer := 0;
- end TC_Tasks_Completed;
- --
- TC_Expected_To_Complete : constant integer := 2;
-
-
- task type Message_Task;
- type acc_Message_Task is access Message_Task;
-
- task Line_Driver is
- entry Start;
- end Line_Driver;
-
- task Distributor is
- entry Input;
- end Distributor;
-
- task Credit_Computation is
- entry Input;
- end Credit_Computation;
-
- task Debit_Computation is
- entry Input;
- entry TC_Artificial_Rendezvous_1; -- test purposes only
- entry TC_Artificial_Rendezvous_2; -- test purposes only
- end Debit_Computation;
-
-
- -- Mechanism to count the number of Message tasks completed
- protected body TC_Tasks_Completed is
- procedure Increment is
- begin
- Number_Complete := Number_Complete + 1;
- end Increment;
-
- function Count return integer is
- begin
- return Number_Complete;
- end Count;
- end TC_Tasks_Completed;
-
-
-
- -- Assemble messages received from an external source
- -- Creates a message task for each and sends this to a Distributor
- -- for appropriate disposal around the network of tasks
- -- Such a task would normally be designed to loop continuously
- -- creating the messages as input is received. Simulate this
- -- but limit it to two dummy messages for this test and allow it
- -- to terminate at that point
- --
- task body Line_Driver is
-
- begin
-
- accept Start; -- Wait for trigger from main
-
- for i in 1..2 loop
- declare
- -- create a new message task
- N : acc_Message_Task := new Message_Task;
- begin
- -- preparation code
- null; -- stub
-
- end; -- declare
- end loop;
-
- exception
- when others =>
- Report.Failed ("Unexpected exception in Line_Driver");
- end Line_Driver;
-
-
- task body Message_Task is
- begin
- -- Queue up on Distributor's Input queue
- Distributor.Input;
-
- -- After the required computations have been performed
- -- return the message appropriately (probably to an output
- -- line driver
- null; -- stub
-
- -- Increment to show completion of this task
- TC_Tasks_Completed.Increment;
-
- exception
- when others =>
- Report.Failed ("Unexpected exception in Message_Task");
-
- end Message_Task;
-
-
- -- Dispose each input message to the appropriate computation tasks
- -- Normally this would be according to some parameters in the entry
- -- but this simple test is using parameterless entries.
- --
- task body Distributor is
- Last_was_for_Credit_Computation : Boolean := false; -- switch
- begin
- loop
- select
- accept Input do
- -- Determine to which task the message should be
- -- distributed
- -- For this test arbitrarily send the first to
- -- Credit_Computation and the second to Debit_Computation
- if Last_was_for_Credit_Computation then
- requeue Debit_Computation.Input with abort;
- else
- Last_was_for_Credit_Computation := true;
- requeue Credit_Computation.Input with abort;
- end if;
- end Input;
- or
- terminate;
- end select;
- end loop;
-
- exception
- when others =>
- Report.Failed ("Unexpected exception in Distributor");
- end Distributor;
-
-
- -- Computation task. After the computation is performed the rendezvous
- -- in the original message task is completed.
- task body Credit_Computation is
- begin
- loop
- select
- accept Input do
- -- Perform the computations required for this message
- --
- null; -- stub
-
- -- For the test:
- -- Artificially rendezvous with Debit_Computation.
- -- If the first requeue in Distributor has blocked
- -- waiting for the current rendezvous to complete then the
- -- second message will not be sent to Debit_Computation
- -- which will still be waiting on its Input accept.
- -- This task will HANG
- --
- Debit_Computation.TC_Artificial_Rendezvous_1;
- --
- end Input;
- or
- terminate;
- end select;
- end loop;
- exception
- when others =>
- Report.Failed ("Unexpected exception in Credit_Computation");
- end Credit_Computation;
-
-
- -- Computation task. After the computation is performed the rendezvous
- -- in the original message task is completed.
- task body Debit_Computation is
- Message_Count : integer := 0;
- TC_AR1_is_complete : Boolean := false;
- begin
- loop
- select
- accept Input do
- -- Perform the computations required for this message
- null; -- stub
- end Input;
- Message_Count := Message_Count + 1;
- or
- -- Guard until the rendezvous with the message for this task
- -- has completed
- when Message_Count > 0 =>
- accept TC_Artificial_Rendezvous_1; -- see comments in
- -- Credit_Computation above
- TC_AR1_is_complete := true;
- or
- -- Completion rendezvous with the main procedure
- when TC_AR1_is_complete =>
- accept TC_Artificial_Rendezvous_2;
- or
- terminate;
- end select;
- end loop;
- exception
- when others =>
- Report.Failed ("Unexpected exception in Debit_Computation");
-
-
- end Debit_Computation;
-
-
-begin -- c954010
- Report.Test ("C954010", "Requeue in an accept body does not block");
-
- Line_Driver.Start;
-
- -- Ensure that both messages were delivered to the computation tasks
- -- This shows that both requeues were effective.
- --
- Debit_Computation.TC_Artificial_Rendezvous_2;
-
- -- Ensure that the message tasks completed
- while (TC_Tasks_Completed.Count < TC_Expected_To_Complete) loop
- delay ImpDef.Minimum_Task_Switch;
- end loop;
-
- Report.Result;
-
-end C954010;
diff --git a/gcc/testsuite/ada/acats/tests/c9/c954011.a b/gcc/testsuite/ada/acats/tests/c9/c954011.a
deleted file mode 100644
index 159b32dba58..00000000000
--- a/gcc/testsuite/ada/acats/tests/c9/c954011.a
+++ /dev/null
@@ -1,384 +0,0 @@
--- C954011.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that a requeue is placed on the correct entry; that the
--- original caller waits for the completion of the requeued rendezvous;
--- that the original caller continues after the rendezvous.
--- Specifically, this test checks requeue to an entry in a different
--- task, requeue where the entry has parameters, and requeue with
--- abort.
---
--- TEST DESCRIPTION:
--- In the Distributor task, requeue two successive calls on the entries
--- of two separate target tasks. Each task in each of the paths adds
--- identifying information in the transaction being passed. This
--- information is checked by the Message tasks on completion ensuring that
--- the requeues have been placed on the correct queues.
---
--- This series of tests uses a simulation of a transaction driven
--- processing system. Line Drivers accept input from an external source
--- and build them into transaction records. These records are then
--- encapsulated in message tasks which remain extant for the life of the
--- transaction in the system. The message tasks put themselves on the
--- input queue of a Distributor which, from information in the
--- transaction and/or system load conditions forwards them to other
--- operating tasks. These in turn might forward the transactions to yet
--- other tasks for further action. The routing is, in real life,
--- dynamic and unpredictable at the time of message generation. All
--- rerouting in this model is done by means of requeues.
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 26 Nov 95 SAIC Fixed problems with shared global variables
--- for ACVC 2.0.1
---
---!
-
-with Report;
-with ImpDef;
-
-procedure C954011 is
-
-
- -- Arbitrary test values
- Credit_Return : constant := 1;
- Debit_Return : constant := 2;
-
- type Transaction_Code is (Credit, Debit);
-
- type Transaction_Record;
- type acc_Transaction_Record is access Transaction_Record;
- type Transaction_Record is
- record
- ID : integer := 0;
- Code : Transaction_Code := Debit;
- Account_Number : integer := 0;
- Stock_Number : integer := 0;
- Quantity : integer := 0;
- Return_Value : integer := 0;
- TC_Message_Count : integer := 0;
- TC_Thru_Distrib : Boolean := false;
- end record;
-
- protected type Message_Mgr is
- procedure Mark_Complete;
- function Is_Complete return Boolean;
- private
- Complete : Boolean := False;
- end Message_Mgr;
-
- protected body Message_Mgr is
- procedure Mark_Complete is
- begin
- Complete := True;
- end Mark_Complete;
-
- Function Is_Complete return Boolean is
- begin
- return Complete;
- end Is_Complete;
- end Message_Mgr;
-
- TC_Debit_Message : Message_Mgr;
- TC_Credit_Message : Message_Mgr;
-
-
- task type Message_Task is
- entry Accept_Transaction (In_Transaction : acc_Transaction_Record);
- end Message_Task;
- type acc_Message_Task is access Message_Task;
-
- task Line_Driver is
- entry Start;
- end Line_Driver;
-
- task Distributor is
- entry Input(Transaction : acc_Transaction_Record);
- end Distributor;
-
- task Credit_Computation is
- entry Input(Transaction : acc_Transaction_Record);
- end Credit_Computation;
-
- task Debit_Computation is
- entry Input(Transaction : acc_Transaction_Record);
- end Debit_Computation;
-
-
-
- -- Assemble messages received from an external source
- -- Creates a message task for each. The message tasks remain extant
- -- for the life of the messages in the system.
- -- The Line Driver task would normally be designed to loop continuously
- -- creating the messages as input is received. Simulate this
- -- but limit it to two dummy messages for this test and allow it
- -- to terminate at that point
- --
- task body Line_Driver is
- Current_ID : integer := 1;
- TC_Last_was_for_credit : Boolean := false;
-
- procedure Build_Credit_Record
- ( Next_Transaction : acc_Transaction_Record ) is
- Dummy_Account : constant integer := 100;
- begin
- Next_Transaction.ID := Current_ID;
- Next_Transaction.Code := Credit;
-
- Next_Transaction.Account_Number := Dummy_Account;
- Current_ID := Current_ID + 1;
- end Build_Credit_Record;
-
-
- procedure Build_Debit_Record
- ( Next_Transaction : acc_Transaction_Record ) is
- Dummy_Account : constant integer := 200;
- begin
- Next_Transaction.ID := Current_ID;
- Next_Transaction.Code := Debit;
-
- Next_Transaction.Account_Number := Dummy_Account;
- Current_ID := Current_ID + 1;
- end Build_Debit_Record;
-
- begin
-
- accept Start; -- Wait for trigger from Main
-
- for i in 1..2 loop -- arbitrarily limit to two messages for the test
- declare
- -- Create a task for the next message
- Next_Message_Task : acc_Message_Task := new Message_Task;
- -- Create a record for it
- Next_Transaction : acc_Transaction_Record
- := new Transaction_Record;
- begin
- if TC_Last_was_for_credit then
- Build_Debit_Record ( Next_Transaction );
- else
- Build_Credit_Record( Next_Transaction );
- TC_Last_was_for_credit := true;
- end if;
- Next_Message_Task.Accept_Transaction ( Next_Transaction );
- end; -- declare
- end loop;
-
- exception
- when others =>
- Report.Failed ("Unexpected exception in Line_Driver");
- end Line_Driver;
-
-
-
-
- task body Message_Task is
-
- TC_Original_Transaction_Code : Transaction_Code;
- This_Transaction : acc_Transaction_Record := new Transaction_Record;
-
- begin
- accept Accept_Transaction (In_Transaction : acc_Transaction_Record) do
- This_Transaction.all := In_Transaction.all;
- end Accept_Transaction;
-
- -- Note the original code to ensure correct return
- TC_Original_Transaction_Code := This_Transaction.Code;
-
- -- Queue up on Distributor's Input queue
- Distributor.Input ( This_Transaction );
- -- This task will now wait for the requeued rendezvous
- -- to complete before proceeding
-
- -- After the required computations have been performed
- -- return the Transaction_Record appropriately (probably to an output
- -- line driver)
- null; -- stub
-
-
- -- The following is all Test Control Code
-
- -- Check that the return values are as expected
- if TC_Original_Transaction_Code /= This_Transaction.Code then
- -- Incorrect rendezvous
- Report.Failed ("Message Task: Incorrect code returned");
- end if;
-
- if This_Transaction.Code = Credit then
- if This_Transaction.Return_Value /= Credit_Return or
- This_Transaction.TC_Message_Count /= 1 or not
- This_Transaction.TC_Thru_Distrib then
- Report.Failed ("Expected path not traversed");
- end if;
- TC_Credit_Message.Mark_Complete;
- else
- if This_Transaction.Return_Value /= Debit_Return or
- This_Transaction.TC_Message_Count /= 1 or not
- This_Transaction.TC_Thru_Distrib then
- Report.Failed ("Expected path not traversed");
- end if;
- TC_Debit_Message.Mark_Complete;
- end if;
-
- exception
- when others =>
- Report.Failed ("Unexpected exception in Message_Task");
-
- end Message_Task;
-
-
-
- -- Dispose each input Transaction_Record to the appropriate
- -- computation tasks
- --
- task body Distributor is
-
- begin
- loop
- select
- accept Input (Transaction : acc_Transaction_Record) do
- -- Mark the message as having passed through the distributor
- Transaction.TC_Thru_Distrib := true;
-
- -- Pass this transaction on the appropriate computation
- -- task
- case Transaction.Code is
- when Credit =>
- requeue Credit_Computation.Input with abort;
- when Debit =>
- requeue Debit_Computation.Input with abort;
- end case;
- end Input;
- or
- terminate;
- end select;
- end loop;
-
- exception
- when others =>
- Report.Failed ("Unexpected exception in Distributor");
- end Distributor;
-
-
-
- -- Computation task.
- -- Note: After the computation is performed in this task and the
- -- accept body is completed the rendezvous in the original
- -- message task is completed.
- --
- task body Credit_Computation is
- Message_Count : integer := 0;
- begin
- loop
- select
- accept Input ( Transaction : acc_Transaction_Record) do
- -- Perform the computations required for this transaction
- null; -- stub
-
- -- For the test:
- if not Transaction.TC_Thru_Distrib then
- Report.Failed
- ("Credit Task: Wrong queue, Distributor bypassed");
- end if;
- if Transaction.code /= Credit then
- Report.Failed
- ("Credit Task: Requeue delivered to the wrong queue");
- end if;
-
- -- for the test plug a known value and count
- Transaction.Return_Value := Credit_Return;
- -- one, and only one message should pass through
- Message_Count := Message_Count + 1;
- Transaction.TC_Message_Count := Message_Count;
- end Input;
- or
- terminate;
- end select;
- end loop;
- exception
- when others =>
- Report.Failed ("Unexpected exception in Credit_Computation");
- end Credit_Computation;
-
-
-
- -- Computation task.
- -- Note: After the computation is performed in this task and the
- -- accept body is completed the rendezvous in the original
- -- message task is completed.
- --
- task body Debit_Computation is
- Message_Count : integer := 0;
- begin
- loop
- select
- accept Input (Transaction : acc_Transaction_Record) do
- -- Perform the computations required for this message
- null; -- stub
-
- -- For the test:
- if not Transaction.TC_Thru_Distrib then
- Report.Failed
- ("Debit Task: Wrong queue, Distributor bypassed");
- end if;
- if Transaction.code /= Debit then
- Report.Failed
- ("Debit Task: Requeue delivered to the wrong queue");
- end if;
-
- -- for the test plug a known value and count
- Transaction.Return_Value := Debit_Return;
- -- one, and only one, message should pass through
- Message_Count := Message_Count + 1;
- Transaction.TC_Message_Count := Message_Count;
- end Input;
- or
- terminate;
- end select;
- end loop;
- exception
- when others =>
- Report.Failed ("Unexpected exception in Debit_Computation");
-
-
- end Debit_Computation;
-
-
-begin -- c954011
-
- Report.Test ("C954011", "Requeue from task body to task entry");
-
- Line_Driver.Start; -- Start the test
-
- -- Ensure that the message tasks complete before reporting the result
- while not (TC_Credit_Message.Is_Complete and
- TC_Debit_Message.Is_Complete) loop
- delay ImpDef.Minimum_Task_Switch;
- end loop;
-
- Report.Result;
-
-end C954011;
diff --git a/gcc/testsuite/ada/acats/tests/c9/c954012.a b/gcc/testsuite/ada/acats/tests/c9/c954012.a
deleted file mode 100644
index 44575b1b1e5..00000000000
--- a/gcc/testsuite/ada/acats/tests/c9/c954012.a
+++ /dev/null
@@ -1,496 +0,0 @@
--- C954012.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check a requeue within an accept body to another entry in the same task
--- Specifically, check a call with parameters and a requeue with abort.
---
--- TEST DESCRIPTION:
--- One transaction is sent through to check the paths. After
--- processing this the Credit task sets the "overloaded" indicator. Once
--- this indicator is set the Distributor queues low priority transactions
--- on a Wait_for_Underload queue in the same task using a requeue. The
--- Distributor still delivers high priority transactions. After two high
--- priority transactions have been processed by the Credit task it clears
--- the overload condition. The low priority transactions should now be
--- delivered.
---
--- This series of tests uses a simulation of a transaction driven
--- processing system. Line Drivers accept input from an external source
--- and build them into transaction records. These records are then
--- encapsulated in message tasks which remain extant for the life of the
--- transaction in the system. The message tasks put themselves on the
--- input queue of a Distributor which, from information in the
--- transaction and/or system load conditions forwards them to other
--- operating tasks. These in turn might forward the transactions to yet
--- other tasks for further action. The routing is, in real life, dynamic
--- and unpredictable at the time of message generation. All rerouting in
--- this model is done by means of requeues.
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 25 Nov 95 SAIC Fixed shared global variable problem for
--- ACVC 2.0.1
--- 14 Mar 03 RLB Fixed a race condition and an incorrect termination
--- condition in the test.
---!
-
-with Report;
-with ImpDef;
-with Ada.Calendar;
-
-procedure C954012 is
-
- function "=" (X,Y: Ada.Calendar.Time) return Boolean
- renames Ada.Calendar."=";
-
- -- Arbitrary test values
- Credit_Return : constant := 1;
- Debit_Return : constant := 2;
-
-
- -- This is used as an "initializing" time for the messages as they are
- -- created. As they pass through the Distributor they get a time_stamp
- -- of the current time. An arbitrary base time is chosen.
- -- TC: this fact is used, incidentally, to check that the messages have,
- -- indeed, passed through the Distributor as expected.
- --
- Base_Time : Ada.Calendar.Time := Ada.Calendar.Time_of(1959,3,9);
-
-
- -- Mechanism to count the number of Credit Message tasks completed
- protected TC_Tasks_Completed is
- procedure Increment;
- function Count return integer;
- private
- Number_Complete : integer := 0;
- end TC_Tasks_Completed;
-
- protected type Shared_Boolean (Initial_Value : Boolean := False) is
- procedure Set_True;
- procedure Set_False;
- function Value return Boolean;
- private
- Current_Value : Boolean := Initial_Value;
- end Shared_Boolean;
-
- protected body Shared_Boolean is
- procedure Set_True is
- begin
- Current_Value := True;
- end Set_True;
-
- procedure Set_False is
- begin
- Current_Value := False;
- end Set_False;
-
- function Value return Boolean is
- begin
- return Current_Value;
- end Value;
- end Shared_Boolean;
-
- TC_Debit_Message_Complete : Shared_Boolean (False);
- -- Handshaking mechanism between the Line Driver and the Credit task
- TC_First_Message_Has_Arrived : Shared_Boolean (False);
- Credit_Overloaded : Shared_Boolean (False);
-
- TC_Credit_Messages_Expected : constant integer := 5;
-
- type Transaction_Code is (Credit, Debit);
- type Transaction_Priority is (High, Low);
-
- type Transaction_Record;
- type acc_Transaction_Record is access Transaction_Record;
- type Transaction_Record is
- record
- ID : integer := 0;
- Code : Transaction_Code := Debit;
- Priority : Transaction_Priority := High;
- Account_Number : integer := 0;
- Stock_Number : integer := 0;
- Quantity : integer := 0;
- Return_Value : integer := 0;
- Message_Count : integer := 0; -- for test
- Time_Stamp : Ada.Calendar.Time := Base_Time;
- end record;
-
-
- task type Message_Task is
- entry Accept_Transaction (In_Transaction : acc_Transaction_Record);
- end Message_Task;
- type acc_Message_Task is access Message_Task;
-
- task Line_Driver is
- entry Start;
- end Line_Driver;
-
- task Distributor is
- entry Input (Transaction : acc_Transaction_Record);
- entry Wait_for_Underload (Transaction : acc_Transaction_Record);
- entry TC_Credit_OK;
- end Distributor;
-
- task Credit_Computation is
- entry Input(Transaction : acc_Transaction_Record);
- end Credit_Computation;
-
- task Debit_Computation is
- entry Input(Transaction : acc_Transaction_Record);
- end Debit_Computation;
-
-
- -- Mechanism to count the number of Message tasks completed (Credit)
- protected body TC_Tasks_Completed is
- procedure Increment is
- begin
- Number_Complete := Number_Complete + 1;
- end Increment;
-
- function Count return integer is
- begin
- return Number_Complete;
- end Count;
- end TC_Tasks_Completed;
-
-
- -- Assemble messages received from an external source
- -- Creates a message task for each. The message tasks remain extant
- -- for the life of the messages in the system.
- -- The Line Driver task would normally be designed to loop continuously
- -- creating the messages as input is received. Simulate this
- -- but limit it to the required number of dummy messages needed for
- -- this test and allow it to terminate at that point. Artificially
- -- alternate High and Low priority Credit transactions for this test.
- --
- task body Line_Driver is
- Current_ID : integer := 1;
- Current_Priority : Transaction_Priority := High;
-
- -- Artificial: number of messages required for this test
- type TC_Trans_Range is range 1..6;
-
- procedure Build_Credit_Record
- ( Next_Transaction : acc_Transaction_Record ) is
- Dummy_Account : constant integer := 100;
- begin
- Next_Transaction.ID := Current_ID;
- Next_Transaction.Code := Credit;
- Next_Transaction.Priority := Current_Priority;
-
- Next_Transaction.Account_Number := Dummy_Account;
- Current_ID := Current_ID + 1;
- end Build_Credit_Record;
-
-
- procedure Build_Debit_Record
- ( Next_Transaction : acc_Transaction_Record ) is
- Dummy_Account : constant integer := 200;
- begin
- Next_Transaction.ID := Current_ID;
- Next_Transaction.Code := Debit;
-
- Next_Transaction.Account_Number := Dummy_Account;
- Current_ID := Current_ID + 1;
- end Build_Debit_Record;
-
- begin
-
- accept Start; -- Wait for trigger from Main
-
- for Transaction_Numb in TC_Trans_Range loop -- TC: limit the loop
- declare
- -- Create a task for the next message
- Next_Message_Task : acc_Message_Task := new Message_Task;
- -- Create a record for it
- Next_Transaction : acc_Transaction_Record
- := new Transaction_Record;
- begin
- if Transaction_Numb = TC_Trans_Range'first then
- -- Send the first Credit message
- Build_Credit_Record ( Next_Transaction );
- Next_Message_Task.Accept_Transaction ( Next_Transaction );
- -- TC: Wait until the first message has been received by the
- -- Credit task and it has set the Overload indicator for the
- -- Distributor
- while not TC_First_Message_Has_Arrived.Value loop
- delay ImpDef.Minimum_Task_Switch;
- end loop;
- elsif Transaction_Numb = TC_Trans_Range'last then
- -- For this test send the last transaction to the Debit task
- -- to improve the mix
- Build_Debit_Record( Next_Transaction );
- Next_Message_Task.Accept_Transaction ( Next_Transaction );
- else
- -- TC: Alternate high and low priority transactions
- if Current_Priority = High then
- Current_Priority := Low;
- else
- Current_Priority := High;
- end if;
- Build_Credit_Record( Next_Transaction );
- Next_Message_Task.Accept_Transaction ( Next_Transaction );
- end if;
- end; -- declare
- end loop;
-
- -- TC: Wait for Credit_Overloaded to be cleared, then insure that the
- -- Distributor has evalated all tasks. Otherwise, some tasks may never
- -- be evaluated.
- while Credit_Overloaded.Value loop
- delay ImpDef.Minimum_Task_Switch;
- end loop;
- Distributor.TC_Credit_OK;
-
- exception
- when others =>
- Report.Failed ("Unexpected exception in Line_Driver");
- end Line_Driver;
-
-
-
-
- task body Message_Task is
-
- TC_Original_Transaction_Code : Transaction_Code;
- This_Transaction : acc_Transaction_Record := new Transaction_Record;
-
- begin
-
- accept Accept_Transaction (In_Transaction : acc_Transaction_Record) do
- This_Transaction.all := In_Transaction.all;
- end Accept_Transaction;
-
- -- Note the original code to ensure correct return
- TC_Original_Transaction_Code := This_Transaction.Code;
-
- -- Queue up on Distributor's Input queue
- Distributor.Input ( This_Transaction );
- -- This task will now wait for the requeued rendezvous
- -- to complete before proceeding
-
- -- After the required computations have been performed
- -- return the Transaction_Record appropriately (probably to an output
- -- line driver)
- null; -- stub
-
- -- For the test check that the return values are as expected
- if TC_Original_Transaction_Code /= This_Transaction.Code then
- -- Incorrect rendezvous
- Report.Failed ("Message Task: Incorrect code returned");
- end if;
-
- if This_Transaction.Code = Credit then
- if This_Transaction.Return_Value /= Credit_Return or
- This_Transaction.Time_Stamp = Base_Time then
- Report.Failed ("Expected path not traversed");
- end if;
- TC_Tasks_Completed.Increment;
- else
- if This_Transaction.Return_Value /= Debit_Return or
- This_Transaction.Message_Count /= 1 or
- This_Transaction.Time_Stamp = Base_Time then
- Report.Failed ("Expected path not traversed");
- end if;
- TC_Debit_Message_Complete.Set_True;
- end if;
-
- exception
- when others =>
- Report.Failed ("Unexpected exception in Message_Task");
-
- end Message_Task;
-
-
-
-
- -- Dispose each input Transaction_Record to the appropriate
- -- computation tasks
- --
- task body Distributor is
- begin
- loop
- select
- accept Input (Transaction : acc_Transaction_Record) do
- -- Time_Stamp the messages with the current time
- -- TC: Used, incidentally, by the test to check that the
- -- message did pass through the Distributor Task
- Transaction.Time_Stamp := Ada.Calendar.Clock;
-
- -- Pass this transaction on to the appropriate computation
- -- task but temporarily hold low-priority transactions under
- -- overload conditions
- case Transaction.Code is
- when Credit =>
- if Credit_Overloaded.Value and
- Transaction.Priority = Low then
- requeue Wait_for_Underload with abort;
- else
- requeue Credit_Computation.Input with abort;
- end if;
- when Debit =>
- requeue Debit_Computation.Input with abort;
- end case;
- end Input;
- or
- when not Credit_Overloaded.Value =>
- accept Wait_for_Underload (Transaction : acc_Transaction_Record) do
- requeue Credit_Computation.Input with abort;
- end Wait_for_Underload;
- or
- accept TC_Credit_OK;
- -- We need this to insure that we evaluate the guards at least
- -- once when Credit_Overloaded is False. Otherwise, tasks
- -- could stay queued on Wait_for_Underload forever (starvation).
- or
- terminate;
- end select;
- end loop;
-
- exception
- when others =>
- Report.Failed ("Unexpected exception in Distributor");
- end Distributor;
-
-
-
- -- Computation task. After the computation is performed the rendezvous
- -- in the original message task is completed.
- --
- task body Credit_Computation is
-
- Message_Count : integer := 0;
-
- begin
- loop
- select
- accept Input ( Transaction : acc_Transaction_Record) do
- if Credit_Overloaded.Value and
- Transaction.Priority = Low then
- -- We should not be getting any Low Priority messages. They
- -- should be waiting on the Distributor's Wait_for_Underload
- -- queue
- Report.Failed
- ("Credit Task: Low priority transaction during overload");
- end if;
- -- Perform the computations required for this transaction
- null; -- stub
-
- -- For the test:
- if Transaction.Time_Stamp = Base_Time then
- Report.Failed
- ("Credit Task: Wrong queue, Distributor bypassed");
- end if;
- if Transaction.code /= Credit then
- Report.Failed
- ("Credit Task: Requeue delivered to the wrong queue");
- end if;
-
- -- The following is all Test Control code:
- Transaction.Return_Value := Credit_Return;
- Message_Count := Message_Count + 1;
- --
- -- Now take special action depending on which Message
- if Message_Count = 1 then
- -- After the first message :
- Credit_Overloaded.Set_True;
- -- Now flag the Line_Driver that the second and subsequent
- -- messages may now be sent
- TC_First_Message_Has_Arrived.Set_True;
- end if;
- if Message_Count = 3 then
- -- The two high priority transactions created subsequent
- -- to the overload have now been processed
- Credit_Overloaded.Set_False;
- end if;
- end Input;
- or
- terminate;
- end select;
- end loop;
- exception
- when others =>
- Report.Failed ("Unexpected exception in Credit_Computation");
- end Credit_Computation;
-
-
-
- -- Computation task. After the computation is performed the rendezvous
- -- in the original message task is completed.
- --
- task body Debit_Computation is
- Message_Count : integer := 0;
- begin
- loop
- select
- accept Input (Transaction : acc_Transaction_Record) do
- -- Perform the computations required for this message
- null; -- stub
-
- -- For the test:
- if Transaction.Time_Stamp = Base_Time then
- Report.Failed
- ("Debit Task: Wrong queue, Distributor bypassed");
- end if;
- if Transaction.code /= Debit then
- Report.Failed
- ("Debit Task: Requeue delivered to the wrong queue");
- end if;
-
- -- for the test plug a known value and count
- Transaction.Return_Value := Debit_Return;
- -- one, and only one, message should pass through
- Message_Count := Message_Count + 1;
- Transaction.Message_Count := Message_Count;
- end Input;
- or
- terminate;
- end select;
- end loop;
- exception
- when others =>
- Report.Failed ("Unexpected exception in Debit_Computation");
-
-
- end Debit_Computation;
-
-
-begin -- c954012
- Report.Test ("C954012", "Requeue within an accept body" &
- " to another entry in the same task");
-
- Line_Driver.Start; -- Start the test
-
- -- Ensure that the message tasks complete before reporting the result
- while (TC_Tasks_Completed.Count < TC_Credit_Messages_Expected)
- or (not TC_Debit_Message_Complete.Value) loop
- delay ImpDef.Minimum_Task_Switch;
- end loop;
-
- Report.Result;
-
-end C954012;
diff --git a/gcc/testsuite/ada/acats/tests/c9/c954013.a b/gcc/testsuite/ada/acats/tests/c9/c954013.a
deleted file mode 100644
index a9de8c56b12..00000000000
--- a/gcc/testsuite/ada/acats/tests/c9/c954013.a
+++ /dev/null
@@ -1,521 +0,0 @@
--- C954013.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that a requeue is cancelled and that the requeuing task is
--- unaffected when the calling task is aborted.
--- Specifically, check requeue to an entry in a different task,
--- requeue where the entry has parameters, and requeue with abort.
---
--- TEST DESCRIPTION:
--- Abort a task that has a call requeued to the entry queue of another
--- task. We do this by sending two messages to the Distributor which
--- requeues them to the Credit task. In the accept body of the Credit
--- task we wait for the second message to arrive then check that an
--- abort of the second message task does result in the requeue being
--- removed. The Line Driver task which generates the messages and the
--- Credit task communicate artificially in this test to arrange for the
--- proper timing of the messages and the abort. One extra message is
--- sent to the Debit task to ensure that the Distributor is still viable
--- and has been unaffected by the abort.
---
--- This series of tests uses a simulation of a transaction driven
--- processing system. Line Drivers accept input from an external source
--- and build them into transaction records. These records are then
--- encapsulated in message tasks which remain extant for the life of the
--- transaction in the system. The message tasks put themselves on the
--- input queue of a Distributor which, from information in the
--- transaction and/or system load conditions forwards them to other
--- operating tasks. These in turn might forward the transactions to yet
--- other tasks for further action. The routing is, in real life, dynamic
--- and unpredictable at the time of message generation. All rerouting in
--- this model is done by means of requeues.
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 25 Nov 95 SAIC Fixed shared global variable problems for
--- ACVC 2.0.1
---
---!
-
-with Report;
-with ImpDef;
-
-procedure C954013 is
-
-
- -- Arbitrary test values
- Credit_Return : constant := 1;
- Debit_Return : constant := 2;
-
-
- protected type Shared_Boolean (Initial_Value : Boolean := False) is
- procedure Set_True;
- procedure Set_False;
- function Value return Boolean;
- private
- Current_Value : Boolean := Initial_Value;
- end Shared_Boolean;
-
- protected body Shared_Boolean is
- procedure Set_True is
- begin
- Current_Value := True;
- end Set_True;
-
- procedure Set_False is
- begin
- Current_Value := False;
- end Set_False;
-
- function Value return Boolean is
- begin
- return Current_Value;
- end Value;
- end Shared_Boolean;
-
-
- TC_Debit_Message_Complete : Shared_Boolean (False);
- TC_Credit_Message_Complete : Shared_Boolean (False);
-
-
- type Transaction_Code is (Credit, Debit);
-
- type Transaction_Record;
- type acc_Transaction_Record is access Transaction_Record;
- type Transaction_Record is
- record
- ID : integer := 0;
- Code : Transaction_Code := Debit;
- Account_Number : integer := 0;
- Stock_Number : integer := 0;
- Quantity : integer := 0;
- Return_Value : integer := 0;
- TC_Message_Count : integer := 0;
- TC_Thru_Dist : Boolean := false;
- end record;
-
-
- task type Message_Task is
- entry Accept_Transaction (In_Transaction : acc_Transaction_Record);
- end Message_Task;
- type acc_Message_Task is access Message_Task;
-
- task Line_Driver is
- entry Start;
- end Line_Driver;
-
- task Distributor is
- entry Input(Transaction : acc_Transaction_Record);
- end Distributor;
-
- task Credit_Computation is
- entry Input(Transaction : acc_Transaction_Record);
- end Credit_Computation;
-
- task Debit_Computation is
- entry Input(Transaction : acc_Transaction_Record);
- end Debit_Computation;
-
- -- This protected object is here for Test Control purposes only
- protected TC_Prt is
- procedure Set_First_Has_Arrived;
- procedure Set_Second_Has_Arrived;
- procedure Set_Abort_Has_Completed;
- function First_Has_Arrived return Boolean;
- function Second_Has_Arrived return Boolean;
- function Abort_Has_Completed return Boolean;
- private
- First_Flag, Second_Flag, Abort_Flag : Boolean := false;
- end TC_Prt;
-
- protected body TC_Prt is
-
- Procedure Set_First_Has_Arrived is
- begin
- First_Flag := true;
- end Set_First_Has_Arrived;
-
- Procedure Set_Second_Has_Arrived is
- begin
- Second_Flag := true;
- end Set_Second_Has_Arrived;
-
- Procedure Set_Abort_Has_Completed is
- begin
- Abort_Flag := true;
- end Set_Abort_Has_Completed;
-
- Function First_Has_Arrived return boolean is
- begin
- return First_Flag;
- end First_Has_Arrived;
-
- Function Second_Has_Arrived return boolean is
- begin
- return Second_Flag;
- end Second_has_Arrived;
-
- Function Abort_Has_Completed return boolean is
- begin
- return Abort_Flag;
- end Abort_Has_Completed;
-
- end TC_PRT;
-
- -- Assemble messages received from an external source
- -- Creates a message task for each. The message tasks remain extant
- -- for the life of the messages in the system.
- -- TC: The Line Driver task would normally be designed to loop
- -- continuously creating the messages as input is received. Simulate
- -- this but limit it to three dummy messages for this test and use
- -- special artificial checks to pace the messages out under controlled
- -- conditions for the test; allow it to terminate at the end
- --
- task body Line_Driver is
- Current_ID : integer := 1;
- TC_First_message_sent: Boolean := false;
-
- procedure Build_Credit_Record
- ( Next_Transaction : acc_Transaction_Record ) is
- Dummy_Account : constant integer := 100;
- begin
- Next_Transaction.ID := Current_ID;
- Next_Transaction.Code := Credit;
-
- Next_Transaction.Account_Number := Dummy_Account;
- Current_ID := Current_ID + 1;
- end Build_Credit_Record;
-
-
- procedure Build_Debit_Record
- ( Next_Transaction : acc_Transaction_Record ) is
- Dummy_Account : constant integer := 200;
- begin
- Next_Transaction.ID := Current_ID;
- Next_Transaction.Code := Debit;
-
- Next_Transaction.Account_Number := Dummy_Account;
- Current_ID := Current_ID + 1;
- end Build_Debit_Record;
-
- begin
-
- accept Start; -- Wait for trigger from main
-
- for i in 1..3 loop -- TC: arbitrarily limit to two credit messages
- -- and one debit, then complete
- declare
- -- Create a task for the next message
- Next_Message_Task : acc_Message_Task := new Message_Task;
- -- Create a record for it
- Next_Transaction : acc_Transaction_Record :=
- new Transaction_Record;
- begin
- if not TC_First_Message_Sent then
- -- send out the first message to start up the Credit task
- Build_Credit_Record ( Next_Transaction );
- Next_Message_Task.Accept_Transaction ( Next_Transaction );
- TC_First_Message_Sent := true;
- elsif not TC_Prt.Abort_Has_Completed then
- -- We have not yet processed the second message
- -- Wait to send the second message until we know the first
- -- has arrived at the Credit task and that task is in the
- -- accept body
- while not TC_Prt.First_Has_Arrived loop
- delay ImpDef.Minimum_Task_Switch;
- end loop;
-
- -- We can now send the second message
- Build_Credit_Record( Next_Transaction );
- Next_Message_Task.Accept_Transaction ( Next_Transaction );
-
- -- Now wait for the second to arrive on the Credit input queue
- while not TC_Prt.Second_Has_Arrived loop
- delay ImpDef.Minimum_Task_Switch;
- end loop;
-
- -- At this point: The Credit task is in the accept block
- -- dealing with the first message and the second message is
- -- is on the input queue
- abort Next_Message_Task.all; -- Note: we are still in the
- -- declare block for the
- -- second message task
-
- -- Make absolutely certain that all the actions
- -- associated with the abort have been completed, that the
- -- task has gone from Abnormal right through to
- -- Termination. All requeues that are to going to be
- -- cancelled will have been by the point of Termination.
- while not Next_Message_Task.all'terminated loop
- delay ImpDef.Minimum_Task_Switch;
- end loop;
-
-
- -- We now signal the Credit task that the abort has taken place
- -- so that it can check that the entry queue is empty as the
- -- requeue should have been cancelled
- TC_Prt.Set_Abort_Has_Completed;
- else
- -- The main part of the test is complete. Send one Debit message
- -- as further exercise of the Distributor to ensure it has not
- -- been affected by the cancellation of the requeue.
- Build_Debit_Record ( Next_Transaction );
- Next_Message_Task.Accept_Transaction ( Next_Transaction );
- end if;
- end; -- declare
- end loop;
-
- exception
- when others =>
- Report.Failed ("Unexpected exception in Line_Driver");
- end Line_Driver;
-
-
-
-
- task body Message_Task is
-
- TC_Original_Transaction_Code : Transaction_Code;
- This_Transaction : acc_Transaction_Record := new Transaction_Record;
-
- begin
-
- accept Accept_Transaction (In_Transaction : acc_Transaction_Record) do
- This_Transaction.all := In_Transaction.all;
- end Accept_Transaction;
-
- -- Note the original code to ensure correct return
- TC_Original_Transaction_Code := This_Transaction.Code;
-
- -- Queue up on Distributor's Input queue
- Distributor.Input ( This_Transaction );
- -- This task will now wait for the requeued rendezvous
- -- to complete before proceeding
-
- -- After the required computations have been performed
- -- return the Transaction_Record appropriately (probably to an output
- -- line driver)
- null; -- stub
-
- -- For the test check that the return values are as expected
- if TC_Original_Transaction_Code /= This_Transaction.Code then
- -- Incorrect rendezvous
- Report.Failed ("Message Task: Incorrect code returned");
- end if;
-
- if This_Transaction.Code = Credit then
- if This_Transaction.Return_Value /= Credit_Return or
- This_Transaction.TC_Message_Count /= 1 or not
- This_Transaction.TC_Thru_Dist then
- Report.Failed ("Expected path not traversed");
- end if;
- TC_Credit_Message_Complete.Set_True;
- else
- if This_Transaction.Return_Value /= Debit_Return or
- This_Transaction.TC_Message_Count /= 1 or not
- This_Transaction.TC_Thru_Dist then
- Report.Failed ("Expected path not traversed");
- end if;
- TC_Debit_Message_Complete.Set_True;
- end if;
-
- exception
- when others =>
- Report.Failed ("Unexpected exception in Message_Task");
-
- end Message_Task;
-
-
-
- -- Dispose each input Transaction_Record to the appropriate
- -- computation tasks
- --
- task body Distributor is
-
- begin
- loop
- select
- accept Input (Transaction : acc_Transaction_Record) do
- -- Show that this message did pass through the Distributor Task
- Transaction.TC_Thru_Dist := true;
-
- -- Pass this transaction on the the appropriate computation
- -- task
- case Transaction.Code is
- when Credit =>
- requeue Credit_Computation.Input with abort;
- when Debit =>
- requeue Debit_Computation.Input with abort;
- end case;
- end Input;
- or
- terminate;
- end select;
- end loop;
-
- exception
- when others =>
- Report.Failed ("Unexpected exception in Distributor");
- end Distributor;
-
-
-
- -- Computation task.
- -- Note: After the computation is performed in this task and the
- -- accept body is completed the rendezvous in the original
- -- message task is completed.
- task body Credit_Computation is
- Message_Count : integer := 0;
- begin
- loop
- select
- accept Input ( Transaction : acc_Transaction_Record) do
- -- Perform the computations required for this transaction
- --
- null; -- stub
-
- -- The rest of this code is for Test Control
- --
- if not Transaction.TC_Thru_Dist then
- Report.Failed
- ("Credit Task: Wrong queue, Distributor bypassed");
- end if;
- if Transaction.code /= Credit then
- Report.Failed
- ("Credit Task: Requeue delivered to the wrong queue");
- end if;
-
- -- for the test plug a known value and count
- Transaction.Return_Value := Credit_Return;
- -- one, and only one message should pass through
- if Message_Count /= 0 then
- Report.Failed ("Aborted Requeue was not cancelled -1");
- end if;
- Message_Count := Message_Count + 1;
- Transaction.TC_Message_Count := Message_Count;
-
-
- -- Having done the basic housekeeping we now need to signal
- -- that we are in the accept body of the credit task. The
- -- first message has arrived and the Line Driver may now send
- -- the second one
- TC_Prt.Set_First_Has_Arrived;
-
- -- Now wait for the second to arrive
-
- while Input'Count = 0 loop
- delay ImpDef.Minimum_Task_Switch;
- end loop;
- -- Second message has been requeued - the Line driver may
- -- now abort the calling task
- TC_Prt.Set_Second_Has_Arrived;
-
- -- Now wait for the Line Driver to signal that the abort of
- -- the first task is complete - the requeue should be cancelled
- -- at this time
- while not TC_Prt.Abort_Has_Completed loop
- delay ImpDef.Minimum_Task_Switch;
- end loop;
-
- if Input'Count /=0 then
- Report.Failed ("Aborted Requeue was not cancelled -2");
- end if;
- -- We can now complete the rendezvous with the first caller
- end Input;
- or
- terminate;
- end select;
- end loop;
- exception
- when others =>
- Report.Failed ("Unexpected exception in Credit_Computation");
- end Credit_Computation;
-
-
-
- -- Computation task.
- -- Note: After the computation is performed in this task and the
- -- accept body is completed the rendezvous in the original
- -- message task is completed.
- task body Debit_Computation is
- Message_Count : integer := 0;
- begin
- loop
- select
- accept Input (Transaction : acc_Transaction_Record) do
- -- Perform the computations required for this message
- --
- null; -- stub
-
- -- The rest of this code is for Test Control
- --
- if not Transaction.TC_Thru_Dist then
- Report.Failed
- ("Debit Task: Wrong queue, Distributor bypassed");
- end if;
- if Transaction.code /= Debit then
- Report.Failed
- ("Debit Task: Requeue delivered to the wrong queue");
- end if;
-
- -- for the test plug a known value and count
- Transaction.Return_Value := Debit_Return;
- -- one, and only one, message should pass through
- Message_Count := Message_Count + 1;
- Transaction.TC_Message_Count := Message_Count;
- end Input;
- or
- terminate;
- end select;
- end loop;
- exception
- when others =>
- Report.Failed ("Unexpected exception in Debit_Computation");
-
-
- end Debit_Computation;
-
-
-begin -- c954013
-
- Report.Test ("C954013", "Abort a task that has a call requeued");
-
- Line_Driver.Start; -- start the test
-
- -- Wait for the message tasks to complete before calling Report.Result.
- -- Although two Credit tasks are generated one is aborted so only
- -- one completes, thus a single flag is sufficient
- -- Note: the test will hang here if there is a problem with the
- -- completion of the tasks
- while not (TC_Credit_Message_Complete.Value and
- TC_Debit_Message_Complete.Value) loop
- delay ImpDef.Minimum_Task_Switch;
- end loop;
-
- Report.Result;
-
-end C954013;
diff --git a/gcc/testsuite/ada/acats/tests/c9/c954014.a b/gcc/testsuite/ada/acats/tests/c9/c954014.a
deleted file mode 100644
index 53e45a090dd..00000000000
--- a/gcc/testsuite/ada/acats/tests/c9/c954014.a
+++ /dev/null
@@ -1,485 +0,0 @@
--- C954014.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that a requeue is not canceled and that the requeueing
--- task is unaffected when a calling task is aborted. Check that the
--- abort is deferred until the entry call is complete.
--- Specifically, check requeue to an entry in a different task,
--- requeue where the entry call has parameters, and requeue
--- without the abort option.
---
--- TEST DESCRIPTION
--- In the Driver create a task that places a call on the
--- Distributor. In the Distributor requeue this call on the Credit task.
--- Abort the calling task when it is known to be in rendezvous with the
--- Credit task. (We arrange this by using artificial synchronization
--- points in the Driver and the accept body of the Credit task) Ensure
--- that the abort is deferred (the task is not terminated) until the
--- accept body completes. Afterwards, send one extra message through
--- the Distributor to check that the requeueing task has not been
--- disrupted.
---
--- This series of tests uses a simulation of a transaction driven
--- processing system. Line Drivers accept input from an external source
--- and build them into transaction records. These records are then
--- encapsulated in message tasks which remain extant for the life of the
--- transaction in the system. The message tasks put themselves on the
--- input queue of a Distributor which, from information in the
--- transaction and/or system load conditions forwards them to other
--- operating tasks. These in turn might forward the transactions to yet
--- other tasks for further action. The routing is, in real life, dynamic
--- and unpredictable at the time of message generation. All rerouting in
--- this model is done by means of requeues.
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 25 Nov 95 SAIC Replaced global variables with protected objects
--- for ACVC 2.0.1.
---
---!
-
-with Report;
-with ImpDef;
-
-procedure C954014 is
-
- -- Arbitrary test values
- Credit_Return : constant := 1;
- Debit_Return : constant := 2;
-
-
- protected type Shared_Boolean (Initial_Value : Boolean := False) is
- procedure Set_True;
- procedure Set_False;
- function Value return Boolean;
- private
- Current_Value : Boolean := Initial_Value;
- end Shared_Boolean;
-
- protected body Shared_Boolean is
- procedure Set_True is
- begin
- Current_Value := True;
- end Set_True;
-
- procedure Set_False is
- begin
- Current_Value := False;
- end Set_False;
-
- function Value return Boolean is
- begin
- return Current_Value;
- end Value;
- end Shared_Boolean;
-
-
- TC_Debit_Message_Complete : Shared_Boolean (False);
-
- -- Synchronization flags for handshaking between the Line_Driver
- -- and the Accept body in the Credit Task
- TC_Handshake_A : Shared_Boolean (False);
- TC_Handshake_B : Shared_Boolean (False);
- TC_Handshake_C : Shared_Boolean (False);
- TC_Handshake_D : Shared_Boolean (False);
- TC_Handshake_E : Shared_Boolean (False);
- TC_Handshake_F : Shared_Boolean (False);
-
-
- type Transaction_Code is (Credit, Debit);
-
- type Transaction_Record;
- type acc_Transaction_Record is access Transaction_Record;
- type Transaction_Record is
- record
- ID : integer := 0;
- Code : Transaction_Code := Debit;
- Account_Number : integer := 0;
- Stock_Number : integer := 0;
- Quantity : integer := 0;
- Return_Value : integer := 0;
- TC_Message_Count : integer := 0;
- TC_Thru_Distrib : Boolean;
- end record;
-
-
- task type Message_Task is
- entry Accept_Transaction (In_Transaction : acc_Transaction_Record);
- end Message_Task;
- type acc_Message_Task is access Message_Task;
-
- task Line_Driver is
- entry start;
- end Line_Driver;
-
- task Distributor is
- entry Input(Transaction : acc_Transaction_Record);
- end Distributor;
-
- task Credit_Computation is
- entry Input(Transaction : acc_Transaction_Record);
- end Credit_Computation;
-
- task Debit_Computation is
- entry Input(Transaction : acc_Transaction_Record);
- end Debit_Computation;
-
-
- -- Assemble messages received from an external source
- -- Creates a message task for each. The message tasks remain extant
- -- for the life of the messages in the system.
- -- TC: The Line Driver task would normally be designed to loop
- -- continuously creating the messages as input is received. Simulate
- -- this but limit it to two dummy messages for this test and use
- -- special artificial handshaking checks with the Credit accept body
- -- to control the test. Allow it to terminate at the end
- --
- task body Line_Driver is
- Current_ID : integer := 1;
- TC_First_message_sent: Boolean := false;
-
- procedure Build_Credit_Record
- ( Next_Transaction : acc_Transaction_Record ) is
- Dummy_Account : constant integer := 100;
- begin
- Next_Transaction.ID := Current_ID;
- Next_Transaction.Code := Credit;
-
- Next_Transaction.Account_Number := Dummy_Account;
- Current_ID := Current_ID + 1;
- end Build_Credit_Record;
-
-
- procedure Build_Debit_Record
- ( Next_Transaction : acc_Transaction_Record ) is
- Dummy_Account : constant integer := 200;
- begin
- Next_Transaction.ID := Current_ID;
- Next_Transaction.Code := Debit;
-
- Next_Transaction.Account_Number := Dummy_Account;
- Current_ID := Current_ID + 1;
- end Build_Debit_Record;
-
- begin
-
- accept Start; -- Wait for trigger from main
-
- for i in 1..2 loop -- TC: arbitrarily limit to one credit message
- -- and one debit, then complete
- declare
- -- Create a task for the next message
- Next_Message_Task : acc_Message_Task := new Message_Task;
- -- Create a record for it
- Next_Transaction : acc_Transaction_Record :=
- new Transaction_Record;
- begin
- if not TC_First_Message_Sent then
- -- send out the first message which will be aborted
- Build_Credit_Record ( Next_Transaction );
- Next_Message_Task.Accept_Transaction ( Next_Transaction );
- TC_First_Message_Sent := true;
-
- -- Wait for Credit task to get into the accept body
- -- The call from the Message Task has been requeued by
- -- the distributor
- while not TC_Handshake_A.Value loop
- delay ImpDef.Minimum_Task_Switch;
- end loop;
-
- -- Abort the calling task; the Credit task is guaranteed to
- -- be in the accept body
- abort Next_Message_Task.all; -- We are still in this declare
- -- block
-
- -- Inform the Credit task that the abort has been initiated
- TC_Handshake_B.Set_True;
-
- -- Now wait for the "acknowledgment" from the Credit task
- -- this ensures a complete task switch (at least)
- while not TC_Handshake_C.Value loop
- delay ImpDef.Minimum_Task_Switch;
- end loop;
-
- -- The aborted task must not terminate till the accept body
- -- has completed
- if Next_Message_Task'terminated then
- Report.Failed ("The abort was not deferred");
- end if;
-
- -- Inform the Credit task that the termination has been checked
- TC_Handshake_D.Set_True;
-
- -- Now wait for the completion of the accept body in the
- -- Credit task
- while not TC_Handshake_E.Value loop
- delay ImpDef.Minimum_Task_Switch;
- end loop;
-
- while not ( Next_Message_Task'terminated ) loop
- delay ImpDef.Minimum_Task_Switch;
- end loop;
-
- -- Indicate to the Main program that this section is complete
- TC_Handshake_F.Set_True;
-
- else
- -- The main part of the test is complete. Send one Debit message
- -- as further exercise of the Distributor to ensure it has not
- -- been affected by the abort of the requeue;
- Build_Debit_Record ( Next_Transaction );
- Next_Message_Task.Accept_Transaction ( Next_Transaction );
- end if;
- end; -- declare
- end loop;
-
- exception
- when others =>
- Report.Failed ("Unexpected exception in Line_Driver");
- end Line_Driver;
-
-
-
- task body Message_Task is
-
- TC_Original_Transaction_Code : Transaction_Code;
- This_Transaction : acc_Transaction_Record := new Transaction_Record;
-
- begin
-
- accept Accept_Transaction (In_Transaction : acc_Transaction_Record) do
- This_Transaction.all := In_Transaction.all;
- end Accept_Transaction;
-
- -- Note the original code to ensure correct return
- TC_Original_Transaction_Code := This_Transaction.Code;
-
- -- Queue up on Distributor's Input queue
- Distributor.Input ( This_Transaction );
- -- This task will now wait for the requeued rendezvous
- -- to complete before proceeding
-
- -- After the required computations have been performed
- -- return the Transaction_Record appropriately (probably to an output
- -- line driver)
- null; -- stub
-
- -- For the test check that the return values are as expected
- if TC_Original_Transaction_Code /= This_Transaction.Code then
- -- Incorrect rendezvous
- Report.Failed ("Message Task: Incorrect code returned");
- end if;
-
- if This_Transaction.Code = Credit then
- -- The only Credit message was the one that should have been aborted
- Report.Failed ("Abort was not effective");
- else
- if This_Transaction.Return_Value /= Debit_Return or
- This_Transaction.TC_Message_Count /= 1 or not
- This_Transaction.TC_Thru_Distrib then
- Report.Failed ("Expected path not traversed");
- end if;
- TC_Debit_Message_Complete.Set_True;
- end if;
-
- exception
- when others =>
- Report.Failed ("Unexpected exception in Message_Task");
-
- end Message_Task;
-
-
-
- -- Dispose each input Transaction_Record to the appropriate
- -- computation tasks
- --
- task body Distributor is
-
- begin
- loop
- select
- accept Input (Transaction : acc_Transaction_Record) do
-
- -- Indicate that the message did pass through the
- -- Distributor Task
- Transaction.TC_Thru_Distrib := true;
-
- -- Pass this transaction on the appropriate computation
- -- task
- case Transaction.Code is
- when Credit =>
- requeue Credit_Computation.Input; -- without abort
- when Debit =>
- requeue Debit_Computation.Input; -- without abort
- end case;
- end Input;
- or
- terminate;
- end select;
- end loop;
-
- exception
- when others =>
- Report.Failed ("Unexpected exception in Distributor");
- end Distributor;
-
-
-
- -- Computation task.
- -- Note: After the computation is performed in this task and the
- -- accept body is completed the rendezvous in the original
- -- message task is completed.
- task body Credit_Computation is
- Message_Count : integer := 0;
- begin
- loop
- select
- accept Input ( Transaction : acc_Transaction_Record) do
- -- Perform the computations required for this transaction
- --
- null; -- stub
-
- -- The rest of this code is for Test Control
- --
- if not Transaction.TC_Thru_Distrib then
- Report.Failed
- ("Credit Task: Wrong queue, Distributor bypassed");
- end if;
- if Transaction.code /= Credit then
- Report.Failed
- ("Credit Task: Requeue delivered to the wrong queue");
- end if;
-
- -- for the test plug a known value and count
- Transaction.Return_Value := Credit_Return;
- -- one, and only one message should pass through
- if Message_Count /= 0 then
- Report.Failed ("Aborted Requeue was not canceled -1");
- end if;
- Message_Count := Message_Count + 1;
- Transaction.TC_Message_Count := Message_Count;
-
- -- Having done the basic housekeeping we now need to signal
- -- that we are in the accept body of the credit task. The
- -- message has arrived and the Line Driver may now abort the
- -- calling task
- TC_Handshake_A.Set_True;
-
- -- Now wait for the Line Driver to inform us the calling
- -- task has been aborted
- while not TC_Handshake_B.Value loop
- delay ImpDef.Minimum_Task_Switch;
- end loop;
-
- -- The abort has taken place
- -- Inform the Line Driver that we are still running in the
- -- accept body
- TC_Handshake_C.Set_True;
-
- -- Now wait for the Line Driver to digest this information
- while not TC_Handshake_D.Value loop
- delay ImpDef.Minimum_Task_Switch;
- end loop;
-
- -- The Line driver has checked that the caller is not terminated
- -- We can now complete the accept
-
- end Input;
- -- We are out of the accept
- TC_Handshake_E.Set_True;
-
- or
- terminate;
- end select;
- end loop;
- exception
- when others =>
- Report.Failed ("Unexpected exception in Credit_Computation");
- end Credit_Computation;
-
-
-
- -- Computation task.
- -- Note: After the computation is performed in this task and the
- -- accept body is completed the rendezvous in the original
- -- message task is completed.
- task body Debit_Computation is
- Message_Count : integer := 0;
- begin
- loop
- select
- accept Input (Transaction : acc_Transaction_Record) do
- -- Perform the computations required for this message
- --
- null; -- stub
-
- -- The rest of this code is for Test Control
- --
- if not Transaction.TC_Thru_Distrib then
- Report.Failed
- ("Debit Task: Wrong queue, Distributor bypassed");
- end if;
- if Transaction.code /= Debit then
- Report.Failed
- ("Debit Task: Requeue delivered to the wrong queue");
- end if;
-
- -- for the test plug a known value and count
- Transaction.Return_Value := Debit_Return;
- -- one, and only one, message should pass through
- Message_Count := Message_Count + 1;
- Transaction.TC_Message_Count := Message_Count;
- end Input;
- or
- terminate;
- end select;
- end loop;
- exception
- when others =>
- Report.Failed ("Unexpected exception in Debit_Computation");
-
-
- end Debit_Computation;
-
-
-begin -- c954014
- Report.Test ("C954014", "Abort a task that has a call" &
- " requeued_without_abort");
-
- Line_Driver.Start; -- Start the test
-
- -- Wait for the message tasks to complete before reporting the result
- --
- while not (TC_Handshake_F.Value -- abort not effective?
- and TC_Debit_Message_Complete.Value -- Distributor affected?
- and TC_Handshake_E.Value ) loop -- accept not completed?
- delay ImpDef.Minimum_Task_Switch;
- end loop;
-
- Report.Result;
-
-end C954014;
diff --git a/gcc/testsuite/ada/acats/tests/c9/c954015.a b/gcc/testsuite/ada/acats/tests/c9/c954015.a
deleted file mode 100644
index c86e1078e79..00000000000
--- a/gcc/testsuite/ada/acats/tests/c9/c954015.a
+++ /dev/null
@@ -1,549 +0,0 @@
--- C954015.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that requeued calls to task entries may, in turn, be requeued.
--- Check that the intermediate requeues are not blocked and that the
--- original caller remains blocked until the last requeue is complete.
--- This test uses:
--- Call with parameters
--- Requeue with abort
---
--- TEST DESCRIPTION
--- A call is placed on the input queue of the Distributor. The
--- Distributor requeues to the Credit task; the Credit task requeues to a
--- secondary task which, in turn requeues to yet another task. This
--- continues down the chain. At the furthest point of the chain the
--- rendezvous is completed. To verify the action, the furthest task
--- waits in the accept statement for a second message to arrive before
--- completing. This second message can only arrive if none of the earlier
--- tasks in the chain are blocked waiting for completion. Apart from
--- the two Credit messages which are used to check the requeue chain one
--- Debit message is sent to validate the mix.
---
---
--- This series of tests uses a simulation of a transaction driven
--- processing system. Line Drivers accept input from an external source
--- and build them into transaction records. These records are then
--- encapsulated in message tasks which remain extant for the life of the
--- transaction in the system. The message tasks put themselves on the
--- input queue of a Distributor which, from information in the
--- transaction and/or system load conditions forwards them to other
--- operating tasks. These in turn might forward the transactions to yet
--- other tasks for further action. The routing is, in real life, dynamic
--- and unpredictable at the time of message generation. All rerouting in
--- this model is done by means of requeues.
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
---
---!
-
-
-with Report;
-with ImpDef;
-
-procedure C954015 is
-
- -- Arbitrary test values
- Credit_Return : constant := 1;
- Debit_Return : constant := 2;
-
- -- Mechanism to count the number of Credit Message tasks completed
- protected TC_Tasks_Completed is
- procedure Increment;
- function Count return integer;
- private
- Number_Complete : integer := 0;
- end TC_Tasks_Completed;
-
- TC_Expected_To_Complete : constant integer := 3;
-
-
- -- Values added to the Return_Value indicating passage through the
- -- particular task
- TC_Credit_Value : constant integer := 1;
- TC_Sub_1_Value : constant integer := 2;
- TC_Sub_2_Value : constant integer := 3;
- TC_Sub_3_Value : constant integer := 4;
- TC_Sub_4_Value : constant integer := 5;
- --
- TC_Full_Value : integer := TC_Credit_Value + TC_Sub_1_Value +
- TC_Sub_2_Value + TC_Sub_3_Value +
- TC_Sub_4_Value;
-
- type Transaction_Code is (Credit, Debit);
-
- type Transaction_Record;
- type acc_Transaction_Record is access Transaction_Record;
- type Transaction_Record is
- record
- ID : integer := 0;
- Code : Transaction_Code := Debit;
- Account_Number : integer := 0;
- Stock_Number : integer := 0;
- Quantity : integer := 0;
- Return_Value : integer := 0;
- TC_Message_Count : integer := 0;
- TC_Thru_Distrib : Boolean := false;
- end record;
-
-
- task type Message_Task is
- entry Accept_Transaction (In_Transaction : acc_Transaction_Record);
- end Message_Task;
- type acc_Message_Task is access Message_Task;
-
- task Line_Driver is
- entry Start;
- end Line_Driver;
-
- task Distributor is
- entry Input(Transaction : acc_Transaction_Record);
- end Distributor;
-
- task Credit_Computation is
- entry Input(Transaction : acc_Transaction_Record);
- end Credit_Computation;
-
- task Debit_Computation is
- entry Input(Transaction : acc_Transaction_Record);
- end Debit_Computation;
-
- -- The following are almost identical for the purpose of the test
- task Credit_Sub_1 is
- entry Input(Transaction : acc_Transaction_Record);
- end Credit_Sub_1;
- --
- task Credit_Sub_2 is
- entry Input(Transaction : acc_Transaction_Record);
- end Credit_Sub_2;
- --
- task Credit_Sub_3 is
- entry Input(Transaction : acc_Transaction_Record);
- end Credit_Sub_3;
-
- -- This is the last in the chain
- task Credit_Sub_4 is
- entry Input(Transaction : acc_Transaction_Record);
- end Credit_Sub_4;
-
-
- -- Mechanism to count the number of Message tasks completed (Credit)
- protected body TC_Tasks_Completed is
- procedure Increment is
- begin
- Number_Complete := Number_Complete + 1;
- end Increment;
-
- function Count return integer is
- begin
- return Number_Complete;
- end Count;
- end TC_Tasks_Completed;
-
-
-
- -- Assemble messages received from an external source
- -- Creates a message task for each. The message tasks remain extant
- -- for the life of the messages in the system.
- -- The Line Driver task would normally be designed to loop continuously
- -- creating the messages as input is received. Simulate this
- -- but limit it to the number of dummy messages needed for this
- -- test and allow it to terminate at that point.
- --
- task body Line_Driver is
- Current_ID : integer := 1;
- TC_Last_was_for_credit : Boolean := false;
-
- -- Arbitrary limit for the number of messages sent for this test
- type TC_Trans_Range is range 1..3;
-
- procedure Build_Credit_Record
- ( Next_Transaction : acc_Transaction_Record ) is
- Dummy_Account : constant integer := 100;
- begin
- Next_Transaction.ID := Current_ID;
- Next_Transaction.Code := Credit;
- Next_Transaction.Account_Number := Dummy_Account;
- Current_ID := Current_ID + 1;
- end Build_Credit_Record;
-
- procedure Build_Debit_Record
- ( Next_Transaction : acc_Transaction_Record ) is
- Dummy_Account : constant integer := 200;
- begin
- Next_Transaction.ID := Current_ID;
- Next_Transaction.Code := Debit;
- Next_Transaction.Account_Number := Dummy_Account;
- Current_ID := Current_ID + 1;
- end Build_Debit_Record;
-
-
- begin
-
- accept Start; -- wait for trigger from Main
-
- -- Arbitrarily limit the loop to the number needed for this test only
- for Transaction_Numb in TC_Trans_Range loop
- declare
- -- Create a task for the next message
- Next_Message_Task : acc_Message_Task := new Message_Task;
- -- Create a record for it
- Next_Transaction : acc_Transaction_Record :=
- new Transaction_Record;
- begin
- -- Artificially send out in the order required
- case Transaction_Numb is
- when 1 =>
- Build_Credit_Record( Next_Transaction );
- when 2 =>
- Build_Credit_Record( Next_Transaction );
- when 3 =>
- Build_Debit_Record ( Next_Transaction );
- end case;
-
- -- Present the record to the message task
- Next_Message_Task.Accept_Transaction ( Next_Transaction );
- end; -- declare
- end loop;
-
- exception
- when others =>
- Report.Failed ("Unexpected exception in Line_Driver");
- end Line_Driver;
-
-
-
- task body Message_Task is
-
- TC_Original_Transaction_Code : Transaction_Code;
- This_Transaction : acc_Transaction_Record := new Transaction_Record;
-
- begin
-
- accept Accept_Transaction (In_Transaction : acc_Transaction_Record) do
- This_Transaction.all := In_Transaction.all;
- end Accept_Transaction;
-
- -- Note the original code to ensure correct return
- TC_Original_Transaction_Code := This_Transaction.Code;
-
- -- Queue up on Distributor's Input queue
- Distributor.Input ( This_Transaction );
- -- This task will now wait for the requeued rendezvous
- -- to complete before proceeding
-
- -- After the required computations have been performed
- -- return the Transaction_Record appropriately (probably to an output
- -- line driver)
- null; -- stub
-
-
- -- The following is all Test Control Code
-
- -- Check that the return values are as expected
- if TC_Original_Transaction_Code /= This_Transaction.Code then
- -- Incorrect rendezvous
- Report.Failed ("Message Task: Incorrect code returned");
- end if;
-
- if This_Transaction.Code = Credit then
- if This_Transaction.Return_Value /= TC_Full_Value or not
- This_Transaction.TC_Thru_Distrib then
- Report.Failed ("Expected path not traversed - CR");
- end if;
- if
- This_Transaction.TC_Message_Count not in 1..2 then
- Report.Failed ("Incorrect Message Count");
- end if;
- else
- if This_Transaction.Return_Value /= Debit_Return or
- This_Transaction.TC_Message_Count /= 1 or not
- This_Transaction.TC_Thru_Distrib then
- Report.Failed ("Expected path not traversed - DB");
- end if;
- end if;
- TC_Tasks_Completed.Increment;
- exception
- when others =>
- Report.Failed ("Unexpected exception in Message_Task");
-
- end Message_Task;
-
-
-
- -- Dispose each input Transaction_Record to the appropriate
- -- computation tasks
- --
- task body Distributor is
-
- begin
- loop
- select
- accept Input (Transaction : acc_Transaction_Record) do
- -- Show that the message did pass through the Distributor Task
- Transaction.TC_Thru_Distrib := true;
-
- -- Pass this transaction on to the appropriate computation
- -- task
- case Transaction.Code is
- when Credit =>
- requeue Credit_Computation.Input with abort;
- when Debit =>
- requeue Debit_Computation.Input with abort;
- end case;
- end Input;
- or
- terminate;
- end select;
- end loop;
-
- exception
- when others =>
- Report.Failed ("Unexpected exception in Distributor");
- end Distributor;
-
-
-
-
- -- Computation task.
- -- Note: After the computation is performed in this task the message is
- -- passed on for further processing to some subsidiary task. The choice
- -- of subsidiary task is made according to criteria not specified in
- -- this test.
- --
- task body Credit_Computation is
- Message_Count : integer := 0;
- begin
- loop
- select
- accept Input ( Transaction : acc_Transaction_Record) do
- -- Perform the computations required for this transaction
- null; -- stub
-
- -- For the test:
- if not Transaction.TC_Thru_Distrib then
- Report.Failed
- ("Credit Task: Wrong queue, Distributor bypassed");
- end if;
- if Transaction.code /= Credit then
- Report.Failed
- ("Credit Task: Requeue delivered to the wrong queue");
- end if;
-
- -- for the test, plug a known value and count
- Transaction.Return_Value := TC_Credit_Value;
- Message_Count := Message_Count + 1;
- Transaction.TC_Message_Count := Message_Count;
-
- -- Depending on transaction content send it on to the
- -- some other task for further processing
- -- TC: Arbitrarily send the message on to Credit_Sub_1
- requeue Credit_Sub_1.Input with abort;
- end Input;
- or
- terminate;
- end select;
- end loop;
- exception
- when others =>
- Report.Failed ("Unexpected exception in Credit_Computation");
- end Credit_Computation;
-
-
-
- task body Credit_Sub_1 is
- begin
- loop
- select
- accept Input(Transaction : acc_Transaction_Record) do
- -- Process this transaction
- null; -- stub
-
- -- Add the value showing passage through this task
- Transaction.Return_Value :=
- Transaction.Return_Value + TC_Sub_1_Value;
- -- Depending on transaction content send it on to the
- -- some other task for further processing
- -- Arbitrarily send the message on to Credit_Sub_2
- requeue Credit_Sub_2.Input with abort;
- end Input;
- or
- terminate;
- end select;
- end loop;
- exception
- when others =>
- Report.Failed ("Unexpected exception in Credit_Sub_1");
-
- end Credit_Sub_1;
-
- task body Credit_Sub_2 is
- begin
- loop
- select
- accept Input(Transaction : acc_Transaction_Record) do
- -- Process this transaction
- null; -- stub
-
- -- Add the value showing passage through this task
- Transaction.Return_Value :=
- Transaction.Return_Value + TC_Sub_2_Value;
- -- Depending on transaction content send it on to the
- -- some other task for further processing
- -- Arbitrarily send the message on to Credit_Sub_3
- requeue Credit_Sub_3.Input with abort;
- end Input;
- or
- terminate;
- end select;
- end loop;
- exception
- when others =>
- Report.Failed ("Unexpected exception in Credit_Sub_2");
- end Credit_Sub_2;
-
- task body Credit_Sub_3 is
- begin
- loop
- select
- accept Input(Transaction : acc_Transaction_Record) do
- -- Process this transaction
- null; -- stub
-
- -- Add the value showing passage through this task
- Transaction.Return_Value :=
- Transaction.Return_Value + TC_Sub_3_Value;
- -- Depending on transaction content send it on to the
- -- some other task for further processing
- -- Arbitrarily send the message on to Credit_Sub_4
- requeue Credit_Sub_4.Input with abort;
- end Input;
- or
- terminate;
- end select;
- end loop;
- exception
- when others =>
- Report.Failed ("Unexpected exception in Credit_Sub_3");
- end Credit_Sub_3;
-
- -- This is the last in the chain of tasks to which transactions will
- -- be requeued
- --
- task body Credit_Sub_4 is
-
- TC_First_Message : Boolean := true;
-
- begin
- loop
- select
- accept Input(Transaction : acc_Transaction_Record) do
- -- Process this transaction
- null; -- stub
-
- -- Add the value showing passage through this task
- Transaction.Return_Value :=
- Transaction.Return_Value + TC_Sub_4_Value;
- -- TC: stay in the accept body dealing with the first message
- -- until the second arrives. If any of the requeues are
- -- blocked the test will hang here indicating failure
- if TC_First_Message then
- while Input'count = 0 loop
- delay ImpDef.Minimum_Task_Switch;
- end loop;
- TC_First_Message := false;
- end if;
- -- for the second message, just complete the rendezvous
- end Input;
- or
- terminate;
- end select;
- end loop;
- exception
- when others =>
- Report.Failed ("Unexpected exception in Credit_Sub_4");
- end Credit_Sub_4;
-
-
-
- -- Computation task.
- -- Note: After the computation is performed in this task and the
- -- accept body is completed the rendezvous in the original
- -- message task is completed.
- --
- task body Debit_Computation is
- Message_Count : integer := 0;
- begin
- loop
- select
- accept Input (Transaction : acc_Transaction_Record) do
- -- Perform the computations required for this message
- null; -- stub
-
- -- For the test:
- if not Transaction.TC_Thru_Distrib then
- Report.Failed
- ("Debit Task: Wrong queue, Distributor bypassed");
- end if;
- if Transaction.code /= Debit then
- Report.Failed
- ("Debit Task: Requeue delivered to the wrong queue");
- end if;
-
- -- for the test plug a known value and count
- Transaction.Return_Value := Debit_Return;
- -- one, and only one, message should pass through
- Message_Count := Message_Count + 1;
- Transaction.TC_Message_Count := Message_Count;
- end Input;
- or
- terminate;
- end select;
- end loop;
- exception
- when others =>
- Report.Failed ("Unexpected exception in Debit_Computation");
-
-
- end Debit_Computation;
-
-
-begin
-
- Report.Test ("C954015", "Test multiple levels of requeue to task entry");
-
- Line_Driver.Start; -- Start the test
-
- -- Ensure that the message tasks completed before calling Result
- while (TC_Tasks_Completed.Count < TC_Expected_To_Complete) loop
- delay ImpDef.Minimum_Task_Switch;
- end loop;
-
- Report.Result;
-
-end C954015;
diff --git a/gcc/testsuite/ada/acats/tests/c9/c954016.a b/gcc/testsuite/ada/acats/tests/c9/c954016.a
deleted file mode 100644
index 1390801eec0..00000000000
--- a/gcc/testsuite/ada/acats/tests/c9/c954016.a
+++ /dev/null
@@ -1,182 +0,0 @@
--- C954016.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that when a task that is called by a requeue is aborted, the
--- original caller receives Tasking_Error and the requeuing task is
--- unaffected.
---
--- TEST DESCRIPTION:
--- The Intermediate task requeues a call from the Original_Caller to the
--- Receiver. While the Receiver is in the accept body for this
--- rendezvous the Main aborts it. Check that Tasking_Error is raised in
--- the Original_Caller, that the Receiver does, indeed, get aborted and
--- the Intermediate task is undisturbed.
--- There are several delay loops in this test any one of which could
--- cause it to hang which would constitute failure.
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 25 Nov 95 SAIC Replaced shared global variable with protected
--- object for ACVC 2.0.1
---
---!
-
-with Report;
-with ImpDef;
-
-procedure C954016 is
-
- TC_Original_Caller_Complete : Boolean := false;
- TC_Intermediate_Complete : Boolean := false;
-
-
- protected type Shared_Boolean (Initial_Value : Boolean := False) is
- procedure Set_True;
- procedure Set_False;
- function Value return Boolean;
- private
- Current_Value : Boolean := Initial_Value;
- end Shared_Boolean;
-
- protected body Shared_Boolean is
- procedure Set_True is
- begin
- Current_Value := True;
- end Set_True;
-
- procedure Set_False is
- begin
- Current_Value := False;
- end Set_False;
-
- function Value return Boolean is
- begin
- return Current_Value;
- end Value;
- end Shared_Boolean;
-
- TC_Receiver_in_Accept : Shared_Boolean (False);
-
-
- task Original_Caller is
- entry Start;
- end Original_Caller;
-
- task Intermediate is
- entry Input;
- entry TC_Abort_Process_Complete;
- end Intermediate;
-
- task Receiver is
- entry Input;
- entry TC_Never_Called;
- end Receiver;
-
-
- task body Original_Caller is
- begin
- accept Start; -- wait for the trigger from Main
-
- Intermediate.Input;
- Report.Failed ("Tasking_Error not raised in Original_Caller task");
-
- exception
- when tasking_error =>
- TC_Original_Caller_Complete := true; -- expected behavior
- when others =>
- Report.Failed ("Unexpected Exception in Original_Caller task");
- end Original_Caller;
-
-
- task body Intermediate is
- begin
- accept Input do
- -- Within this accept call another task
- requeue Receiver.Input with abort;
- end Input;
-
- -- Wait for Main to ensure that the abort housekeeping is finished
- accept TC_Abort_Process_Complete;
-
- TC_Intermediate_Complete := true;
-
- exception
- when others =>
- Report.Failed ("Unexpected exception in Intermediate task");
- end Intermediate;
-
-
- task body Receiver is
- begin
- accept Input do
- TC_Receiver_in_Accept.Set_True;
- -- Hang within the accept body to allow Main to abort this task
- accept TC_Never_Called;
- end Input;
- exception
- when others =>
- Report.Failed ("Unexpected Exception in Receiver Task");
-
- end Receiver;
-
-
-begin
- Report.Test ("C954016", "Requeue: abort the called task");
-
- Original_Caller.Start;
-
- -- Wait till the rendezvous with Receiver is started
- while not TC_Receiver_in_Accept.Value loop
- delay ImpDef.Minimum_Task_Switch;
- end loop;
-
- -- At this point the Receiver is guaranteed to be in its accept
- --
- abort Receiver;
-
- -- Wait for the whole of the abort process to complete
- while not ( Original_Caller'terminated and Receiver'terminated ) loop
- delay ImpDef.Minimum_Task_Switch;
- end loop;
-
- -- Inform the Intermediate task that the process is complete to allow
- -- it to continue to completion itself
- Intermediate.TC_Abort_Process_Complete;
-
- -- Wait for everything to settle before reporting the result
- while not ( Intermediate'terminated ) loop
- delay ImpDef.Minimum_Task_Switch;
- end loop;
-
-
- if not ( TC_Original_Caller_Complete and TC_Intermediate_Complete ) then
- Report.Failed ("Proper paths not traversed");
- end if;
-
- Report.Result;
-
-end C954016;
diff --git a/gcc/testsuite/ada/acats/tests/c9/c954017.a b/gcc/testsuite/ada/acats/tests/c9/c954017.a
deleted file mode 100644
index a5447a756c5..00000000000
--- a/gcc/testsuite/ada/acats/tests/c9/c954017.a
+++ /dev/null
@@ -1,184 +0,0 @@
--- C954017.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that when an exception is raised in the rendezvous of a task
--- that was called by a requeue the exception is propagated to the
--- original caller and that the requeuing task is unaffected.
---
--- TEST DESCRIPTION:
--- The Intermediate task requeues a call from the Original_Caller to the
--- Receiver. While the Receiver is in the accept body for this
--- rendezvous a Constraint_Error exception is raised. Check that the
--- exception is propagated to the Original_Caller, that the Receiver's
--- normal exception logic is employed and that the Intermediate task
--- is undisturbed.
--- There are several delay loops in this test any one of which could
--- cause it to hang (and thus fail).
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 25 Nov 95 SAIC Fixed shared global variable problem for
--- ACVC 2.0.1
---
---!
-
-with Report;
-with ImpDef;
-
-
-procedure C954017 is
-
- TC_Original_Caller_Complete : Boolean := false;
- TC_Intermediate_Complete : Boolean := false;
- TC_Receiver_Complete : Boolean := false;
- TC_Exception : Exception;
-
-
- protected type Shared_Boolean (Initial_Value : Boolean := False) is
- procedure Set_True;
- procedure Set_False;
- function Value return Boolean;
- private
- Current_Value : Boolean := Initial_Value;
- end Shared_Boolean;
-
- protected body Shared_Boolean is
- procedure Set_True is
- begin
- Current_Value := True;
- end Set_True;
-
- procedure Set_False is
- begin
- Current_Value := False;
- end Set_False;
-
- function Value return Boolean is
- begin
- return Current_Value;
- end Value;
- end Shared_Boolean;
-
- TC_Exception_Process_Complete : Shared_Boolean (False);
-
- task Original_Caller is
- entry Start;
- end Original_Caller;
-
- task Intermediate is
- entry Input;
- end Intermediate;
-
- task Receiver is
- entry Input;
- end Receiver;
-
-
- task body Original_Caller is
- begin
- accept Start; -- wait for the trigger from Main
-
- Intermediate.Input;
- Report.Failed ("Exception not propagated to Original_Caller");
-
- exception
- when TC_Exception =>
- TC_Original_Caller_Complete := true; -- Expected behavior
- when others =>
- Report.Failed ("Unexpected Exception in Original_Caller task");
- end Original_Caller;
-
-
- task body Intermediate is
- begin
- accept Input do
- -- Within this accept call another task
- requeue Receiver.Input with abort;
- end Input;
-
- -- Wait for Main to ensure that the exception housekeeping is finished
- while not TC_Exception_Process_Complete.Value loop
- delay ImpDef.Minimum_Task_Switch;
- end loop;
-
- TC_Intermediate_Complete := true;
-
- exception
- when others =>
- Report.Failed ("Unexpected exception in Intermediate task");
- end Intermediate;
-
-
- task body Receiver is
- --
- begin
- accept Input do
- null; -- the user code for the rendezvous is stubbed out
-
- -- Test Control: Raise an exception in the destination task which
- -- should then be propagated
- raise TC_Exception;
-
- end Input;
- exception
- when TC_Exception =>
- TC_Receiver_Complete := true; -- expected behavior
- when others =>
- Report.Failed ("Unexpected Exception in Receiver Task");
- end Receiver;
-
-
-begin
-
- Report.Test ("C954017", "Requeue: exception processing");
-
- Original_Caller.Start; -- Start the test after the Report.Test
-
- -- Wait for the whole of the exception process to complete
- while not ( Original_Caller'terminated and Receiver'terminated ) loop
- delay ImpDef.Minimum_Task_Switch;
- end loop;
-
- -- Inform the Intermediate task that the process is complete to allow
- -- it to continue to completion itself
- TC_Exception_Process_Complete.Set_True;
-
- -- Wait for everything to settle before reporting the result
- while not ( Intermediate'terminated ) loop
- delay ImpDef.Minimum_Task_Switch;
- end loop;
-
-
- if not ( TC_Original_Caller_Complete and
- TC_Intermediate_Complete and
- TC_Receiver_Complete) then
- Report.Failed ("Proper paths not traversed");
- end if;
-
- Report.Result;
-
-end C954017;
diff --git a/gcc/testsuite/ada/acats/tests/c9/c954018.a b/gcc/testsuite/ada/acats/tests/c9/c954018.a
deleted file mode 100644
index a9da1e06bad..00000000000
--- a/gcc/testsuite/ada/acats/tests/c9/c954018.a
+++ /dev/null
@@ -1,227 +0,0 @@
--- C954018.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that if a task is aborted while a requeued call is queued
--- on one of its entries the original caller receives Tasking_Error
--- and the requeuing task is unaffected.
--- This test uses: Requeue to an entry in a different task
--- Parameterless call
--- Requeue with abort
---
--- TEST DESCRIPTION:
--- The Intermediate task requeues a call from the Original_Caller to the
--- Receiver on an entry with a guard that is always false. While the
--- Original_Caller is still queued the Receiver is aborted.
--- Check that Tasking_Error is raised in the Original_Caller, that the
--- Receiver does, indeed, get aborted and the Intermediate task
--- is undisturbed.
--- There are several delay loops in this test any one of which could
--- cause it to hang and thus indicate failure.
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
---
---!
-
-
-with Report;
-with ImpDef;
-
-
-procedure C954018 is
-
-
- -- Protected object to control the shared test variables
- --
- protected TC_State is
- function On_Entry_Queue return Boolean;
- procedure Set_On_Entry_Queue;
- function Original_Caller_Complete return Boolean;
- procedure Set_Original_Caller_Complete;
- function Intermediate_Complete return Boolean;
- procedure Set_Intermediate_Complete;
- private
- On_Entry_Queue_Flag : Boolean := false;
- Original_Caller_Complete_Flag : Boolean := false;
- Intermediate_Complete_Flag : Boolean := false;
- end TC_State;
- --
- --
- protected body TC_State is
- function On_Entry_Queue return Boolean is
- begin
- return On_Entry_Queue_Flag;
- end On_Entry_Queue;
-
- procedure Set_On_Entry_Queue is
- begin
- On_Entry_Queue_Flag := true;
- end Set_On_Entry_Queue;
-
- function Original_Caller_Complete return Boolean is
- begin
- return Original_Caller_Complete_Flag;
- end Original_Caller_Complete;
-
- procedure Set_Original_Caller_Complete is
- begin
- Original_Caller_Complete_Flag := true;
- end Set_Original_Caller_Complete;
-
- function Intermediate_Complete return Boolean is
- begin
- return Intermediate_Complete_Flag;
- end Intermediate_Complete;
-
- procedure Set_Intermediate_Complete is
- begin
- Intermediate_Complete_Flag := true;
- end Set_Intermediate_Complete;
-
- end TC_State;
-
- --================================
-
- task Original_Caller is
- entry Start;
- end Original_Caller;
-
- task Intermediate is
- entry Input;
- entry TC_Abort_Process_Complete;
- end Intermediate;
-
- task Receiver is
- entry Input;
- end Receiver;
-
-
- task body Original_Caller is
- begin
- accept Start; -- wait for the trigger from Main
-
- Intermediate.Input;
- Report.Failed ("Tasking_Error not raised in Original_Caller task");
-
- exception
- when tasking_error =>
- TC_State.Set_Original_Caller_Complete; -- expected behavior
- when others =>
- Report.Failed ("Unexpected Exception in Original_Caller task");
- end Original_Caller;
-
-
- task body Intermediate is
- begin
- accept Input do
- -- Within this accept call another task
- TC_State.Set_On_Entry_Queue;
- requeue Receiver.Input with abort;
- Report.Failed ("Requeue did not complete the Accept");
- end Input;
-
- -- Wait for Main to ensure that the abort housekeeping is finished
- accept TC_Abort_Process_Complete;
-
- TC_State.Set_Intermediate_Complete;
-
- exception
- when others =>
- Report.Failed ("Unexpected exception in Intermediate task");
- end Intermediate;
-
-
- task body Receiver is
- begin
- loop
- select
- -- A call to Input will be placed on the queue and never serviced
- when Report.Equal (1,2) => -- Always false
- accept Input do
- Report.Failed ("Receiver in Accept");
- end Input;
- or
- delay ImpDef.Minimum_Task_Switch;
- end select;
- end loop;
- exception
- when others =>
- Report.Failed ("Unexpected Exception in Receiver Task");
-
- end Receiver;
-
-
-begin
-
- Report.Test ("C954018", "Requeue: abort the called task" &
- " while Caller is still queued");
-
- Original_Caller.Start;
-
-
- -- This is the main part of the test
-
- -- Wait for the requeue
- while not TC_State.On_Entry_Queue loop
- delay ImpDef.Minimum_Task_Switch;
- end loop;
-
- -- Delay long enough to ensure that the requeue has "arrived" on
- -- the entry queue. Note: TC_State.Set_On_Entry_Queue is called the
- -- statement before the requeue
- --
- delay ImpDef.Switch_To_New_Task;
-
- -- At this point the Receiver is guaranteed to have the requeue on
- -- the entry queue
- --
- abort Receiver;
-
- -- Wait for the whole of the abort process to complete
- while not ( Original_Caller'terminated and Receiver'terminated ) loop
- delay ImpDef.Minimum_Task_Switch;
- end loop;
-
-
- -- Inform the Intermediate task that the process is complete to allow
- -- it to continue to completion itself
- Intermediate.TC_Abort_Process_Complete;
-
- -- Wait for everything to settle before reporting the result
- while not ( Intermediate'terminated ) loop
- delay ImpDef.Minimum_Task_Switch;
- end loop;
-
-
- if not ( TC_State.Original_Caller_Complete and
- TC_State.Intermediate_Complete ) then
- Report.Failed ("Proper paths not traversed");
- end if;
-
- Report.Result;
-
-end C954018;
diff --git a/gcc/testsuite/ada/acats/tests/c9/c954019.a b/gcc/testsuite/ada/acats/tests/c9/c954019.a
deleted file mode 100644
index fafc6aa591f..00000000000
--- a/gcc/testsuite/ada/acats/tests/c9/c954019.a
+++ /dev/null
@@ -1,314 +0,0 @@
--- C954019.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that when a requeue is to the same entry the items go to the
--- right queue and that they are placed back on the end of the queue.
---
--- TEST DESCRIPTION:
--- Simulate part of a message handling application where the messages are
--- composed of several segments. The sequence of the segments within the
--- message is specified by Seg_Sequence_No. The segments are handled by
--- different tasks and finally forwarded to an output driver. The
--- segments can arrive in any order but must be assembled into the proper
--- sequence for final output. There is a Sequencer task interposed
--- before the Driver. This takes the segments of the message off the
--- Ordering_Queue and those that are in the right order it sends on to
--- the driver; those that are out of order it places back on the end of
--- the queue.
---
--- The test just simulates the arrival of the segments at the Sequencer.
--- The task generating the segments handshakes with the Sequencer during
--- the "Await Arrival" phase ensuring that the three segments of a
--- message arrive in REVERSE order (the End-of-Message segment arrives
--- first and the Header last). In the first cycle the sequencer pulls
--- segments off the queue and puts them back on the end till it
--- encounters the header. It checks the sequence of the ones it pulls
--- off in case the segments are being put back on in the wrong part of
--- the queue. Having cycled once through it no longer verifies the
--- sequence - it just executes the "application" code for the correct
--- order for dispatch to the driver.
---
--- In this simple example no attempt is made to address segments of
--- another message arriving or any other error conditions (such as
--- missing segments, timing etc.)
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 19 Dec 94 SAIC Remove parameter from requeue statement
---
---!
-
-with Report;
-with ImpDef;
-
-procedure C954019 is
-begin
-
-
- Report.Test ("C954019", "Check Requeue to the same Accept");
-
- declare -- encapsulate the test
-
- type Segment_Sequence is range 1..8;
- Header : constant Segment_Sequence := Segment_Sequence'first;
-
- type Message_Segment is record
- ID : integer; -- Message ID
- Seg_Sequence_No : Segment_Sequence; -- Within the message
- Alpha : string (1..128);
- EOM : Boolean := false; -- true for final msg segment
- end record;
- type acc_Message_Segment is access Message_Segment;
-
- task TC_Simulate_Arrival;
-
- task type Carrier_Task is
- entry Input ( Segment : acc_Message_Segment );
- end Carrier_Task;
- type acc_Carrier_Task is access Carrier_Task;
-
- task Sequencer is
- entry Ordering_Queue ( Segment : acc_Message_Segment );
- entry TC_Handshake_1;
- entry TC_Handshake_2;
- end Sequencer;
-
- task Output_Driver is
- entry Input ( Segment : acc_Message_Segment );
- end Output_Driver;
-
-
- -- Simulate the arrival of three message segments in REVERSE order
- --
- task body TC_Simulate_Arrival is
- begin
-
- for i in 1..3 loop
- declare
- -- Create a task for the next message segment
- Next_Segment_Task : acc_Carrier_Task := new Carrier_Task;
- -- Create a record for the next segment
- Next_Segment : acc_Message_Segment := new Message_Segment;
- begin
- if i = 1 then
- -- Build the EOM segment as the first to "send"
- Next_Segment.Seg_Sequence_No := Header + 2;
- Next_Segment.EOM := true;
- elsif i = 2 then
- -- Wait for the first segment to arrive at the Sequencer
- -- before "sending" the second
- Sequencer.TC_Handshake_1;
- -- Build the segment
- Next_Segment.Seg_Sequence_No := Header + 1;
- else
- -- Wait for the second segment to arrive at the Sequencer
- -- before "sending" the third
- Sequencer.TC_Handshake_2;
- -- Build the segment. The last segment in order to
- -- arrive will be the "header" segment
- Next_Segment.Seg_Sequence_No := Header;
- end if;
- -- pass the record to its carrier
- Next_Segment_Task.Input ( Next_Segment );
- end;
- end loop;
- exception
- when others =>
- Report.Failed ("Unexpected Exception in TC_Simulate_Arrival");
- end TC_Simulate_Arrival;
-
-
- -- One of these is generated for each message segment and the flow
- -- of the segments through the system is controlled by the calls the
- -- task makes and the requeues of those calls
- --
- task body Carrier_Task is
- This_Segment : acc_Message_Segment := new Message_Segment;
- begin
- accept Input ( Segment : acc_Message_Segment ) do
- This_Segment.all := Segment.all;
- end Input;
- null; --:: stub. Pass the segment around the application as needed
-
- -- Now output the segment to the Output_Driver. First we have to
- -- go through the Sequencer.
- Sequencer.Ordering_Queue ( This_Segment );
- exception
- when others =>
- Report.Failed ("Unexpected Exception in Carrier_Task");
- end Carrier_Task;
-
-
- -- Pull segments off the Ordering_Queue and deliver them in the correct
- -- sequence to the Output_Driver.
- --
- task body Sequencer is
- Next_Needed : Segment_Sequence := Header;
-
- TC_Await_Arrival : Boolean := true;
- TC_First_Cycle : Boolean := true;
- TC_Expected_Sequence : Segment_Sequence := Header+2;
- begin
- loop
- select
- accept Ordering_Queue ( Segment : acc_Message_Segment ) do
-
- --=====================================================
- -- This part is all Test_Control code
-
- if TC_Await_Arrival then
- -- We have to arrange that the segments arrive on the
- -- queue in the right order, so we handshake with the
- -- TC_Simulate_Arrival task to "send" only one at
- -- a time
- accept TC_Handshake_1; -- the first has arrived
- -- and has been pulled off the
- -- queue
-
- -- Wait for the second to arrive (the first has already
- -- been pulled off the queue
- while Ordering_Queue'count < 1 loop
- delay ImpDef.Minimum_Task_Switch;
- end loop;
- --
- accept TC_Handshake_2; -- the second has arrived
-
- -- Wait for the third to arrive
- while Ordering_Queue'count < 2 loop
- delay ImpDef.Minimum_Task_Switch;
- end loop;
-
- -- Subsequent passes through the loop, bypass this code
- TC_Await_Arrival := false;
-
-
- end if; -- await arrival
-
- if TC_First_Cycle then
- -- Check the order of the original three
- if Segment.Seg_Sequence_No /= TC_Expected_Sequence then
- -- The segments are not being pulled off in the
- -- expected sequence. This could occur if the
- -- requeue is not putting them back on the end.
- Report.Failed ("Sequencer: Segment out of sequence");
- end if; -- sequence check
- -- Decrement the expected sequence
- if TC_Expected_Sequence /= Header then
- TC_Expected_Sequence := TC_Expected_Sequence - 1;
- else
- TC_First_Cycle := false; -- This is the Header - the
- -- first two segments are
- -- back on the queue
-
- end if; -- decrementing
- end if; -- first pass
- --=====================================================
-
- -- And this is the Application code
- if Segment.Seg_Sequence_No = Next_Needed then
- if Segment.EOM then
- Next_Needed := Header; -- reset for next message
- else
- Next_Needed := Next_Needed + 1;
- end if;
- requeue Output_Driver.Input with abort;
- Report.Failed ("Requeue did not complete accept body");
- else
- -- Not the next needed - put it back on the queue
- requeue Sequencer.Ordering_Queue;
- Report.Failed ("Requeue did not complete accept body");
- end if;
- end Ordering_Queue;
- or
- terminate;
- end select;
- end loop;
- exception
- when others =>
- Report.Failed ("Unexpected Exception in Sequencer");
- end Sequencer;
-
-
- task body Output_Driver is
- This_Segment : acc_Message_Segment := new Message_Segment;
-
- TC_Expected_Sequence : Segment_Sequence := Segment_Sequence'first;
- TC_Segment_Total : integer := 0;
- TC_Expected_Total : integer := 3;
- begin
- loop
- -- Note: normally we would expect this Accept to be in a select
- -- with terminate. For the test we exit the loop on completion
- -- to give better control
- accept Input ( Segment : acc_Message_Segment ) do
- This_Segment.all := Segment.all;
- end Input;
-
- null; --::: stub - output the next segment of the message
-
- -- The following is all test control code
- --
- if This_Segment.Seg_Sequence_No /= TC_Expected_Sequence then
- Report.Failed ("Output_Driver: Segment out of sequence");
- end if;
- TC_Expected_Sequence := TC_Expected_Sequence + 1;
-
- -- Now count the number of segments
- TC_Segment_Total := TC_Segment_Total + 1;
-
- -- Check the number and exit loop when complete
- -- There must be exactly TC_Expected_Total in number and
- -- the last one must be EOM
- -- (test will hang if < TC_Expected_Total arrive
- -- without EOM)
- if This_Segment.EOM then
- -- This is the last segment.
- if TC_Segment_Total /= TC_Expected_Total then
- Report.Failed ("EOM and wrong number of segments");
- end if;
- exit; -- the loop and terminate the task
- elsif TC_Segment_Total = TC_Expected_Total then
- Report.Failed ("No EOM found");
- exit;
- end if;
- end loop;
- exception
- when others =>
- Report.Failed ("Unexpected Exception in Output_Driver");
- end Output_Driver;
-
-
-
- begin
-
- null;
-
- end; -- encapsulation
-
- Report.Result;
-
-end C954019;
diff --git a/gcc/testsuite/ada/acats/tests/c9/c954020.a b/gcc/testsuite/ada/acats/tests/c9/c954020.a
deleted file mode 100644
index bc08a6bd4c2..00000000000
--- a/gcc/testsuite/ada/acats/tests/c9/c954020.a
+++ /dev/null
@@ -1,422 +0,0 @@
--- C954020.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that a call to a protected entry can be requeued to a task
--- entry. Check that the requeue is placed on the correct entry; that the
--- original caller waits for the completion of the requeue and continues
--- after the requeued rendezvous. Check that the requeue does not block.
--- Specifically, check a requeue with abort from a protected entry to
--- an entry in a task.
---
--- TEST DESCRIPTION:
---
--- In the Distributor protected object, requeue two successive calls on
--- the entries of two separate target tasks. Each task in each of the
--- paths adds identifying information in the transaction being passed.
--- This information is checked by the Message tasks on completion
--- ensuring that the requeues have been placed on the correct queues.
--- There is an artificial guard on the Credit Task to ensure that the
--- input is queued; this guard is released by the Debit task which
--- handles its input immediately. This ensures that we have one of the
--- requeued items actually queued for later handling and also verifies
--- that the requeuing process (in the protected object) is not blocked.
---
--- This series of tests uses a simulation of a transaction driven
--- processing system. Line Drivers accept input from an external source
--- and build them into transaction records. These records are then
--- encapsulated in message tasks which remain extant for the life of the
--- transaction in the system. The message tasks put themselves on the
--- input queue of a Distributor object which, from information in the
--- transaction and/or system load conditions forwards them to other
--- operating tasks. These in turn might forward the transactions to yet
--- other tasks for further action. The routing is, in real life,
--- dynamic and unpredictable at the time of message generation. All
--- rerouting in this model is done by means of requeues.
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 06 Nov 95 SAIC Fixed problems for ACVC 2.0.1
---
---!
-
-with Report;
-with ImpDef;
-
-procedure C954020 is
- Verbose : constant Boolean := False;
-
- -- Arbitrary test values
- Credit_Return : constant := 1;
- Debit_Return : constant := 2;
-
- protected type Message_Status is
- procedure Set_Complete;
- function Complete return Boolean;
- private
- Is_Complete : Boolean := False;
- end Message_Status;
-
- protected body Message_Status is
- procedure Set_Complete is
- begin
- Is_Complete := True;
- end Set_Complete;
-
- function Complete return Boolean is
- begin
- return Is_Complete;
- end Complete;
- end Message_Status;
-
- TC_Debit_Message : Message_Status;
- TC_Credit_Message : Message_Status;
-
- type Transaction_Code is (Credit, Debit);
-
- type Transaction_Record;
- type acc_Transaction_Record is access Transaction_Record;
- type Transaction_Record is
- record
- ID : integer := 0;
- Code : Transaction_Code := Debit;
- Account_Number : integer := 0;
- Stock_Number : integer := 0;
- Quantity : integer := 0;
- Return_Value : integer := 0;
- TC_Message_Count : integer := 0;
- TC_Thru_Dist : Boolean := false;
- end record;
-
-
- task type Message_Task is
- entry Accept_Transaction (In_Transaction : acc_Transaction_Record);
- end Message_Task;
- type acc_Message_Task is access Message_Task;
-
- task Line_Driver is
- entry Start;
- end Line_Driver;
-
- task Credit_Computation is
- entry Input(Transaction : acc_Transaction_Record);
- end Credit_Computation;
-
- task Debit_Computation is
- entry Input(Transaction : acc_Transaction_Record);
- end Debit_Computation;
-
- protected Time_Lock is
- procedure Credit_Start;
- function Credit_Enabled return Boolean;
- private
- Credit_OK : Boolean := false;
- end Time_Lock;
-
- protected body Time_Lock is
- procedure Credit_Start is
- begin
- Credit_OK := true;
- end Credit_Start;
-
- function Credit_Enabled return Boolean is
- begin
- return Credit_OK;
- end Credit_Enabled;
- end Time_Lock;
-
-
-
- protected Distributor is
- entry Input (Transaction : acc_Transaction_Record);
- end Distributor;
- --
- --
- -- Dispose each input Transaction_Record to the appropriate
- -- computation tasks
- --
- protected body Distributor is
- entry Input (Transaction : acc_Transaction_Record) when true is
- -- barrier is always open
- begin
- -- Test Control: Set the indicator in the message to show it has
- -- passed through the Distributor object
- Transaction.TC_thru_Dist := true;
-
- -- Pass this transaction on to the appropriate computation
- -- task
- case Transaction.Code is
- when Credit =>
- requeue Credit_Computation.Input with abort;
- when Debit =>
- requeue Debit_Computation.Input with abort;
- end case;
- end Input;
- end Distributor;
-
-
-
-
- -- Assemble messages received from an external source
- -- Creates a message task for each. The message tasks remain extant
- -- for the life of the messages in the system.
- -- The Line Driver task would normally be designed to loop continuously
- -- creating the messages as input is received. Simulate this
- -- but limit it to two dummy messages for this test and allow it
- -- to terminate at that point
- --
- task body Line_Driver is
- Current_ID : integer := 1;
- TC_Last_was_for_credit : Boolean := false;
-
- procedure Build_Credit_Record
- ( Next_Transaction : acc_Transaction_Record ) is
- Dummy_Account : constant integer := 100;
- begin
- Next_Transaction.ID := Current_ID;
- Next_Transaction.Code := Credit;
-
- Next_Transaction.Account_Number := Dummy_Account;
- Current_ID := Current_ID + 1;
- end Build_Credit_Record;
-
-
- procedure Build_Debit_Record
- ( Next_Transaction : acc_Transaction_Record ) is
- Dummy_Account : constant integer := 200;
- begin
- Next_Transaction.ID := Current_ID;
- Next_Transaction.Code := Debit;
-
- Next_Transaction.Account_Number := Dummy_Account;
- Current_ID := Current_ID + 1;
- end Build_Debit_Record;
-
- begin
-
- accept Start; -- Wait for trigger from Main
-
- for i in 1..2 loop -- arbitrarily limit to two messages for the test
- declare
- -- Create a task for the next message
- Next_Message_Task : acc_Message_Task := new Message_Task;
- -- Create a record for it
- Next_Transaction : acc_Transaction_Record
- := new Transaction_Record;
- begin
- if TC_Last_was_for_credit then
- Build_Debit_Record ( Next_Transaction );
- else
- Build_Credit_Record( Next_Transaction );
- TC_Last_was_for_credit := true;
- end if;
- Next_Message_Task.Accept_Transaction ( Next_Transaction );
- end; -- declare
- end loop;
-
- exception
- when others =>
- Report.Failed ("Unexpected exception in Line_Driver");
- end Line_Driver;
-
-
-
-
- task body Message_Task is
-
- TC_Original_Transaction_Code : Transaction_Code;
- This_Transaction : acc_Transaction_Record := new Transaction_Record;
-
- begin
- accept Accept_Transaction (In_Transaction : acc_Transaction_Record) do
- This_Transaction.all := In_Transaction.all;
- end Accept_Transaction;
-
- if Verbose then
- Report.Comment ("message task got " &
- Transaction_Code'Image (This_Transaction.Code));
- end if;
-
- -- Note the original code to ensure correct return
- TC_Original_Transaction_Code := This_Transaction.Code;
-
- -- Queue up on Distributor's Input queue
- Distributor.Input ( This_Transaction );
- -- This task will now wait for the requeued rendezvous
- -- to complete before proceeding
-
- -- After the required computations have been performed
- -- return the Transaction_Record appropriately (probably to an output
- -- line driver)
- null; -- stub
-
-
- -- The following is all Test Control Code
-
- -- Check that the return values are as expected
- if TC_Original_Transaction_Code /= This_Transaction.Code then
- -- Incorrect rendezvous
- Report.Failed ("Message Task: Incorrect code returned");
- end if;
-
- if This_Transaction.Code = Credit then
- if This_Transaction.Return_Value /= Credit_Return or
- This_Transaction.TC_Message_Count /= 1 or
- not This_Transaction.TC_thru_Dist then
- Report.Failed ("Expected path not traversed");
- end if;
- TC_Credit_Message.Set_Complete;
- else
- if This_Transaction.Return_Value /= Debit_Return or
- This_Transaction.TC_Message_Count /= 1 or
- not This_Transaction.TC_thru_Dist then
- Report.Failed ("Expected path not traversed");
- end if;
- TC_Debit_Message.Set_Complete;
- end if;
-
- exception
- when others =>
- Report.Failed ("Unexpected exception in Message_Task");
-
- end Message_Task;
-
-
-
- -- Computation task.
- -- Note: After the computation is performed in this task and the
- -- accept body is completed the rendezvous in the original
- -- message task is completed.
- --
- task body Credit_Computation is
- Message_Count : integer := 0;
- begin
- loop
- select
- when Time_Lock.Credit_enabled =>
- accept Input ( Transaction : acc_Transaction_Record) do
- -- Perform the computations required for this transaction
- null; -- stub
-
- if Verbose then
- Report.Comment ("Credit_Computation in accept");
- end if;
-
- -- For the test:
- if not Transaction.TC_thru_Dist then
- Report.Failed
- ("Credit Task: Wrong queue, Distributor bypassed");
- end if;
- if Transaction.code /= Credit then
- Report.Failed
- ("Credit Task: Requeue delivered to the wrong queue");
- end if;
-
- -- for the test plug a known value and count
- Transaction.Return_Value := Credit_Return;
- -- one, and only one message should pass through
- Message_Count := Message_Count + 1;
- Transaction.TC_Message_Count := Message_Count;
-
- end Input;
- exit; -- only handle 1 transaction
- else
- -- poll until we can accept credit transaction
- delay ImpDef.Clear_Ready_Queue;
- end select;
- end loop;
- exception
- when others =>
- Report.Failed ("Unexpected exception in Credit_Computation");
- end Credit_Computation;
-
-
-
- -- Computation task.
- -- Note: After the computation is performed in this task and the
- -- accept body is completed the rendezvous in the original
- -- message task is completed.
- --
- task body Debit_Computation is
- Message_Count : integer := 0;
- begin
- loop
- select
- accept Input (Transaction : acc_Transaction_Record) do
- -- Perform the computations required for this message
- null; -- stub
-
- if Verbose then
- Report.Comment ("Debit_Computation in accept");
- end if;
-
- -- For the test:
- if not Transaction.TC_thru_Dist then
- Report.Failed
- ("Debit Task: Wrong queue, Distributor bypassed");
- end if;
- if Transaction.code /= Debit then
- Report.Failed
- ("Debit Task: Requeue delivered to the wrong queue");
- end if;
-
- -- for the test plug a known value and count
- Transaction.Return_Value := Debit_Return;
- -- one, and only one, message should pass through
- Message_Count := Message_Count + 1;
- Transaction.TC_Message_Count := Message_Count;
- -- for the test: once we have completed the only Debit
- -- message release the Credit Messages which are queued
- -- on the Credit Input queue
- Time_Lock.Credit_Start;
- end Input;
- or
- terminate;
- end select;
- end loop;
- exception
- when others =>
- Report.Failed ("Unexpected exception in Debit_Computation");
-
-
- end Debit_Computation;
-
-
-begin -- C954020
-
- Report.Test ("C954020", "Requeue, with abort, from protected entry " &
- "to task entry");
-
- Line_Driver.Start; -- Start the test
-
- -- Ensure that the message tasks complete before reporting the result
- while not (TC_Credit_Message.Complete and TC_Debit_Message.Complete) loop
- delay ImpDef.Minimum_Task_Switch;
- end loop;
-
- Report.Result;
-
-end C954020;
diff --git a/gcc/testsuite/ada/acats/tests/c9/c954021.a b/gcc/testsuite/ada/acats/tests/c9/c954021.a
deleted file mode 100644
index 626f2f970a2..00000000000
--- a/gcc/testsuite/ada/acats/tests/c9/c954021.a
+++ /dev/null
@@ -1,524 +0,0 @@
--- C954021.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that a requeue within a protected entry to an entry in a
--- different protected object is queued correctly.
---
--- TEST DESCRIPTION:
--- One transaction is sent through to check the paths. After processing
--- this the Credit task sets the "overloaded" indicator. Once this
--- indicator is set the Distributor (a protected object) queues low
--- priority transactions on a Wait_for_Underload queue in another
--- protected object using a requeue. The Distributor still delivers high
--- priority transactions. After two high priority transactions have been
--- processed by the Credit task it clears the overload condition. The
--- low priority transactions should now be delivered.
---
--- This series of tests uses a simulation of a transaction driven
--- processing system. Line Drivers accept input from an external source
--- and build them into transaction records. These records are then
--- encapsulated in message tasks which remain extant for the life of the
--- transaction in the system. The message tasks put themselves on the
--- input queue of a Distributor which, from information in the
--- transaction and/or system load conditions forwards them to other
--- operating tasks. These in turn might forward the transactions to yet
--- other tasks for further action. The routing is, in real life, dynamic
--- and unpredictable at the time of message generation. All rerouting in
--- this model is done by means of requeues.
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 26 Nov 95 SAIC Fixed shared global variable for ACVC 2.0.1
---
---!
-
-with Report;
-with ImpDef;
-
-procedure C954021 is
-
- -- Arbitrary test values
- Credit_Return : constant := 1;
- Debit_Return : constant := 2;
-
-
- -- Mechanism to count the number of Credit Message tasks completed
- protected TC_Tasks_Completed is
- procedure Increment;
- function Count return integer;
- private
- Number_Complete : integer := 0;
- end TC_Tasks_Completed;
-
-
- TC_Credit_Messages_Expected : constant integer := 5;
-
- protected TC_Handshake is
- procedure Set;
- function First_Message_Arrived return Boolean;
- private
- Arrived_Flag : Boolean := false;
- end TC_Handshake;
-
- -- Handshaking mechanism between the Line Driver and the Credit task
- --
- protected body TC_Handshake is
- --
- procedure Set is
- begin
- Arrived_Flag := true;
- end Set;
- --
- function First_Message_Arrived return Boolean is
- begin
- return Arrived_Flag;
- end First_Message_Arrived;
- --
- end TC_Handshake;
-
-
- protected type Shared_Boolean (Initial_Value : Boolean := False) is
- procedure Set_True;
- procedure Set_False;
- function Value return Boolean;
- private
- Current_Value : Boolean := Initial_Value;
- end Shared_Boolean;
-
- protected body Shared_Boolean is
- procedure Set_True is
- begin
- Current_Value := True;
- end Set_True;
-
- procedure Set_False is
- begin
- Current_Value := False;
- end Set_False;
-
- function Value return Boolean is
- begin
- return Current_Value;
- end Value;
- end Shared_Boolean;
-
- TC_Debit_Message_Complete : Shared_Boolean (False);
-
- type Transaction_Code is (Credit, Debit);
- type Transaction_Priority is (High, Low);
-
- type Transaction_Record;
- type acc_Transaction_Record is access Transaction_Record;
- type Transaction_Record is
- record
- ID : integer := 0;
- Code : Transaction_Code := Debit;
- Priority : Transaction_Priority := High;
- Account_Number : integer := 0;
- Stock_Number : integer := 0;
- Quantity : integer := 0;
- Return_Value : integer := 0;
- TC_Message_Count : integer := 0;
- TC_Thru_Dist : Boolean := false;
- end record;
-
-
- task type Message_Task is
- entry Accept_Transaction (In_Transaction : acc_Transaction_Record);
- end Message_Task;
- type acc_Message_Task is access Message_Task;
-
- task Line_Driver is
- entry Start;
- end Line_Driver;
-
- protected Distributor is
- procedure Set_Credit_Overloaded;
- procedure Clear_Credit_Overloaded;
- function Credit_is_Overloaded return Boolean;
- entry Input (Transaction : acc_Transaction_Record);
- private
- Credit_Overloaded : Boolean := false;
- end Distributor;
-
- protected Hold is
- procedure Underloaded;
- entry Wait_for_Underload (Transaction : acc_Transaction_Record);
- private
- Release_All : Boolean := false;
- end Hold;
-
- task Credit_Computation is
- entry Input(Transaction : acc_Transaction_Record);
- end Credit_Computation;
-
- task Debit_Computation is
- entry Input(Transaction : acc_Transaction_Record);
- end Debit_Computation;
-
- --
- -- Dispose each input Transaction_Record to the appropriate
- -- computation tasks
- --
- protected body Distributor is
-
- procedure Set_Credit_Overloaded is
- begin
- Credit_Overloaded := true;
- end Set_Credit_Overloaded;
-
- procedure Clear_Credit_Overloaded is
- begin
- Credit_Overloaded := false;
- Hold.Underloaded; -- Release all held messages
- end Clear_Credit_Overloaded;
-
- function Credit_is_Overloaded return Boolean is
- begin
- return Credit_Overloaded;
- end Credit_is_Overloaded;
-
-
- entry Input (Transaction : acc_Transaction_Record) when true is
- -- barrier is always open
- begin
- -- Test Control: Set the indicator in the message to show it has
- -- passed through the Distributor object
- Transaction.TC_thru_Dist := true;
-
- -- Pass this transaction on to the appropriate computation
- -- task but temporarily hold low-priority transactions under
- -- overload conditions
- case Transaction.Code is
- when Credit =>
- if Credit_Overloaded and Transaction.Priority = Low then
- requeue Hold.Wait_for_Underload with abort;
- else
- requeue Credit_Computation.Input with abort;
- end if;
- when Debit =>
- requeue Debit_Computation.Input with abort;
- end case;
- end Input;
- end Distributor;
-
-
- -- Low priority Message tasks are held on the Wait_for_Underload queue
- -- while the Credit computation system is overloaded. Once the Credit
- -- system reached underload send all queued messages immediately
- --
- protected body Hold is
-
- -- Once this is executed the barrier condition for the entry is
- -- evaluated
- procedure Underloaded is
- begin
- Release_All := true;
- end Underloaded;
-
- entry Wait_for_Underload (Transaction : acc_Transaction_Record)
- when Release_All is
- begin
- requeue Credit_Computation.Input with abort;
- if Wait_for_Underload'count = 0 then
- -- Queue is purged. Set up to hold next batch
- Release_All := false;
- end if;
- end Wait_for_Underload;
-
- end Hold;
-
- -- Mechanism to count the number of Message tasks completed (Credit)
- protected body TC_Tasks_Completed is
- procedure Increment is
- begin
- Number_Complete := Number_Complete + 1;
- end Increment;
-
- function Count return integer is
- begin
- return Number_Complete;
- end Count;
- end TC_Tasks_Completed;
-
-
- -- Assemble messages received from an external source
- -- Creates a message task for each. The message tasks remain extant
- -- for the life of the messages in the system.
- -- The Line Driver task would normally be designed to loop continuously
- -- creating the messages as input is received. Simulate this
- -- but limit it to the required number of dummy messages needed for
- -- this test and allow it to terminate at that point. Artificially
- -- alternate High and Low priority Credit transactions for this test.
- --
- task body Line_Driver is
- Current_ID : integer := 1;
- Current_Priority : Transaction_Priority := High;
-
- -- Artificial: number of messages required for this test
- type TC_Trans_Range is range 1..6;
-
- procedure Build_Credit_Record
- ( Next_Transaction : acc_Transaction_Record ) is
- Dummy_Account : constant integer := 100;
- begin
- Next_Transaction.ID := Current_ID;
- Next_Transaction.Code := Credit;
- Next_Transaction.Priority := Current_Priority;
-
- Next_Transaction.Account_Number := Dummy_Account;
- Current_ID := Current_ID + 1;
- end Build_Credit_Record;
-
-
- procedure Build_Debit_Record
- ( Next_Transaction : acc_Transaction_Record ) is
- Dummy_Account : constant integer := 200;
- begin
- Next_Transaction.ID := Current_ID;
- Next_Transaction.Code := Debit;
-
- Next_Transaction.Account_Number := Dummy_Account;
- Current_ID := Current_ID + 1;
- end Build_Debit_Record;
-
- begin
-
- accept Start; -- Wait for trigger from Main
-
- for Transaction_Numb in TC_Trans_Range loop -- TC: limit the loop
- declare
- -- Create a task for the next message
- Next_Message_Task : acc_Message_Task := new Message_Task;
- -- Create a record for it
- Next_Transaction : acc_Transaction_Record :=
- new Transaction_Record;
- begin
- if Transaction_Numb = TC_Trans_Range'first then
- -- Send the first Credit message
- Build_Credit_Record ( Next_Transaction );
- Next_Message_Task.Accept_Transaction ( Next_Transaction );
- -- TC: Wait until the first message has been received by the
- -- Credit task and it has set the Overload indicator for the
- -- Distributor
- while not TC_Handshake.First_Message_Arrived loop
- delay ImpDef.Minimum_Task_Switch;
- end loop;
- elsif Transaction_Numb = TC_Trans_Range'last then
- -- For this test send the last transaction to the Debit task
- -- to improve the mix
- Build_Debit_Record( Next_Transaction );
- Next_Message_Task.Accept_Transaction ( Next_Transaction );
- else
- -- TC: Alternate high and low priority transactions
- if Current_Priority = High then
- Current_Priority := Low;
- else
- Current_Priority := High;
- end if;
- Build_Credit_Record( Next_Transaction );
- Next_Message_Task.Accept_Transaction ( Next_Transaction );
- end if;
- end; -- declare
- end loop;
-
- exception
- when others =>
- Report.Failed ("Unexpected exception in Line_Driver");
- end Line_Driver;
-
-
-
-
- task body Message_Task is
-
- TC_Original_Transaction_Code : Transaction_Code;
- This_Transaction : acc_Transaction_Record := new Transaction_Record;
-
- begin
-
- accept Accept_Transaction (In_Transaction : acc_Transaction_Record) do
- This_Transaction.all := In_Transaction.all;
- end Accept_Transaction;
-
- -- Note the original code to ensure correct return
- TC_Original_Transaction_Code := This_Transaction.Code;
-
- -- Queue up on Distributor's Input queue
- Distributor.Input ( This_Transaction );
- -- This task will now wait for the requeued rendezvous
- -- to complete before proceeding
-
- -- After the required computations have been performed
- -- return the Transaction_Record appropriately (probably to an output
- -- line driver)
- null; -- stub
-
- -- For the test check that the return values are as expected
- if TC_Original_Transaction_Code /= This_Transaction.Code then
- -- Incorrect rendezvous
- Report.Failed ("Message Task: Incorrect code returned");
- end if;
-
- if This_Transaction.Code = Credit then
- if This_Transaction.Return_Value /= Credit_Return or
- not This_Transaction.TC_thru_Dist then
- Report.Failed ("Expected path not traversed - Credit");
- end if;
- TC_Tasks_Completed.Increment;
- else
- if This_Transaction.Return_Value /= Debit_Return or
- This_Transaction.TC_Message_Count /= 1 or
- not This_Transaction.TC_thru_Dist then
- Report.Failed ("Expected path not traversed - Debit");
- end if;
- TC_Debit_Message_Complete.Set_True;
- end if;
-
- exception
- when others =>
- Report.Failed ("Unexpected exception in Message_Task");
- end Message_Task;
-
-
-
-
-
- -- Computation task. After the computation is performed the rendezvous
- -- in the original message task is completed.
- task body Credit_Computation is
-
- Message_Count : integer := 0;
-
- begin
- loop
- select
- accept Input ( Transaction : acc_Transaction_Record) do
- if Distributor.Credit_is_Overloaded
- and Transaction.Priority = Low then
- -- We should not be getting any Low Priority messages. They
- -- should be waiting on the Hold.Wait_for_Underload
- -- queue
- Report.Failed
- ("Credit Task: Low priority transaction during overload");
- end if;
- -- Perform the computations required for this transaction
- null; -- stub
-
- -- For the test:
- if not Transaction.TC_thru_Dist then
- Report.Failed
- ("Credit Task: Wrong queue, Distributor bypassed");
- end if;
- if Transaction.code /= Credit then
- Report.Failed
- ("Credit Task: Requeue delivered to the wrong queue");
- end if;
-
- -- The following is all Test Control code:
- Transaction.Return_Value := Credit_Return;
- Message_Count := Message_Count + 1;
- --
- -- Now take special action depending on which Message
- if Message_Count = 1 then
- -- After the first message :
- Distributor.Set_Credit_Overloaded;
- -- Now flag the Line_Driver that the second and subsequent
- -- messages may now be sent
- TC_Handshake.Set;
- end if;
- if Message_Count = 3 then
- -- The two high priority transactions created subsequent
- -- to the overload have now been processed
- Distributor.Clear_Credit_Overloaded;
- end if;
- end Input;
- or
- terminate;
- end select;
- end loop;
- exception
- when others =>
- Report.Failed ("Unexpected exception in Credit_Computation");
- end Credit_Computation;
-
-
-
- -- Computation task. After the computation is performed the rendezvous
- -- in the original message task is completed.
- --
- task body Debit_Computation is
- Message_Count : integer := 0;
- begin
- loop
- select
- accept Input (Transaction : acc_Transaction_Record) do
- -- Perform the computations required for this message
- null; -- stub
-
- -- For the test:
- if not Transaction.TC_thru_Dist then
- Report.Failed
- ("Debit Task: Wrong queue, Distributor bypassed");
- end if;
- if Transaction.code /= Debit then
- Report.Failed
- ("Debit Task: Requeue delivered to the wrong queue");
- end if;
-
- -- for the test plug a known value and count
- Transaction.Return_Value := Debit_Return;
- -- one, and only one, message should pass through
- Message_Count := Message_Count + 1;
- Transaction.TC_Message_Count := Message_Count;
- end Input;
- or
- terminate;
- end select;
- end loop;
- exception
- when others =>
- Report.Failed ("Unexpected exception in Debit_Computation");
- end Debit_Computation;
-
-
-begin
- Report.Test ("C954021", "Requeue from one entry body to an entry in" &
- " another protected object");
-
- Line_Driver.Start; -- Start the test
-
-
- -- Ensure that the message tasks have completed before reporting result
- while (TC_Tasks_Completed.Count < TC_Credit_Messages_Expected)
- and not TC_Debit_Message_Complete.Value loop
- delay ImpDef.Minimum_Task_Switch;
- end loop;
-
- Report.Result;
-
-end C954021;
diff --git a/gcc/testsuite/ada/acats/tests/c9/c954022.a b/gcc/testsuite/ada/acats/tests/c9/c954022.a
deleted file mode 100644
index 5ebff8dcb0f..00000000000
--- a/gcc/testsuite/ada/acats/tests/c9/c954022.a
+++ /dev/null
@@ -1,351 +0,0 @@
--- C954022.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- In an entry body requeue the call to the same entry. Check that the
--- items go to the right queue and that they are placed back on the end
--- of the queue
---
--- TEST DESCRIPTION:
--- Simulate part of a message handling application where the messages are
--- composed of several segments. The sequence of the segments within the
--- message is specified by Seg_Sequence_No. The segments are handled by
--- different tasks and finally forwarded to an output driver. The
--- segments can arrive in any order but must be assembled into the proper
--- sequence for final output. There is a Sequencer task interposed
--- before the Driver. This takes the segments of the message off the
--- Ordering_Queue and those that are in the right order it sends on to
--- the driver; those that are out of order it places back on the end of
--- the queue.
---
--- The test just simulates the arrival of the segments at the Sequencer.
--- The task generating the segments handshakes with the Sequencer during
--- the "Await Arrival" phase ensuring that the three segments of a
--- message arrive in REVERSE order (the End-of-Message segment arrives
--- first and the Header last). In the first cycle the sequencer pulls
--- segments off the queue and puts them back on the end till it
--- encounters the header. It checks the sequence of the ones it pulls
--- off in case the segments are being put back on in the wrong part of
--- the queue. Having cycled once through it no longer verifies the
--- sequence - it just executes the "application" code for the correct
--- order for dispatch to the driver.
---
--- In this simple example no attempt is made to address segments of
--- another message arriving or any other error conditions (such as
--- missing segments, timing etc.)
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 07 Nov 95 SAIC ACVC 2.0.1
---
---!
-
-with Report;
-with ImpDef;
-
-procedure C954022 is
-
- -- These global Booleans are set when failure conditions inside Protected
- -- objects are encountered. Report.Failed cannot be called within
- -- the object or a Bounded Error would occur
- --
- TC_Failed_1 : Boolean := false;
- TC_Failed_2 : Boolean := false;
- TC_Failed_3 : Boolean := false;
-
-begin
-
-
- Report.Test ("C954022", "Check Requeue to the same Protected Entry");
-
- declare -- encapsulate the test
-
- type Segment_Sequence is range 1..8;
- Header : constant Segment_Sequence := Segment_Sequence'first;
-
- type Message_Segment is record
- ID : integer; -- Message ID
- Seg_Sequence_No : Segment_Sequence; -- Within the message
- Segs_In_Message : integer; -- Total segs this message
- EOM : Boolean := false; -- true for final msg segment
- Alpha : string (1..128);
- end record;
- type acc_Message_Segment is access Message_Segment;
-
- task TC_Simulate_Arrival;
-
- task type Carrier_Task is
- entry Input ( Segment : acc_Message_Segment );
- end Carrier_Task;
- type acc_Carrier_Task is access Carrier_Task;
-
- protected Sequencer is
- function TC_Arrivals return integer;
- entry Input ( Segment : acc_Message_Segment );
- entry Ordering_Queue ( Segment : acc_Message_Segment );
- private
- Number_of_Segments_Arrived : integer := 0;
- Number_of_Segments_Expected : integer := 0;
- Next_Needed : Segment_Sequence := Header;
- All_Segments_Arrived : Boolean := false;
- Seen_EOM : Boolean := false;
-
- TC_First_Cycle : Boolean := true;
- TC_Expected_Sequence : Segment_Sequence := Header+2;
-
- end Sequencer;
-
-
- task Output_Driver is
- entry Input ( Segment : acc_Message_Segment );
- end Output_Driver;
-
-
- -- Simulate the arrival of three message segments in REVERSE order
- --
- task body TC_Simulate_Arrival is
- begin
- for i in 1..3 loop
- declare
- -- Create a task for the next message segment
- Next_Segment_Task : acc_Carrier_Task := new Carrier_Task;
- -- Create a record for the next segment
- Next_Segment : acc_Message_Segment := new Message_Segment;
- begin
- if i = 1 then
- -- Build the EOM segment as the first to "send"
- Next_Segment.Seg_Sequence_No := Header + 2;
- Next_Segment.Segs_In_Message := 3;
- Next_Segment.EOM := true;
- elsif i = 2 then
- -- Wait for the first segment to arrive at the Sequencer
- -- before "sending" the second
- while Sequencer.TC_Arrivals < 1 loop
- delay ImpDef.Minimum_Task_Switch;
- end loop;
- -- Build the segment
- Next_Segment.Seg_Sequence_No := Header +1;
- else
- -- Wait for the second segment to arrive at the Sequencer
- -- before "sending" the third
- while Sequencer.TC_Arrivals < 2 loop
- delay ImpDef.Minimum_Task_Switch;
- end loop;
- -- Build the segment. The last segment (in order) to
- -- arrive will be the "header" segment
- Next_Segment.Seg_Sequence_No := Header;
- end if;
- -- pass the record to its carrier
- Next_Segment_Task.Input ( Next_Segment );
- end;
- end loop;
-
-
- exception
- when others =>
- Report.Failed ("Unexpected Exception in TC_Simulate_Arrival");
- end TC_Simulate_Arrival;
-
-
- -- One of these is generated for each message segment and the flow
- -- of the segments through the system is controlled by the calls the
- -- task makes and the requeues of those calls
- --
- task body Carrier_Task is
- This_Segment : acc_Message_Segment := new Message_Segment;
- begin
- accept Input ( Segment : acc_Message_Segment ) do
- This_Segment.all := Segment.all;
- end Input;
- null; --:: stub. Pass the segment around the application as needed
-
- -- Now output the segment to the Output_Driver. First we have to
- -- go through the Sequencer.
- Sequencer.Input ( This_Segment );
- exception
- when others =>
- Report.Failed ("Unexpected Exception in Carrier_Task");
- end Carrier_Task;
-
- -- Store segments on the Ordering_Queue then deliver them in the correct
- -- sequence to the Output_Driver.
- --
- protected body Sequencer is
-
- function TC_Arrivals return integer is
- begin
- return Number_of_Segments_Arrived;
- end TC_Arrivals;
-
-
- -- Segments arriving at the Input queue are counted and checked
- -- against the total number of segments for the message. They
- -- are requeued onto the ordering queue where they are held until
- -- all the segments have arrived.
- entry Input ( Segment : acc_Message_Segment ) when true is
- begin
- -- check for EOM, if so get the number of segments in the message
- -- Note: in this portion of code no attempt is made to address
- -- reset for new message , end conditions, missing segments,
- -- segments of a different message etc.
- Number_of_Segments_Arrived := Number_of_Segments_Arrived + 1;
- if Segment.EOM then
- Number_of_Segments_Expected := Segment.Segs_In_Message;
- Seen_EOM := true;
- end if;
-
- if Seen_EOM then
- if Number_of_Segments_Arrived = Number_of_Segments_Expected then
- -- This is the last segment for this message
- All_Segments_Arrived := true; -- clear the barrier
- end if;
- end if;
-
- requeue Ordering_Queue;
-
- -- At this exit point the entry queue barriers are evaluated
-
- end Input;
-
-
- entry Ordering_Queue ( Segment : acc_Message_Segment )
- when All_Segments_Arrived is
- begin
-
- --=====================================================
- -- This part is all Test_Control code
-
- if TC_First_Cycle then
- -- Check the order of the original three
- if Segment.Seg_Sequence_No /= TC_Expected_Sequence then
- -- The segments are not being pulled off in the
- -- expected sequence. This could occur if the
- -- requeue is not putting them back on the end.
- TC_Failed_3 := true;
- end if; -- sequence check
- -- Decrement the expected sequence
- if TC_Expected_Sequence /= Header then
- TC_Expected_Sequence := TC_Expected_Sequence - 1;
- else
- TC_First_Cycle := false; -- This is the Header - the
- -- first two segments are
- -- back on the queue
- end if; -- decrementing
- end if; -- first cycle
- --=====================================================
-
- -- And this is the Application code
- if Segment.Seg_Sequence_No = Next_Needed then
- if Segment.EOM then
- Next_Needed := Header; -- reset for next message
- -- :: other resets not shown
- else
- Next_Needed := Next_Needed + 1;
- end if;
- requeue Output_Driver.Input with abort;
- -- set to Report Failed - Requeue did not complete entry body
- TC_Failed_1 := true;
- else
- -- Not the next needed - put it back on the queue
- -- NOTE: here we are requeueing to the same entry
- requeue Sequencer.Ordering_Queue;
- -- set to Report Failed - Requeue did not complete entry body
- TC_Failed_2 := true;
- end if;
- end Ordering_Queue;
- end Sequencer;
-
-
- task body Output_Driver is
- This_Segment : acc_Message_Segment := new Message_Segment;
-
- TC_Expected_Sequence : Segment_Sequence := Segment_Sequence'first;
- TC_Segment_Total : integer := 0;
- TC_Expected_Total : integer := 3;
- begin
- loop
- -- Note: normally we would expect this Accept to be in a select
- -- with terminate. For the test we exit the loop on completion
- -- to give better control
- accept Input ( Segment : acc_Message_Segment ) do
- This_Segment.all := Segment.all;
- end Input;
-
- null; --::: stub - output the next segment of the message
-
- -- The following is all test control code
- --
- if This_Segment.Seg_Sequence_No /= TC_Expected_Sequence then
- Report.Failed ("Output_Driver: Segment out of sequence");
- end if;
- TC_Expected_Sequence := TC_Expected_Sequence + 1;
-
- -- Now count the number of segments
- TC_Segment_Total := TC_Segment_Total + 1;
-
- -- Check the number and exit loop when complete
- -- There must be exactly TC_Expected_Total in number and
- -- the last one must be EOM
- -- (test will hang if < TC_Expected_Total arrive
- -- without EOM)
- if This_Segment.EOM then
- -- This is the last segment.
- if TC_Segment_Total /= TC_Expected_Total then
- Report.Failed ("EOM and wrong number of segments");
- end if;
- exit; -- the loop and terminate the task
- elsif TC_Segment_Total = TC_Expected_Total then
- Report.Failed ("No EOM found");
- exit;
- end if;
- end loop;
- exception
- when others =>
- Report.Failed ("Unexpected Exception in Output_Driver");
- end Output_Driver;
-
-
- begin
-
- null;
-
- end; -- encapsulation
-
- if TC_Failed_1 then
- Report.Failed ("Requeue did not complete entry body - 1");
- end if;
-
- if TC_Failed_2 then
- Report.Failed ("Requeue did not complete entry body - 2");
- end if;
-
- if TC_Failed_3 then
- Report.Failed ("Sequencer: Segment out of sequence");
- end if;
-
- Report.Result;
-
-end C954022;
diff --git a/gcc/testsuite/ada/acats/tests/c9/c954023.a b/gcc/testsuite/ada/acats/tests/c9/c954023.a
deleted file mode 100644
index bfa69dc6054..00000000000
--- a/gcc/testsuite/ada/acats/tests/c9/c954023.a
+++ /dev/null
@@ -1,558 +0,0 @@
--- C954023.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that a requeue within a protected entry to a family of entries
--- in a different protected object is queued correctly
--- Call with parameters
--- Requeue with abort
---
--- TEST DESCRIPTION:
--- One transaction is sent through to check the paths. After processing
--- this, the Credit task sets the "overloaded" indicator. Once this
--- indicator is set the Distributor (a protected object) queues lower
--- priority transactions on a family of queues (Wait_for_Underload) in
--- another protected object using a requeue. The Distributor still
--- delivers high priority transactions. After two more high priority
--- transactions have been processed by the Credit task the artificial
--- test code clears the overload condition to the threshold level that
--- allows only the items on the Medium priority queue of the family to be
--- released. When these have been processed and checked the test code
--- then lowers the priority threshold once again, allowing the Low
--- priority items from the last queue in the family to be released,
--- processed and checked. Note: the High priority queue in the family is
--- not used.
---
--- This series of tests uses a simulation of a transaction driven
--- processing system. Line Drivers accept input from an external source
--- and build them into transaction records. These records are then
--- encapsulated in message tasks which remain extant for the life of the
--- transaction in the system. The message tasks put themselves on the
--- input queue of a Distributor which, from information in the
--- transaction and/or system load conditions forwards them to other
--- operating tasks. These in turn might forward the transactions to yet
--- other tasks for further action. The routing is, in real life, dynamic
--- and unpredictable at the time of message generation. All rerouting in
--- this model is done by means of requeues.
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
---
---!
-
-with Report;
-with ImpDef;
-
-procedure C954023 is
-
- -- Artificial: number of messages required for this test
- subtype TC_Trans_Range is integer range 1..8;
-
- TC_Credit_Messages_Expected : constant integer
- := TC_Trans_Range'Last - 1;
-
- TC_Debit_Message_Complete : Boolean := false;
-
-
- -- Mechanism for handshaking between tasks
- protected TC_PO is
- procedure Increment_Tasks_Completed_Count;
- function Tasks_Completed_Count return integer;
- function First_Message_Has_Arrived return Boolean;
- procedure Set_First_Message_Has_Arrived;
- private
- Number_Complete : integer := 0;
- Message_Arrived_Flag : Boolean := false;
- end TC_PO;
- --
- protected body TC_PO is
- procedure Increment_Tasks_Completed_Count is
- begin
- Number_Complete := Number_Complete + 1;
- end Increment_Tasks_Completed_Count;
-
- function Tasks_Completed_Count return integer is
- begin
- return Number_Complete;
- end Tasks_Completed_Count;
-
- function First_Message_Has_Arrived return Boolean is
- begin
- return Message_Arrived_Flag;
- end First_Message_Has_Arrived;
-
- procedure Set_First_Message_Has_Arrived is
- begin
- Message_Arrived_Flag := true;
- end Set_First_Message_Has_Arrived;
-
- end TC_PO;
-
-begin
-
- Report.Test ("C954023", "Requeue from within a protected object" &
- " to a family of entries in another protected object");
-
-
- declare -- encapsulate the test
-
- -- Arbitrary test values
- Credit_Return : constant := 1;
- Debit_Return : constant := 2;
-
- type Transaction_Code is (Credit, Debit);
- type App_Priority is (Low, Medium, High);
- type Priority_Block is array (App_Priority) of Boolean;
-
- type Transaction_Record;
- type acc_Transaction_Record is access Transaction_Record;
- type Transaction_Record is
- record
- ID : integer := 0;
- Code : Transaction_Code := Debit;
- Priority : App_Priority := High;
- Account_Number : integer := 0;
- Stock_Number : integer := 0;
- Quantity : integer := 0;
- Return_Value : integer := 0;
- TC_Message_Count : integer := 0;
- TC_Thru_Distrib : Boolean := false;
- end record;
-
-
- task type Message_Task is
- entry Accept_Transaction (In_Transaction : acc_Transaction_Record);
- end Message_Task;
- type acc_Message_Task is access Message_Task;
-
- task Line_Driver is
- entry Start;
- end Line_Driver;
-
- protected Distributor is
- procedure Set_Credit_Overloaded;
- procedure Clear_Overload_to_Medium;
- procedure Clear_Overload_to_Low;
- entry Input (Transaction : acc_Transaction_Record);
- private
- Credit_Overloaded : Boolean := false;
- end Distributor;
-
- protected Hold is
- procedure Release_Medium;
- procedure Release_Low;
- -- Family of entry queues indexed by App_Priority
- entry Wait_for_Underload (App_Priority)
- (Transaction : acc_Transaction_Record);
- private
- Release : Priority_Block := (others => false);
- end Hold;
-
- task Credit_Computation is
- entry Input(Transaction : acc_Transaction_Record);
- end Credit_Computation;
-
- task Debit_Computation is
- entry Input(Transaction : acc_Transaction_Record);
- end Debit_Computation;
-
- --
- -- Dispose each input Transaction_Record to the appropriate
- -- computation tasks
- --
- protected body Distributor is
-
- procedure Set_Credit_Overloaded is
- begin
- Credit_Overloaded := true;
- end Set_Credit_Overloaded;
-
- procedure Clear_Overload_to_Medium is
- begin
- Credit_Overloaded := false;
- Hold.Release_Medium; -- Release all held messages on Medium
- -- priority queue
- end Clear_Overload_to_Medium;
-
- procedure Clear_Overload_to_Low is
- begin
- Credit_Overloaded := false;
- Hold.Release_Low; -- Release all held messages on Low
- -- priority queue
- end Clear_Overload_to_Low;
-
-
-
- entry Input (Transaction : acc_Transaction_Record) when true is
- -- barrier is always open
- begin
- -- Test Control: Set the indicator in the message to show it has
- -- passed through the Distributor object
- Transaction.TC_thru_Distrib := true;
-
- -- Pass this transaction on to the appropriate computation
- -- task but temporarily hold low-priority transactions under
- -- overload conditions
- case Transaction.Code is
- when Credit =>
- if Credit_Overloaded and Transaction.Priority /= High then
- -- use the appropriate queue in the family
- requeue Hold.Wait_for_Underload(Transaction.Priority)
- with abort;
- else
- requeue Credit_Computation.Input with abort;
- end if;
- when Debit =>
- requeue Debit_Computation.Input with abort;
- end case;
- end Input;
- end Distributor;
-
-
- -- Low priority Message tasks are held on the Wait_for_Underload queue
- -- while the Credit computation system is overloaded. Once the Credit
- -- system reached underload send all queued messages immediately
- --
- protected body Hold is
-
- -- Once these are executed the barrier conditions for the entries
- -- are evaluated
- procedure Release_Medium is
- begin
- Release(Medium) := true;
- end Release_Medium;
- --
- procedure Release_Low is
- begin
- Release(Low) := true;
- end Release_Low;
-
- -- This is a family of entry queues indexed by App_Priority
- entry Wait_for_Underload (for AP in App_Priority)
- (Transaction : acc_Transaction_Record)
- when Release(AP) is
- begin
- requeue Credit_Computation.Input with abort;
- if Wait_for_Underload(AP)'count = 0 then
- -- Queue is purged. Set up to hold next batch
- Release(AP) := false;
- end if;
- end Wait_for_Underload;
-
- end Hold;
-
-
-
-
- -- Assemble messages received from an external source
- -- Creates a message task for each. The message tasks remain extant
- -- for the life of the messages in the system.
- -- The Line Driver task would normally be designed to loop
- -- creating the messages as input is received. Simulate this
- -- but limit it to the required number of dummy messages needed for
- -- this test and allow it to terminate at that point. Artificially
- -- cycle the generation of High medium and Low priority Credit
- -- transactions for this test. Send out one final Debit message
- --
- task body Line_Driver is
- Current_ID : integer := 1;
- Current_Priority : App_Priority := High;
-
- procedure Build_Credit_Record
- ( Next_Transaction : acc_Transaction_Record ) is
- Dummy_Account : constant integer := 100;
- begin
- Next_Transaction.ID := Current_ID;
- Next_Transaction.Code := Credit;
- Next_Transaction.Priority := Current_Priority;
-
- Next_Transaction.Account_Number := Dummy_Account;
- Current_ID := Current_ID + 1;
- end Build_Credit_Record;
-
-
- procedure Build_Debit_Record
- ( Next_Transaction : acc_Transaction_Record ) is
- Dummy_Account : constant integer := 200;
- begin
- Next_Transaction.ID := Current_ID;
- Next_Transaction.Code := Debit;
-
- Next_Transaction.Account_Number := Dummy_Account;
- Current_ID := Current_ID + 1;
- end Build_Debit_Record;
-
- begin
-
- for Transaction_Numb in TC_Trans_Range loop -- TC: limit the loop
- declare
- -- Create a task for the next message
- Next_Message_Task : acc_Message_Task := new Message_Task;
- -- Create a record for it
- Next_Transaction : acc_Transaction_Record :=
- new Transaction_Record;
- begin
- if Transaction_Numb = TC_Trans_Range'first then
- -- Send the first Credit message
- Build_Credit_Record ( Next_Transaction );
- Next_Message_Task.Accept_Transaction ( Next_Transaction );
- -- TC: Wait until the first message has been received by the
- -- Credit task and it has set the Overload indicator for the
- -- Distributor
- while not TC_PO.First_Message_Has_Arrived loop
- delay ImpDef.Minimum_Task_Switch;
- end loop;
- elsif Transaction_Numb = TC_Trans_Range'last then
- -- For this test send the last transaction to the Debit task
- -- to improve the mix
- Build_Debit_Record( Next_Transaction );
- Next_Message_Task.Accept_Transaction ( Next_Transaction );
- else
- -- TC: Cycle generation of high medium and low priority
- -- transactions
- if Current_Priority = High then
- Current_Priority := Medium;
- elsif
- Current_Priority = Medium then
- Current_Priority := Low;
- else
- Current_Priority := High;
- end if;
- Build_Credit_Record( Next_Transaction );
- Next_Message_Task.Accept_Transaction ( Next_Transaction );
- end if;
- end; -- declare
- end loop;
-
- exception
- when others =>
- Report.Failed ("Unexpected exception in Line_Driver");
- end Line_Driver;
-
-
-
-
- task body Message_Task is
-
- TC_Original_Transaction_Code : Transaction_Code;
- This_Transaction : acc_Transaction_Record := new Transaction_Record;
-
- begin
-
- accept Accept_Transaction(In_Transaction : acc_Transaction_Record) do
- This_Transaction.all := In_Transaction.all;
- end Accept_Transaction;
-
- -- Note the original code to ensure correct return
- TC_Original_Transaction_Code := This_Transaction.Code;
-
- -- Queue up on Distributor's Input queue
- Distributor.Input ( This_Transaction );
- -- This task will now wait for the requeued rendezvous
- -- to complete before proceeding
-
- -- After the required computations have been performed
- -- return the Transaction_Record appropriately (probably to an output
- -- line driver)
- null; -- stub
-
- -- For the test check that the return values are as expected
- if TC_Original_Transaction_Code /= This_Transaction.Code then
- -- Incorrect rendezvous
- Report.Failed ("Message Task: Incorrect code returned");
- end if;
-
- if This_Transaction.Code = Credit then
- if This_Transaction.Return_Value /= Credit_Return or
- not This_Transaction.TC_thru_Distrib then
- Report.Failed ("Expected path not traversed - Credit");
- end if;
- TC_PO.Increment_Tasks_Completed_Count;
- else
- if This_Transaction.Return_Value /= Debit_Return or
- This_Transaction.TC_Message_Count /= 1 or
- not This_Transaction.TC_thru_Distrib then
- Report.Failed ("Expected path not traversed - Debit");
- end if;
- TC_Debit_Message_Complete := true;
- end if;
-
- exception
- when others =>
- Report.Failed ("Unexpected exception in Message_Task");
- end Message_Task;
-
-
-
-
-
- -- Computation task. After the computation is performed the rendezvous
- -- in the original message task is completed.
- task body Credit_Computation is
-
- Message_Count : integer := 0;
-
- begin
- loop
- select
- accept Input ( Transaction : acc_Transaction_Record) do
-
- -- Perform the computations required for this transaction
- null; -- stub
-
-
- -- The following is all Test Control code:
-
- if not Transaction.TC_thru_Distrib then
- Report.Failed
- ("Credit Task: Wrong queue, Distributor bypassed");
- end if;
-
- if Transaction.code /= Credit then
- Report.Failed
- ("Credit Task: Requeue delivered to the wrong queue");
- end if;
-
- -- This is checked by the Message_Task:
- Transaction.Return_Value := Credit_Return;
-
- -- Now take special action depending on which Message.
- -- Note: The count gives the order in which the messages are
- -- arriving at this task NOT the order in which they
- -- were originally generated and sent out.
-
- Message_Count := Message_Count + 1;
-
- if Message_Count < 4 then
- -- This is one of the first three messages which must
- -- be High priority because we will set "Overload" after
- -- the first, which is known to be High. The lower
- -- priority should be waiting on the queues
- if Transaction.Priority /= High then
- Report.Failed
- ("Credit Task: Lower priority trans. during overload");
- end if;
- if Message_Count = 1 then
- -- After the first message :
- Distributor.Set_Credit_Overloaded;
- -- Now flag the Line_Driver that the second and
- -- subsequent messages may now be sent
- TC_PO.Set_First_Message_Has_Arrived;
- elsif
- Message_Count = 3 then
- -- The two high priority transactions created
- -- subsequent to the overload have now been processed,
- -- release the Medium priority items
- Distributor.Clear_Overload_to_Medium;
- end if;
- elsif Message_Count < 6 then
- -- This must be one of the Medium priority messages
- if Transaction.Priority /= Medium then
- Report.Failed
- ("Credit Task: Second group not Medium Priority");
- end if;
- if Message_Count = 5 then
- -- The two medium priority transactions
- -- have now been processed - release the
- -- Low priority items
- Distributor.Clear_Overload_to_Low;
- end if;
- elsif Message_Count < TC_Trans_Range'Last then
- -- This must be one of the Low priority messages
- if Transaction.Priority /= Low then
- Report.Failed
- ("Credit Task: Third group not Low Priority");
- end if;
- else
- -- Too many transactions have arrived. Duplicates?
- -- the Debit transaction?
- Report.Failed
- ("Credit Task: Too many transactions");
- end if;
- end Input;
- or
- terminate;
- end select;
- end loop;
- exception
- when others =>
- Report.Failed ("Unexpected exception in Credit_Computation");
- end Credit_Computation;
-
-
-
- -- Computation task. After the computation is performed the rendezvous
- -- in the original message task is completed.
- --
- task body Debit_Computation is
- Message_Count : integer := 0;
- begin
- loop
- select
- accept Input (Transaction : acc_Transaction_Record) do
- -- Perform the computations required for this message
- null; -- stub
-
- -- For the test:
- if not Transaction.TC_thru_Distrib then
- Report.Failed
- ("Debit Task: Wrong queue, Distributor bypassed");
- end if;
- if Transaction.code /= Debit then
- Report.Failed
- ("Debit Task: Requeue delivered to the wrong queue");
- end if;
-
- -- for the test plug a known value and count
- Transaction.Return_Value := Debit_Return;
- -- one, and only one, message should pass through
- Message_Count := Message_Count + 1;
- Transaction.TC_Message_Count := Message_Count;
- end Input;
- or
- terminate;
- end select;
- end loop;
- exception
- when others =>
- Report.Failed ("Unexpected exception in Debit_Computation");
- end Debit_Computation;
-
-
- begin -- declare
-
- null;
-
- end; -- declare (test encapsulation)
-
- if (TC_PO.Tasks_Completed_Count /= TC_Credit_Messages_Expected)
- and not TC_Debit_Message_Complete then
- Report.Failed ("Incorrect number of Message Tasks completed");
- end if;
-
- Report.Result;
-
-end C954023;
diff --git a/gcc/testsuite/ada/acats/tests/c9/c954024.a b/gcc/testsuite/ada/acats/tests/c9/c954024.a
deleted file mode 100644
index 7f19a818322..00000000000
--- a/gcc/testsuite/ada/acats/tests/c9/c954024.a
+++ /dev/null
@@ -1,380 +0,0 @@
--- C954024.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that a call to a protected entry can be requeued to a task
--- entry. Check that the requeue is placed on the correct entry; that the
--- original caller waits for the completion of the requeue and continues
--- after the requeued rendezvous. Check that the requeue does not block.
--- Specifically, check a requeue without abort from a protected entry to
--- an entry in a task.
---
--- TEST DESCRIPTION:
--- In the Distributor protected object, requeue two successive calls on
--- the entries of two separate target tasks. Each task in each of the
--- paths adds identifying information in the transaction being passed.
--- This information is checked by the Message tasks on completion
--- ensuring that the requeues have been placed on the correct queues.
--- There is an artificial guard on the Credit Task to ensure that the
--- input is queued; this guard is released by the Debit task which
--- handles its input immediately. This ensures that we have one of the
--- requeued items actually queued for later handling and also verifies
--- that the requeuing process (in the protected object) is not blocked.
---
--- This series of tests uses a simulation of a transaction driven
--- processing system. Line Drivers accept input from an external source
--- and build them into transaction records. These records are then
--- encapsulated in message tasks which remain extant for the life of the
--- transaction in the system. The message tasks put themselves on the
--- input queue of a Distributor object which, from information in the
--- transaction and/or system load conditions forwards them to other
--- operating tasks. These in turn might forward the transactions to yet
--- other tasks for further action. The routing is, in real life,
--- dynamic and unpredictable at the time of message generation. All
--- rerouting in this model is done by means of requeues.
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 08 Nov 95 SAIC Fixed reported problems for ACVC 2.0.1
---
---!
-
-with Report;
-with ImpDef;
-procedure C954024 is
-
-
-begin -- C954024
-
- Report.Test ("C954024", "Requeue from protected entry to task entry");
-
- declare -- encapsulate the test
-
- -- Arbitrary test values
- Credit_Return : constant := 1;
- Debit_Return : constant := 2;
-
- type Transaction_Code is (Credit, Debit);
-
- type Transaction_Record;
- type acc_Transaction_Record is access Transaction_Record;
- type Transaction_Record is
- record
- ID : integer := 0;
- Code : Transaction_Code := Debit;
- Account_Number : integer := 0;
- Stock_Number : integer := 0;
- Quantity : integer := 0;
- Return_Value : integer := 0;
- TC_Message_Count : integer := 0;
- TC_Thru_Dist : Boolean := false;
- end record;
-
-
- task type Message_Task is
- entry Accept_Transaction (In_Transaction : acc_Transaction_Record);
- end Message_Task;
- type acc_Message_Task is access Message_Task;
-
- task Line_Driver is
- entry Start;
- end Line_Driver;
-
- task Credit_Computation is
- entry Input(Transaction : acc_Transaction_Record);
- end Credit_Computation;
-
- task Debit_Computation is
- entry Input(Transaction : acc_Transaction_Record);
- end Debit_Computation;
-
- protected Time_Lock is
- procedure Credit_Start;
- function Credit_Enabled return Boolean;
- private
- Credit_OK : Boolean := false;
- end Time_Lock;
-
- protected body Time_Lock is
- procedure Credit_Start is
- begin
- Credit_OK := true;
- end Credit_Start;
-
- function Credit_Enabled return Boolean is
- begin
- return Credit_OK;
- end Credit_Enabled;
- end Time_Lock;
-
-
-
- protected Distributor is
- entry Input (Transaction : acc_Transaction_Record);
- end Distributor;
- --
- --
- -- Dispose each input Transaction_Record to the appropriate
- -- computation tasks
- --
- protected body Distributor is
- entry Input (Transaction : acc_Transaction_Record) when true is
- -- barrier is always open
- begin
- -- Test Control: Set the indicator in the message to show it has
- -- passed through the Distributor object
- Transaction.TC_thru_Dist := true;
-
- -- Pass this transaction on to the appropriate computation
- -- task
- case Transaction.Code is
- when Credit =>
- requeue Credit_Computation.Input;
- when Debit =>
- requeue Debit_Computation.Input;
- end case;
- end Input;
- end Distributor;
-
-
-
-
- -- Assemble messages received from an external source
- -- Creates a message task for each. The message tasks remain extant
- -- for the life of the messages in the system.
- -- NOTE:
- -- The Line Driver task would normally be designed to loop continuously
- -- creating the messages as input is received. Simulate this
- -- but limit it to two dummy messages for this test and allow it
- -- to terminate at that point
- --
- task body Line_Driver is
- Current_ID : integer := 1;
- TC_Last_was_for_credit : Boolean := false;
-
- procedure Build_Credit_Record
- ( Next_Transaction : acc_Transaction_Record ) is
- Dummy_Account : constant integer := 100;
- begin
- Next_Transaction.ID := Current_ID;
- Next_Transaction.Code := Credit;
-
- Next_Transaction.Account_Number := Dummy_Account;
- Current_ID := Current_ID + 1;
- end Build_Credit_Record;
-
-
- procedure Build_Debit_Record
- ( Next_Transaction : acc_Transaction_Record ) is
- Dummy_Account : constant integer := 200;
- begin
- Next_Transaction.ID := Current_ID;
- Next_Transaction.Code := Debit;
-
- Next_Transaction.Account_Number := Dummy_Account;
- Current_ID := Current_ID + 1;
- end Build_Debit_Record;
-
- begin
-
- accept Start; -- Wait for trigger from Main
-
- for i in 1..2 loop -- arbitrarily limit to two messages for the test
- declare
- -- Create a task for the next message
- Next_Message_Task : acc_Message_Task := new Message_Task;
- -- Create a record for it
- Next_Transaction : acc_Transaction_Record
- := new Transaction_Record;
- begin
- if TC_Last_was_for_credit then
- Build_Debit_Record ( Next_Transaction );
- else
- Build_Credit_Record( Next_Transaction );
- TC_Last_was_for_credit := true;
- end if;
- Next_Message_Task.Accept_Transaction ( Next_Transaction );
- end; -- declare
- end loop;
-
- exception
- when others =>
- Report.Failed ("Unexpected exception in Line_Driver");
- end Line_Driver;
-
-
-
-
- task body Message_Task is
-
- TC_Original_Transaction_Code : Transaction_Code;
- This_Transaction : acc_Transaction_Record := new Transaction_Record;
-
- begin
- accept Accept_Transaction
- (In_Transaction : acc_Transaction_Record) do
- This_Transaction.all := In_Transaction.all;
- end Accept_Transaction;
-
- -- Note the original code to ensure correct return
- TC_Original_Transaction_Code := This_Transaction.Code;
-
- -- Queue up on Distributor's Input queue
- Distributor.Input ( This_Transaction );
- -- This task will now wait for the requeued rendezvous
- -- to complete before proceeding
-
- -- After the required computations have been performed
- -- return the Transaction_Record appropriately (probably to an output
- -- line driver)
- null; -- stub
-
-
- -- The following is all Test Control Code
-
- -- Check that the return values are as expected
- if TC_Original_Transaction_Code /= This_Transaction.Code then
- -- Incorrect rendezvous
- Report.Failed ("Message Task: Incorrect code returned");
- end if;
-
- if This_Transaction.Code = Credit then
- if This_Transaction.Return_Value /= Credit_Return or
- This_Transaction.TC_Message_Count /= 1 or
- not This_Transaction.TC_thru_Dist then
- Report.Failed ("Expected path not traversed");
- end if;
- else
- if This_Transaction.Return_Value /= Debit_Return or
- This_Transaction.TC_Message_Count /= 1 or
- not This_Transaction.TC_thru_Dist then
- Report.Failed ("Expected path not traversed");
- end if;
- end if;
-
- exception
- when others =>
- Report.Failed ("Unexpected exception in Message_Task");
-
- end Message_Task;
-
-
-
- -- Computation task.
- -- Note: After the computation is performed in this task and the
- -- accept body is completed the rendezvous in the original
- -- message task is completed.
- --
- task body Credit_Computation is
- Message_Count : integer := 0;
- begin
- loop
- select
- when Time_Lock.Credit_enabled =>
- accept Input ( Transaction : acc_Transaction_Record) do
- -- Perform the computations required for this transaction
- null; -- stub
-
- -- For the test:
- if not Transaction.TC_thru_Dist then
- Report.Failed
- ("Credit Task: Wrong queue, Distributor bypassed");
- end if;
- if Transaction.code /= Credit then
- Report.Failed
- ("Credit Task: Requeue delivered to the wrong queue");
- end if;
-
- -- for the test plug a known value and count
- Transaction.Return_Value := Credit_Return;
- -- one, and only one message should pass through
- Message_Count := Message_Count + 1;
- Transaction.TC_Message_Count := Message_Count;
- end Input;
- exit; -- one message is enough
- else
- delay ImpDef.Clear_Ready_Queue; -- poll
- end select;
- end loop;
- exception
- when others =>
- Report.Failed ("Unexpected exception in Credit_Computation");
- end Credit_Computation;
-
-
-
- -- Computation task.
- -- Note: After the computation is performed in this task and the
- -- accept body is completed the rendezvous in the original
- -- message task is completed.
- --
- task body Debit_Computation is
- Message_Count : integer := 0;
- begin
- loop
- select
- accept Input (Transaction : acc_Transaction_Record) do
- -- Perform the computations required for this message
- null; -- stub
-
- -- For the test:
- if not Transaction.TC_thru_Dist then
- Report.Failed
- ("Debit Task: Wrong queue, Distributor bypassed");
- end if;
- if Transaction.code /= Debit then
- Report.Failed
- ("Debit Task: Requeue delivered to the wrong queue");
- end if;
-
- -- for the test plug a known value and count
- Transaction.Return_Value := Debit_Return;
- -- one, and only one, message should pass through
- Message_Count := Message_Count + 1;
- Transaction.TC_Message_Count := Message_Count;
- -- for the test: once we have completed the only Debit
- -- message release the Credit Messages which are queued
- -- on the Credit Input queue
- Time_Lock.Credit_Start;
-
- end Input;
- or
- terminate;
- end select;
- end loop;
- exception
- when others =>
- Report.Failed ("Unexpected exception in Debit_Computation");
-
- end Debit_Computation;
-
- begin -- declare block
- Line_Driver.Start;
- end; -- test encapsulation
-
- Report.Result;
-
-end C954024;
diff --git a/gcc/testsuite/ada/acats/tests/c9/c954025.a b/gcc/testsuite/ada/acats/tests/c9/c954025.a
deleted file mode 100644
index f48d4cd9096..00000000000
--- a/gcc/testsuite/ada/acats/tests/c9/c954025.a
+++ /dev/null
@@ -1,237 +0,0 @@
--- C954025.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that if the original entry call was a conditional entry call,
--- the call is cancelled if a requeue-with-abort of the call is not
--- selected immediately.
--- Check that if the original entry call was a timed entry call, the
--- expiration time for a requeue-with-abort is the original expiration
--- time.
---
--- TEST DESCRIPTION:
--- This test declares two tasks: Launch_Control and Mission_Control.
--- Mission_Control instructs Launch_Control to start its countdown
--- and then requeues (with abort) to the Launch_Control.Launch
--- entry. This call to Launch will be accepted at the end of the
--- countdown (if the task is still waiting).
--- The main task does an unconditional, conditional, and timed
--- entry call to Mission_Control and checks to see if the launch
--- was accepted.
---
---
--- CHANGE HISTORY:
--- 18 OCT 95 SAIC ACVC 2.1
--- 10 JUL 96 SAIC Incorporated reviewer's comments.
---
---!
-
-with Calendar; use type Calendar.Time;
-with Report;
-with ImpDef;
-procedure C954025 is
- Verbose : constant Boolean := False;
- Countdown_Amount : constant Duration := 2.0 * Impdef.One_Second;
- Plenty_Of_Time : constant Duration :=
- Countdown_Amount + ImpDef.Clear_Ready_Queue + 1.0 * Impdef.One_Second;
- Not_Enough_Time : constant Duration :=
- Countdown_Amount - 0.5 * Impdef.One_Second;
-begin
- Report.Test ("C954025",
- "Check that if the original entry" &
- " call was a conditional or timed entry call, the" &
- " expiration time for a requeue with abort is the" &
- " original expiration time");
- declare
- -- note that the following object is a shared object and its use
- -- governed by the rules of 9.10(3,4,8);6.0
- Launch_Accepted : Boolean := False;
-
- task Launch_Control is
- entry Enable_Launch_Control;
- entry Start_Countdown (How_Long : Duration);
- -- Launch will be accepted if a call is waiting when the countdown
- -- reaches 0
- entry Launch;
- end Launch_Control;
-
- task body Launch_Control is
- Wait_Amount : Duration := 0.0;
- begin
- loop
- select
- accept Enable_Launch_Control do
- Launch_Accepted := False;
- end Enable_Launch_Control;
- or
- terminate;
- end select;
-
- accept Start_Countdown (How_Long : Duration) do
- Wait_Amount := How_Long;
- end Start_Countdown;
-
- delay Wait_Amount;
-
- select
- accept Launch do
- Launch_Accepted := True;
- end Launch;
- else
- null;
- -- note that Launch_Accepted is False here
- end select;
- end loop;
- end Launch_Control;
-
- task Mission_Control is
- -- launch will occur if we are given enough time to complete
- -- a standard countdown. We will not be rushed!
- entry Do_Launch;
- end Mission_Control;
-
- task body Mission_Control is
- begin
- loop
- select
- accept Do_Launch do
- Launch_Control.Start_Countdown (Countdown_Amount);
- requeue Launch_Control.Launch with abort;
- end Do_Launch;
- or
- terminate;
- end select;
- end loop;
- end Mission_Control;
-
- begin -- test encapsulation
- -- unconditional entry call to check the simple case
- Launch_Control.Enable_Launch_Control;
- Mission_Control.Do_Launch;
- if Launch_Accepted then
- if Verbose then
- Report.Comment ("simple case passed");
- end if;
- else
- Report.Failed ("simple case");
- end if;
-
-
- -- timed but with plenty of time - delay relative
- Launch_Control.Enable_Launch_Control;
- select
- Mission_Control.Do_Launch;
- or
- delay Plenty_Of_Time;
- if Launch_Accepted then
- Report.Failed ("plenty of time timed out after accept (1)");
- end if;
- end select;
- if Launch_Accepted then
- if Verbose then
- Report.Comment ("plenty of time case passed (1)");
- end if;
- else
- Report.Failed ("plenty of time (1)");
- end if;
-
-
- -- timed but with plenty of time -- delay until
- Launch_Control.Enable_Launch_Control;
- select
- Mission_Control.Do_Launch;
- or
- delay until Calendar.Clock + Plenty_Of_Time;
- if Launch_Accepted then
- Report.Failed ("plenty of time timed out after accept(2)");
- end if;
- end select;
- if Launch_Accepted then
- if Verbose then
- Report.Comment ("plenty of time case passed (2)");
- end if;
- else
- Report.Failed ("plenty of time (2)");
- end if;
-
-
- -- timed without enough time - delay relative
- Launch_Control.Enable_Launch_Control;
- select
- Mission_Control.Do_Launch;
- Report.Failed ("not enough time completed accept (1)");
- or
- delay Not_Enough_Time;
- end select;
- if Launch_Accepted then
- Report.Failed ("not enough time (1)");
- else
- if Verbose then
- Report.Comment ("not enough time case passed (1)");
- end if;
- end if;
-
-
- -- timed without enough time - delay until
- Launch_Control.Enable_Launch_Control;
- select
- Mission_Control.Do_Launch;
- Report.Failed ("not enough time completed accept (2)");
- or
- delay until Calendar.Clock + Not_Enough_Time;
- end select;
- if Launch_Accepted then
- Report.Failed ("not enough time (2)");
- else
- if Verbose then
- Report.Comment ("not enough time case passed (2)");
- end if;
- end if;
-
-
- -- conditional case
- Launch_Control.Enable_Launch_Control;
- -- make sure Mission_Control is ready to accept immediately
- delay ImpDef.Clear_Ready_Queue;
- select
- Mission_Control.Do_Launch;
- Report.Failed ("no time completed accept");
- else
- if Verbose then
- Report.Comment ("conditional case - else taken");
- end if;
- end select;
- if Launch_Accepted then
- Report.Failed ("no time");
- else
- if Verbose then
- Report.Comment ("no time case passed");
- end if;
- end if;
-
- end;
-
- Report.Result;
-end C954025;
diff --git a/gcc/testsuite/ada/acats/tests/c9/c954026.a b/gcc/testsuite/ada/acats/tests/c9/c954026.a
deleted file mode 100644
index 881b74af81c..00000000000
--- a/gcc/testsuite/ada/acats/tests/c9/c954026.a
+++ /dev/null
@@ -1,269 +0,0 @@
--- C954026.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that if the original protected entry call was a conditional
--- entry call, the call is cancelled if a requeue-with-abort of the
--- call is not selected immediately.
--- Check that if the original protected entry call was a timed entry
--- call, the expiration time for a requeue-with-abort is the original
--- expiration time.
---
--- TEST DESCRIPTION:
--- In this test the main task makes a variety of calls to the protected
--- object Initial_PO. These calls include a simple call, a conditional
--- call, and a timed call. The timed calls include calls with enough
--- time and those with less than the needed amount of time to get through
--- the requeue performed by Initial_PO.
--- Initial_PO requeues its entry call to Final_PO.
--- Final_PO does not accept the requeued call until the protected
--- procedure Ok_To_Take_Requeue is called.
--- A separate task, Delayed_Opener, is used to call Ok_To_Take_Requeue
--- after a delay amount specified by the main task has expired.
---
---
--- CHANGE HISTORY:
--- 15 DEC 95 SAIC ACVC 2.1
--- 10 JUL 96 SAIC Incorporated reviewer comments.
--- 10 OCT 96 SAIC Incorporated fix provided by vendor.
---
---!
-
-with Calendar;
-use type Calendar.Time;
-with Report;
-with Impdef;
-procedure C954026 is
- Verbose : constant Boolean := False;
- Final_Po_Reached : Boolean := False;
- Allowed_Time : constant Duration := 2.0 * Impdef.One_Second;
- Plenty_Of_Time : constant Duration :=
- Allowed_Time + Impdef.Clear_Ready_Queue + 1.0 * Impdef.One_Second;
- Not_Enough_Time : constant Duration := Allowed_Time - 0.5 * Impdef.One_Second;
-begin
- Report.Test ("C954026",
- "Check that if the original entry" &
- " call was a conditional or timed entry call," &
- " the expiration time for a requeue with" &
- " abort to a protected" &
- " entry is the original expiration time");
- declare
-
- protected Initial_Po is
- entry Start_Here;
- end Initial_Po;
-
- protected Final_Po is
- entry Requeue_Target;
- procedure Ok_To_Take_Requeue;
- procedure Close_Requeue;
- private
- Open : Boolean := False;
- end Final_Po;
-
- -- the Delayed_Opener task is used to notify Final_PO that it can
- -- accept the Requeue_Target entry.
- task Delayed_Opener is
- entry Start_Timer (Amt : Duration);
- entry Cancel_Timer;
- end Delayed_Opener;
-
- task body Delayed_Opener is
- Wait_Amt : Duration;
- begin
- loop
- accept Start_Timer (Amt : Duration) do
- Wait_Amt := Amt;
- end Start_Timer;
- exit when Wait_Amt < 0.0;
- if Verbose then
- Report.Comment ("Timer started");
- end if;
- select
- accept Cancel_Timer do
- Final_Po.Close_Requeue;
- end Cancel_Timer;
- or
- delay Wait_Amt;
- Final_Po.Ok_To_Take_Requeue;
- accept Cancel_Timer do
- Final_Po.Close_Requeue;
- end Cancel_Timer;
- end select;
- end loop;
- exception
- when others =>
- Report.Failed ("exception in Delayed_Opener");
- end Delayed_Opener;
-
- protected body Initial_Po is
- entry Start_Here when True is
- begin
- Final_Po_Reached := False;
- requeue Final_Po.Requeue_Target with abort;
- end Start_Here;
- end Initial_Po;
-
- protected body Final_Po is
- entry Requeue_Target when Open is
- begin
- Open := False;
- Final_Po_Reached := True;
- end Requeue_Target;
-
- procedure Ok_To_Take_Requeue is
- begin
- Open := True;
- end Ok_To_Take_Requeue;
-
- procedure Close_Requeue is
- begin
- Open := False;
- end Close_Requeue;
- end Final_Po;
-
- begin -- test encapsulation
- -- unconditional entry call to check the simple case
- Delayed_Opener.Start_Timer (0.0);
- Initial_Po.Start_Here;
- if Final_Po_Reached then
- if Verbose then
- Report.Comment ("simple case passed");
- end if;
- else
- Report.Failed ("simple case");
- end if;
- Delayed_Opener.Cancel_Timer;
-
-
- -- timed but with plenty of time - delay relative
- Delayed_Opener.Start_Timer (Allowed_Time);
- select
- Initial_Po.Start_Here;
- or
- delay Plenty_Of_Time;
- Report.Failed ("plenty of time timed out (1)");
- if Final_Po_Reached then
- Report.Failed (
- "plenty of time timed out after accept (1)");
- end if;
- end select;
- if Final_Po_Reached then
- if Verbose then
- Report.Comment ("plenty of time case passed (1)");
- end if;
- else
- Report.Failed ("plenty of time (1)");
- end if;
- Delayed_Opener.Cancel_Timer;
-
-
- -- timed but with plenty of time -- delay until
- Delayed_Opener.Start_Timer (Allowed_Time);
- select
- Initial_Po.Start_Here;
- or
- delay until Calendar.Clock + Plenty_Of_Time;
- Report.Failed ("plenty of time timed out (2)");
- if Final_Po_Reached then
- Report.Failed (
- "plenty of time timed out after accept(2)");
- end if;
- end select;
- if Final_Po_Reached then
- if Verbose then
- Report.Comment ("plenty of time case passed (2)");
- end if;
- else
- Report.Failed ("plenty of time (2)");
- end if;
- Delayed_Opener.Cancel_Timer;
-
-
- -- timed without enough time - delay relative
- Delayed_Opener.Start_Timer (Allowed_Time);
- select
- Initial_Po.Start_Here;
- Report.Failed ("not enough time completed accept (1)");
- or
- delay Not_Enough_Time;
- end select;
- if Final_Po_Reached then
- Report.Failed ("not enough time (1)");
- else
- if Verbose then
- Report.Comment ("not enough time case passed (1)");
- end if;
- end if;
- Delayed_Opener.Cancel_Timer;
-
-
- -- timed without enough time - delay until
- Delayed_Opener.Start_Timer (Allowed_Time);
- select
- Initial_Po.Start_Here;
- Report.Failed ("not enough time completed accept (2)");
- or
- delay until Calendar.Clock + Not_Enough_Time;
- end select;
- if Final_Po_Reached then
- Report.Failed ("not enough time (2)");
- else
- if Verbose then
- Report.Comment ("not enough time case passed (2)");
- end if;
- end if;
- Delayed_Opener.Cancel_Timer;
-
-
- -- conditional case
- Delayed_Opener.Start_Timer (Allowed_Time);
- select
- Initial_Po.Start_Here;
- Report.Failed ("no time completed accept");
- else
- if Verbose then
- Report.Comment ("conditional case - else taken");
- end if;
- end select;
- if Final_Po_Reached then
- Report.Failed ("no time");
- else
- if Verbose then
- Report.Comment ("no time case passed");
- end if;
- end if;
- Delayed_Opener.Cancel_Timer;
-
- -- kill off the Delayed_Opener task
- Delayed_Opener.Start_Timer (-10.0);
-
- exception
- when others =>
- Report.Failed ("exception in main");
- end;
-
- Report.Result;
-end C954026;
diff --git a/gcc/testsuite/ada/acats/tests/c9/c954a01.a b/gcc/testsuite/ada/acats/tests/c9/c954a01.a
deleted file mode 100644
index 34f48b29171..00000000000
--- a/gcc/testsuite/ada/acats/tests/c9/c954a01.a
+++ /dev/null
@@ -1,262 +0,0 @@
--- C954A01.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that if a task requeued without abort on a protected entry queue
--- is aborted, the abort is deferred until the entry call completes,
--- after which the task becomes completed.
---
--- TEST DESCRIPTION:
--- Declare a protected type which simulates a printer device driver
--- (foundation code).
---
--- Declare a task which simulates a printer server for multiple printers.
---
--- For the protected type, declare an entry with a barrier that is set
--- false by a protected procedure (which simulates starting a print job
--- on the printer), and is set true by a second protected procedure (which
--- simulates a handler called when the printer interrupts, indicating
--- that printing is done).
---
--- For the task, declare an entry whose corresponding accept statement
--- contains a call to first protected procedure of the protected type
--- (which sets the barrier of the protected entry to false), followed by
--- a requeue with abort to the protected entry. Declare a second entry
--- which does nothing.
---
--- Declare a "requesting" task which calls the printer server task entry
--- (and thus executes the requeue). Attempt to abort the requesting
--- task. Verify that it is not aborted. Call the second protected
--- procedure of the protected type (the interrupt handler) and verify that
--- the protected entry completes for the requesting task. Verify that
--- the requesting task is then aborted.
---
--- TEST FILES:
--- This test depends on the following foundation code:
---
--- F954A00.A
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 10 Oct 96 SAIC Added pragma elaborate.
---
---!
-
-package C954A01_0 is -- Printer server abstraction.
-
- -- Simulate a system with multiple printers. The entry Print requests
- -- that data be printed on the next available printer. The entry call
- -- is accepted when a printer is available, and completes when printing
- -- is done.
-
-
- task Printer_Server is
- entry Print (File_Name : String); -- Test the requeue statement.
- entry Verify_Results; -- Artifice for test purposes.
- end Printer_Server;
-
-end C954A01_0;
-
-
- --==================================================================--
-
-
-with Report;
-with ImpDef;
-
-with F954A00; -- Printer device abstraction.
-use F954A00;
-pragma Elaborate(F954A00);
-
-package body C954A01_0 is -- Printer server abstraction.
-
- task body Printer_Server is
- Printers_Busy : Boolean := True;
- Index : Printer_ID := 1;
- Print_Accepted : Boolean := False;
- begin
-
- loop
- -- Wait for a printer to become available:
-
- while Printers_Busy loop
- Printers_Busy := False; -- Exit loop if
- -- entry accepted.
- select
- Printer(Index).Done_Printing; -- Accepted immed.
- -- when printer is
- -- available.
- else
- Index := 1 + (Index mod Number_Of_Printers);-- Entry not immed.
- Printers_Busy := True; -- accepted; keep
- end select; -- looping.
- end loop;
- -- Value of Index
- -- at loop exit
- -- identifies the
- -- avail. printer.
-
- -- Wait for a print request or terminate:
-
- select
- accept Print (File_Name : String) do
- Print_Accepted := True; -- Allow
- -- Verify_Results
- -- to be accepted.
-
- Printer(Index).Start_Printing (File_Name); -- Begin printing on
- -- the available
- -- -- -- printer.
- -- Requeue is tested here --
- -- --
- -- Requeue caller so
- requeue Printer(Index).Done_Printing; -- server task free
- -- to accept other
- end Print; -- requests.
- or
- -- Guard ensures that Verify_Results cannot be accepted
- -- until after Print has been accepted. This avoids a
- -- race condition in the main program.
-
- when Print_Accepted => accept Verify_Results; -- Artifice for
- -- testing purposes.
- or
- terminate;
- end select;
-
- -- Allow other tasks to get control
- delay ImpDef.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.Switch_To_New_Task;
-
- --==============================================--
-
- task Print_Request; -- Send a print request.
-
- task body Print_Request is
- My_File : constant String := "MYFILE.DAT";
- begin
- Printer_Server.Print (My_File); -- Invoke requeue statement.
- Report.Failed ("Task continued execution following entry call");
- exception
- when others =>
- Report.Failed ("Exception raised in Print_Request task");
- end Print_Request;
-
- --==============================================--
-
-begin -- Main program.
-
- Report.Test ("C954A01", "Requeue without abort - check that the abort " &
- "is deferred until after the rendezvous completes. (Task to PO)");
-
- -- To pass this test, the following must be true:
- --
- -- (A) The abort of Print_Request is deferred until after the
- -- Done_Printing entry body completes.
- -- (B) Print_Request aborts after the Done_Printing entry call
- -- completes.
- --
- -- Call the entry Verify_Results. The entry call will not be accepted
- -- until after Print_Request has been requeued to Done_Printing.
-
- Printer_Server.Verify_Results; -- Accepted after Print_Request is
- -- requeued to Done_Printing.
-
- -- Simulate an application which needs access to the printer within
- -- a specified time, and which aborts the current printer job if time
- -- runs out.
-
- select
- Printer(1).Done_Printing; -- Wait for printer to come free.
- or
- delay Long_Enough; -- Print job took too long.
- abort Print_Request; -- Abort print job.
- end select;
-
- Printer_Server.Verify_Results; -- Abortion completion point: force
- -- abort to complete (if it's going
- -- to).
-
- -- Verify that the Done_Printing entry body has not yet completed,
- -- and thus that Print_Request has not been aborted.
-
- if Printer(1).Is_Done then
- Report.Failed ("Target entry of requeue executed prematurely");
- elsif Print_Request'Terminated then
- Report.Failed ("Caller was aborted before entry was complete");
- else
-
- Printer(1).Handle_Interrupt; -- Simulate a printer interrupt,
- -- signaling that printing is
- -- done.
-
- -- The Done_Printing entry body will complete before the next protected
- -- action is called (Printer(1).Is_Done). Verify (A) and (B): that the
- -- Print_Request is aborted.
-
- Printer_Server.Verify_Results; -- Abortion completion point: force
- -- Print_Request abort to complete.
-
- if not Printer(1).Is_Done then
- Report.Failed ("Target entry of requeue did not complete");
- end if;
-
- if not Print_Request'Terminated then
- Report.Failed ("Task not aborted following completion of entry call");
- abort Print_Request; -- Try to kill hung task.
- end if;
-
- end if;
-
- Report.Result;
-
-end C954A01;
diff --git a/gcc/testsuite/ada/acats/tests/c9/c954a02.a b/gcc/testsuite/ada/acats/tests/c9/c954a02.a
deleted file mode 100644
index 7d61aea8c23..00000000000
--- a/gcc/testsuite/ada/acats/tests/c9/c954a02.a
+++ /dev/null
@@ -1,259 +0,0 @@
--- C954A02.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that if a task requeued with abort on a protected entry queue
--- is aborted, the protected entry call is canceled and the aborted
--- task becomes completed.
---
--- TEST DESCRIPTION:
--- Declare a protected type which simulates a printer device driver
--- (foundation code).
---
--- Declare a task which simulates a printer server for multiple printers.
---
--- For the protected type, declare an entry with a barrier that is set
--- false by a protected procedure (which simulates starting a print job
--- on the printer), and is set true by a second protected procedure (which
--- simulates a handler called when the printer interrupts, indicating
--- that printing is done).
---
--- For the task, declare an entry whose corresponding accept statement
--- contains a call to first protected procedure of the protected type
--- (which sets the barrier of the protected entry to false), followed by
--- a requeue with abort to the protected entry. Declare a second entry
--- which does nothing.
---
--- Declare a "requesting" task which calls the printer server task entry
--- (and thus executes the requeue). Attempt to abort the requesting
--- task. Verify that it is aborted, that the requeued entry call is
--- canceled, and that the corresponding entry body is not executed.
---
--- TEST FILES:
--- This test depends on the following foundation code:
---
--- F954A00.A
---
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 10 Oct 96 SAIC Added pragma elaborate
---
---!
-
-package C954A02_0 is -- Printer server abstraction.
-
- -- Simulate a system with multiple printers. The entry Print requests
- -- that data be printed on the next available printer. The entry call
- -- is accepted when a printer is available, and completes when printing
- -- is done.
-
-
- task Printer_Server is
- entry Print (File_Name : String); -- Test the requeue statement.
- entry Verify_Results; -- Artifice for test purposes.
- end Printer_Server;
-
-end C954A02_0;
-
-
- --==================================================================--
-
-
-with Report;
-with ImpDef;
-
-with F954A00; -- Printer device abstraction.
-use F954A00;
-pragma Elaborate(F954a00);
-
-package body C954A02_0 is -- Printer server abstraction.
-
- task body Printer_Server is
- Printers_Busy : Boolean := True;
- Index : Printer_ID := 1;
- Print_Accepted : Boolean := False;
- begin
-
- loop
- -- Wait for a printer to become available:
-
- while Printers_Busy loop
- Printers_Busy := False; -- Exit loop if
- -- entry accepted.
- select
- Printer(Index).Done_Printing; -- Accepted immed.
- -- when printer is
- -- available.
- else
- Index := 1 + (Index mod Number_Of_Printers);-- Entry not immed.
- Printers_Busy := True; -- accepted; keep
- end select; -- looping.
-
- -- Allow other task to get control
- delay ImpDef.Minimum_Task_Switch;
-
- end loop; -- Value of Index
- -- at loop exit
- -- identifies the
- -- avail. printer.
-
- -- Wait for a print request or terminate:
-
- select
- accept Print (File_Name : String) do
- Print_Accepted := True; -- Allow
- -- Verify_Results
- -- to be accepted.
-
- Printer(Index).Start_Printing (File_Name); -- Begin printing on
- -- the available
- -- -- -- printer.
- -- Requeue is tested here --
- -- --
- -- Requeue caller so
- requeue Printer(Index).Done_Printing -- server task free
- with abort; -- to accept other
- end Print; -- requests.
- or
- -- Guard ensures that Verify_Results cannot be accepted
- -- until after Print has been accepted. This avoids a
- -- race condition in the main program.
-
- when Print_Accepted => accept Verify_Results; -- Artifice for
- -- testing purposes.
- or
- terminate;
- end select;
-
- end loop;
-
- exception
- when others =>
- Report.Failed ("Exception raised in Printer_Server task");
- end Printer_Server;
-
-
-end C954A02_0;
-
-
- --==================================================================--
-
-
-with Report;
-with ImpDef;
-
-with F954A00; -- Printer device abstraction.
-with C954A02_0; -- Printer server abstraction.
-
-use C954A02_0;
-use F954A00;
-
-procedure C954A02 is
-
- -- Length of time which simulates a very long process
- Long_Enough : constant Duration := ImpDef.Clear_Ready_Queue;
-
- --==============================================--
-
- task Print_Request; -- Send a print request.
-
- task body Print_Request is
- My_File : constant String := "MYFILE.DAT";
- begin
- Printer_Server.Print (My_File); -- Invoke requeue statement.
- Report.Failed ("Task continued execution following entry call");
- exception
- when others =>
- Report.Failed ("Exception raised in Print_Request task");
- end Print_Request;
-
- --==============================================--
-
-begin -- Main program.
-
- Report.Test ("C954A02", "Abort a requeue on a Protected entry");
-
- -- To pass this test, the following must be true:
- --
- -- (A) The abort of Print_Request takes place immediately.
- -- (B) The Done_Printing entry call is canceled, and the corresponding
- -- entry body is not executed.
- --
- -- Call the entry Verify_Results. The entry call will not be accepted
- -- until after Print_Request has been requeued to Done_Printing.
-
- Printer_Server.Verify_Results; -- Accepted after Print_Request is
- -- requeued to Done_Printing.
-
- -- Verify that the Done_Printing entry call has not been completed.
- --
- if Printer(1).Is_Done then
- Report.Failed ("Target entry of requeue executed prematurely");
- else
-
- -- Simulate an application which needs access to the printer within
- -- a specified time, and which aborts the current printer job if time
- -- runs out.
-
- select
- Printer(1).Done_Printing; -- Wait for printer to come free.
- or
- delay Long_Enough; -- Print job took too long.
- abort Print_Request; -- Abort print job.
- end select;
-
- Printer_Server.Verify_Results; -- Abortion completion point: force
- -- Print_Request abort to complete.
-
- -- Verify (A): that Print_Request has been aborted.
- -- Note: the test will hang if the task as not been aborted
- --
- while not Print_Request'Terminated loop
- delay ImpDef.Minimum_Task_Switch;
- end loop;
-
- -- Verify (B): that the Done_Printing entry call was canceled, and
- -- the corresponding entry body was not executed.
- --
- -- Set the barrier of the entry to true, then check that the entry
- -- body is not executed. If the entry call is NOT canceled, the
- -- entry body will execute when the barrier is set true.
-
- Printer(1).Handle_Interrupt; -- Simulate a printer interrupt,
- -- signaling that printing is
- -- done.
- if Printer(1).Is_Done then
- Report.Failed ("Entry call was not canceled");
- end if;
-
-
- end if;
-
-
- Report.Result;
-
-end C954A02;
diff --git a/gcc/testsuite/ada/acats/tests/c9/c954a03.a b/gcc/testsuite/ada/acats/tests/c9/c954a03.a
deleted file mode 100644
index 13d21311c7b..00000000000
--- a/gcc/testsuite/ada/acats/tests/c9/c954a03.a
+++ /dev/null
@@ -1,322 +0,0 @@
--- C954A03.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that a requeue statement in an accept_statement with
--- parameters may requeue the entry call to a protected entry with no
--- parameters. Check that, if the call is queued on the new entry's
--- queue, the original caller remains blocked after the requeue, but
--- the accept_statement containing the requeue is completed.
---
--- Note that this test uses a requeue "with abort," although it does not
--- check that such a requeued caller can be aborted; that feature is
--- tested elsewhere.
---
--- TEST DESCRIPTION:
--- Declare a protected type which simulates a printer device driver
--- (foundation code).
---
--- Declare a task which simulates a printer server for multiple printers.
---
--- For the protected type, declare an entry with a barrier that is set
--- false by a protected procedure (which simulates starting a print job
--- on the printer), and is set true by a second protected procedure (which
--- simulates a handler called when the printer interrupts, indicating
--- that printing is done).
---
--- For the task, declare an entry whose corresponding accept statement
--- contains a call to first protected procedure of the protected type
--- (which sets the barrier of the protected entry to false), followed by
--- a requeue with abort to the protected entry. Declare a second entry
--- which does nothing.
---
--- Declare a "requesting" task which calls the printer server task entry
--- (and thus executes the requeue). Verify that, following the requeue,
--- the requesting task remains blocked. Call the second entry of the
--- printer server task (the acceptance of this entry call verifies that
--- the requeue statement completed the entry call by the requesting task.
--- Call the second protected procedure of the protected type (the
--- interrupt handler) and verify that the protected entry completes for
--- the requesting task (which verifies that the requeue statement queued
--- the first task object to the protected entry).
---
--- TEST FILES:
--- This test depends on the following foundation code:
---
--- F954A00.A
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 10 Oct 96 SAIC Added pragma elaborate.
---
---!
-
-package C954A03_0 is -- Printer server abstraction.
-
- -- Simulate a system with multiple printers. The entry Print requests
- -- that data be printed on the next available printer. The entry call
- -- is accepted when a printer is available, and completes when printing
- -- is done.
-
- task Printer_Server is
- entry Print (File_Name : String); -- Test the requeue statement.
- entry Verify_Results; -- Artifice for test purposes.
- end Printer_Server;
-
-end C954A03_0;
-
-
- --==================================================================--
-
-
-with Report;
-with ImpDef;
-
-with F954A00; -- Printer device abstraction.
-use F954A00;
-pragma Elaborate(F954a00);
-
-package body C954A03_0 is -- Printer server abstraction.
-
-
- task body Printer_Server is
- Printers_Busy : Boolean := True;
- Index : Printer_ID := 1;
- Print_Accepted : Boolean := False;
- begin
-
- loop
- -- Wait for a printer to become available:
-
- while Printers_Busy loop
- Printers_Busy := False; -- Exit loop if
- -- entry accepted.
- select
- Printer(Index).Done_Printing; -- Accepted immed.
- -- when printer is
- -- available.
- else
- Index := 1 + (Index mod Number_Of_Printers);-- Entry not immed.
- Printers_Busy := True; -- accepted; keep
- end select; -- looping.
-
- -- Allow other tasks to get control
- delay ImpDef.Minimum_Task_Switch;
-
- end loop;
- -- Value of Index
- -- at loop exit
- -- identifies the
- -- avail. printer.
-
- -- Wait for a print request or terminate:
-
- select
- accept Print (File_Name : String) do
- Print_Accepted := True; -- Allow
- -- Verify_Results
- -- to be accepted.
-
- Printer(Index).Start_Printing (File_Name); -- Begin printing on
- -- the available
- -- -- -- printer.
- -- Requeue is tested here --
- -- --
- -- Requeue caller so
- requeue Printer(Index).Done_Printing -- server task free
- with abort; -- to accept other
- end Print; -- requests.
- or
- -- Guard ensures that Verify_Results cannot be accepted
- -- until after Print has been accepted. This avoids a
- -- race condition in the main program.
-
- when Print_Accepted => accept Verify_Results; -- Artifice for
- -- testing purposes.
- or
- terminate;
- end select;
-
- end loop;
-
- exception
- when others =>
- Report.Failed ("Exception raised in Printer_Server task");
- end Printer_Server;
-
-
-end C954A03_0;
-
-
- --==================================================================--
-
-
-with Report;
-with ImpDef;
-
-with F954A00; -- Printer device abstraction.
-with C954A03_0; -- Printer server abstraction.
-
-use C954A03_0;
-use F954A00;
-
-procedure C954A03 is
-
- Long_Enough : constant Duration := ImpDef.Clear_Ready_Queue;
-
-
- --==============================================--
-
- Task_Completed : Boolean := False; -- Testing flag.
-
- protected Interlock is -- Artifice for test purposes.
- entry Wait; -- Wait for lock to be released.
- procedure Release; -- Release the lock.
- private
- Locked : Boolean := True;
- end Interlock;
-
-
- protected body Interlock is
-
- entry Wait when not Locked is -- Calls are queued until after
- -- -- Release is called.
- begin
- Task_Completed := True;
- end Wait;
-
- procedure Release is -- Called by Print_Request.
- begin
- Locked := False;
- end Release;
-
- end Interlock;
-
- --==============================================--
-
- task Print_Request is -- Send a print request.
- end Print_Request;
-
- task body Print_Request is
- My_File : constant String := "MYFILE.DAT";
- begin
- Printer_Server.Print (My_File); -- Invoke requeue statement.
- Interlock.Release; -- Allow main to continue.
- exception
- when others =>
- Report.Failed ("Exception raised in Print_Request task");
- end Print_Request;
-
- --==============================================--
-
-begin -- Main program.
-
- Report.Test ("C954A03", "Requeue from an Accept with parameters" &
- " to a Protected Entry without parameters");
-
- -- To pass this test, the following must be true:
- --
- -- (A) The Print entry call made by the task Print_Request must be
- -- completed by the requeue statement.
- -- (B) Print_Request must remain blocked following the requeue.
- -- (C) Print_Request must be queued on the Done_Printing queue of
- -- Printer(1).
- -- (D) Print_Request must continue execution after Done_Printing is
- -- complete.
- --
- -- First, verify (A): that the Print entry call is complete.
- --
- -- Call the entry Verify_Results. If the requeue statement completed the
- -- entry call to Print, the entry call to Verify_Results should be
- -- accepted. Since the main will hang if this is NOT the case, make this
- -- a timed entry call.
-
- select
- Printer_Server.Verify_Results; -- Accepted if requeue completed
- -- entry call to Print.
- or
- delay Long_Enough; -- Time out otherwise.
- Report.Failed ("Requeue did not complete entry call");
- end select;
-
- -- Now verify (B): that Print_Request remains blocked following the
- -- requeue. Also verify that Done_Printing (the entry to which
- -- Print_Request should have been queued) has not yet executed.
-
- if Printer(1).Is_Done then
- Report.Failed ("Target entry of requeue executed prematurely");
- elsif Print_Request'Terminated then
- Report.Failed ("Caller did not remain blocked after the requeue");
- else
-
- -- Verify (C): that Print_Request is queued on the
- -- Done_Printing queue of Printer(1).
- --
- -- Set the barrier for Printer(1).Done_Printing to true. Check
- -- that the Done flag is updated and that Print_Request terminates.
-
- Printer(1).Handle_Interrupt; -- Simulate a printer interrupt,
- -- signaling that printing is
- -- done.
-
- -- The Done_Printing entry body will complete before the next
- -- protected action is called (Printer(1).Is_Done).
-
- if not Printer(1).Is_Done then
- Report.Failed ("Caller was not requeued on target entry");
- end if;
-
- -- Finally, verify (D): that Print_Request continues after Done_Printing
- -- completes.
- --
- -- After Done_Printing completes, there is a potential race condition
- -- between the main program and Print_Request. The protected object
- -- Interlock is provided to ensure that the check of whether
- -- Print_Request continued is made *after* it has had a chance to do so.
- -- The main program waits until the statement in Print_Request following
- -- the requeue-causing statement has executed, then checks to see
- -- whether Print_Request did in fact continue executing.
- --
- -- Note that the test will hang here if Print_Request does not continue
- -- executing following the completion of the requeued entry call.
-
- Interlock.Wait; -- Wait until Print_Request is
- -- done.
- if not Task_Completed then
- Report.Failed ("Caller remained blocked after target " &
- "entry released");
- end if;
-
- -- Wait for Print_Request to finish before calling Report.Result.
- while not Print_Request'Terminated loop
- delay ImpDef.Minimum_Task_Switch;
- end loop;
-
- end if;
-
- Report.Result;
-
-end C954A03;
diff --git a/gcc/testsuite/ada/acats/tests/c9/c960001.a b/gcc/testsuite/ada/acats/tests/c9/c960001.a
deleted file mode 100644
index 4eaa1f49ff1..00000000000
--- a/gcc/testsuite/ada/acats/tests/c9/c960001.a
+++ /dev/null
@@ -1,164 +0,0 @@
--- C960001.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Confirm that a simple Delay Until statement is performed. Check
--- that the delay does not complete before the requested time and that it
--- does complete thereafter
---
--- TEST DESCRIPTION:
--- Simulate a task that sends a "pulse" at regular intervals. The Delay
--- Until statement is used to avoid accumulated drift. For the
--- test, we expect the delay to return very close to the requested time;
--- we use an additional Pulse_Time_Delta for the limit. The test
--- driver (main) artificially limits the number of iterations by setting
--- the Stop_Pulse Boolean after a small number.
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 15 Nov 95 SAIC Fixed global variable problem for ACVC 2.0.1
---
---!
-
-with Report;
-with Ada.Calendar;
-with ImpDef;
-
-procedure C960001 is
-
-begin
-
- Report.Test ("C960001", "Simple Delay Until");
-
- declare -- To get the Report.Result after all has completed
-
- function "+" (Left : Ada.Calendar.Time; Right: Duration)
- return Ada.Calendar.Time renames Ada.Calendar."+";
- function "<" (Left, Right : Ada.Calendar.Time)
- return Boolean renames Ada.Calendar."<";
- function ">" (Left, Right : Ada.Calendar.Time)
- return Boolean renames Ada.Calendar.">";
-
- TC_Loop_Count : integer range 0..4 := 0;
-
-
- -- control over stopping tasks
- protected Control is
- procedure Stop_Now;
- function Stop return Boolean;
- private
- Halt : Boolean := False;
- end Control;
-
- protected body Control is
- procedure Stop_Now is
- begin
- Halt := True;
- end Stop_Now;
-
- function Stop return Boolean is
- begin
- return Halt;
- end Stop;
- end Control;
-
- task Pulse_Task is
- entry Trigger;
- end Pulse_Task;
-
-
- -- Task to synchronize all qualified receivers.
- -- The entry Trigger starts the synchronization; Control.Stop
- -- becoming true terminates the task.
- --
- task body Pulse_Task is
-
- Pulse_Time : Ada.Calendar.Time;
-
- Pulse_Time_Delta : duration := ImpDef.Clear_Ready_Queue;
-
- TC_Last_Time : Ada.Calendar.Time;
- TC_Current : Ada.Calendar.Time;
-
-
- -- This routine transmits a synchronizing "pulse" to
- -- all receivers
- procedure Pulse is
- begin
- null; -- Stub
- Report.Comment (".......PULSE........");
- end Pulse;
-
- begin
- accept Trigger;
-
- Pulse_Time := Ada.Calendar.Clock + Pulse_Time_Delta;
- TC_Last_Time := Pulse_Time;
-
- while not Control.Stop loop
- delay until Pulse_Time;
- Pulse;
-
- -- Calculate time for next pulse. Note: this is based on the
- -- last pulse time, not the time we returned from the delay
- --
- Pulse_Time := Pulse_Time + Pulse_Time_Delta;
-
- -- Test Control:
- TC_Current := Ada.Calendar.Clock;
- if TC_Current < TC_Last_Time then
- Report.Failed ("Delay expired before requested time");
- end if;
- if TC_Current > Pulse_Time then
- Report.Failed ("Delay too long");
- end if;
- TC_Last_Time := Pulse_Time;
- TC_Loop_Count := TC_Loop_Count +1;
- end loop;
-
- exception
- when others =>
- Report.Failed ("Unexpected exception in Pulse_Task");
- end Pulse_Task;
-
-
-
- begin -- declare
-
- Pulse_Task.Trigger; -- Start test
-
- -- Artificially limit the number of iterations
- while TC_Loop_Count < 3 loop
- delay ImpDef.Minimum_Task_Switch;
- end loop;
- --
- Control.Stop_Now; -- End test
-
- end; -- declare
-
- Report.Result;
-
-end C960001;
diff --git a/gcc/testsuite/ada/acats/tests/c9/c960002.a b/gcc/testsuite/ada/acats/tests/c9/c960002.a
deleted file mode 100644
index 06edaf0c9d5..00000000000
--- a/gcc/testsuite/ada/acats/tests/c9/c960002.a
+++ /dev/null
@@ -1,171 +0,0 @@
--- C960002.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that the simple "delay until" when the request time is "now" and
--- also some time already in the past is obeyed and returns immediately
---
--- TEST DESCRIPTION:
--- Simulate a task that sends a "pulse" at regular intervals. The Delay
--- Until statement is used to avoid accumulated drift. In this test
--- three simple situations simulating the start of drift are used: the
--- next pulse being called for at the normal time, the next pulse being
--- called for at exactly the current time and then at some time which has
--- already past. We assume the delay is within a While Loop and, to
--- simplify the test, we "unfold" the While Loop and execute the Delays
--- in a serial fashion. This loop is shown in test C960001.
--- It is not possible to test the actual immediacy of the expiration. We
--- can only check that it returns in a "reasonable" time. In this case
--- we check that it expires before the next "pulse" should have been
--- issued.
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
---
---!
-
-with Report;
-with ImpDef;
-
-with Ada.Calendar;
-with System;
-
-procedure C960002 is
-
-begin
-
- Report.Test ("C960002", "Simple Delay Until with requested time being" &
- " ""now"" and time already in the past");
-
- declare -- To get the Report.Result after all has completed
-
- function "+" (Left : Ada.Calendar.Time; Right: Duration)
- return Ada.Calendar.Time renames Ada.Calendar."+";
- function "-" (Left : Ada.Calendar.Time; Right: Duration)
- return Ada.Calendar.Time renames Ada.Calendar."-";
- function "-" (Left, Right : Ada.Calendar.Time)
- return duration renames Ada.Calendar."-";
- function ">" (Left, Right : Ada.Calendar.Time)
- return Boolean renames Ada.Calendar.">";
-
-
- task Pulse_Task is
- entry Trigger;
- end Pulse_Task;
-
-
- -- Task to synchronize all qualified receivers.
- -- The entry Trigger starts the synchronization.
- --
- task body Pulse_Task is
- Pulse_Time : Ada.Calendar.Time;
- Pulse_Time_Delta : constant duration := ImpDef.Clear_Ready_Queue;
-
-
-
- TC_Time_Back : Ada.Calendar.Time;
-
-
- -- This routine transmits a synchronizing "pulse" to
- -- all receivers
- procedure Pulse is
- begin
- null; -- Stub
- Report.Comment (".......PULSE........");
- end Pulse;
-
- begin
- accept Trigger;
- Pulse;
- ---------------
- -- normal calculation for "next"
- Pulse_Time := Ada.Calendar.Clock + Pulse_Time_Delta;
-
- -- TC: unfold the "while" loop in C960001. Four passes through
- -- the loop are shown
-
- delay until Pulse_Time;
-
- Pulse;
- ---------------
- -- TC: the normal calculation for "next" would be
- -- Pulse_Time := Pulse_Time + Pulse_Time_Delta;
- -- Instead of this normal pulse time calculation simulate
- -- the new pulse time to be exactly "now" (or, as exactly as
- -- we can)
- Pulse_Time := Ada.Calendar.Clock;
- delay until Ada.Calendar.Clock;
-
- TC_Time_Back := Ada.Calendar.Clock;
-
- -- Now check for reasonableness
- if TC_Time_Back > Pulse_Time + Pulse_Time_Delta then
- Report.Failed
- ("""Now"" delayed for more than Pulse_Time_Delta - A");
- end if;
- Pulse;
- ---------------
- -- normal calculation for "next" would be
- Pulse_Time := Pulse_Time + Pulse_Time_Delta;
-
- -- TC: Instead of this, simulate the new calculated pulse time
- -- being already past
- Pulse_Time := Ada.Calendar.Clock - System.Tick;
- delay until Pulse_Time;
-
- TC_Time_Back := Ada.Calendar.Clock;
-
- -- Now check for reasonableness
- if TC_Time_Back > Pulse_Time + Pulse_Time_Delta then
- Report.Failed
- ("""Now"" delayed for more than Pulse_Time_Delta - B");
- end if;
- Pulse;
- ---------------
- -- normal calculation for "next"
- Pulse_Time := Pulse_Time + Pulse_Time_Delta;
- -- Now simulate getting back into synch
- delay until Pulse_Time;
- Pulse;
- ---------------
- -- This would be the end of the "while" loop
-
- exception
- when others =>
- Report.Failed ("Unexpected exception in Pulse_Task");
- end Pulse_Task;
-
-
-
- begin -- declare
-
- Pulse_Task.Trigger; -- Start test
-
- end; -- declare
-
- Report.Result;
-
-end C960002;
diff --git a/gcc/testsuite/ada/acats/tests/c9/c960004.a b/gcc/testsuite/ada/acats/tests/c9/c960004.a
deleted file mode 100644
index f394aab66fc..00000000000
--- a/gcc/testsuite/ada/acats/tests/c9/c960004.a
+++ /dev/null
@@ -1,206 +0,0 @@
--- C960004.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- With the triggering statement being a delay and with the Asynchronous
--- Select statement being in a tasking situation complete the abortable
--- part before the delay expires. Check that the delay is cancelled
--- and that the optional statements in the triggering part are not
--- executed.
---
--- TEST DESCRIPTION:
--- Simulate the creation of a carrier task to control the output of
--- a message via a line driver. If the message sending process is
--- not complete (the completion of the rendezvous) within a
--- specified time the carrier task is designed to take corrective action.
--- Use an asynchronous select to control the timing; arrange that
--- the abortable part (the rendezvous) completes almost immediately.
--- Check that the optional statements are not executed and that the
--- test completes well before the time of the trigger delay request thus
--- showing that it has been cancelled.
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
---
---!
-
-
-with Report;
-with Ada.Calendar;
-
-procedure C960004 is
-
- function "-" (Left, Right : Ada.Calendar.Time)
- return Duration renames Ada.Calendar."-";
- TC_Start_Time : Ada.Calendar.Time := Ada.Calendar.Clock;
- TC_Elapsed_Time : duration;
-
- -- Note: a properly executing test will complete immediately.
- Allowable_ACK_Time : duration := 600.0;
-
-begin
-
- Report.Test ("C960004", "ATC: When abortable part completes before " &
- "a triggering delay, check that the delay " &
- "is cancelled & optional statements " &
- "are not performed. Tasking situation");
-
- declare -- To get the Report.Result after all has completed
-
- type Sequence_Number is range 1..1_999_999; -- Message Number
- subtype S_length_subtype is integer range 1..80;
-
- type Message_Type (Max_String : S_length_subtype := 1) is
- record
- Message_Number : Sequence_Number;
- Alpha : string(1..Max_String);
- end record;
-
- -- TC: Dummy message for the test
- Dummy_Alpha : constant string := "This could be printed";
- Message_to_Send : Message_Type (Max_string => Dummy_Alpha'length);
-
-
- -- This is the carrier task. One of these is created for each
- -- message that requires ACK
- --
- task type Require_ACK_task is
- entry Message_In (Message_to_Send: Message_Type);
- end Require_ACK_task;
- type acc_Require_ACK_task is access Require_ACK_task;
-
-
- --:::::::::::::::::::::::::::::::::
- -- There would also be another task type "No_ACK_Task" which would
- -- be the carrier task for those messages not requiring an ACK.
- -- This task would call Send_Message.ACK_Not_Required. It is not
- -- shown in this test as it is not used.
- --:::::::::::::::::::::::::::::::::
-
-
-
- task Send_Message is
- entry ACK_Required (Message_to_Send: Message_Type);
- entry ACK_Not_Required (Message_to_Send: Message_Type);
- end Send_Message;
-
-
- -- This is the carrier task. One of these is created for each
- -- message that requires ACK
- --
- task body Require_ACK_task is
- Hold_Message : Message_Type;
-
- procedure Time_Out (Failed_Message_Number : Sequence_Number) is
- begin
- -- Take remedial action on the timed-out message
- null; -- stub
-
- Report.Failed ("Optional statements in triggering part" &
- " were performed");
- end Time_out;
-
- begin
- accept Message_In (Message_to_Send: Message_Type) do
- Hold_Message := Message_to_Send; -- to release caller
- end Message_In;
-
- -- Now put the message out to the Send_Message task and
- -- wait (no more than Allowable_Ack_Time) for its completion
- --
- select
- delay Allowable_ACK_Time;
- -- ACK not received in specified time
- Time_out (Hold_Message.Message_Number);
- then abort
- -- If the rendezvous is not completed in the above time, this
- -- call is cancelled
- -- Note: for this test this call will complete immediately
- -- and thus the trigger should be cancelled
- Send_Message.ACK_Required (Hold_Message);
- end select;
-
- exception
- when others =>
- Report.Failed ("Unexpected exception in Require_ACK_task");
- end Require_ACK_task;
-
-
- -- This is the Line Driver task
- --
- task body Send_Message is
- Hold_Non_ACK_Message : Message_Type;
- begin
- loop
- select
- accept ACK_Required (Message_to_Send: Message_Type) do
- -- Here send the message from within the rendezvous
- -- waiting for full transmission to complete
- null; -- stub
- -- Note: In this test this accept will complete immediately
- end ACK_Required;
- or
- accept ACK_Not_Required (Message_to_Send: Message_Type) do
- Hold_Non_ACK_Message := Message_to_Send;
- end ACK_Not_Required;
- -- Here send the message from outside the rendezvous
- null; -- stub
- or
- terminate;
- end select;
- end loop;
- exception
- when others => Report.Failed ("Unexpected exception in Send_Message");
- end Send_Message;
-
- begin -- declare
- -- Build a dummy message
- Message_to_Send.Alpha := Dummy_Alpha;
- Message_to_Send.Message_Number := 110_693;
-
- declare
- New_Require_ACK_task : acc_Require_ACK_task :=
- new Require_ACK_task;
- begin
- -- Create a carrier task for this message and pass the latter in
- New_Require_ACK_task.Message_In (Message_to_Send);
- end; -- declare
-
- end; -- declare
-
- --Once we are out of the above declarative region, all tasks have completed
-
- TC_Elapsed_Time := Ada.Calendar.Clock - TC_Start_Time;
-
- -- Check that the test has completed well before the time of the requested
- -- delay to ensure the delay was cancelled
- --
- if (TC_Elapsed_Time > Allowable_ACK_Time/2) then
- Report.Failed ("Triggering delay statement was not cancelled");
- end if;
-
- Report.Result;
-end C960004;
diff --git a/gcc/testsuite/ada/acats/tests/c9/c974001.a b/gcc/testsuite/ada/acats/tests/c9/c974001.a
deleted file mode 100644
index 04ac93e6d8f..00000000000
--- a/gcc/testsuite/ada/acats/tests/c9/c974001.a
+++ /dev/null
@@ -1,152 +0,0 @@
--- C974001.A
---
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that the abortable part of an asynchronous select statement
--- is aborted if it does not complete before the triggering statement
--- completes, where the triggering statement is a delay_relative
--- statement and check that the sequence of statements of the triggering
--- alternative is executed after the abortable part is left.
---
--- TEST DESCRIPTION:
--- Declare a task with an accept statement containing an asynchronous
--- select with a delay_relative triggering statement. Parameterize
--- the accept statement with the time to be used in the delay. Simulate a
--- time-consuming calculation by declaring a procedure containing an
--- infinite loop. Call this procedure in the abortable part.
---
--- The delay will expire before the abortable part completes, at which
--- time the abortable part is aborted, and the sequence of statements
--- following the triggering statement is executed.
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
---
---!
-
-with Report;
-with ImpDef;
-
-procedure C974001 is
-
-
- --========================================================--
-
- -- Medium length delay
- Allotted_Time : constant Duration := ImpDef.Switch_To_New_Task;
-
- Calculation_Canceled : exception;
-
-
- Count : Integer := 1234;
-
- procedure Lengthy_Calculation is
- begin
- -- Simulate a non-converging calculation.
- loop -- Infinite loop.
- Count := (Count + 1) mod 10;
- delay ImpDef.Minimum_Task_Switch; -- allow other task
- end loop;
- end Lengthy_Calculation;
-
-
- --========================================================--
-
-
- task type Timed_Calculation is
- entry Calculation (Time_Limit : in Duration);
- end Timed_Calculation;
-
-
- task body Timed_Calculation is
- --
- begin
- loop
- select
- accept Calculation (Time_Limit : in Duration) do
-
- -- --
- -- Asynchronous select is tested here --
- -- --
-
- select
- delay Time_Limit; -- Time_Limit is not up yet, so
- -- Lengthy_Calculation starts.
-
- raise Calculation_Canceled; -- This is executed after
- -- Lengthy_Calculation aborted.
- then abort
- Lengthy_Calculation; -- Delay expires before complete,
- -- so this call is aborted.
-
- -- Check that the whole of the abortable part is aborted,
- -- not just the statement in the abortable part that was
- -- executing at the time
- Report.Failed ("Abortable part not aborted");
-
- end select;
-
- Report.Failed ("Triggering alternative sequence of " &
- "statements not executed");
-
- exception -- New Ada 9x: handler within accept
- when Calculation_Canceled =>
- if Count = 1234 then
- Report.Failed ("Abortable part did not execute");
- end if;
- end Calculation;
- or
- terminate;
- end select;
- end loop;
- exception
- when others =>
- Report.Failed ("Unexpected exception in Timed_Calculation task");
- end Timed_Calculation;
-
-
- --========================================================--
-
-
-begin -- Main program.
-
- Report.Test ("C974001", "Asynchronous Select: Trigger is delay_relative" &
- " which completes before abortable part");
-
- declare
- Timed : Timed_Calculation; -- Task.
- begin
- Timed.Calculation (Time_Limit => Allotted_Time); -- Asynchronous select
- -- inside accept block.
- exception
- when Calculation_Canceled =>
- null; -- expected behavior
- end;
-
- Report.Result;
-
-end C974001;
diff --git a/gcc/testsuite/ada/acats/tests/c9/c974002.a b/gcc/testsuite/ada/acats/tests/c9/c974002.a
deleted file mode 100644
index 1138e8da3bc..00000000000
--- a/gcc/testsuite/ada/acats/tests/c9/c974002.a
+++ /dev/null
@@ -1,209 +0,0 @@
--- C974002.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that the sequence of statements of the triggering alternative
--- of an asynchronous select statement is executed if the triggering
--- statement is a delay_until statement, and the specified time has
--- already passed. Check that the abortable part is not executed after
--- the sequence of statements of the triggering alternative is left.
---
--- Check that the sequence of statements of the triggering alternative
--- of an asynchronous select statement is not executed if the abortable
--- part completes before the triggering statement, and the triggering
--- statement is a delay_until statement.
---
--- TEST DESCRIPTION:
--- Declare a task with an accept statement containing an asynchronous
--- select with a delay_until triggering statement. Parameterize
--- the accept statement with the time to be used in the delay. Simulate
--- a quick calculation by declaring a procedure which sets a Boolean
--- flag. Call this procedure in the abortable part.
---
--- Make two calls to the task entry: (1) with a time that has already
--- expired, and (2) with a time that will not expire before the quick
--- calculation completes.
---
--- For (1), the sequence of statements following the triggering statement
--- is executed, and the abortable part never starts.
---
--- For (2), the abortable part completes before the triggering statement,
--- the delay is canceled, and the sequence of statements following the
--- triggering statement never starts.
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 26 Nov 95 SAIC Bug fix for ACVC 2.0.1.
---
---!
-
-with Report;
-with Ada.Calendar;
-with ImpDef;
-procedure C974002 is
-
- function "-" (Left: Ada.Calendar.Time; Right: Duration )
- return Ada.Calendar.Time renames Ada.Calendar."-";
- function "+" (Left: Ada.Calendar.Time; Right: Duration )
- return Ada.Calendar.Time renames Ada.Calendar."+";
-
- Abortable_Part_Executed : Boolean;
- Triggering_Alternative_Executed : Boolean;
-
-
- --========================================================--
-
-
- procedure Quick_Calculation is
- begin
- if Report.Equal (1, 1) then
- Abortable_Part_Executed := True;
- end if;
- end Quick_Calculation;
-
-
- --========================================================--
-
-
- task type Timed_Calculation_Task is
- entry Calculation (Time_Out : in Ada.Calendar.Time);
- end Timed_Calculation_Task;
-
-
- task body Timed_Calculation_Task is
- begin
- loop
- select
- accept Calculation (Time_Out : in Ada.Calendar.Time) do
-
- -- --
- -- Asynchronous select is tested here --
- -- --
-
- select
- delay until Time_Out; -- Triggering
- -- statement.
-
- Triggering_Alternative_Executed := True; -- Triggering
- -- alternative.
- then abort
- Quick_Calculation; -- Abortable part.
- end select;
- end Calculation;
- or
- terminate;
- end select;
- end loop;
- exception
- when others =>
- Report.Failed ("Unexpected exception in Timed_Calculation_Task");
- end Timed_Calculation_Task;
-
-
- --========================================================--
-
-
- Start_Time : constant Ada.Calendar.Time :=
- Ada.Calendar.Time_of (1901,1,1);
- Minute : constant Duration := 60.0;
-
-
- --========================================================--
-
-
-begin -- Main program.
-
- Report.Test ("C974002", "Asynchronous Select with Delay_Until");
-
- -- take care of implementations that start the clock at 1/1/01
- delay ImpDef.Delay_For_Time_Past;
-
-
- Abortable_Part_Executed := False;
- Triggering_Alternative_Executed := False;
-
- NO_DELAY_SUBTEST:
-
- declare
- -- Set Expiry to a time which has already passed
- Expiry : constant Ada.Calendar.Time := Start_Time;
- Timed : Timed_Calculation_Task;
- begin
-
- -- Expiry is the time to be specified in the delay_until statement
- -- of the asynchronous select. Since it has already passed, the
- -- abortable part should not execute, and the sequence of statements
- -- of the triggering alternative should be executed.
-
- Timed.Calculation (Time_Out => Expiry); -- Asynchronous select
- -- inside accept block.
- if Abortable_Part_Executed then
- Report.Failed ("No delay: Abortable part was executed");
- end if;
-
- if not Triggering_Alternative_Executed then
- Report.Failed ("No delay: triggering alternative sequence " &
- "of statements was not executed");
- end if;
- end No_Delay_Subtest;
-
-
- Abortable_Part_Executed := False;
- Triggering_Alternative_Executed := False;
-
- LONG_DELAY_SUBTEST:
-
- declare
-
- -- Quick_Calculation should finish before expiry.
- Expiry : constant Ada.Calendar.Time :=
- Ada.Calendar.Clock + Minute;
- Timed : Timed_Calculation_Task;
-
- begin
-
- -- Expiry is the time to be specified in the delay_until statement
- -- of the asynchronous select. It should not pass before the abortable
- -- part completes, at which time control should return to the caller;
- -- the sequence of statements of the triggering alternative should
- -- not be executed.
-
- Timed.Calculation (Time_Out => Expiry); -- Asynchronous select.
-
- if not Abortable_Part_Executed then
- Report.Failed ("Long delay: Abortable part was not executed");
- end if;
-
- if Triggering_Alternative_Executed then
- Report.Failed ("Long delay: triggering alternative sequence " &
- "of statements was executed");
- end if;
- end Long_Delay_Subtest;
-
-
- Report.Result;
-
-end C974002;
diff --git a/gcc/testsuite/ada/acats/tests/c9/c974003.a b/gcc/testsuite/ada/acats/tests/c9/c974003.a
deleted file mode 100644
index c353a918db1..00000000000
--- a/gcc/testsuite/ada/acats/tests/c9/c974003.a
+++ /dev/null
@@ -1,249 +0,0 @@
--- C974003.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that the abortable part of an asynchronous select statement
--- is aborted if it does not complete before the triggering statement
--- completes, where the triggering statement is a task entry call, and
--- the entry call is queued.
---
--- Check that the sequence of statements of the triggering alternative
--- is executed after the abortable part is left.
---
--- TEST DESCRIPTION:
--- Declare a main procedure containing an asynchronous select with a task
--- entry call as triggering statement. Force the entry call to be
--- queued by having the task call a procedure, prior to the corresponding
--- accept statement, which simulates a routine waiting for user input
--- (with a delay).
---
--- Simulate a time-consuming routine in the abortable part by calling a
--- procedure containing an infinite loop. Meanwhile, simulate input by
--- the user (the delay expires), which causes the task to execute the
--- accept statement corresponding to the triggering entry call.
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
---
---!
-
-package C974003_0 is -- Automated teller machine abstraction.
-
-
- -- Flags for testing purposes:
- --
- TC_Triggering_Statement_Completed : Boolean := False;
- TC_Count : Integer := 1234; -- Global to defeat
- -- optimization.
-
- type Key_Enum is (None, Cancel, Deposit, Withdraw);
-
- type Card_Number_Type is private;
- type Card_PIN_Type is private;
- type ATM_Card_Type is private;
-
-
- Transaction_Canceled : exception;
-
-
- task type ATM_Keyboard_Task is
- entry Cancel_Pressed;
- end ATM_Keyboard_Task;
-
-
- procedure Read_Card (Card : in out ATM_Card_Type);
-
- procedure Validate_Card (Card : in ATM_Card_Type);
-
- procedure Perform_Transaction (Card : in ATM_Card_Type);
-
-private
-
- type Card_Number_Type is range 1 .. 9999;
- type Card_PIN_Type is range 100 .. 999;
-
- type ATM_Card_Type is record
- Number : Card_Number_Type;
- PIN : Card_PIN_Type;
- end record;
-
-end C974003_0;
-
-
- --==================================================================--
-
-
-with Report;
-with ImpDef;
-
-package body C974003_0 is
-
-
- procedure Listen_For_Input (Key : out Key_Enum) is
- begin
- -- Model the situation where the user waits a bit for the card to
- -- be validated, then presses cancel before it completes.
-
- -- Delay long enough to force queuing of Keyboard.Cancel_Pressed.
- delay ImpDef.Minimum_Task_Switch;
-
- if Report.Equal (3, 3) then -- Always true.
- Key := Cancel;
- end if;
- end Listen_For_Input;
-
-
-
- -- One of these gets created as "Keyboard" for each transaction
- --
- task body ATM_Keyboard_Task is
- Key_Pressed : Key_Enum := None;
- begin
- loop
- -- Force entry calls
- Listen_For_Input (Key_Pressed); -- to be queued,
- -- then set guard to
- -- true.
- select
- when (Key_Pressed = Cancel) => -- Guard is now
- accept Cancel_Pressed do -- true, so accept
- TC_Triggering_Statement_Completed := True; -- queued entry
- end Cancel_Pressed; -- call.
-
- -- User has cancelled the transaction so we exit the
- -- loop and allow the task to terminate
- exit;
- else
- Key_Pressed := None;
- end select;
-
- end loop;
- exception
- when others =>
- Report.Failed ("Unexpected Exception in ATM_Keyboard_Task");
- end ATM_Keyboard_Task;
-
-
-
- procedure Read_Card (Card : in out ATM_Card_Type) is
- begin
- Card.Number := 9999;
- Card.PIN := 111;
- end Read_Card;
-
-
- procedure Validate_Card (Card : in ATM_Card_Type) is
- begin
- -- Simulate an exceedingly long validation activity.
- loop -- Infinite loop.
- TC_Count := (TC_Count + 1) mod Integer (Card.PIN);
- -- Synch. point to allow transfer of control to Keyboard
- -- task during this simulation
- delay ImpDef.Minimum_Task_Switch;
- exit when not Report.Equal (TC_Count, TC_Count); -- Always false.
- end loop;
- end Validate_Card;
-
-
- procedure Perform_Transaction (Card : in ATM_Card_Type) is
- begin
- Report.Failed ("Triggering alternative sequence of statements " &
- "not executed");
- if not TC_Triggering_Statement_Completed then
- Report.Failed ("Triggering statement did not complete");
- end if;
- if TC_Count = 1234 then
- -- Initial value is unchanged
- Report.Failed ("Abortable part did not execute");
- end if;
- end Perform_Transaction;
-
-
-end C974003_0;
-
-
- --==================================================================--
-
-
-with Report;
-
-with C974003_0; -- Automated teller machine abstraction.
-use C974003_0;
-
-procedure C974003 is
-
- Card_Data : ATM_Card_Type;
-
-begin -- Main program.
-
- Report.Test ("C974003", "Asynchronous Select: Trigger is queued on a " &
- "task entry and completes first");
-
- Read_Card (Card_Data);
-
- declare
- -- Create the task for this transaction
- Keyboard : C974003_0.ATM_Keyboard_Task;
- begin
-
- -- --
- -- Asynchronous select is tested here --
- -- --
-
- select
- Keyboard.Cancel_Pressed; -- Entry call is initially queued, so
- -- abortable part starts.
-
- raise Transaction_Canceled; -- This is executed after Validate_Card
- -- is aborted.
- then abort
- Validate_Card (Card_Data); -- Keyboard.Cancel_Pressed is accepted
- -- and completes before this call
- -- finishes; it is then aborted.
-
- -- Check that the whole of the abortable part is aborted, not
- -- just the statement in the abortable part that was executing
- -- at the time
- Report.Failed ("Abortable part not aborted");
-
- end select;
-
- Perform_Transaction (Card_Data); -- Should not be reached.
- exception
- when Transaction_Canceled =>
- if not TC_Triggering_Statement_Completed then
- Report.Failed ("Triggering alternative sequence of statements " &
- "executed but triggering statement not complete");
- end if;
- if TC_Count = 1234 then
- -- Initial value is unchanged
- Report.Failed ("Abortable part did not execute");
- end if;
- end;
-
- Report.Result;
-
-end C974003;
diff --git a/gcc/testsuite/ada/acats/tests/c9/c974004.a b/gcc/testsuite/ada/acats/tests/c9/c974004.a
deleted file mode 100644
index b1200c10368..00000000000
--- a/gcc/testsuite/ada/acats/tests/c9/c974004.a
+++ /dev/null
@@ -1,273 +0,0 @@
--- C974004.A
---
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that the abortable part of an asynchronous select statement
--- is aborted if it does not complete before the triggering statement
--- completes, where the triggering statement is a task entry call,
--- the entry call is queued, and the entry call completes by propagating
--- an exception and that the sequence of statements of the triggering
--- alternative is not executed after the abortable part is left and that
--- the exception propagated by the entry call is re-raised immediately
--- following the asynchronous select.
---
--- TEST DESCRIPTION:
--- Declare a main procedure containing an asynchronous select with a task
--- entry call as triggering statement. Force the entry call to be
--- queued by having the task call a procedure, prior to the corresponding
--- accept statement, which simulates a routine waiting for user input
--- (with a delay).
---
--- Simulate a time-consuming routine in the abortable part by calling a
--- procedure containing an infinite loop. Meanwhile, simulate input by
--- the user (the delay expires), which causes the task to execute the
--- accept statement corresponding to the triggering entry call. Raise
--- an exception in the accept statement which is not handled by the task,
--- and which is thus propagated to the caller.
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
---
---!
-
-package C974004_0 is -- Automated teller machine abstraction.
-
-
- -- Flags for testing purposes:
-
- Count : Integer := 1234; -- Global to defeat
- -- optimization.
- Propagated_From_Task : exception;
-
-
- type Key_Enum is (None, Cancel, Deposit, Withdraw);
-
- type Card_Number_Type is private;
- type Card_PIN_Type is private;
- type ATM_Card_Type is private;
-
-
- Transaction_Canceled : exception;
-
-
- task type ATM_Keyboard_Task is
- entry Cancel_Pressed;
- end ATM_Keyboard_Task;
-
-
- procedure Read_Card (Card : in out ATM_Card_Type);
-
- procedure Validate_Card (Card : in ATM_Card_Type);
-
- procedure Perform_Transaction (Card : in ATM_Card_Type);
-
-private
-
- type Card_Number_Type is range 1 .. 9999;
- type Card_PIN_Type is range 100 .. 999;
-
- type ATM_Card_Type is record
- Number : Card_Number_Type;
- PIN : Card_PIN_Type;
- end record;
-
-end C974004_0;
-
-
- --==================================================================--
-
-
-with Report;
-with ImpDef;
-
-package body C974004_0 is
-
-
- procedure Listen_For_Input (Key : out Key_Enum) is
- begin
- -- Simulate the situation where a user waits a bit for the card to
- -- be validated, then presses cancel before it completes.
-
- -- Delay long enough to force queuing of Keyboard.Cancel_Pressed.
- delay ImpDef.Clear_Ready_Queue;
-
- if Report.Equal (3, 3) then -- Always true.
- Key := Cancel;
- end if;
- end Listen_For_Input;
-
-
- -- One of these gets created as "Keyboard" for each transaction
- --
- task body ATM_Keyboard_Task is
- Key_Pressed : Key_Enum := None;
- begin
- loop
- -- Force entry calls to be
- Listen_For_Input (Key_Pressed); -- queued, then set guard to
- -- true.
- select
- when (Key_Pressed = Cancel) => -- Guard is now true, so accept
- accept Cancel_Pressed do -- queued entry call.
- null; --:::: user code for cancel
- -- Now simulate an unexpected exception arising in the
- -- user code
- raise Propagated_From_Task; -- Propagate an exception.
-
- end Cancel_Pressed;
-
- Report.Failed
- ("Exception not propagated in ATM_Keyboard_Task");
-
- -- User has canceled the transaction so we exit the
- -- loop and allow the task to terminate
- exit;
- else
- Key_Pressed := None;
- end select;
- end loop;
- exception
- when Propagated_From_Task =>
- null; -- This is the expected test behavior
- when others =>
- Report.Failed ("Unexpected Exception in ATM_Keyboard_Task");
- end ATM_Keyboard_Task;
-
-
-
- procedure Read_Card (Card : in out ATM_Card_Type) is
- begin
- Card.Number := 9999;
- Card.PIN := 111;
- end Read_Card;
-
-
- procedure Validate_Card (Card : in ATM_Card_Type) is
- begin
- -- Simulate an exceedingly long validation activity.
- loop -- Infinite loop.
- Count := (Count + 1) mod Integer (Card.PIN);
- -- Synch. point to allow transfer of control to Keyboard
- -- task during this simulation
- delay ImpDef.Minimum_Task_Switch;
- exit when not Report.Equal (Count, Count); -- Always false.
- end loop;
- end Validate_Card;
-
-
- procedure Perform_Transaction (Card : in ATM_Card_Type) is
- begin
- Report.Failed ("Exception not re-raised immediately following " &
- "asynchronous select");
- if Count = 1234 then
- -- Initial value is unchanged
- Report.Failed ("Abortable part did not execute");
- end if;
- end Perform_Transaction;
-
-
-end C974004_0;
-
-
- --==================================================================--
-
-
-with Report;
-
-with C974004_0; -- Automated teller machine abstraction.
-use C974004_0;
-
-procedure C974004 is
-
- Card_Data : ATM_Card_Type;
-
-begin -- Main program.
-
- Report.Test ("C974004", "Asynchronous Select: Trigger is queued on a " &
- "task entry and is completed first by an " &
- "exception");
-
- Read_Card (Card_Data);
-
- begin
-
- declare
- -- Create the task for this transaction
- Keyboard : C974004_0.ATM_Keyboard_Task;
- begin
-
- -- --
- -- Asynchronous select is tested here --
- -- --
-
- select
- Keyboard.Cancel_Pressed; -- Entry call initially queued, so
- -- abortable part starts.
-
- raise Transaction_Canceled; -- Should not be executed.
- then abort
- Validate_Card (Card_Data); -- Keyboard.Cancel_Pressed is accepted
- -- and propagates an exception before
- -- this call finishes; it is then
- -- aborted.
-
- -- Check that the whole of the abortable part is aborted, not
- -- just the statement in the abortable part that was executing
- -- at the time
- Report.Failed ("Abortable part not aborted");
- end select;
- -- The propagated exception is
- -- re-raised here; control passes to
- -- the exception handler.
-
- Perform_Transaction(Card_Data); -- Should not be reached.
- exception
- when Transaction_Canceled =>
- Report.Failed ("Triggering alternative sequence of statements " &
- "executed");
- when Propagated_From_Task =>
- -- This is the expected test path
- if Count = 1234 then
- -- Initial value is unchanged
- Report.Failed ("Abortable part did not execute");
- end if;
- when Tasking_Error =>
- Report.Failed ("Tasking_Error raised");
- when others =>
- Report.Failed ("Wrong exception raised");
- end;
-
- exception
- when Propagated_From_Task =>
- Report.Failed ("Correct exception raised at wrong level");
- when others =>
- Report.Failed ("Wrong exception raised at wrong level");
- end;
-
- Report.Result;
-
-end C974004;
diff --git a/gcc/testsuite/ada/acats/tests/c9/c974005.a b/gcc/testsuite/ada/acats/tests/c9/c974005.a
deleted file mode 100644
index 196a8edc04c..00000000000
--- a/gcc/testsuite/ada/acats/tests/c9/c974005.a
+++ /dev/null
@@ -1,259 +0,0 @@
--- C974005.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that Tasking_Error is raised at the point of an entry call
--- which is the triggering statement of an asynchronous select, if
--- the entry call is queued, but the task containing the entry completes
--- before it can be accepted or canceled.
---
--- Check that the abortable part is aborted if it does not complete
--- before the triggering statement completes.
---
--- Check that the sequence of statements of the triggering alternative
--- is not executed.
---
--- TEST DESCRIPTION:
--- Declare a main procedure containing an asynchronous select with a task
--- entry call as triggering statement. Force the entry call to be
--- queued by having the task call a procedure, prior to the corresponding
--- accept statement, which simulates a routine waiting for user input
--- (with a delay).
---
--- Simulate a time-consuming routine in the abortable part by calling a
--- procedure containing an infinite loop. Meanwhile, simulate input by
--- the user (the delay expires) which is NOT the input expected by the
--- guard on the accept statement. The entry remains closed, and the
--- task completes its execution. Since the entry was not accepted before
--- its task completed, Tasking_Error is raised at the point of the entry
--- call.
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
---
---!
-
-package C974005_0 is -- Automated teller machine abstraction.
-
-
- -- Flags for testing purposes:
-
- Count : Integer := 1234;
-
- type Key_Enum is (None, Cancel, Deposit, Withdraw);
-
- type Card_Number_Type is private;
- type Card_PIN_Type is private;
- type ATM_Card_Type is private;
-
-
- Transaction_Canceled : exception;
-
-
- task type ATM_Keyboard_Task is
- entry Cancel_Pressed;
- end ATM_Keyboard_Task;
-
-
- procedure Read_Card (Card : in out ATM_Card_Type);
-
- procedure Validate_Card (Card : in ATM_Card_Type);
-
- procedure Perform_Transaction (Card : in ATM_Card_Type);
-
-private
-
- type Card_Number_Type is range 1 .. 9999;
- type Card_PIN_Type is range 100 .. 999;
-
- type ATM_Card_Type is record
- Number : Card_Number_Type;
- PIN : Card_PIN_Type;
- end record;
-
-end C974005_0;
-
-
- --==================================================================--
-
-
-with Report;
-with ImpDef;
-
-package body C974005_0 is
-
-
- procedure Listen_For_Input (Key : out Key_Enum) is
- begin
- -- Simulate the situation where a user waits a bit for the card to
- -- be validated, then presses a transaction key (NOT Cancel).
-
- -- Delay long enough to force queuing of Keyboard.Cancel_Pressed.
- delay ImpDef.Clear_Ready_Queue;
-
- if Report.Equal (3, 3) then -- Always true.
- Key := Deposit; -- Cancel is NOT pressed.
- end if;
- end Listen_For_Input;
-
-
- task body ATM_Keyboard_Task is
- Key_Pressed : Key_Enum := None;
- begin
-
- -- Note: no loop. If the user does not press Cancel, the task completes.
- -- In this model of the keyboard monitor, the user only gets one chance
- -- to cancel the card validation.
- -- Force entry
- Listen_For_Input (Key_Pressed); -- calls to be
- -- queued, but do
- -- NOT set guard
- -- to true.
- select
- when (Key_Pressed = Cancel) => -- Guard is false,
- accept Cancel_Pressed do -- so entry call
- Report.Failed ("Accept statement executed"); -- remains queued.
- end Cancel_Pressed;
- else -- Else alternative
- Key_Pressed := None; -- executed, then
- end select; -- task ends.
- exception
- when others =>
- Report.Failed ("Unexpected exception in ATM_Keyboard_Task");
- end ATM_Keyboard_Task;
-
-
-
- procedure Read_Card (Card : in out ATM_Card_Type) is
- begin
- Card.Number := 9999;
- Card.PIN := 111;
- end Read_Card;
-
-
- procedure Validate_Card (Card : in ATM_Card_Type) is
- begin
- -- Simulate an exceedingly long validation activity.
- loop -- Infinite loop.
- Count := (Count + 1) mod Integer (Card.PIN);
-
- -- Synch Point to allow transfer of control to Keyboard task
- -- during this simulation
- delay ImpDef.Minimum_Task_Switch;
-
- exit when not Report.Equal (Count, Count); -- Always false.
- end loop;
- end Validate_Card;
-
-
- procedure Perform_Transaction (Card : in ATM_Card_Type) is
- begin
- Report.Failed ("Exception not re-raised immediately following " &
- "asynchronous select");
- if Count = 1234 then
- -- Additional analysis added to aid developers
- Report.Failed ("Abortable part did not execute");
- end if;
- end Perform_Transaction;
-
-
-end C974005_0;
-
-
- --==================================================================--
-
-
-with Report;
-
-with C974005_0; -- Automated teller machine abstraction.
-use C974005_0;
-
-procedure C974005 is
-
- Card_Data : ATM_Card_Type;
-
-begin -- Main program.
-
- Report.Test ("C974005", "ATC: trigger is queued but task terminates" &
- " before call is serviced");
-
- Read_Card (Card_Data);
-
- begin
-
- declare
- Keyboard : C974005_0.ATM_Keyboard_Task;
- begin
-
- -- --
- -- Asynchronous select is tested here --
- -- --
-
- select
- Keyboard.Cancel_Pressed; -- Entry call initially queued, so
- -- abortable part starts.
-
- -- Tasking_Error raised here when
- -- Keyboard completes before entry
- -- call can be accepted, and before
- -- abortable part completes.
-
- raise Transaction_Canceled; -- Should not be executed.
- then abort
- Validate_Card (Card_Data); -- Keyboard task completes before
- -- Keyboard.Cancel_Pressed is
- -- accepted, and before this call
- -- finishes. Tasking_Error is raised
- -- at the point of the entry call,
- -- and this call is aborted.
- -- Check that the whole of the abortable part is aborted, not just
- -- the statement in the abortable part that was executing at
- -- the time
- Report.Failed ("Abortable part not aborted");
- end select;
- Perform_Transaction (Card_Data); -- Should not be reached.
- exception
- when Transaction_Canceled =>
- Report.Failed ("Triggering alternative sequence of statements " &
- "executed");
- when Tasking_Error =>
- if Count = 1234 then
- Report.Failed ("Abortable part did not execute");
- end if;
- when others =>
- Report.Failed ("Wrong exception raised");
- end;
-
- exception
- when Tasking_Error =>
- Report.Failed ("Correct exception raised at wrong level");
- when others =>
- Report.Failed ("Wrong exception raised at wrong level");
- end;
-
- Report.Result;
-
-end C974005;
diff --git a/gcc/testsuite/ada/acats/tests/c9/c974006.a b/gcc/testsuite/ada/acats/tests/c9/c974006.a
deleted file mode 100644
index f6f4d92e869..00000000000
--- a/gcc/testsuite/ada/acats/tests/c9/c974006.a
+++ /dev/null
@@ -1,197 +0,0 @@
--- C974006.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that the sequence of statements of the triggering alternative
--- of an asynchronous select statement is executed if the triggering
--- statement is a protected entry call, and the entry is accepted
--- immediately. Check that the corresponding entry body is executed
--- before the sequence of statements of the triggering alternative.
--- Check that the abortable part is not executed.
---
--- TEST DESCRIPTION:
--- Declare a main procedure containing an asynchronous select with a
--- protected entry call as triggering statement. Declare a protected
--- procedure which sets the protected entry's barrier true. Force the
--- entry call to be accepted immediately by calling this protected
--- procedure prior to the asynchronous select. Since the entry call
--- is accepted immediately, the abortable part should never start. When
--- entry call completes, the sequence of statements of the triggering
--- alternative should execute.
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
---
---!
-
-
-package C974006_0 is -- Automated teller machine abstraction.
-
-
- -- Flag for testing purposes:
-
- Entry_Body_Executed : Boolean := False;
-
-
- type Key_Enum is (None, Cancel, Deposit, Withdraw);
-
- type Card_Number_Type is private;
- type Card_PIN_Type is private;
- type ATM_Card_Type is private;
-
-
- Transaction_Canceled : exception;
-
-
- protected type ATM_Keyboard_Protected is
- entry Cancel_Pressed;
- procedure Read_Key;
- private
- Last_Key_Pressed : Key_Enum := None;
- end ATM_Keyboard_Protected;
-
-
- procedure Read_Card (Card : in out ATM_Card_Type);
-
- procedure Validate_Card (Card : in ATM_Card_Type);
-
- procedure Perform_Transaction (Card : in ATM_Card_Type);
-
-private
-
- type Card_Number_Type is range 1 .. 9999;
- type Card_PIN_Type is range 100 .. 999;
-
- type ATM_Card_Type is record
- Number : Card_Number_Type;
- PIN : Card_PIN_Type;
- end record;
-
-end C974006_0;
-
-
- --==================================================================--
-
-
-with Report;
-package body C974006_0 is
-
-
- protected body ATM_Keyboard_Protected is
-
- entry Cancel_Pressed when (Last_Key_Pressed = Cancel) is
- begin
- Entry_Body_Executed := True;
- end Cancel_Pressed;
-
- procedure Read_Key is
- begin
- -- Simulate a procedure which processes user keyboard input, and
- -- which is called by some interrupt handler.
- Last_Key_Pressed := Cancel;
- end Read_Key;
-
- end ATM_Keyboard_Protected;
-
-
- procedure Read_Card (Card : in out ATM_Card_Type) is
- begin
- Card.Number := 9999;
- Card.PIN := 111;
- end Read_Card;
-
-
- procedure Validate_Card (Card : in ATM_Card_Type) is
- begin
- Report.Failed ("Abortable part executed");
- end Validate_Card;
-
-
- procedure Perform_Transaction (Card : in ATM_Card_Type) is
- begin
- Report.Failed ("Triggering alternative sequence of statements " &
- "not fully executed");
- end Perform_Transaction;
-
-
-end C974006_0;
-
-
- --==================================================================--
-
-
-with Report;
-
-with C974006_0; -- Automated teller machine abstraction.
-use C974006_0;
-
-procedure C974006 is
-
- Card_Data : ATM_Card_Type;
-
-begin
-
- Report.Test ("C974006", "ATC: trigger is protected entry call" &
- " and completes first");
-
- Read_Card (Card_Data);
-
- declare
- Keyboard : C974006_0.ATM_Keyboard_Protected;
- begin
-
- -- Simulate the situation where the user hits cancel before the
- -- validation process can start:
- Keyboard.Read_Key; -- Force Keyboard.Cancel_Pressed to
- -- be accepted immediately.
-
- -- --
- -- Asynchronous select is tested here --
- -- --
-
- select
- Keyboard.Cancel_Pressed; -- Entry call is accepted immediately,
- -- so abortable part does NOT start.
-
- if not Entry_Body_Executed then -- Executes after entry completes.
- Report.Failed ("Triggering alternative sequence of statements " &
- "executed before triggering statement complete");
- end if;
-
- raise Transaction_Canceled; -- Control passes to exception
- -- handler.
- then abort
- Validate_Card (Card_Data); -- Should not be executed.
- end select;
- Perform_Transaction (Card_Data); -- Should not be reached.
- exception
- when Transaction_Canceled =>
- null;
- end;
-
- Report.Result;
-
-end C974006;
diff --git a/gcc/testsuite/ada/acats/tests/c9/c974007.a b/gcc/testsuite/ada/acats/tests/c9/c974007.a
deleted file mode 100644
index 07007b9bb56..00000000000
--- a/gcc/testsuite/ada/acats/tests/c9/c974007.a
+++ /dev/null
@@ -1,205 +0,0 @@
--- C974007.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that the sequence of statements of the triggering alternative
--- of an asynchronous select statement is not executed if the triggering
--- statement is a protected entry call, and the entry is not accepted
--- before the abortable part completes. Check that execution continues
--- immediately following the asynchronous select.
---
--- TEST DESCRIPTION:
--- Declare a main procedure containing an asynchronous select with a
--- protected entry call as triggering statement. Declare a protected
--- procedure which sets the protected entry's barrier true. Ensure
--- that the entry call is never accepted by not calling the protected
--- procedure; the barrier remains false, and the entry call from
--- asynchronous select is queued. Since the abortable part will complete
--- before the entry is accepted, the sequence of statements of the
--- triggering alternative is never executed.
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
---
---!
-
-
-package C974007_0 is -- Automated teller machine abstraction.
-
-
- -- Flags for testing purposes:
- --
- Abortable_Part_Executed : Boolean := False;
- Perform_Transaction_Executed : Boolean := False;
- Triggering_Statement_Executed : Boolean := False;
-
-
- type Key_Enum is (None, Cancel, Deposit, Withdraw);
-
- type Card_Number_Type is private;
- type Card_PIN_Type is private;
- type ATM_Card_Type is private;
-
-
- Transaction_Canceled : exception;
-
-
- protected type ATM_Keyboard_Protected is
- entry Cancel_Pressed;
- procedure Read_Key;
- private
- Last_Key_Pressed : Key_Enum := None;
- end ATM_Keyboard_Protected;
-
-
- procedure Read_Card (Card : in out ATM_Card_Type);
-
- procedure Validate_Card (Card : in ATM_Card_Type);
-
- procedure Perform_Transaction (Card : in ATM_Card_Type);
-
-private
-
- type Card_Number_Type is range 1 .. 9999;
- type Card_PIN_Type is range 100 .. 999;
-
- type ATM_Card_Type is record
- Number : Card_Number_Type;
- PIN : Card_PIN_Type;
- end record;
-
-end C974007_0;
-
-
- --==================================================================--
-
-
-with Report;
-package body C974007_0 is
-
-
- protected body ATM_Keyboard_Protected is
-
- -- Barrier is false for the live of the test
- entry Cancel_Pressed when (Last_Key_Pressed = Cancel) is
- begin
- Triggering_Statement_Executed := true; -- Test has failed
- -- (Note: cannot call Report.Failed in the protected entry body]
- end Cancel_Pressed;
-
- procedure Read_Key is -- Never
- begin -- called.
- -- Simulate a procedure which reads user keyboard input, and
- -- which is called by some interrupt handler.
- Last_Key_Pressed := Cancel;
- end Read_Key;
-
- end ATM_Keyboard_Protected;
-
-
- procedure Read_Card (Card : in out ATM_Card_Type) is
- begin
- Card.Number := 9999;
- Card.PIN := 111;
- end Read_Card;
-
-
- procedure Validate_Card (Card : in ATM_Card_Type) is
- begin
- Abortable_Part_Executed := True;
- end Validate_Card;
-
-
- procedure Perform_Transaction (Card : in ATM_Card_Type) is
- begin
- Perform_Transaction_Executed := True;
- end Perform_Transaction;
-
-
-end C974007_0;
-
-
- --==================================================================--
-with Report;
-
-with C974007_0; -- Automated teller machine abstraction.
-use C974007_0;
-
-procedure C974007 is
-
- Card_Data : ATM_Card_Type;
-
-begin
-
- Report.Test ("C974007", "ATC: trigger is protected entry call" &
- " and abortable part completes first");
-
- Read_Card (Card_Data);
-
- declare
- Keyboard : C974007_0.ATM_Keyboard_Protected;
- begin
-
- -- --
- -- Asynchronous select is tested here --
- -- --
-
- select
- Keyboard.Cancel_Pressed; -- Barrier is never set true, so
- -- entry call is queued and never
- -- accepted.
-
- raise Transaction_Canceled; -- Should not be executed.
- then abort
- Validate_Card (Card_Data); -- This call completes before
- -- Keyboard.Cancel_Pressed can be
- -- accepted.
- end select;
- Perform_Transaction (Card_Data); -- Execution proceeds here after
- -- Validate_Card completes.
- exception
- when Transaction_Canceled =>
- Report.Failed ("Triggering alternative sequence of statements " &
- "executed");
- end;
-
-
- if Triggering_Statement_Executed then
- Report.Failed ("Triggering statement was executed");
- end if;
-
- if not Abortable_Part_Executed then
- Report.Failed ("Abortable part not executed");
- end if;
-
- if not Perform_Transaction_Executed then
- Report.Failed ("Statements following asynchronous select not " &
- "executed");
- end if;
-
- Report.Result;
-
-end C974007;
diff --git a/gcc/testsuite/ada/acats/tests/c9/c974008.a b/gcc/testsuite/ada/acats/tests/c9/c974008.a
deleted file mode 100644
index b76db7bd05e..00000000000
--- a/gcc/testsuite/ada/acats/tests/c9/c974008.a
+++ /dev/null
@@ -1,229 +0,0 @@
--- C974008.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that the abortable part of an asynchronous select statement
--- is not started if the triggering statement is a task entry call, and
--- the entry call is not queued.
---
--- Check that the sequence of statements of the triggering alternative
--- is executed after the abortable part is left.
---
--- TEST DESCRIPTION:
--- Declare a main procedure containing an asynchronous select with a task
--- entry call as triggering statement. Ensure that the task is waiting
--- at the accept statement so the rendezvous is executed immediately (the
--- entry call is not queued).
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
---
---!
-
-package C974008_0 is -- Automated teller machine abstraction.
-
-
- -- Flags for testing purposes:
-
- Triggering_Statement_Completed : Boolean := False;
- Count : Integer := 1234; -- Global to defeat
- -- optimization.
-
- type Key_Enum is (None, Cancel, Deposit, Withdraw);
-
- type Card_Number_Type is private;
- type Card_PIN_Type is private;
- type ATM_Card_Type is private;
-
-
- Transaction_Canceled : exception;
-
-
- task type ATM_Keyboard_Task is
- entry Cancel_Pressed;
- end ATM_Keyboard_Task;
-
-
- procedure Read_Card (Card : in out ATM_Card_Type);
-
-
- procedure Perform_Transaction (Card : in ATM_Card_Type);
-
-private
-
- type Card_Number_Type is range 1 .. 9999;
- type Card_PIN_Type is range 100 .. 999;
-
- type ATM_Card_Type is record
- Number : Card_Number_Type;
- PIN : Card_PIN_Type;
- end record;
-
-end C974008_0;
-
-
- --==================================================================--
-
-
-with Report;
-package body C974008_0 is
-
-
- procedure Listen_For_Input (Key : out Key_Enum) is
- begin
- -- Simulate the situation where the user presses the cancel key
- -- before the card is validated
-
- -- press the cancel key immediately
- Key := Cancel;
-
- end Listen_For_Input;
-
-
-
- -- One of these gets created as "Keyboard" for each transaction
- --
- task body ATM_Keyboard_Task is
- Key_Pressed : Key_Enum := None;
- begin
- -- NOTE: Normal usage for this routine would be the loop with
- -- the select statement included. This particular test
- -- requires that the task be waiting at the accept
- -- for the call. To ensure that this is the case the
- -- extraneous commands are commented out (we leave them
- -- in this form to show the reader the surrounds to the
- -- fragment of code remaining)
-
- -- loop
-
- Listen_For_Input (Key_Pressed);
-
- -- select
- -- when (Key_Pressed = Cancel) => -- Guard is now
- accept Cancel_Pressed do -- true, so accept
- Triggering_Statement_Completed := True; -- queued entry
- end Cancel_Pressed; -- call.
-
- -- User has cancelled the transaction so we exit the
- -- loop and allow the task to terminate
- -- exit;
- -- else
- -- Key_Pressed := None;
- -- end select;
-
- -- end loop;
- exception
- when others =>
- Report.Failed ("Unexpected Exception in ATM_Keyboard_Task");
- end ATM_Keyboard_Task;
-
-
-
- procedure Read_Card (Card : in out ATM_Card_Type) is
- begin
- Card.Number := 9999;
- Card.PIN := 111;
- end Read_Card;
-
-
- procedure Perform_Transaction (Card : in ATM_Card_Type) is
- begin
- Report.Failed ("Triggering alternative sequence of statements " &
- "not executed");
- if not Triggering_Statement_Completed then
- Report.Failed ("Triggering statement did not complete");
- end if;
- end Perform_Transaction;
-
-
-end C974008_0;
-
-
- --==================================================================--
-
-
-with Report;
-with ImpDef;
-
-with C974008_0; -- Automated teller machine abstraction.
-use C974008_0;
-
-procedure C974008 is
-
- Card_Data : ATM_Card_Type;
-
-begin -- Main program.
-
- Report.Test ("C974008", "Asynchronous Select: Trigger is a call to a " &
- "waiting task entry and completes immediately");
-
- Read_Card (Card_Data);
-
- declare
- -- Create the task for this transaction
- Keyboard : C974008_0.ATM_Keyboard_Task;
- begin
-
- -- Ensure task is waiting at the accept
- -- This is the time required to activate another task and allow it
- -- to run to its first accept statement.
- --
- delay ImpDef.Switch_To_New_Task;
-
- -- --
- -- Asynchronous select is tested here --
- -- --
-
- select
- Keyboard.Cancel_Pressed; -- Entry call is executed immediately
-
- raise Transaction_Canceled; -- This is executed after Validate_Card
- -- is aborted.
- then abort
-
- -- In other similar tests Validate_Card is called here. In this
- -- test we just check to see if the abortable part is called at
- -- all. Since the triggering call is not queued the abortable
- -- part should not be started
- --
- Report.Failed ("Abortable part started");
-
- end select;
-
- Perform_Transaction (Card_Data); -- Should not be reached.
- exception
- when Transaction_Canceled =>
-
- if not Triggering_Statement_Completed then
- Report.Failed ("Triggering alternative sequence of statements " &
- "executed but triggering statement not complete");
- end if;
-
- end;
-
- Report.Result;
-
-end C974008;
diff --git a/gcc/testsuite/ada/acats/tests/c9/c974009.a b/gcc/testsuite/ada/acats/tests/c9/c974009.a
deleted file mode 100644
index 419f2a3e9ad..00000000000
--- a/gcc/testsuite/ada/acats/tests/c9/c974009.a
+++ /dev/null
@@ -1,206 +0,0 @@
--- C974009.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that the abortable part of an asynchronous select statement
--- is not started if the triggering statement is a task entry call,
--- the entry call is not queued and the entry call completes by
--- propagating an exception.
---
--- Check that the exception is properly propagated to the asynchronous
--- select statement and thus the sequence of statements of the triggering
--- alternative is not executed after the abortable part is left.
---
--- Check that the exception propagated by the entry call is re-raised
--- immediately following the asynchronous select.
---
--- TEST DESCRIPTION:
---
--- Use a small subset of the base Automated teller machine simulation
--- which is shown in greater detail in other tests of this series.
--- Declare a main procedure containing an asynchronous select with a task
--- entry call as triggering statement. Force the task to be waiting at
--- the accept statement so that the call is not queued and the rendezvous
--- is executed immediately. Simulate an unexpected exception in the
--- rendezvous. Use stripped down versions of called procedures to check
--- the correct path in the test.
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
---
---!
-
-
-package C974009_0 is -- Automated teller machine abstraction.
-
-
- Propagated_From_Task : exception;
- Transaction_Canceled : exception;
-
- type Key_Enum is (None, Cancel, Deposit, Withdraw);
-
- type Card_Number_Type is private;
- type Card_PIN_Type is private;
- type ATM_Card_Type is private;
-
- task type ATM_Keyboard_Task is
- entry Cancel_Pressed;
- end ATM_Keyboard_Task;
-
-
- procedure Validate_Card (Card : in ATM_Card_Type);
-
- procedure Perform_Transaction (Card : in ATM_Card_Type);
-
-
-private
-
- type Card_Number_Type is range 1 .. 9999;
- type Card_PIN_Type is range 100 .. 999;
-
- type ATM_Card_Type is record
- Number : Card_Number_Type;
- PIN : Card_PIN_Type;
- end record;
-
-end C974009_0;
-
-
- --==================================================================--
-
-
-with Report;
-package body C974009_0 is
-
-
-
- -- One of these gets created as "Keyboard" for each transaction
- --
- task body ATM_Keyboard_Task is
- Key_Pressed : Key_Enum := None;
- begin
- accept Cancel_Pressed do -- queued entry call.
- null; --:::: stub, user code for cancel
- -- Now simulate an unexpected exception arising in the
- -- user code
- raise Propagated_From_Task; -- Propagate an exception.
-
- end Cancel_Pressed;
-
- Report.Failed ("Exception not propagated in ATM_Keyboard_Task");
-
- exception
- when Propagated_From_Task =>
- null; -- This is the expected test behavior
- when others =>
- Report.Failed ("Unexpected Exception in ATM_Keyboard_Task");
- end ATM_Keyboard_Task;
-
- procedure Validate_Card (Card : in ATM_Card_Type) is
- begin
- Report.Failed ("Abortable part was executed");
- end Validate_Card;
-
-
- procedure Perform_Transaction (Card : in ATM_Card_Type) is
- begin
- Report.Failed ("Exception not re-raised immediately following " &
- "asynchronous select");
- end Perform_Transaction;
-
-
-end C974009_0;
-
-
- --==================================================================--
-
-
-with Report;
-with ImpDef;
-
-with C974009_0; -- Automated teller machine abstraction.
-use C974009_0;
-
-procedure C974009 is
-
- Card_Data : ATM_Card_Type;
-
-begin -- Main program.
-
- Report.Test ("C974009", "Asynchronous Select: Trigger is a call to a " &
- "task entry, is not queued and is completed " &
- "first by an exception");
-
-
- begin
-
- declare
- -- Create the task for this transaction
- Keyboard : C974009_0.ATM_Keyboard_Task;
- begin
-
- -- Ensure task is waiting a the accept so the call is not queued
- -- This is the time required to activate another task and allow it
- -- to run to its first accept statement
- --
- delay ImpDef.Switch_To_New_Task;
-
- -- --
- -- Asynchronous select is tested here --
- -- --
-
- select
-
- Keyboard.Cancel_Pressed;
-
- raise Transaction_Canceled; -- Should not be executed.
- then abort
- Validate_Card (Card_Data); -- Keyboard.Cancel_Pressed is accepted
- -- and propagates an exception before
- -- this call is executed
- end select;
-
- -- The propagated exception is re-raised here.
- Perform_Transaction(Card_Data); -- Should not be reached.
-
- exception
- when Transaction_Canceled =>
- Report.Failed ("Triggering alternative sequence of statements " &
- "executed");
- when Propagated_From_Task =>
- null; -- This is the expected test path
- when others =>
- Report.Failed ("Wrong exception raised");
- end;
-
- exception
- when others =>
- Report.Failed ("Unexpected exception raised");
- end;
-
- Report.Result;
-
-end C974009;
diff --git a/gcc/testsuite/ada/acats/tests/c9/c974010.a b/gcc/testsuite/ada/acats/tests/c9/c974010.a
deleted file mode 100644
index caeb9d57059..00000000000
--- a/gcc/testsuite/ada/acats/tests/c9/c974010.a
+++ /dev/null
@@ -1,209 +0,0 @@
--- C974010.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that the abortable part of an asynchronous select statement
--- is not started if the triggering statement is a task entry call to
--- a task that has already terminated.
---
--- Check that Tasking_Error is properly propagated to the asynchronous
--- select statement and thus the sequence of statements of the triggering
--- alternative is not executed after the abortable part is left.
---
--- Check that Tasking_Error is re-raised immediately following the
--- asynchronous select.
---
--- TEST DESCRIPTION:
---
--- Use a small subset of the base Automated Teller Machine simulation
--- which is shown in greater detail in other tests of this series.
--- Declare a main procedure containing an asynchronous select with a task
--- entry call as triggering statement. Ensure that the task is
--- terminated before the entry call. Use stripped down versions of
--- the called procedures to check the correct path in the test.
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
---
---!
-
-package C974010_0 is -- Automated teller machine abstraction.
-
-
- Transaction_Canceled : exception;
-
- type Key_Enum is (None, Cancel, Deposit, Withdraw);
-
- type Card_Number_Type is private;
- type Card_PIN_Type is private;
- type ATM_Card_Type is private;
-
- task type ATM_Keyboard_Task is
- entry Cancel_Pressed;
- end ATM_Keyboard_Task;
-
-
- procedure Validate_Card (Card : in ATM_Card_Type);
-
- procedure Perform_Transaction (Card : in ATM_Card_Type);
-
-
-private
-
- type Card_Number_Type is range 1 .. 9999;
- type Card_PIN_Type is range 100 .. 999;
-
- type ATM_Card_Type is record
- Number : Card_Number_Type;
- PIN : Card_PIN_Type;
- end record;
-
-end C974010_0;
-
-
- --==================================================================--
-
-
-with Report;
-package body C974010_0 is
-
-
-
- -- One of these gets created as "Keyboard" for each transaction
- --
- task body ATM_Keyboard_Task is
- TC_Suicide : exception;
- Key_Pressed : Key_Enum := None;
- begin
- raise TC_Suicide; -- Simulate early, unexpected termination
-
- accept Cancel_Pressed do -- queued entry call.
- null; --:::: user code for cancel
-
- end Cancel_Pressed;
-
- exception
- when TC_Suicide =>
- null; -- This is the expected test behavior
- when others =>
- Report.Failed ("Unexpected Exception in ATM_Keyboard_Task");
- end ATM_Keyboard_Task;
-
- procedure Validate_Card (Card : in ATM_Card_Type) is
- begin
- Report.Failed ("Abortable part was executed");
- end Validate_Card;
-
-
- procedure Perform_Transaction (Card : in ATM_Card_Type) is
- begin
- Report.Failed ("Exception not re-raised immediately following " &
- "asynchronous select");
- end Perform_Transaction;
-
-
-end C974010_0;
-
-
- --==================================================================--
-
-
-with Report;
-with ImpDef;
-
-with C974010_0; -- Automated teller machine abstraction.
-use C974010_0;
-
-procedure C974010 is
-
- Card_Data : ATM_Card_Type;
- TC_Tasking_Error_Handled : Boolean := false;
-
-begin -- Main program.
-
- Report.Test ("C974010", "Asynchronous Select: Trigger is a call to a " &
- "task entry of a task that is already completed");
-
-
- declare
- -- Create the task for this transaction
- Keyboard : C974010_0.ATM_Keyboard_Task;
- begin
-
- -- Ensure the task is already completed before calling
- --
- while not Keyboard'terminated loop
- delay ImpDef.Minimum_Task_Switch;
- end loop;
-
- -- --
- -- Asynchronous select is tested here --
- -- --
-
- select
-
- Keyboard.Cancel_Pressed;
-
- raise Transaction_Canceled; -- Should not be executed.
-
- then abort
-
- -- Since the triggering call is not queued the abortable part
- -- should not be executed.
- --
- Validate_Card (Card_Data);
-
- end select;
- --
- -- The propagated exception is re-raised here.
-
- Perform_Transaction(Card_Data); -- Should not be reached.
-
- exception
- when Transaction_Canceled =>
- Report.Failed ("Triggering alternative sequence of statements " &
- "executed");
- when Tasking_Error =>
- -- This is the expected test path
- TC_Tasking_Error_Handled := true;
- when others =>
- Report.Failed ("Wrong exception raised: ");
- end;
-
-
- if not TC_Tasking_Error_Handled then
- Report.Failed ("Tasking_Error not properly propagated");
- end if;
-
- Report.Result;
-
-exception
- when Tasking_Error =>
- Report.Failed ("Tasking_Error propagated to wrong handler");
- Report.Result;
-
-
-end C974010;
diff --git a/gcc/testsuite/ada/acats/tests/c9/c974011.a b/gcc/testsuite/ada/acats/tests/c9/c974011.a
deleted file mode 100644
index 4682db6286d..00000000000
--- a/gcc/testsuite/ada/acats/tests/c9/c974011.a
+++ /dev/null
@@ -1,275 +0,0 @@
--- C974011.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that the sequence of statements of the triggering alternative
--- of an asynchronous select statement is not executed if the triggering
--- statement is a task entry call and the entry is not accepted
--- before the abortable part completes.
--- Check that the call queued on the entry is cancelled
---
--- TEST DESCRIPTION:
--- Declare a main procedure containing an asynchronous select with a task
--- entry call as triggering statement. Force the entry call to be
--- queued by having the task call a procedure, prior to the corresponding
--- accept statement, which simulates (with a delay) a routine waiting
--- for user input
---
--- Once the call is known to be queued, complete the abortable part.
--- Check that the rendezvous (and thus the trigger) does not complete.
--- Then clear the barrier and check that the entry has been cancelled
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 28 Nov 95 SAIC Eliminated shared global variable for ACVC 2.0.1
---
---!
-
-with ImpDef;
---
-package C974011_0 is -- Automated teller machine abstraction.
-
-
-
- type Key_Enum is (None, Cancel, Deposit, Withdraw);
-
- protected Key_PO is
- procedure Set (K : Key_Enum);
- function Value return Key_Enum;
- private
- Current : Key_Enum := None;
- end Key_PO;
-
-
- -- Flags for testing purposes
- TC_Abortable_Part_Completed : Boolean := False;
- TC_Rendezvous_Entered : Boolean := False;
- TC_Delay_Time : constant duration := ImpDef.Switch_To_New_Task;
-
-
- Count : Integer := 1234; -- Global to defeat optimization.
-
-
- type Card_Number_Type is private;
- type Card_PIN_Type is private;
- type ATM_Card_Type is private;
-
-
- Transaction_Canceled : exception;
-
-
- task type ATM_Keyboard_Task is
- entry Cancel_Pressed;
- end ATM_Keyboard_Task;
-
- procedure Read_Card (Card : in out ATM_Card_Type);
-
- procedure Validate_Card (Card : in ATM_Card_Type);
-
- procedure Perform_Transaction (Card : in ATM_Card_Type);
-
-private
-
- type Card_Number_Type is range 1 .. 9999;
- type Card_PIN_Type is range 100 .. 999;
-
- type ATM_Card_Type is record
- Number : Card_Number_Type;
- PIN : Card_PIN_Type;
- end record;
-
-end C974011_0;
-
-
- --==================================================================--
-
-
-with Report;
-package body C974011_0 is
-
- protected body Key_PO is
- procedure Set (K : Key_Enum) is
- begin
- Current := K;
- end Set;
-
- function Value return Key_Enum is
- begin
- return Current;
- end Value;
- end Key_PO;
-
-
- procedure Listen_For_Input (Key : out Key_Enum) is
- begin
- -- Model the situation where the user does not press cancel thus
- -- allowing validation to complete
-
- delay TC_Delay_Time; -- Long enough to force queuing on
- -- Keyboard.Cancel_Pressed.
-
- Key := Key_PO.Value;
-
- end Listen_For_Input;
-
-
-
- -- One of these gets created as "Keyboard" for each transaction
- --
- task body ATM_Keyboard_Task is
- Key_Pressed : Key_Enum;
- begin
- loop
- -- Force entry calls
- Listen_For_Input (Key_Pressed); -- to be queued,
-
- select
- when (Key_Pressed = Cancel) =>
- accept Cancel_Pressed do
- TC_Rendezvous_Entered := True;
- end Cancel_Pressed;
-
- -- User has cancelled the transaction so we exit the
- -- loop and allow the task to terminate
- exit;
- else
- delay ImpDef.Switch_To_New_Task;
- end select;
-
- end loop;
- exception
- when others =>
- Report.Failed ("Unexpected Exception in ATM_Keyboard_Task");
- end ATM_Keyboard_Task;
-
-
-
- procedure Read_Card (Card : in out ATM_Card_Type) is
- begin
- Card.Number := 9999;
- Card.PIN := 111;
- end Read_Card;
-
-
- procedure Validate_Card (Card : in ATM_Card_Type) is
- begin
- Count := (Count + 1) mod Integer (Card.PIN);
-
- -- Simulate a validation activity which is longer than the time
- -- taken in Listen_For_Input but not inordinately so.
- delay TC_Delay_Time * 2;
-
- end Validate_Card;
-
-
- procedure Perform_Transaction (Card : in ATM_Card_Type) is
- begin
- if TC_Rendezvous_Entered then
- Report.Failed ("Triggering statement completed");
- end if;
- if Count = 1234 then
- -- Initial value is unchanged
- Report.Failed ("Abortable part did not execute");
- end if;
- if not TC_Abortable_Part_Completed then
- Report.Failed ("Abortable part did not complete");
- end if;
- end Perform_Transaction;
-
-
-end C974011_0;
-
-
- --==================================================================--
-
-
-with Report;
-
-with C974011_0; -- Automated teller machine abstraction.
-use C974011_0;
-
-procedure C974011 is
-
- Card_Data : ATM_Card_Type;
-
-begin -- Main program.
-
- Report.Test ("C974011", "Asynchronous Select: Trigger is queued on a " &
- "task entry and the abortable part " &
- "completes first");
-
- Read_Card (Card_Data);
-
- declare
- -- Create the task for this transaction
- Keyboard : C974011_0.ATM_Keyboard_Task;
- begin
-
- -- --
- -- Asynchronous select is tested here --
- -- --
-
- select
-
- Keyboard.Cancel_Pressed; -- Entry call is initially queued, so
- -- abortable part starts.
- raise Transaction_Canceled; -- This would be executed if we
- -- completed the rendezvous
- then abort
-
- Validate_Card (Card_Data);
- TC_Abortable_Part_Completed := true;
-
- end select;
-
- Perform_Transaction (Card_Data);
-
-
- -- Now clear the entry barrier to allow the rendezvous to complete
- -- if the triggering call has not been cancelled
- Key_PO.Set (Cancel);
- --
- delay TC_Delay_Time; -- to allow it all to take place
-
- if TC_Rendezvous_Entered then
- Report.Failed ("Triggering Call was not cancelled");
- end if;
-
- abort Keyboard; -- clean up. (Note: the task will only exit the
- -- loop and terminate if the call hanging on the
- -- entry is executed.)
-
- exception
- when Transaction_Canceled =>
- Report.Failed ("Triggering alternative sequence of statements " &
- "executed");
- when Others =>
- Report.Failed ("Unexpected exception in the Main");
- end;
-
- Report.Result;
-
-end C974011;
diff --git a/gcc/testsuite/ada/acats/tests/c9/c974012.a b/gcc/testsuite/ada/acats/tests/c9/c974012.a
deleted file mode 100644
index 4e43c72a842..00000000000
--- a/gcc/testsuite/ada/acats/tests/c9/c974012.a
+++ /dev/null
@@ -1,165 +0,0 @@
--- C974012.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that the abortable part of an asynchronous select statement is
--- aborted if it does not complete before the triggering statement
--- completes, where the triggering statement is a call on a protected
--- entry which is queued.
---
--- TEST DESCRIPTION:
--- A fraction of in-line code is simulated. A voltage deficiency causes
--- the routine to seek an alternate best-cost route on an electrical grid
--- system.
---
--- An asynchronous select is used with the triggering alternative being a
--- call to a protected entry with a barrier. The abortable part is a
--- routine simulating the lengthy alternate path negotiation. The entry
--- barrier would be cleared if the voltage deficiency is rectified before
--- the alternate can be found thus nullifying the need for the alternate.
---
--- The test simulates a return to normal in the middle of the
--- negotiation. The barrier is cleared, the triggering alternative
--- completes first and the abortable part should be aborted.
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
---
---!
-
-
-with Report;
-with ImpDef;
-
-procedure C974012 is
-
- subtype Grid_Path is string(1..21);
- subtype Deficiency is integer range 100..1_000; -- in MWh
-
- New_Path : Grid_Path;
- Dummy_Deficiency : Deficiency := 520;
- Path_Available : Boolean := false;
-
- TC_Terminate_Negotiation_Executed : Boolean := false;
- TC_Trigger_Completed : Boolean := false;
- TC_Negotiation_Completed : Boolean := false;
-
- protected Local_Deficit is
- procedure Set_Good_Voltage;
- procedure Bad_Voltage;
- entry Terminate_Negotiation;
- private
- Good_Voltage : Boolean := false; -- barrier
- end Local_Deficit;
-
- protected body Local_Deficit is
-
- procedure Set_Good_Voltage is
- begin
- Good_Voltage := true;
- end Set_Good_Voltage;
-
- procedure Bad_Voltage is
- begin
- Good_Voltage := false;
- end Bad_Voltage;
-
- -- Trigger is queued on this entry with barrier condition
- entry Terminate_Negotiation when Good_Voltage is
- begin
- -- complete the triggering call thus terminating grid_path
- -- negotiation.
- null; --::: stub - signal main board
- TC_Terminate_Negotiation_Executed := true; -- show path traversal
- end Terminate_Negotiation;
-
- end Local_Deficit;
-
-
- -- Routine to find the most cost effective grid path for this
- -- particular deficiency at this particular time
- --
- procedure Path_Negotiation (Requirement : in Deficiency;
- Best_Path : out Grid_Path ) is
-
- Dummy_Path : Grid_Path := "NYC.425_NY.227_NH.132";
- Match : Deficiency := Report.Ident_Int (Requirement);
-
- begin
- --
- null; --::: stub
- --
- -- Simulate a lengthy path negotiation
- for i in 1..5 loop
- delay ImpDef.Minimum_Task_Switch;
- -- Part of the way through the negotiation simulate some external
- -- event returning the voltage to acceptable level
- if i = 3 then
- Local_Deficit.Set_Good_Voltage; -- clear the barrier
- end if;
- end loop;
-
- Best_Path := Dummy_Path;
- TC_Negotiation_Completed := true;
-
- end Path_Negotiation;
-
-
-
-begin
-
- Report.Test ("C974012", "Asynchronous Select: Trigger is queued on a " &
- "protected entry and completes before the " &
- "abortable part");
-
- -- ::::::::: Fragment of code
-
- Local_Deficit.Bad_Voltage; -- Set barrier condition
-
- -- For the given voltage deficiency start negotiating the best grid
- -- path. If voltage returns to acceptable level cancel the negotiation
- --
- select
- -- Prepare to terminate the Path_Negotiation if voltage improves
- Local_Deficit.Terminate_Negotiation;
- TC_Trigger_Completed := true;
- then abort
- Path_Negotiation (Dummy_Deficiency, New_Path) ;
- Path_Available := true;
- end select;
- -- :::::::::
-
- if not TC_Terminate_Negotiation_Executed or else not
- TC_Trigger_Completed then
- Report.Failed ("Unexpected test path taken");
- end if;
-
- if Path_Available or else TC_Negotiation_Completed then
- Report.Failed ("Abortable part was not aborted");
- end if;
- Report.Result;
-
-end C974012;
diff --git a/gcc/testsuite/ada/acats/tests/c9/c974013.a b/gcc/testsuite/ada/acats/tests/c9/c974013.a
deleted file mode 100644
index 4a930da93b3..00000000000
--- a/gcc/testsuite/ada/acats/tests/c9/c974013.a
+++ /dev/null
@@ -1,167 +0,0 @@
--- C974013.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that the abortable part of an asynchronous select statement
--- is aborted if it does not complete before the triggering statement
--- completes, where the triggering statement is a delay_until
--- statement.
---
--- Check that the sequence of statements of the triggering alternative
--- is executed after the abortable part is left.
---
--- TEST DESCRIPTION:
--- Declare a task with an accept statement containing an asynchronous
--- select with a delay_until triggering statement. Parameterize
--- the accept statement with the amount of time to be added to the
--- current time to be used for the delay. Simulate a time-consuming
--- calculation by declaring a procedure containing an infinite loop.
--- Call this procedure in the abortable part.
---
--- The delay will expire before the abortable part completes, at which
--- time the abortable part is aborted, and the sequence of statements
--- following the triggering statement is executed.
---
--- Main test logic is identical to c974001 which uses simple delay
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 28 Nov 95 SAIC Fixed problems for ACVC 2.0.1.
---
---!
-
-with Report;
-with ImpDef;
-with Ada.Calendar;
-
-procedure C974013 is
-
-
- --========================================================--
-
- function "+" (Left : Ada.Calendar.Time; Right: Duration)
- return Ada.Calendar.Time renames Ada.Calendar."+";
-
-
- Allotted_Time : constant Duration := ImpDef.Switch_To_New_Task;
- Calculation_Canceled : exception;
-
- Count : Integer := 1234;
- procedure Lengthy_Calculation is
- begin
- -- Simulate a non-converging calculation.
- loop -- Infinite loop.
- Count := (Count + 1) mod 10;
- exit when not Report.Equal (Count, Count); -- Condition always false.
- delay 0.0; -- abort completion point
- end loop;
- end Lengthy_Calculation;
-
-
- --========================================================--
-
-
- task type Timed_Calculation is
- entry Calculation (Time_Limit : in Duration);
- end Timed_Calculation;
-
-
- task body Timed_Calculation is
- Delay_Time : Ada.Calendar.Time;
- begin
- loop
- select
- accept Calculation (Time_Limit : in Duration) do
-
- -- We have to construct an "until" time artificially
- -- as we have no control over when the test will be run
- --
- Delay_Time := Ada.Calendar.Clock + Time_Limit;
-
- -- --
- -- Asynchronous select is tested here --
- -- --
-
- select
-
- delay until Delay_Time; -- Time not reached yet, so
- -- Lengthy_Calculation starts.
-
- raise Calculation_Canceled; -- This is executed after
- -- Lengthy_Calculation aborted.
-
- then abort
-
- Lengthy_Calculation; -- Delay expires before complete,
- -- so this call is aborted.
- -- Check that the whole of the abortable part is aborted,
- -- not just the statement in the abortable part that was
- -- executing at the time
- Report.Failed ("Abortable part not aborted");
-
- end select;
-
- Report.Failed ("Triggering alternative sequence of " &
- "statements not executed");
-
- exception -- New Ada 9x: handler within accept
- when Calculation_Canceled =>
- if Count = 1234 then
- Report.Failed ("Abortable part did not execute");
- end if;
- end Calculation;
- or
- terminate;
- end select;
- end loop;
- exception
- when others =>
- Report.Failed ("Unexpected exception in Timed_Calculation task");
- end Timed_Calculation;
-
-
- --========================================================--
-
-
-
-begin -- Main program.
-
- Report.Test ("C974013", "Asynchronous Select: Trigger is delay_until " &
- "which completes before abortable part");
-
- declare
- Timed : Timed_Calculation; -- Task.
- begin
- Timed.Calculation (Time_Limit => Allotted_Time); -- Asynchronous select
- -- inside accept block.
- exception
- when Calculation_Canceled =>
- Report.Failed ("wrong exception handler used");
- end;
-
- Report.Result;
-
-end C974013;
diff --git a/gcc/testsuite/ada/acats/tests/c9/c974014.a b/gcc/testsuite/ada/acats/tests/c9/c974014.a
deleted file mode 100644
index 03ca915f896..00000000000
--- a/gcc/testsuite/ada/acats/tests/c9/c974014.a
+++ /dev/null
@@ -1,132 +0,0 @@
--- C974014.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that if the triggering alternative of an asynchronous select
--- statement is a delay and the abortable part completes before the delay
--- expires then the delay is cancelled and the optional statements in the
--- triggering part are not performed. In particular, check the case of
--- the ATC in non-tasking code.
---
--- TEST DESCRIPTION:
--- A fraction of in-line code is simulated. An asynchronous select
--- is used with a triggering delay of several minutes. The abortable
--- part, which is simulating a very lengthy, time consuming procedure
--- actually returns almost immediately thus ensuring that it completes
--- first. At the conclusion, if a substantial amount of time has passed
--- the delay is assumed not to have been cancelled.
--- (based on example in LRM 9.7.4)
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
---
---!
-
-
-with Report;
-with Ada.Calendar;
-
-procedure C974014 is
-
- function "-" (Left, Right : Ada.Calendar.Time)
- return Duration renames Ada.Calendar."-";
-
- TC_Start_Time : Ada.Calendar.Time := Ada.Calendar.Clock;
- TC_Elapsed_Time : duration;
-
- Maximum_Allowable_Time : duration := 300.0; -- for Calculate_Gamma_Function
-
-begin
-
- Report.Test ("C974014", "ATC: When abortable part completes before " &
- "a triggering delay, check that the delay " &
- "is cancelled & optional statements " &
- "are not performed");
-
- declare -- encapsulate test code
-
- type Gamma_Index is digits 5; -- float precision
-
- -- (These two fields are assumed filled elsewhere)
- Input_Field, Result_of_Beta : Gamma_Index;
-
- -- Notify and take corrective action in the event that
- -- the procedure Calculate_Gamma_Function does not converge.
- --
- procedure Non_Convergent is
- begin
- null; -- stub
-
- Report.Failed ("Optional statements in triggering part" &
- " were performed");
- end Non_Convergent;
-
-
- -- This is a very time consuming calculation. It is possible,
- -- that, with certain parameters, it will not converge. If it
- -- runs for more than Maximum_Allowable_Time it is considered
- -- not to be convergent and should be aborted.
- --
- Procedure Calculate_Gamma_Function (X, Y : Gamma_Index) is
- begin
- null; -- Stub
- --
- end Calculate_Gamma_Function;
-
- begin -- declare
-
- -- ..... Isolated segment of inline code
-
- -- Now Print Gamma Function (abort and display if not convergent)
- --
- select
- delay Maximum_Allowable_Time; -- for Calculate_Gamma_Function
- Non_Convergent; -- Display error and flag result as failed
-
- then abort
- Calculate_Gamma_Function (Input_Field, Result_of_Beta);
- end select;
-
- -- ..... End of Isolated segment of inline code
-
- end; -- declare
-
- TC_Elapsed_Time := Ada.Calendar.Clock - TC_Start_Time;
-
- -- Note: We are not checking for "cancellation within a reasonable time",
- -- we are checking for cancellation/non-cancellation of the delay. We
- -- use a number which, if exceeded, means that the delay was not
- -- cancelled and has proceeded to full term.
- --
- if ( TC_Elapsed_Time > Maximum_Allowable_Time/2 ) then
- -- Test time exceeds a reasonable value.
- Report.Failed ("Triggering delay statement was not cancelled");
- end if;
-
-
- Report.Result;
-
-end C974014;
diff --git a/gcc/testsuite/ada/acats/tests/c9/c980001.a b/gcc/testsuite/ada/acats/tests/c9/c980001.a
deleted file mode 100644
index 3bd4196f0ec..00000000000
--- a/gcc/testsuite/ada/acats/tests/c9/c980001.a
+++ /dev/null
@@ -1,303 +0,0 @@
--- C980001.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that when a construct is aborted the execution of an Initialize
--- procedure as the last step of the default initialization of a
--- controlled object is abort-deferred.
---
--- Check that when a construct is aborted the execution of a Finalize
--- procedure as part of the finalization of a controlled object is
--- abort-deferred.
---
--- Check that an assignment operation to an object with a controlled
--- part is an abort-deferred operation.
---
--- TEST DESCRIPTION:
--- The controlled operations which are being tested call a subprogram
--- which guarantees that the enclosing operation becomes aborted.
---
--- Each object is created with a unique value to prevent optimizations
--- due to the values being the same.
---
--- Two protected objects are utilized to warrant that the operations
--- are delayed in their execution until such time that the abort is
--- processed. The object Hold_Up is used to hold the targeted
--- operation in execution, the object Progress is used to communicate
--- to the driver software that progress is indeed being made.
---
---
--- CHANGE HISTORY:
--- 01 MAY 95 SAIC Initial version
--- 01 MAY 96 SAIC Revised for 2.1
--- 11 DEC 96 SAIC Final revision for 2.1
--- 02 DEC 97 EDS Remove 2 calls to C980001_0.Hold_Up.Lock
---!
-
----------------------------------------------------------------- C980001_0
-
-with Impdef;
-with Ada.Finalization;
-package C980001_0 is
-
- A_Little_While : constant Duration := Impdef.Switch_To_New_Task * 2.0;
- Enough_Time_For_The_Controlled_Operation_To_Happen : constant Duration
- := Impdef.Switch_To_New_Task * 4.0;
-
- function TC_Unique return Integer;
-
- type Sticks_In_Initialize is new Ada.Finalization.Controlled with record
- Item: Integer := TC_Unique;
- end record;
- procedure Initialize( AV: in out Sticks_In_Initialize );
-
- type Sticks_In_Adjust is new Ada.Finalization.Controlled with record
- Item: Integer := TC_Unique;
- end record;
- procedure Adjust ( AV: in out Sticks_In_Adjust );
-
- type Sticks_In_Finalize is new Ada.Finalization.Controlled with record
- Item: Integer := TC_Unique;
- end record;
- procedure Finalize ( AV: in out Sticks_In_Finalize );
-
- Initialize_Called : Boolean := False;
- Adjust_Called : Boolean := False;
- Finalize_Called : Boolean := False;
-
- protected type Sticker is
- entry Lock;
- procedure Unlock;
- function Is_Locked return Boolean;
- private
- Locked : Boolean := False;
- end Sticker;
-
- Hold_Up : Sticker;
- Progress : Sticker;
-
- procedure Fail_And_Clear( Message : String );
-
-
-end C980001_0;
-
--- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
-
-with Report;
-with TCTouch;
-package body C980001_0 is
-
- TC_Master_Value : Integer := 0;
-
-
- function TC_Unique return Integer is -- make all values unique.
- begin
- TC_Master_Value := TC_Master_Value +1;
- return TC_Master_Value;
- end TC_Unique;
-
- protected body Sticker is
-
- entry Lock when not Locked is
- begin
- Locked := True;
- end Lock;
-
- procedure Unlock is
- begin
- Locked := False;
- end Unlock;
-
- function Is_Locked return Boolean is
- begin
- return Locked;
- end Is_Locked;
-
- end Sticker;
-
- procedure Initialize( AV: in out Sticks_In_Initialize ) is
- begin
- TCTouch.Touch('I'); -------------------------------------------------- I
- Hold_Up.Unlock; -- cause the select to abort
- Initialize_Called := True;
- AV.Item := TC_Unique;
- TCTouch.Touch('i'); -------------------------------------------------- i
- Progress.Unlock; -- allows Wait_Your_Turn to continue
- end Initialize;
-
- procedure Adjust ( AV: in out Sticks_In_Adjust ) is
- begin
- TCTouch.Touch('A'); -------------------------------------------------- A
- Hold_Up.Unlock; -- cause the select to abort
- Adjust_Called := True;
- AV.Item := TC_Unique;
- TCTouch.Touch('a'); -------------------------------------------------- a
- Progress.Unlock;
- end Adjust;
-
- procedure Finalize ( AV: in out Sticks_In_Finalize ) is
- begin
- TCTouch.Touch('F'); -------------------------------------------------- F
- Hold_Up.Unlock; -- cause the select to abort
- Finalize_Called := True;
- AV.Item := TC_Unique;
- TCTouch.Touch('f'); -------------------------------------------------- f
- Progress.Unlock;
- end Finalize;
-
- procedure Fail_And_Clear( Message : String ) is
- begin
- Report.Failed(Message);
- Hold_Up.Unlock;
- Progress.Unlock;
- end Fail_And_Clear;
-
-end C980001_0;
-
----------------------------------------------------------------------------
-
-with Report;
-with TCTouch;
-with Impdef;
-with C980001_0;
-procedure C980001 is
-
- procedure Check_Initialize_Conditions is
- begin
- if not C980001_0.Initialize_Called then
- C980001_0.Fail_And_Clear("Initialize did not correctly complete");
- end if;
- TCTouch.Validate("Ii", "Initialization Sequence");
- end Check_Initialize_Conditions;
-
- procedure Check_Adjust_Conditions is
- begin
- if not C980001_0.Adjust_Called then
- C980001_0.Fail_And_Clear("Adjust did not correctly complete");
- end if;
- TCTouch.Validate("Aa", "Adjust Sequence");
- end Check_Adjust_Conditions;
-
- procedure Check_Finalize_Conditions is
- begin
- if not C980001_0.Finalize_Called then
- C980001_0.Fail_And_Clear("Finalize did not correctly complete");
- end if;
- TCTouch.Validate("FfFfFf", "Finalization Sequence",
- Order_Meaningful => False);
- end Check_Finalize_Conditions;
-
- procedure Wait_Your_Turn is
- Overrun : Natural := 0;
- begin
- while C980001_0.Progress.Is_Locked loop -- and waits
- delay C980001_0.A_Little_While;
- Overrun := Overrun +1;
- if Overrun > 10 then
- C980001_0.Fail_And_Clear("Overrun expired lock");
- end if;
- end loop;
- end Wait_Your_Turn;
-
-begin -- Main test procedure.
-
- Report.Test ("C980001", "Check the interaction between asynchronous " &
- "transfer of control and controlled types" );
-
- C980001_0.Progress.Lock;
- C980001_0.Hold_Up.Lock;
-
- select
- C980001_0.Hold_Up.Lock; -- Init will unlock
-
- Wait_Your_Turn; -- abortable part is stuck in Initialize
- Check_Initialize_Conditions;
-
- then abort
- declare
- Object : C980001_0.Sticks_In_Initialize;
- begin
- delay Impdef.Minimum_Task_Switch;
- if Report.Ident_Int( Object.Item ) /= Object.Item then
- Report.Failed("Optimization foil caused failure");
- end if;
- C980001_0.Fail_And_Clear(
- "Initialize test executed beyond expected region");
- end;
- end select;
-
- C980001_0.Progress.Lock;
-
- select
- C980001_0.Hold_Up.Lock; -- Adjust will unlock
-
- Wait_Your_Turn; -- abortable part is stuck in Adjust
- Check_Adjust_Conditions;
-
- then abort
- declare
- Object1 : C980001_0.Sticks_In_Adjust;
- Object2 : C980001_0.Sticks_In_Adjust;
- begin
- Object1 := Object2;
- delay Impdef.Minimum_Task_Switch;
- if Report.Ident_Int( Object2.Item )
- /= Report.Ident_Int( Object1.Item ) then
- Report.Failed("Optimization foil 1 caused failure");
- end if;
- C980001_0.Fail_And_Clear("Adjust test executed beyond expected region");
- end;
- end select;
-
- C980001_0.Progress.Lock;
-
- select
- C980001_0.Hold_Up.Lock; -- Finalize will unlock
-
- Wait_Your_Turn; -- abortable part is stuck in Finalize
- Check_Finalize_Conditions;
-
- then abort
- declare
- Object1 : C980001_0.Sticks_In_Finalize;
- Object2 : C980001_0.Sticks_In_Finalize;
- begin
- Object1 := Object2; -- cause a finalize call
- delay Impdef.Minimum_Task_Switch;
- if Report.Ident_Int( Object2.Item )
- /= Report.Ident_Int( Object1.Item ) then
- Report.Failed("Optimization foil 2 caused failure");
- end if;
- C980001_0.Fail_And_Clear(
- "Finalize test executed beyond expected region");
- end;
- end select;
-
- Report.Result;
-
-exception
- when others => C980001_0.Fail_And_Clear("Exception in main");
- Report.Result;
-end C980001;
diff --git a/gcc/testsuite/ada/acats/tests/c9/c980002.a b/gcc/testsuite/ada/acats/tests/c9/c980002.a
deleted file mode 100644
index f2b9c52479c..00000000000
--- a/gcc/testsuite/ada/acats/tests/c9/c980002.a
+++ /dev/null
@@ -1,165 +0,0 @@
--- C980002.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that aborts are deferred during protected actions.
---
--- TEST DESCRIPTION:
--- This test uses an asynchronous transfer of control to attempt
--- to abort a protected operation. The protected operation
--- includes several requeues to check that the requeue does not
--- allow the abort to occur.
---
---
--- CHANGE HISTORY:
--- 30 OCT 95 SAIC ACVC 2.1
---
---!
-
-with Report;
-procedure C980002 is
-
- Max_Checkpoints : constant := 7;
- type Checkpoint_ID is range 1..Max_Checkpoints;
- type Points_Array is array (Checkpoint_ID) of Boolean;
-begin
- Report.Test ("C980002",
- "Check that aborts are deferred during a protected action" &
- " including requeues");
-
- declare -- test encapsulation
-
- protected Checkpoint is
- procedure Got_Here (Id : Checkpoint_ID);
- function Results return Points_Array;
- private
- Reached_Points : Points_Array := (others => False);
- end Checkpoint;
-
- protected body Checkpoint is
- procedure Got_Here (Id : Checkpoint_ID) is
- begin
- Reached_Points (Id) := True;
- end Got_Here;
-
- function Results return Points_Array is
- begin
- return Reached_Points;
- end Results;
- end Checkpoint;
-
-
- protected Start_Here is
- entry AST_Waits_Here;
- entry Start_PO;
- private
- Open : Boolean := False;
- entry First_Stop;
- end Start_Here;
-
- protected Middle_PO is
- entry Stop_1;
- entry Stop_2;
- end Middle_PO;
-
- protected Final_PO is
- entry Final_Stop;
- end Final_PO;
-
-
- protected body Start_Here is
- entry AST_Waits_Here when Open is
- begin
- null;
- end AST_Waits_Here;
-
- entry Start_PO when True is
- begin
- Open := True;
- Checkpoint.Got_Here (1);
- requeue First_Stop;
- end Start_PO;
-
- -- make sure the AST has been accepted before continuing
- entry First_Stop when AST_Waits_Here'Count = 0 is
- begin
- Checkpoint.Got_Here (2);
- requeue Middle_PO.Stop_1;
- end First_Stop;
- end Start_Here;
-
- protected body Middle_PO is
- entry Stop_1 when True is
- begin
- Checkpoint.Got_Here (3);
- requeue Stop_2;
- end Stop_1;
-
- entry Stop_2 when True is
- begin
- Checkpoint.Got_Here (4);
- requeue Final_PO.Final_Stop;
- end Stop_2;
- end Middle_PO;
-
- protected body Final_PO is
- entry Final_Stop when True is
- begin
- Checkpoint.Got_Here (5);
- end Final_Stop;
- end Final_PO;
-
-
- begin -- test encapsulation
- select
- Start_Here.AST_Waits_Here;
- Checkpoint.Got_Here (6);
- then abort
- Start_Here.Start_PO;
- delay 0.0; -- abort completion point
- Checkpoint.Got_Here (7);
- end select;
-
- Check_The_Results: declare
- Chk : constant Points_Array := Checkpoint.Results;
- Expected : constant Points_Array := (1..6 => True,
- 7 => False);
- begin
- for I in Checkpoint_ID loop
- if Chk (I) /= Expected (I) then
- Report.Failed ("checkpoint error" &
- Checkpoint_ID'Image (I) &
- " actual is " &
- Boolean'Image (Chk(I)));
- end if;
- end loop;
- end Check_The_Results;
- exception
- when others =>
- Report.Failed ("unexpected exception");
- end; -- test encapsulation
-
- Report.Result;
-end C980002;
diff --git a/gcc/testsuite/ada/acats/tests/c9/c980003.a b/gcc/testsuite/ada/acats/tests/c9/c980003.a
deleted file mode 100644
index dd69fc7ee68..00000000000
--- a/gcc/testsuite/ada/acats/tests/c9/c980003.a
+++ /dev/null
@@ -1,294 +0,0 @@
--- C980003.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- TEST OBJECTIVE:
--- Check that aborts are deferred during the execution of an
--- Initialize procedure (as the last step of the default
--- initialization of a controlled object), during the execution
--- of a Finalize procedure (as part of the finalization of a
--- controlled object), and during an assignment operation to an
--- object with a controlled part.
---
--- TEST DESCRIPTION:
--- A controlled type is created with Initialize, Adjust, and
--- Finalize operations. These operations note in a protected
--- object when the operation starts and completes. This change
--- in state of the protected object will open the barrier for
--- the entry in the protected object.
--- The test contains declarations of objects of the controlled
--- type. An asynchronous select is used to attempt to abort
--- the operations on the controlled type. The asynchronous select
--- makes use of the state change to the protected object to
--- trigger the abort.
---
---
--- CHANGE HISTORY:
--- 11 Jan 96 SAIC Initial Release for 2.1
--- 5 May 96 SAIC Incorporated Reviewer comments.
--- 10 Oct 96 SAIC Addressed issue where assignment statement
--- can be 2 assignment operations.
---
---!
-
-with Ada.Finalization;
-package C980003_0 is
- Verbose : constant Boolean := False;
-
- -- the following flag is set true whenever the
- -- Initialize operation is called.
- Init_Occurred : Boolean;
-
- type Is_Controlled is new Ada.Finalization.Controlled with
- record
- Id : Integer;
- end record;
-
- procedure Initialize (Object : in out Is_Controlled);
- procedure Finalize (Object : in out Is_Controlled);
- procedure Adjust (Object : in out Is_Controlled);
-
- type States is (Unknown,
- Start_Init, Finished_Init,
- Start_Adjust, Finished_Adjust,
- Start_Final, Finished_Final);
-
- protected State_Manager is
- procedure Reset;
- procedure Set (New_State : States);
- function Current return States;
- entry Wait_For_Change;
- private
- Current_State : States := Unknown;
- Changed : Boolean := False;
- end State_Manager;
-
-end C980003_0;
-
-
-with Report;
-with ImpDef;
-package body C980003_0 is
- protected body State_Manager is
- procedure Reset is
- begin
- Current_State := Unknown;
- Changed := False;
- end Reset;
-
- procedure Set (New_State : States) is
- begin
- Changed := True;
- Current_State := New_State;
- end Set;
-
- function Current return States is
- begin
- return Current_State;
- end Current;
-
- entry Wait_For_Change when Changed is
- begin
- Changed := False;
- end Wait_For_Change;
- end State_Manager;
-
- procedure Initialize (Object : in out Is_Controlled) is
- begin
- if Verbose then
- Report.Comment ("starting initialize");
- end if;
- State_Manager.Set (Start_Init);
- if Verbose then
- Report.Comment ("in initialize");
- end if;
- delay ImpDef.Switch_To_New_Task; -- tempting place for abort
- State_Manager.Set (Finished_Init);
- if Verbose then
- Report.Comment ("finished initialize");
- end if;
- Init_Occurred := True;
- end Initialize;
-
- procedure Finalize (Object : in out Is_Controlled) is
- begin
- if Verbose then
- Report.Comment ("starting finalize");
- end if;
- State_Manager.Set (Start_Final);
- if Verbose then
- Report.Comment ("in finalize");
- end if;
- delay ImpDef.Switch_To_New_Task; -- tempting place for abort
- State_Manager.Set (Finished_Final);
- if Verbose then
- Report.Comment ("finished finalize");
- end if;
- end Finalize;
-
- procedure Adjust (Object : in out Is_Controlled) is
- begin
- if Verbose then
- Report.Comment ("starting adjust");
- end if;
- State_Manager.Set (Start_Adjust);
- if Verbose then
- Report.Comment ("in adjust");
- end if;
- delay ImpDef.Switch_To_New_Task; -- tempting place for abort
- State_Manager.Set (Finished_Adjust);
- if Verbose then
- Report.Comment ("finished adjust");
- end if;
- end Adjust;
-end C980003_0;
-
-
-with Report;
-with ImpDef;
-with C980003_0; use C980003_0;
-with Ada.Unchecked_Deallocation;
-procedure C980003 is
-
- procedure Check_State (Should_Be : States;
- Msg : String) is
- Cur : States := State_Manager.Current;
- begin
- if Cur /= Should_Be then
- Report.Failed (Msg);
- Report.Comment ("expected: " & States'Image (Should_Be) &
- " found: " & States'Image (Cur));
- elsif Verbose then
- Report.Comment ("passed: " & Msg);
- end if;
- end Check_State;
-
-begin
-
- Report.Test ("C980003", "Check that aborts are deferred during" &
- " initialization, finalization, and assignment" &
- " operations on controlled objects");
-
- Check_State (Unknown, "initial condition");
-
- -- check that initialization and finalization take place
- Init_Occurred := False;
- select
- State_Manager.Wait_For_Change;
- then abort
- declare
- My_Controlled_Obj : Is_Controlled;
- begin
- delay 0.0; -- abort completion point
- Report.Failed ("state change did not occur");
- end;
- end select;
- if not Init_Occurred then
- Report.Failed ("Initialize did not complete");
- end if;
- Check_State (Finished_Final, "init/final for declared item");
-
- -- check adjust
- State_Manager.Reset;
- declare
- Source, Dest : Is_Controlled;
- begin
- Check_State (Finished_Init, "adjust initial state");
- Source.Id := 3;
- Dest.Id := 4;
- State_Manager.Reset; -- so we will wait for change
- select
- State_Manager.Wait_For_Change;
- then abort
- Dest := Source;
- end select;
-
- -- there are two implementation methods for the
- -- assignment statement:
- -- 1. no temporary was used in the assignment statement
- -- thus the entire
- -- assignment statement is abort deferred.
- -- 2. a temporary was used in the assignment statement so
- -- there are two assignment operations. An abort may
- -- occur between the assignment operations
- -- Various optimizations are allowed by 7.6 that can affect
- -- how many times Adjust and Finalize are called.
- -- Depending upon the implementation, the state can be either
- -- Finished_Adjust or Finished_Finalize. If it is any other
- -- state then the abort took place at the wrong time.
-
- case State_Manager.Current is
- when Finished_Adjust =>
- if Verbose then
- Report.Comment ("assignment aborted after adjust");
- end if;
- when Finished_Final =>
- if Verbose then
- Report.Comment ("assignment aborted after finalize");
- end if;
- when Start_Adjust =>
- Report.Failed ("assignment aborted in adjust");
- when Start_Final =>
- Report.Failed ("assignment aborted in finalize");
- when Start_Init =>
- Report.Failed ("assignment aborted in initialize");
- when Finished_Init =>
- Report.Failed ("assignment aborted after initialize");
- when Unknown =>
- Report.Failed ("assignment aborted in unknown state");
- end case;
-
-
- if Dest.Id /= 3 then
- if Verbose then
- Report.Comment ("assignment not performed");
- end if;
- end if;
- end;
-
-
- -- check dynamically allocated objects
- State_Manager.Reset;
- declare
- type Pointer_Type is access Is_Controlled;
- procedure Free is new Ada.Unchecked_Deallocation (
- Is_Controlled, Pointer_Type);
- Ptr : Pointer_Type;
- begin
- -- make sure initialize is done when object is allocated
- Ptr := new Is_Controlled;
- Check_State (Finished_Init, "init when item allocated");
- -- now try aborting the finalize
- State_Manager.Reset;
- select
- State_Manager.Wait_For_Change;
- then abort
- Free (Ptr);
- end select;
- Check_State (Finished_Final, "finalization in dealloc");
- end;
-
- Report.Result;
-
-end C980003;
diff --git a/gcc/testsuite/ada/acats/tests/ca/ca11001.a b/gcc/testsuite/ada/acats/tests/ca/ca11001.a
deleted file mode 100644
index c9d1e486ca5..00000000000
--- a/gcc/testsuite/ada/acats/tests/ca/ca11001.a
+++ /dev/null
@@ -1,276 +0,0 @@
--- CA11001.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that a child unit can be used to provide an alternate view and
--- operations on a private type in its parent package. Check that a
--- child unit can be a package. Check that a WITH of a child unit
--- includes an implicit WITH of its ancestor unit.
---
--- TEST DESCRIPTION:
--- Declare a private type in a package specification. Declare
--- subprograms for the type.
---
--- Add a public child to the above package. Within the body of this
--- package, access the private type. Declare operations to read and
--- write to its parent private type.
---
--- In the main program, "with" the child. Declare objects of the
--- parent private type. Access the subprograms from both parent and
--- child packages.
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
---
---!
-
-package CA11001_0 is -- Cartesian_Complex
--- This package represents a Cartesian view of a complex number. It contains
--- a private type plus subprograms to construct and decompose a complex
--- number.
-
- type Complex_Int is range 0 .. 100;
-
- type Complex_Type is private;
-
- Constant_Complex : constant Complex_Type;
-
- Complex_Error : exception;
-
- procedure Cartesian_Assign (R, I : in Complex_Int;
- C : out Complex_Type);
-
- function Cartesian_Real_Part (C : Complex_Type)
- return Complex_Int;
-
- function Cartesian_Imag_Part (C : Complex_Type)
- return Complex_Int;
-
- function Complex (Real, Imaginary : Complex_Int)
- return Complex_Type;
-
-private
- type Complex_Type is -- Parent private type
- record
- Real, Imaginary : Complex_Int;
- end record;
-
- Constant_Complex : constant Complex_Type := (Real => 0, Imaginary => 0);
-
-end CA11001_0; -- Cartesian_Complex
-
---=======================================================================--
-
-package body CA11001_0 is -- Cartesian_Complex
-
- procedure Cartesian_Assign (R, I : in Complex_Int;
- C : out Complex_Type) is
- begin
- C.Real := R;
- C.Imaginary := I;
- end Cartesian_Assign;
- -------------------------------------------------------------
- function Cartesian_Real_Part (C : Complex_Type)
- return Complex_Int is
- begin
- return C.Real;
- end Cartesian_Real_Part;
- -------------------------------------------------------------
- function Cartesian_Imag_Part (C : Complex_Type)
- return Complex_Int is
- begin
- return C.Imaginary;
- end Cartesian_Imag_Part;
- -------------------------------------------------------------
- function Complex (Real, Imaginary : Complex_Int)
- return Complex_Type is
- begin
- return (Real, Imaginary);
- end Complex;
-
-end CA11001_0; -- Cartesian_Complex
-
---=======================================================================--
-
-package CA11001_0.CA11001_1 is -- Polar_Complex
--- This public child provides a different view of the private type from its
--- parent. It provides a polar view by the provision of subprograms which
--- construct and decompose a complex number.
-
- procedure Polar_Assign (R, Theta : in Complex_Int;
- C : out Complex_Type);
- -- Complex_Type is a
- -- record of CA11001_0
-
- function Polar_Real_Part (C: Complex_Type) return Complex_Int;
-
- function Polar_Imag_Part (C: Complex_Type) return Complex_Int;
-
- function Equals_Const (Num : Complex_Type) return Boolean;
-
-end CA11001_0.CA11001_1; -- Polar_Complex
-
---=======================================================================--
-
-package body CA11001_0.CA11001_1 is -- Polar_Complex
-
- function Cos (Angle : Complex_Int) return Complex_Int is
- Num : constant Complex_Int := 2;
- begin
- return (Angle * Num); -- not true Cosine function
- end Cos;
- -------------------------------------------------------------
- function Sine (Angle : Complex_Int) return Complex_Int is
- begin
- return 1; -- not true Sine function
- end Sine;
- -------------------------------------------------------------
- function Sqrt (Num : Complex_Int)
- return Complex_Int is
- begin
- return (Num); -- not true Square root function
- end Sqrt;
- -------------------------------------------------------------
- function Tan (Angle : Complex_Int) return Complex_Int is
- begin
- return Angle; -- not true Tangent function
- end Tan;
- -------------------------------------------------------------
- procedure Polar_Assign (R, Theta : in Complex_Int;
- C : out Complex_Type) is
- begin
- if R = 0 and Theta = 0 then
- raise Complex_Error;
- end if;
- C.Real := R * Cos (Theta);
- C.Imaginary := R * Sine (Theta);
- end Polar_Assign;
- -------------------------------------------------------------
- function Polar_Real_Part (C: Complex_Type) return Complex_Int is
- begin
- return Sqrt ((Cartesian_Imag_Part (C)) ** 2 +
- (Cartesian_Real_Part (C)) ** 2);
- end Polar_Real_Part;
- -------------------------------------------------------------
- function Polar_Imag_Part (C: Complex_Type) return Complex_Int is
- begin
- return (Tan (Cartesian_Imag_Part (C) /
- Cartesian_Real_Part (C)));
- end Polar_Imag_Part;
- -------------------------------------------------------------
- function Equals_Const (Num : Complex_Type) return Boolean is
- begin
- return Num.Real = Constant_Complex.Real and
- Num.Imaginary = Constant_Complex.Imaginary;
- end Equals_Const;
-
-end CA11001_0.CA11001_1; -- Polar_Complex
-
---=======================================================================--
-
-with CA11001_0.CA11001_1; -- Polar_Complex
-with Report;
-
-procedure CA11001 is
-
- Complex_No : CA11001_0.Complex_Type; -- Complex_Type is a
- -- record of CA11001_0
-
- Complex_5x2 : CA11001_0.Complex_Type := CA11001_0.Complex (5, 2);
-
- Int_2 : CA11001_0.Complex_Int
- := CA11001_0.Complex_Int (Report.Ident_Int (2));
-
-begin
-
- Report.Test ("CA11001", "Check that a child unit can be used " &
- "to provide an alternate view and operations " &
- "on a private type in its parent package");
-
- Basic_View_Subtest:
-
- begin
- -- Assign using Cartesian coordinates.
- CA11001_0.Cartesian_Assign
- (CA11001_0.Complex_Int (Report.Ident_Int (1)), Int_2, Complex_No);
-
- -- Read back in Polar coordinates.
- -- Polar values are surrogates used in checking for correct
- -- subprogram calls.
- if CA11001_0."/=" (CA11001_0.CA11001_1.Polar_Real_Part (Complex_No),
- CA11001_0.Cartesian_Real_Part (Complex_5x2)) and CA11001_0."/="
- (CA11001_0.CA11001_1.Polar_Imag_Part (Complex_No),
- CA11001_0.Cartesian_Imag_Part (Complex_5x2)) then
- Report.Failed ("Incorrect Cartesian result");
- end if;
-
- end Basic_View_Subtest;
- -------------------------------------------------------------
- Alternate_View_Subtest:
- begin
- -- Assign using Polar coordinates.
- CA11001_0.CA11001_1.Polar_Assign
- (Int_2, CA11001_0.Complex_Int (Report.Ident_Int (3)), Complex_No);
-
- -- Read back in Cartesian coordinates.
- if CA11001_0."/=" (CA11001_0.Cartesian_Real_Part
- (Complex_No), CA11001_0.Complex_Int (Report.Ident_Int (12))) or
- CA11001_0."/=" (CA11001_0.Cartesian_Imag_Part (Complex_No), Int_2)
- then
- Report.Failed ("Incorrect Polar result");
- end if;
- end Alternate_View_Subtest;
- -------------------------------------------------------------
- Other_Subtest:
- begin
- -- Assign using Polar coordinates.
- CA11001_0.CA11001_1.Polar_Assign
- (CA11001_0.Complex_Int (Report.Ident_Int (0)), Int_2, Complex_No);
-
- -- Compare with Complex_Num in CA11001_0.
- if not CA11001_0.CA11001_1.Equals_Const (Complex_No)
- then
- Report.Failed ("Incorrect result");
- end if;
- end Other_Subtest;
- -------------------------------------------------------------
- Exception_Subtest:
- begin
- -- Raised parent's exception.
- CA11001_0.CA11001_1.Polar_Assign
- (CA11001_0.Complex_Int (Report.Ident_Int (0)),
- CA11001_0.Complex_Int (Report.Ident_Int (0)), Complex_No);
- Report.Failed ("Exception was not raised");
- exception
- when CA11001_0.Complex_Error =>
- null;
- when others =>
- Report.Failed ("Unexpected exception raised in test");
- end Exception_Subtest;
-
- Report.Result;
-
-end CA11001;
diff --git a/gcc/testsuite/ada/acats/tests/ca/ca11002.a b/gcc/testsuite/ada/acats/tests/ca/ca11002.a
deleted file mode 100644
index 189e1944c77..00000000000
--- a/gcc/testsuite/ada/acats/tests/ca/ca11002.a
+++ /dev/null
@@ -1,238 +0,0 @@
--- CA11002.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that a public child can utilize its parent unit's visible
--- definitions.
---
--- TEST DESCRIPTION:
--- Declare a parent package that contains the following: type, object,
--- constant, exception, and subprograms. Declare a public child unit
--- that utilizes the components found in the visible part of its parent.
---
--- Demonstrate utilization of the following parent components in the
--- child package:
---
--- Parent
--- Type X
--- Constant X
--- Object X
--- Subprogram X
--- Exception X
---
--- This abstraction simulates a portion of a simple operating system.
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
---
---!
-
-package CA11002_0 is -- Package OS.
-
- type File_Descriptor is new Integer;
- type File_Mode is (Read_Only, Write_Only, Read_Write);
-
- Null_File : constant File_Descriptor := 0;
- Default_Mode : constant File_Mode := Read_Only;
- Active_Mode : constant File_Mode := Read_Write;
-
- type File_Type is
- record
- Descriptor : File_Descriptor := Null_File;
- Mode : File_Mode := Default_Mode;
- end record;
-
- System_File : File_Type;
- File_Mode_Error : exception;
-
- function Next_Available_File return File_Descriptor;
-
- function Mode_Of_File (File : File_Type) return File_Mode;
-
-end CA11002_0; -- Package OS.
-
- --=================================================================--
-
-package body CA11002_0 is -- Package body OS.
-
- File_Count : Integer := 0;
-
- function Next_Available_File return File_Descriptor is
- begin
- File_Count := File_Count + 1;
- return (File_Descriptor(File_Count)); -- Type conversion.
- end Next_Available_File;
- --------------------------------------------------------------
- function Mode_Of_File (File : File_Type) return File_Mode is
- Mode : File_Mode := File.Mode;
- begin
- return (Mode);
- end Mode_Of_File;
-
-end CA11002_0; -- Package body OS.
-
- --=================================================================--
-
-package CA11002_0.CA11002_1 is -- Child package OS.Operations.
-
- -- Dot qualification of types, objects, etc. from parent is not required
- -- in a child unit.
-
- procedure Create_File (Mode : in File_Mode:= Active_Mode;
- File : out File_Type);
-
-end CA11002_0.CA11002_1; -- Child package OS.Operations.
-
- --=================================================================--
-
-with Report;
-package body CA11002_0.CA11002_1 is -- Child package body OS.Operations.
-
- function New_File_Validated (File : File_Type) -- Ensure that a newly
- return Boolean is -- created file has
- Result : Boolean := False; -- appropriate values.
- begin
- if (File.Descriptor > System_File.Descriptor) and -- Parent object.
- (File.Mode in File_Mode ) -- Parent type.
- then
- Result := True;
- end if;
-
- return (Result);
-
- end New_File_Validated;
- --------------------------------------------------------------
- procedure Create_File
- (Mode : in File_Mode := Active_Mode; -- Parent constant.
- File : out File_Type) is -- Parent type.
-
- New_File : File_Type;
-
- begin
- New_File.Descriptor := Next_Available_File; -- Parent subprogram.
- New_File.Mode := Mode;
-
- if New_File_Validated (File => New_File) then
- File := New_File;
- end if;
-
- end Create_File;
-
-end CA11002_0.CA11002_1; -- Child Package body OS.Operations.
-
- --=================================================================--
-
--- Child library subprogram Convert_File_Mode specification.
-procedure CA11002_0.CA11002_2 (File : in out File_Type; -- Parent type.
- New_Mode : in File_Mode); -- Parent type.
-
-
- --=================================================================--
-with Report;
-
--- Child library subprogram Convert_File_Mode body.
-procedure CA11002_0.CA11002_2 (File : in out File_Type;
- New_Mode : in File_Mode) is
-begin
- if File.Mode = New_Mode then
- raise File_Mode_Error; -- Parent exception.
- Report.Failed ("Exception not raised in child unit");
- else
- File.Mode := New_Mode;
- end if;
-end CA11002_0.CA11002_2;
-
- --=================================================================--
-
-with Report;
-with CA11002_0.CA11002_1; -- Child package OS.Operations.
-with CA11002_0.CA11002_2; -- Child subprogram OS.Convert_File_Mode,
- -- Implicitly with parent, OS.
-use CA11002_0; -- All user-defined operators directly
- -- visible.
-procedure CA11002 is
-begin
-
- Report.Test ("CA11002", "Check that a public child can utilize its " &
- "parent unit's visible definitions");
-
- File_Creation: -- This processing block will demonstrate
- -- use of child package subroutine that
- -- takes advantage of components declared
- -- in the parent package.
- declare
- User_File : File_Type;
- begin
- CA11002_0.CA11002_1.Create_File (File => User_File); -- Default mode
- -- parameter used in
- -- this call.
- if (User_File.Descriptor = System_File.Descriptor) or
- (User_File.Mode = Default_Mode)
- then
- Report.Failed ("Incorrect file creation");
- end if;
-
- end File_Creation;
-
- --------------------------------------------------------------
- File_Mode_Conversion: -- This processing block will demonstrate
- -- the occurrence of a (forced) exception
- -- being raised in a child subprogram, and
- -- propagated to the caller. The exception
- -- is handled, and the child subprogram
- -- is called again, this time to perform
- -- without error.
- declare
- procedure Convert_File_Mode (File : in out File_Type;
- New_Mode : in File_Mode) renames CA11002_0.CA11002_2;
- New_File : File_Type;
- begin -- Raise an exception with this
- -- illegal conversion operation
- -- (attempt to change to current mode).
-
- Convert_File_Mode (File => New_File,
- New_Mode => Default_Mode);
- Report.Failed ("Exception should have been raised in child unit");
-
- exception
- when File_Mode_Error => -- Perform the conversion again, this
- -- time with a different file mode.
-
- Convert_File_Mode (File => New_File,
- New_Mode => CA11002_0.Active_Mode);
-
- if New_File.Mode /= Read_Write then
- Report.Failed ("Incorrect result from mode conversion operation");
- end if;
-
- when others =>
- Report.Failed ("Unexpected exception raised in File_Mode_Conversion");
-
- end File_Mode_Conversion;
-
- Report.Result;
-
-end CA11002;
diff --git a/gcc/testsuite/ada/acats/tests/ca/ca11003.a b/gcc/testsuite/ada/acats/tests/ca/ca11003.a
deleted file mode 100644
index ff894250ed0..00000000000
--- a/gcc/testsuite/ada/acats/tests/ca/ca11003.a
+++ /dev/null
@@ -1,290 +0,0 @@
--- CA11003.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that a public grandchild can utilize its ancestor unit's visible
--- definitions.
---
--- TEST DESCRIPTION:
--- Declare a public package, public child package, and public
--- grandchild package and library unit function. Within the
--- grandchild package and function, make use of components that are
--- declared in the ancestor packages, both parent and grandparent.
---
--- Use the following ancestral components in the grandchildren library
--- units:
--- Grandparent Parent
--- Type X X
--- Constant X X
--- Object X X
--- Subprogram X X
--- Exception X X
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 21 Dec 94 SAIC Modified procedure Create_File
--- 15 Nov 95 SAIC Update and repair for ACVC 2.0.1
---
---!
-
-package CA11003_0 is -- Package OS
-
- type File_Descriptor is new Integer;
- type File_Mode is (Read_Only, Write_Only, Read_Write);
-
- Null_File : constant File_Descriptor := 0;
- Default_Mode : constant File_Mode := Read_Only;
- File_Data_Error : exception;
-
- type File_Type is tagged
- record
- Descriptor : File_Descriptor := Null_File;
- Mode : File_Mode := Read_Write;
- end record;
-
- System_File : File_Type;
-
- function Next_Available_File return File_Descriptor;
-
- procedure Reclaim_File_Descriptor;
-
-end CA11003_0; -- Package OS
-
- --=================================================================--
-
-package body CA11003_0 is -- Package body OS
-
- File_Count : Integer := 0;
-
- function Next_Available_File return File_Descriptor is
- begin
- File_Count := File_Count + 1;
- return (File_Descriptor(File_Count));
- end Next_Available_File;
- --------------------------------------------------
- procedure Reclaim_File_Descriptor is
- begin
- null; -- Dummy processing unit.
- end Reclaim_File_Descriptor;
-
-end CA11003_0; -- Package body OS
-
- --=================================================================--
-
-package CA11003_0.CA11003_1 is -- Child package OS.Operations
-
- subtype File_Length_Type is Integer range 0 .. 1000;
- Min_File_Size : File_Length_Type := File_Length_Type'First;
- Max_File_Size : File_Length_Type := File_Length_Type'Last;
-
- File_Duplication_Error : exception;
-
- type Extended_File_Type is new File_Type with private;
-
- procedure Create_File (Mode : in File_Mode;
- File : out Extended_File_Type);
-
- procedure Duplicate_File (Original : in Extended_File_Type;
- Duplicate : out Extended_File_Type);
-
-private
- type Extended_File_Type is new File_Type with
- record
- Blocks : File_Length_Type := Min_File_Size;
- end record;
-
- System_Extended_File : Extended_File_Type;
-
-end CA11003_0.CA11003_1; -- Child Package OS.Operations
-
- --=================================================================--
-
-package body CA11003_0.CA11003_1 is -- Child package body OS.Operations
-
- procedure Create_File
- (Mode : in File_Mode;
- File : out Extended_File_Type) is
- begin
- File.Descriptor := Next_Available_File; -- Parent subprogram.
- File.Mode := Default_Mode; -- Parent constant.
- File.Blocks := Min_File_Size;
- end Create_File;
- --------------------------------------------------
- procedure Duplicate_File (Original : in Extended_File_Type;
- Duplicate : out Extended_File_Type) is
- begin
- Duplicate.Descriptor := Next_Available_File; -- Parent subprogram.
- Duplicate.Mode := Original.Mode;
- Duplicate.Blocks := Original.Blocks;
- end Duplicate_File;
-
-end CA11003_0.CA11003_1; -- Child package body OS.Operations
-
- --=================================================================--
-
--- This package contains menu selectable operations for manipulating files.
--- This abstraction builds on the capabilities available from ancestor
--- packages.
-
-package CA11003_0.CA11003_1.CA11003_2 is
-
- procedure News (Mode : in File_Mode;
- File : out Extended_File_Type);
-
- procedure Copy (Original : in Extended_File_Type;
- Duplicate : out Extended_File_Type);
-
- procedure Delete (File : in Extended_File_Type);
-
-end CA11003_0.CA11003_1.CA11003_2; -- Grandchild package OS.Operations.Menu
-
- --=================================================================--
-
--- Grandchild subprogram Validate
-function CA11003_0.CA11003_1.CA11003_3 (File : in Extended_File_Type)
- return Boolean;
-
- --=================================================================--
-
--- Grandchild subprogram Validate
-function CA11003_0.CA11003_1.CA11003_3
- (File : in Extended_File_Type) -- Parent type.
- return Boolean is
-
- function New_File_Validated (File : Extended_File_Type)
- return Boolean is
- begin
- if (File.Descriptor > System_File.Descriptor) and -- Grandparent
- (File.Mode in File_Mode ) and -- object and type
- not ((File.Blocks < System_Extended_File.Blocks) or
- (File.Blocks > Max_File_Size)) -- Parent object
- then -- and constant.
- return True;
- else
- return False;
- end if;
- end New_File_Validated;
-
-begin
- return (New_File_Validated (File)) and
- (File.Descriptor /= Null_File); -- Grandparent constant.
-
-end CA11003_0.CA11003_1.CA11003_3; -- Grandchild subprogram Validate
-
- --=================================================================--
-
-with CA11003_0.CA11003_1.CA11003_3;
- -- Grandchild package body OS.Operations.Menu
-package body CA11003_0.CA11003_1.CA11003_2 is
-
- procedure News (Mode : in File_Mode;
- File : out Extended_File_Type) is -- Parent type.
- begin
- Create_File (Mode, File); -- Parent subprogram.
- if not CA11003_0.CA11003_1.CA11003_3 (File) then
- raise File_Data_Error; -- Grandparent exception.
- end if;
- end News;
- --------------------------------------------------
- procedure Copy (Original : in Extended_File_Type;
- Duplicate : out Extended_File_Type) is
- begin
- Duplicate_File (Original, Duplicate); -- Parent subprogram.
-
- if Original.Descriptor = Duplicate.Descriptor then
- raise File_Duplication_Error; -- Parent exception.
- end if;
-
- end Copy;
- --------------------------------------------------
- procedure Delete (File : in Extended_File_Type) is
- begin
- Reclaim_File_Descriptor; -- Grandparent
- end Delete; -- subprogram.
-
-end CA11003_0.CA11003_1.CA11003_2;
-
- --=================================================================--
-
-with CA11003_0.CA11003_1.CA11003_2; -- Grandchild Pkg OS.Operations.Menu
-with CA11003_0.CA11003_1.CA11003_3; -- Grandchild Ftn OS.Operations.Validate
-with Report;
-
-procedure CA11003 is
-
- package Menu renames CA11003_0.CA11003_1.CA11003_2;
-
-begin
-
- Report.Test ("CA11003", "Check that a public grandchild can utilize " &
- "its ancestor unit's visible definitions");
-
- File_Processing: -- Validate all of the capabilities contained in
- -- the Menu package by exercising them on specific
- -- files. This will demonstrate the use of child
- -- and grandchild functionality based on components
- -- that have been declared in the
- -- parent/grandparent package.
- declare
-
- function Validate (File : CA11003_0.CA11003_1.Extended_File_Type)
- return Boolean renames CA11003_0.CA11003_1.CA11003_3;
-
- MacWrite_File,
- Backup_Copy : CA11003_0.CA11003_1.Extended_File_Type;
- MacWrite_File_Mode : CA11003_0.File_Mode := CA11003_0.Read_Write;
-
- begin
-
- Menu.News (MacWrite_File_Mode, MacWrite_File);
-
- if not Validate (MacWrite_File) then
- Report.Failed ("Incorrect initialization of files");
- end if;
-
- Menu.Copy (MacWrite_File, Backup_Copy);
-
- if not (Validate (MacWrite_File) and
- Validate (Backup_Copy))
- then
- Report.Failed ("Incorrect duplication of files");
- end if;
-
- Menu.Delete (Backup_Copy);
-
- exception
- when CA11003_0.File_Data_Error =>
- Report.Failed ("Exception raised during file validation");
- when CA11003_0.CA11003_1.File_Duplication_Error =>
- Report.Failed ("Exception raised during file duplication");
- when others =>
- Report.Failed ("Unexpected exception in test procedure");
-
- end File_Processing;
-
- Report.Result;
-
-end CA11003;
diff --git a/gcc/testsuite/ada/acats/tests/ca/ca110040.a b/gcc/testsuite/ada/acats/tests/ca/ca110040.a
deleted file mode 100644
index 72cc6682eab..00000000000
--- a/gcc/testsuite/ada/acats/tests/ca/ca110040.a
+++ /dev/null
@@ -1,90 +0,0 @@
--- CA110040.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- See CA110042.AM
---
--- TEST DESCRIPTION:
--- See CA110042.AM
---
--- TEST FILES:
--- The following files comprise this test:
---
--- => CA110040.A
--- CA110041.A
--- CA110042.AM
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 26 Apr 96 SAIC ACVC 2.1: Modified prologue; Added pragma
--- Elaborate_Body.
---
---!
-
-package CA110040 is -- Package Computer_System.
- pragma Elaborate_Body (CA110040);
-
- -- Types.
- type ID_Type is range 1 .. 4;
- type System_Account_Capacity is new ID_Type;
-
- type Account is tagged
- record
- User_ID : ID_Type;
- end record;
-
- -- Constants.
- Maximum_System_Accounts : constant System_Account_Capacity :=
- System_Account_Capacity'Last;
-
- System_Administrator : constant ID_Type :=
- ID_Type (System_Account_Capacity'First);
-
- Administrator_Account : constant Account :=
- (User_ID => System_Administrator);
-
- -- Objects.
- Total_Accounts : System_Account_Capacity := 1;
-
- -- Exceptions.
- Illegal_Account : exception;
- Account_Limit_Exceeded : exception;
-
- -- Subprograms.
- function Next_Available_ID return ID_Type;
-
-end CA110040; -- Package Computer_System.
-
- --=================================================================--
-
-package body CA110040 is -- Package body Computer_System.
-
- function Next_Available_ID return ID_Type is
- begin
- Total_Accounts := Total_Accounts + 1;
- return (ID_Type(Total_Accounts));
- end Next_Available_ID;
-
-end CA110040; -- Package body Computer_System.
diff --git a/gcc/testsuite/ada/acats/tests/ca/ca110041.a b/gcc/testsuite/ada/acats/tests/ca/ca110041.a
deleted file mode 100644
index 954df7f4d68..00000000000
--- a/gcc/testsuite/ada/acats/tests/ca/ca110041.a
+++ /dev/null
@@ -1,118 +0,0 @@
--- CA110041.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- See CA110042.AM
---
--- TEST DESCRIPTION:
--- See CA110042.AM
---
--- TEST FILES:
--- The following files comprise this test:
---
--- CA110040.A
--- => CA110041.A
--- CA110042.AM
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 26 Apr 96 SAIC ACVC 2.1: Modified prologue.
---
---!
-
-package CA110040.CA110041 is -- Child Package Computer_System.Manager
-
- type User_Account is new Account with private;
-
- procedure Initialize_User_Account (Acct : out User_Account);
-
-private
-
--- The private portion of this spec demonstrates that components contained
--- in the visible part of the parent are directly visible in the private
--- part of a public child.
-
- type Account_Access_Type is (None, Guest, User, System);
-
- type User_Account is new Account with -- Parent type.
- record
- Privilege : Account_Access_Type := None;
- end record;
-
- System_Account : User_Account :=
- (User_ID => Administrator_Account.User_ID, -- Parent constant.
- Privilege => System); -- User_ID has been
- -- set to 1.
- Auditor_Account : User_Account :=
- (User_ID => Next_Available_ID, -- Parent function.
- Privilege => System); -- User_ID has been
- -- set to 2.
- Total_Authorized_Accounts : System_Account_Capacity
- renames Total_Accounts; -- Parent object.
-
- Unauthorized_Account : exception
- renames Illegal_Account; -- Parent exception
-
-end CA110040.CA110041; -- Child Package Computer_System.Manager
-
- --=================================================================--
-
- -- Child Package body Computer_System.Manager
-package body CA110040.CA110041 is
-
- function Account_Limit_Reached return Boolean is
- begin
- if Total_Authorized_Accounts = Maximum_System_Accounts then
- return (True);
- else
- return (False);
- end if;
- end Account_Limit_Reached;
- ---------------------------------------------------------------
- function Valid_Account (Acct : User_Account) return Boolean is
- Result : Boolean := False;
- begin
- if (Acct.User_ID /= System_Account.User_ID) and
- (Acct.User_ID /= Auditor_Account.User_ID)
- then
- Result := True;
- end if;
- return (Result);
- end Valid_Account;
- ---------------------------------------------------------------
- procedure Initialize_User_Account (Acct : out User_Account) is
- begin
- if Account_Limit_Reached then
- raise Account_Limit_Exceeded;
- else
- Acct.User_ID := Next_Available_ID;
- Acct.Privilege := User;
- end if;
- if not Valid_Account (Acct) then
- raise Unauthorized_Account;
- end if;
- end Initialize_User_Account;
-
-end CA110040.CA110041; -- Child Package body Computer_System.Manager
diff --git a/gcc/testsuite/ada/acats/tests/ca/ca110050.a b/gcc/testsuite/ada/acats/tests/ca/ca110050.a
deleted file mode 100644
index 88455762c96..00000000000
--- a/gcc/testsuite/ada/acats/tests/ca/ca110050.a
+++ /dev/null
@@ -1,99 +0,0 @@
--- CA110050.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- See CA110051.AM
---
--- TEST DESCRIPTION:
--- See CA110051.AM
---
--- TEST FILES:
--- The test consists of the following files:
---
--- => CA110050.A
--- CA110051.AM
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 21 Dec 94 SAIC Modified discriminant type
--- 26 Apr 96 SAIC ACVC 2.1: Modified prologue; Added pragma
--- Elaborate_Body.
---
---!
-
-package CA110050_0 is -- Package Messages.
- pragma Elaborate_Body (CA110050_0);
-
- type Descriptor is new Integer;
-
- Null_Descriptor_Value : constant Descriptor := 0;
- Null_Message_Descriptor : constant Descriptor := 0;
-
- type Message_Type is tagged
- record
- Number : Descriptor := Null_Message_Descriptor;
- end record;
-
- function Next_Available_Message return Descriptor;
-
-end CA110050_0; -- Package Messages.
-
- --=================================================================--
-
-package body CA110050_0 is -- Package body Messages.
-
- Message_Count : Integer := 0;
-
- function Next_Available_Message return Descriptor is
- begin
- Message_Count := Message_Count + 5;
- return (Descriptor(Message_Count));
- end Next_Available_Message;
-
-end CA110050_0; -- Package body Messages.
-
- --=================================================================--
-
-package CA110050_0.CA110050_1 is -- Child package Messages.Text
-
- subtype Default_Length is Natural range 0 .. 80;
-
- type Text_Type (Max_Length : Default_Length := 0) is
- record
- Length : Default_Length := Max_Length;
- Text_Field : String (1 .. Max_Length);
- end record;
-
- type Text_Message_Type is new Message_Type with
- record
- Text : Text_Type;
- end record;
-
- Null_Text : Text_Type (0); -- Null range for
- -- Text_Field component.
-
-end CA110050_0.CA110050_1; -- Child package Messages.Text
---
--- No package body needed for this specification.
diff --git a/gcc/testsuite/ada/acats/tests/ca/ca11006.a b/gcc/testsuite/ada/acats/tests/ca/ca11006.a
deleted file mode 100644
index 5cd21fe1f15..00000000000
--- a/gcc/testsuite/ada/acats/tests/ca/ca11006.a
+++ /dev/null
@@ -1,211 +0,0 @@
--- CA11006.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that the private part of a child library unit can utilize
--- its parent unit's private definition.
---
--- TEST DESCRIPTION:
--- Declare a package and public child package, both with private
--- parts. The child package will have a private extension of a type
--- declared in the parent's private part. In addition, the private
--- part of the child package specification will make use of some of
--- the components declared in the private part of the parent.
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 15 Nov 95 SAIC Update and repair for ACVC 2.0.1
---
---!
-
-package CA11006_0 is -- Package File_Package
-
- type File_Descriptor is private;
- type File_Mode is (Read_Only, Write_Only, Read_Write);
- type File_Type is tagged private;
-
- function Next_Available_File return File_Descriptor;
-
-private
-
- type File_Measure is range 0 .. 1000;
- type File_Descriptor is new Integer;
-
- Null_File : constant File_Descriptor := 0;
- Default_Mode : constant File_Mode := Read_Write;
-
- type File_Type is tagged
- record
- Descriptor : File_Descriptor := Null_File;
- Mode : File_Mode := Default_Mode;
- end record;
-
- System_File : File_Type;
-
-end CA11006_0; -- Package File_Package
-
- --=================================================================--
-
-package body CA11006_0 is -- Package File_Package
-
- File_Count : Integer := 0;
-
- function Next_Available_File return File_Descriptor is
- begin
- File_Count := File_Count + 1;
- return File_Descriptor (File_Count);
- end Next_Available_File;
-
-end CA11006_0; -- Package File_Package
-
- --=================================================================--
-
-package CA11006_0.CA11006_1 is -- Child package File_Package.Operations
-
- type File_Length_Type is private;
- type Extended_File_Type is new File_Type with private;
-
- System_Extended_File : constant Extended_File_Type;
-
- procedure Create_File (Mode : in File_Mode;
- File : out Extended_File_Type);
-
- procedure Compress_File (Original : in Extended_File_Type;
- Compressed_File : out Extended_File_Type);
-
- function Validate (File : in Extended_File_Type) return Boolean;
-
- function Validate_Compression (File : in Extended_File_Type)
- return Boolean;
- -- These two validation functions provide
- -- the capability to check the private
- -- components defined in the parent and
- -- child packages from within the client
- -- program.
-private
-
- type File_Length_Type is new File_Measure; -- Parent private type.
-
- Min_File_Size : File_Length_Type := File_Length_Type'First;
- Max_File_Size : File_Length_Type := File_Length_Type'Last;
-
- type Extended_File_Type is new File_Type with -- Parent type.
- record
- Blocks : File_Length_Type := Min_File_Size;
- end record;
-
- System_Extended_File : constant Extended_File_Type :=
- (Descriptor => System_File.Descriptor, -- Parent private object.
- Mode => Read_Only, -- Parent enumeration literal.
- Blocks => Min_File_Size);
-
-
-end CA11006_0.CA11006_1; -- Child Package File_Package.Operations
-
- --=================================================================--
-
- -- Child package body File_Package.Operations
-package body CA11006_0.CA11006_1 is
-
- procedure Create_File
- (Mode : in File_Mode;
- File : out Extended_File_Type) is
- begin
- File.Descriptor := Next_Available_File; -- Parent subprogram.
- File.Mode := Default_Mode; -- Parent private constant.
- File.Blocks := Max_File_Size;
- end Create_File;
- ------------------------------------------------------------------------
- procedure Compress_File (Original : in Extended_File_Type;
- Compressed_File : out Extended_File_Type) is
- begin
- Compressed_File.Descriptor := Next_Available_File;
- Compressed_File.Mode := Read_Only;
- Compressed_File.Blocks := Original.Blocks / 2; -- Simulated file
- end Compress_File; -- compression.
- ------------------------------------------------------------------------
- function Validate (File : in Extended_File_Type) return Boolean is
- begin
- if ((File.Descriptor /= System_Extended_File.Descriptor) and
- (File.Mode = Read_Write) and
- (File.Blocks = Max_File_Size)) then
- return True;
- else
- return False;
- end if;
- end Validate;
- ------------------------------------------------------------------------
- function Validate_Compression (File : in Extended_File_Type)
- return Boolean is
- begin
- if ((File.Descriptor /= System_File.Descriptor) and
- (File.Mode = Read_Only) and
- (File.Blocks = Max_File_Size/2)) then
- return True;
- else
- return False;
- end if;
- end Validate_Compression;
-
-end CA11006_0.CA11006_1; -- Child package body File_Package.Operations
-
- --=================================================================--
-
-with CA11006_0.CA11006_1; -- with Child package File_Package.Operations
-with Report;
-
-procedure CA11006 is
-
- package File renames CA11006_0;
- package File_Ops renames CA11006_0.CA11006_1;
-
- Validation_File_Mode : File.File_Mode := File.Read_Only;
- Validation_File,
- Storage_Copy : File_Ops.Extended_File_Type;
-
-begin
-
- Report.Test ("CA11006", "Check that the private part of a child " &
- "library unit can utilize its parent " &
- "unit's private definition");
-
- File_Ops.Create_File (Validation_File_Mode, Validation_File);
-
- if not File_Ops.Validate (Validation_File) then
- Report.Failed ("Incorrect initialization of file");
- end if;
-
- File_Ops.Compress_File (Validation_File, Storage_Copy);
-
- if not (File_Ops.Validate (Validation_File) and
- File_Ops.Validate_Compression (Storage_Copy))
- then
- Report.Failed ("Incorrect compression of file");
- end if;
-
- Report.Result;
-
-end CA11006;
diff --git a/gcc/testsuite/ada/acats/tests/ca/ca11007.a b/gcc/testsuite/ada/acats/tests/ca/ca11007.a
deleted file mode 100644
index c4a6789ab8e..00000000000
--- a/gcc/testsuite/ada/acats/tests/ca/ca11007.a
+++ /dev/null
@@ -1,228 +0,0 @@
--- CA11007.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that the private part of a grandchild library unit can
--- utilize its grandparent unit's private definition.
---
--- TEST DESCRIPTION:
--- Declare a package, child package, and grandchild package, all
--- with private parts in their specifications.
---
--- The private part of the grandchild package will make use of components
--- that have been declared in the private part of the grandparent
--- specification.
---
--- The child package demonstrates the extension of a parent file type
--- into an abstraction of an analog file structure. The grandchild package
--- extends the grandparent file type into an abstraction of a digital
--- file structure, and provides conversion capability to/from the parent
--- analog file structure.
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
---
---!
-
-package CA11007_0 is -- Package File_Package
-
- type File_Descriptor is private;
- type File_Type is tagged private;
-
- function Next_Available_File return File_Descriptor;
-
-private
-
- type File_Measure_Type is range 0 .. 1000;
- type File_Descriptor is new Integer;
-
- Null_Measure : constant File_Measure_Type := File_Measure_Type'First;
- Null_File : constant File_Descriptor := 0;
-
- type File_Type is tagged
- record
- Descriptor : File_Descriptor := Null_File;
- end record;
-
-end CA11007_0; -- Package File_Package
-
- --=================================================================--
-
-package body CA11007_0 is -- Package body File_Package
-
- File_Count : Integer := 0;
-
- function Next_Available_File return File_Descriptor is
- begin
- File_Count := File_Count + 1;
- return File_Descriptor (File_Count);
- end Next_Available_File;
-
-end CA11007_0; -- Package body File_Package
-
- --=================================================================--
-
-package CA11007_0.CA11007_1 is -- Child package Analog
-
- type Analog_File_Type is new File_Type with private;
-
-private
-
- type Wavelength_Type is new File_Measure_Type;
-
- Min_Wavelength : constant Wavelength_Type := Wavelength_Type'First;
-
- type Analog_File_Type is new File_Type with -- Parent type.
- record
- Wavelength : Wavelength_Type := Min_Wavelength;
- end record;
-
-end CA11007_0.CA11007_1; -- Child package Analog
-
- --=================================================================--
-
-package CA11007_0.CA11007_1.CA11007_2 is -- Grandchild package Digital
-
- type Digital_File_Type is new File_Type with private;
-
- procedure Recording (File : out Digital_File_Type);
-
- procedure Convert (From : in Analog_File_Type;
- To : out Digital_File_Type);
-
- function Validate (File : in Digital_File_Type) return Boolean;
- function Valid_Conversion (To : Digital_File_Type) return Boolean;
- function Valid_Initial (From : Analog_File_Type) return Boolean;
-
-private
-
- type Track_Type is new File_Measure_Type; -- Grandparent type.
-
- Min_Tracks : constant Track_Type :=
- Track_Type (Null_Measure) + Track_Type'First; -- Grandparent private
- Max_Tracks : constant Track_Type := -- constant.
- Track_Type (Null_Measure) + Track_Type'Last;
-
- type Digital_File_Type is new File_Type with -- Grandparent type.
- record
- Tracks : Track_Type := Min_Tracks;
- end record;
-
-end CA11007_0.CA11007_1.CA11007_2; -- Grandchild package Digital
-
- --=================================================================--
-
- -- Grandchild package body Digital
-package body CA11007_0.CA11007_1.CA11007_2 is
-
- procedure Recording (File : out Digital_File_Type) is
- begin
- File.Descriptor := Next_Available_File; -- Assign new file descriptor.
- File.Tracks := Max_Tracks; -- Change initial value.
- end Recording;
- --------------------------------------------------------------------------
- procedure Convert (From : in Analog_File_Type;
- To : out Digital_File_Type) is
- begin
- To.Descriptor := From.Descriptor + 100; -- Dummy conversion.
- To.Tracks := Track_Type (From.Wavelength) / 2;
- end Convert;
- --------------------------------------------------------------------------
- function Validate (File : in Digital_File_Type) return Boolean is
- Result : Boolean := False;
- begin
- if not (File.Tracks /= Max_Tracks) then
- Result := True;
- end if;
- return Result;
- end Validate;
- --------------------------------------------------------------------------
- function Valid_Conversion (To : Digital_File_Type) return Boolean is
- begin
- return (To.Descriptor = 100) and (To.Tracks = (Min_Tracks / 2));
- end Valid_Conversion;
- --------------------------------------------------------------------------
- function Valid_Initial (From : Analog_File_Type) return Boolean is
- begin
- return (From.Wavelength = Min_Wavelength); -- Validate initial
- end Valid_Initial; -- conditions.
-
-end CA11007_0.CA11007_1.CA11007_2; -- Grandchild package body Digital
-
- --=================================================================--
-
-with CA11007_0.CA11007_1.CA11007_2; -- with Grandchild package Digital
-with Report;
-
-procedure CA11007 is
-
- package Analog renames CA11007_0.CA11007_1;
- package Digital renames CA11007_0.CA11007_1.CA11007_2;
-
- Original_Digital_File,
- Converted_Digital_File : Digital.Digital_File_Type;
-
- Original_Analog_File : Analog.Analog_File_Type;
-
-begin
-
- -- This code demonstrates how private extensions could be utilized
- -- in child packages to allow for recording on different media.
- -- The processing contained in the procedures and functions is
- -- "dummy" processing, not intended to perform actual recording,
- -- conversion, or validation operations, but simply to demonstrate
- -- this type of structural decomposition as a possible solution to
- -- a user's design problem.
-
- Report.Test ("CA11007", "Check that the private part of a grandchild " &
- "library unit can utilize its grandparent " &
- "unit's private definition");
-
- if not Digital.Valid_Initial (Original_Analog_File)
- then
- Report.Failed ("Incorrect initialization of Analog File");
- end if;
-
- ---
-
- Digital.Convert (From => Original_Analog_File, -- Convert file to
- To => Converted_Digital_File); -- digital format.
-
- if not Digital.Valid_Conversion (To => Converted_Digital_File) then
- Report.Failed ("Incorrect conversion of analog file");
- end if;
-
- ---
-
- Digital.Recording (Original_Digital_File); -- Create file in
- -- digital format.
- if not Digital.Validate (Original_Digital_File) then
- Report.Failed ("Incorrect recording of digital file");
- end if;
-
- Report.Result;
-
-end CA11007;
diff --git a/gcc/testsuite/ada/acats/tests/ca/ca11008.a b/gcc/testsuite/ada/acats/tests/ca/ca11008.a
deleted file mode 100644
index 1161fbe0c3a..00000000000
--- a/gcc/testsuite/ada/acats/tests/ca/ca11008.a
+++ /dev/null
@@ -1,216 +0,0 @@
--- CA11008.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that a private child package can use entities declared in the
--- visible part of its parent unit.
---
--- TEST DESCRIPTION:
--- Declare a parent package containing types and objects used
--- by the system. Declare a private child package that uses the parent
--- components to provide functionality to the system.
---
--- The tagged file type defined in the parent has defaults for all
--- component fields. Prior to initialization, these values are checked
--- to ensure a correct start condition. The initial subprogram is
--- called, which utilizes the functionality provided in the private
--- child package. This subprogram changes the fields of the file object
--- to something other than the default values, and this process is then
--- verified at the conclusion of the test.
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
---
---!
-
-package CA11008_0 is -- Package OS.
-
- type File_Descriptor_Type is new Integer;
- type File_Name_Type is new String (1 .. 11);
- type Permission_Type is (None, User, System, Bypass);
- type File_Mode_Type is (Read_Only, Write_Only, Read_Write);
- type File_Status_Type is (Open, Closed);
-
- Default_Descriptor : constant File_Descriptor_Type := 0;
- Default_Permission : constant Permission_Type := None;
- Default_Mode : constant File_Mode_Type := Read_Only;
- Default_Status : constant File_Status_Type := Closed;
- Default_Filename : constant File_Name_Type := " ";
-
- Max_Files : constant File_Descriptor_Type := 100;
- Constant_Name : constant File_Name_Type := "AdaFileName";
- File_Counter : Integer := 0;
-
- type File_Type is tagged
- record
- Descriptor : File_Descriptor_Type := Default_Descriptor;
- Name : File_Name_Type := Default_Filename;
- Acct_Access : Permission_Type := Default_Permission;
- Mode : File_Mode_Type := Default_Mode;
- Current_Status : File_Status_Type := Default_Status;
- end record;
-
- type File_Array_Type is array (1 .. Max_Files) of File_Type;
-
- File_Table : File_Array_Type;
-
- --
-
- function Get_File_Name return File_Name_Type;
-
- function Initialize_File return File_Descriptor_Type;
-
-end CA11008_0; -- Package OS.
-
- --=================================================================--
-
--- Subprograms that perform the actual file operations are contained in a
--- private package so that they are not accessible to any client.
-
-private package CA11008_0.CA11008_1 is -- Package OS.Internals
-
- Private_File_Counter : Integer renames File_Counter; -- Parent
- -- object.
- function Initialize
- (File_Name : File_Name_Type := Get_File_Name; -- Parent function.
- File_Mode : File_Mode_Type := Read_Write) -- Parent literal.
- return File_Descriptor_Type; -- Parent type.
-
-end CA11008_0.CA11008_1; -- Package OS.Internals
-
- --=================================================================--
-
-package body CA11008_0.CA11008_1 is -- Package body OS.Internals
-
- function Next_Available_File return File_Descriptor_Type is
- begin
- Private_File_Counter := Private_File_Counter + 1;
- return (File_Descriptor_Type(File_Counter));
- end Next_Available_File;
- -----------------------------------------------------------------
- function Initialize
- (File_Name : File_Name_Type := Get_File_Name; -- Parent function
- File_Mode : File_Mode_Type := Read_Write) -- Parent literal
- return File_Descriptor_Type is -- Parent type
- Number : File_Descriptor_Type;
- begin
- Number := Next_Available_File;
- File_Table(Number).Descriptor := Number; -- Parent object
- File_Table(Number).Name := File_Name; -- Default parameter value
- File_Table(Number).Mode := File_Mode; -- Default parameter value
- File_Table(Number).Acct_Access := User;
- File_Table(Number).Current_Status := Open;
- return (Number);
- end Initialize;
-
-end CA11008_0.CA11008_1; -- Package body OS.Internals
-
- --=================================================================--
-
-with CA11008_0.CA11008_1; -- Private child package "withed" by
- -- parent body.
-
-package body CA11008_0 is -- Package body OS
-
- function Get_File_Name return File_Name_Type is
- begin
- return (Constant_Name); -- Of course if this was a real function, the
- end Get_File_Name; -- user would be asked to input a name, or
- -- there would be some type of similar process.
-
- -- This subprogram utilizes a call to a subprogram contained in a private
- -- child to perform the actual processing.
-
- function Initialize_File return File_Descriptor_Type is
- begin
- return (CA11008_0.CA11008_1.Initialize); -- No parameters are needed,
- -- since defaults have been
- -- provided.
- end Initialize_File;
-
-end CA11008_0; -- Package body OS
-
- --=================================================================--
-
-with CA11008_0; -- with Package OS.
-with Report;
-
-procedure CA11008 is
-
- package OS renames CA11008_0;
- use OS;
- Ada_File_Key : File_Descriptor_Type := Default_Descriptor;
-
-begin
-
- -- This test indicates one approach to file management operations.
- -- It is not intended to demonstrate full functionality, but rather
- -- that the use of a private child package can provide a solution
- -- to a user situation, that being the implementation of certain functions
- -- being provided in a child package, with the parent package body
- -- utilizing these implementations.
-
- Report.Test ("CA11008", "Check that a private child package can use " &
- "entities declared in the visible part of its " &
- "parent unit");
-
- -- Check initial conditions of the first entry in the file table.
- -- These are all default values provided in the declaration of the
- -- type File_Type.
-
- if (Ada_File_Key /= Default_Descriptor) or else
- (File_Table(1).Descriptor /= (Default_Descriptor) or
- (File_Table(1).Name /= Default_Filename)) or else
- (File_Table(1).Acct_Access /= (Default_Permission) or
- (File_Table(1).Mode /= Default_Mode)) or else
- (File_Table(1).Current_Status /= Default_Status)
- then
- Report.Failed ("Initial condition failure");
- end if;
-
- -- Call the initialization function. This will result in the resetting
- -- of the fields associated with the first entry in the File_Table (this
- -- is the first call of Initialize_File).
- -- No parameters are necessary for this call, due to the default values
- -- provided in the private child package routine Initialize.
-
- Ada_File_Key := Initialize_File;
-
- -- Verify that the initial conditions of the file table component have
- -- been properly modified by the initialization function.
-
- if not ((File_Table(1).Descriptor = Ada_File_Key) and then
- (File_Table(1).Name = Constant_Name) and then
- (File_Table(1).Acct_Access = User) and then
- not ((File_Table(1).Mode = Default_Mode) or else
- (File_Table(1).Current_Status = Default_Status)))
- then
- Report.Failed ("Initialization processing failure");
- end if;
-
- Report.Result;
-
-end CA11008;
diff --git a/gcc/testsuite/ada/acats/tests/ca/ca11009.a b/gcc/testsuite/ada/acats/tests/ca/ca11009.a
deleted file mode 100644
index 84d7dc2b3a7..00000000000
--- a/gcc/testsuite/ada/acats/tests/ca/ca11009.a
+++ /dev/null
@@ -1,246 +0,0 @@
--- CA11009.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that a private child package can use entities declared in the
--- visible part of the parent unit of its parent unit.
---
--- TEST DESCRIPTION:
--- Declare a parent package containing types and objects used by the
--- system. Declare a public child package that provides a visible
--- interface to the system functionality.
--- Declare a private grandchild package that uses the visible grandparent
--- components to provide the actual functionality to the system.
---
--- The public child (parent of the private grandchild) uses the
--- functionality of its private child (grandchild package) to provide
--- the visible interface to operations of the system.
---
--- The test itself will utilize the visible interface provided in the
--- public child package to demonstrate a possible structure for
--- file management.
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 15 Apr 96 SAIC ACVC 2.1: Added pragma Elaborate_body.
---
---!
-
-package CA11009_0 is -- Package OS.
- pragma Elaborate_Body (CA11009_0);
-
- type File_Descriptor_Type is new Integer;
- type File_Name_Type is new String (1 .. 11);
- type Permission_Type is (None, User, System, Bypass);
- type File_Mode_Type is (Read_Only, Write_Only, Read_Write);
- type File_Status_Type is (Open, Closed);
-
- Default_Descriptor : constant File_Descriptor_Type := 0;
- Default_Permission : constant Permission_Type := None;
- Default_Mode : constant File_Mode_Type := Read_Only;
- Default_Status : constant File_Status_Type := Closed;
- Default_Filename : constant File_Name_Type := " ";
-
- Max_Files : constant File_Descriptor_Type := 10;
- An_Ada_File_Name : constant File_Name_Type := "AdaFileName";
- File_Counter : Integer := 0;
-
- type File_Type is tagged
- record
- Descriptor : File_Descriptor_Type := Default_Descriptor;
- Name : File_Name_Type := Default_Filename;
- Acct_Access : Permission_Type := Default_Permission;
- Mode : File_Mode_Type := Default_Mode;
- Current_Status : File_Status_Type := Default_Status;
- end record;
-
- type File_Array_Type is array (1 .. Max_Files) of File_Type;
-
- File_Table : File_Array_Type;
-
- --
-
- function Get_File_Name return File_Name_Type;
-
-end CA11009_0; -- Package OS.
-
- --=================================================================--
-
-package body CA11009_0 is -- Package body OS.
-
- function Get_File_Name return File_Name_Type is
- begin
- return (An_Ada_File_Name); -- Processing would be replace by a user
- -- prompt in a functioning system.
- end Get_File_Name;
-
-end CA11009_0; -- Package body OS.
-
- --=================================================================--
-
-package CA11009_0.CA11009_1 is -- Child Package OS.File_Manager
-
- -- This package simulates a visible interface for the Operating System.
- -- The actual processing performed by this routine is encapsulated
- -- in the routines of private child package Internals, which is "withed"
- -- by the body of this package.
-
- procedure Create_File (Mode : in File_Mode_Type;
- File_Key : out File_Descriptor_Type);
-
-end CA11009_0.CA11009_1; -- Child Package OS.File_Manager
-
- --=================================================================--
-
--- Subprogram that performs the actual file operation is contained in a
--- private package so that it is not accessible to any client, and can be
--- modified/extended without requiring recompilation of the clients of the
--- parent (since this package is "withed" by the parent body only.)
-
-
- -- Grandchild Package OS.File_Manager.Internals
-private package CA11009_0.CA11009_1.CA11009_2 is
-
- Initial_Permission : constant Permission_Type := User; -- Grandparent
- Initial_Status : constant File_Status_Type := Open; -- literals.
- Initial_Filename : constant File_Name_Type := -- Grandparent type.
- Get_File_Name; -- Grandparent function.
-
- function Create (Mode : File_Mode_Type)
- return File_Descriptor_Type; -- Grandparent type.
-
-end CA11009_0.CA11009_1.CA11009_2;
- -- Grandchild Package OS.File_Manager.Internals
-
- --=================================================================--
-
- -- Grandchild Package body OS.File_Manager.Internals
-package body CA11009_0.CA11009_1.CA11009_2 is
-
- function Next_Available_File return File_Descriptor_Type is
- begin
- File_Counter := File_Counter + 1; -- Grandparent object.
- return (File_Descriptor_Type(File_Counter));
- end Next_Available_File;
- -------------------------------------------------------------------------
- function Create (Mode : File_Mode_Type) -- Grandparent literal.
- return File_Descriptor_Type is
- Number : File_Descriptor_Type; -- Grandparent type.
- begin
- Number := Next_Available_File;
- File_Table(Number).Descriptor := Number; -- Grandparent object.
- File_Table(Number).Name := Initial_Filename;
- File_Table(Number).Mode := Mode; -- Parameter.
- File_Table(Number).Acct_Access := Initial_Permission;
- File_Table(Number).Current_Status := Initial_Status;
- return (Number);
- end Create;
-
-end CA11009_0.CA11009_1.CA11009_2;
- -- Grandchild Package body OS.File_Manager.Internals
-
- --=================================================================--
-
- -- "With" of a child package
- -- by the parent body.
-with CA11009_0.CA11009_1.CA11009_2; -- Grandchild OS.File_Manager.Internals
-
-package body CA11009_0.CA11009_1 is -- Child Package body OS.File_Manager
-
- package Internal renames CA11009_0.CA11009_1.CA11009_2;
-
- -- These subprograms utilize calls to subprograms contained in a private
- -- sibling to perform the actual processing.
-
- procedure Create_File (Mode : in File_Mode_Type;
- File_Key : out File_Descriptor_Type) is
- begin
- File_Key := Internal.Create (Mode);
- end Create_File;
-
-end CA11009_0.CA11009_1; -- Child Package body OS.File_Manager
-
- --=================================================================--
-
-with CA11009_0.CA11009_1; -- with Child Package OS.File_Manager
-with Report;
-
-procedure CA11009 is
-
- package OS renames CA11009_0;
- use OS;
- package File_Manager renames CA11009_0.CA11009_1;
-
- Data_Base_File_Key : File_Descriptor_Type := Default_Descriptor;
- New_Mode : File_Mode_Type := Read_Write;
-
-begin
-
- -- This test indicates one approach to file management.
- -- It is not intended to demonstrate full functionality, but rather
- -- that the use of a private child package could provide a solution
- -- to this type of situation.
-
- Report.Test ("CA11009", "Check that a private child package can use " &
- "entities declared in the visible part of the " &
- "parent unit of its parent unit");
-
- -- Check initial conditions of the first entry in the file table.
- -- These are all default values provided in the declaration of the
- -- type File_Type.
-
- if (not (Data_Base_File_Key = Default_Descriptor)) and then
- (((not (File_Table(1).Name = Default_Filename)) or
- (File_Table(1).Descriptor /= Default_Descriptor)) or else
- ((File_Table(1).Acct_Access /= Default_Permission) or
- (not (File_Table(1).Mode = Default_Mode)) or
- (File_Table(1).Current_Status /= Default_Status)))
- then
- Report.Failed ("Initial condition failure");
- end if;
-
- -- Create/initialize file using the capability provided by the visible
- -- interface to the operating system, OS.File_Manager. The actual
- -- processing routine is contained in the private grandchild package
- -- Internals, which utilize the components from the grandparent package.
-
- File_Manager.Create_File (New_Mode, Data_Base_File_Key);
-
- -- Verify that the initial conditions of the file table component have
- -- been properly modified by the initialization function.
-
- if not ((File_Table(1).Descriptor = Data_Base_File_Key) and then
- (File_Table(1).Name = An_Ada_File_Name) and then
- (File_Table(1).Acct_Access = User) and then
- not ((File_Table(1).Mode = Default_Mode) or else
- (File_Table(1).Current_Status = Default_Status)))
- then
- Report.Failed ("File creation failure");
- end if;
-
- Report.Result;
-
-end CA11009;
diff --git a/gcc/testsuite/ada/acats/tests/ca/ca11010.a b/gcc/testsuite/ada/acats/tests/ca/ca11010.a
deleted file mode 100644
index b13efd79851..00000000000
--- a/gcc/testsuite/ada/acats/tests/ca/ca11010.a
+++ /dev/null
@@ -1,254 +0,0 @@
--- CA11010.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that a private child package can use entities declared in the
--- private part of its parent unit.
---
--- TEST DESCRIPTION:
--- Declare a parent package containing private types, objects,
--- and functions used by the system. Declare a private child package that
--- uses the parent components to provide functionality to the system.
---
--- Declare an array of files with default values for all
--- component fields of the files (records). Check the initial state of
--- a specified file for proper default values. Perform the file "creation"
--- (initialization), which will modify the fields of the record object.
--- Again verify the file object to determine whether the fields have been
--- reset properly.
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
---
-
-package CA11010_0 is -- Package OS.
-
- type File_Descriptor_Type is private;
-
- Default_Descriptor : constant File_Descriptor_Type;
-
- function Initialize_File return File_Descriptor_Type;
- procedure Verify_Initial_Conditions (Status : out Boolean);
- function Final_Conditions_Valid return Boolean;
-
-private
-
- type File_Descriptor_Type is new Integer;
- type File_Name_Type is new String (1 .. 11);
- type Permission_Type is (None, User, System);
- type File_Mode_Type is (Read_Only, Write_Only, Read_Write);
- type File_Status_Type is (Open, Closed);
-
- Default_Descriptor : constant File_Descriptor_Type := 0;
- Default_Permission : constant Permission_Type := None;
- Default_Mode : constant File_Mode_Type := Read_Only;
- Default_Status : constant File_Status_Type := Closed;
- Default_Filename : constant File_Name_Type := " ";
- An_Ada_File_Name : constant File_Name_Type := "AdaFileName";
- Max_Files : constant File_Descriptor_Type := 100;
-
- type File_Type is tagged
- record
- Descriptor : File_Descriptor_Type := Default_Descriptor;
- Name : File_Name_Type := Default_Filename;
- Acct_Access : Permission_Type := Default_Permission;
- Mode : File_Mode_Type := Default_Mode;
- Current_Status : File_Status_Type := Default_Status;
- end record;
-
- type File_Array_Type is array (1 .. Max_Files) of File_Type;
-
- File_Table : File_Array_Type;
- File_Counter : Integer := 0;
-
- --
-
- function Get_File_Name return File_Name_Type;
-
-end CA11010_0; -- Package OS.
-
- --=================================================================--
-
--- Subprograms that perform the actual file operations are contained in a
--- private package so that they are not accessible to any client.
-
-private package CA11010_0.CA11010_1 is -- Package OS.Internals
-
- Private_File_Counter : Integer renames File_Counter; -- Parent priv. object.
-
- function Initialize
- (File_Name : File_Name_Type := Get_File_Name; -- Parent priv. function.
- File_Mode : File_Mode_Type := Read_Write) -- Parent priv. literal.
- return File_Descriptor_Type; -- Parent type.
-
-end CA11010_0.CA11010_1; -- Package OS.Internals
-
- --=================================================================--
-
-package body CA11010_0.CA11010_1 is -- Package body OS.Internals
-
- function Next_Available_File return File_Descriptor_Type is
- begin
- Private_File_Counter := Private_File_Counter + 1;
- return (File_Descriptor_Type(File_Counter));
- end Next_Available_File;
- ----------------------------------------------------------------
- function Initialize
- (File_Name : File_Name_Type := Get_File_Name; -- Parent priv. function
- File_Mode : File_Mode_Type := Read_Write) -- Parent priv. literal
- return File_Descriptor_Type is -- Parent type
- Number : File_Descriptor_Type;
- begin
- Number := Next_Available_File;
- File_Table(Number).Descriptor := Number; -- Parent priv. object
- File_Table(Number).Name := File_Name; -- Default parameter value
- File_Table(Number).Mode := File_Mode; -- Default parameter value
- File_Table(Number).Acct_Access := User;
- File_Table(Number).Current_Status := Open;
- return (Number);
- end Initialize;
-
-end CA11010_0.CA11010_1; -- Package body OS.Internals
-
- --=================================================================--
-
-with CA11010_0.CA11010_1; -- Private child package "withed" by
- -- parent body.
-
-package body CA11010_0 is -- Package body OS
-
- function Get_File_Name return File_Name_Type is
- begin
- return (An_Ada_File_Name); -- If this was a real function, the user
- end Get_File_Name; -- would be asked to input a name, or there
- -- would be some type of similar processing.
-
- -- This subprogram utilizes a call to a subprogram contained in a private
- -- child to perform the actual processing.
-
- function Initialize_File return File_Descriptor_Type is
- begin
- return (CA11010_0.CA11010_1.Initialize); -- No parameters are needed,
- -- since defaults have been
- -- provided.
- end Initialize_File;
-
- --
- -- Separate subunits.
- --
-
- procedure Verify_Initial_Conditions (Status : out Boolean) is separate;
-
- function Final_Conditions_Valid return Boolean is separate;
-
-end CA11010_0; -- Package body OS
-
- --=================================================================--
-
-separate (CA11010_0)
-procedure Verify_Initial_Conditions (Status : out Boolean) is
-begin
- Status := False;
- if (File_Table(1).Descriptor = Default_Descriptor) and then
- (File_Table(1).Name = Default_Filename) and then
- (File_Table(1).Acct_Access = Default_Permission) and then
- (File_Table(1).Mode = Default_Mode) and then
- (File_Table(1).Current_Status = Default_Status)
- then
- Status := True;
- end if;
-end Verify_Initial_Conditions;
-
- --=================================================================--
-
-separate (CA11010_0)
-function Final_Conditions_Valid return Boolean is
-begin
- if ((File_Table(1).Descriptor /= Default_Descriptor) and then
- (File_Table(1).Name = An_Ada_File_Name) and then
- (File_Table(1).Acct_Access = User) and then
- not ((File_Table(1).Mode = Default_Mode) or else
- (File_Table(1).Current_Status = Default_Status)))
- then
- return (True);
- else
- return (False);
- end if;
-end Final_Conditions_Valid;
-
- --=================================================================--
-
-with CA11010_0; -- with Package OS.
-with Report;
-
-procedure CA11010 is
-
- package OS renames CA11010_0;
-
- Ada_File_Key : OS.File_Descriptor_Type := OS.Default_Descriptor;
- Initialization_Status : Boolean := False;
-
-begin
-
- -- This test indicates one approach to a file management operation.
- -- It is not intended to demonstrate full functionality, but rather
- -- that the use of a private child package can provide a solution
- -- to a user situation, that being the implementation of certain functions
- -- being provided in a child package, with the parent package body
- -- utilizing these implementations.
-
- Report.Test ("CA11010", "Check that a private child package can use " &
- "entities declared in the private part of its " &
- "parent unit");
-
- -- Check initial conditions of the first entry in the file table.
- -- These are all default values provided in the declaration of the
- -- type File_Type.
-
- OS.Verify_Initial_Conditions (Initialization_Status);
-
- if not Initialization_Status then
- Report.Failed ("Initial condition failure");
- end if;
-
- -- Call the initialization function. This will result in the resetting
- -- of the fields associated with the first entry in the File_Table (this
- -- is the first/only call of Initialize_File).
- -- No parameters are necessary for this call, due to the default values
- -- provided in the private child package routine Initialize.
-
- Ada_File_Key := OS.Initialize_File;
-
- -- Verify that the initial conditions of the file table component have
- -- been properly modified by the initialization function.
-
- if not OS.Final_Conditions_Valid then
- Report.Failed ("Initialization processing failure");
- end if;
-
- Report.Result;
-
-end CA11010;
diff --git a/gcc/testsuite/ada/acats/tests/ca/ca11011.a b/gcc/testsuite/ada/acats/tests/ca/ca11011.a
deleted file mode 100644
index a75261dd840..00000000000
--- a/gcc/testsuite/ada/acats/tests/ca/ca11011.a
+++ /dev/null
@@ -1,271 +0,0 @@
--- CA11011.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that a private child package can use entities declared in the
--- private part of the parent unit of its parent unit.
---
--- TEST DESCRIPTION:
--- Declare a parent package containing private types and objects
--- used by the system. Declare a public child package that
--- provides a visible interface to the system functionality.
--- Declare a private grandchild package that uses the visible grandparent
--- components to provide the actual functionality to the system.
---
--- The public child (parent of the private grandchild) uses the
--- functionality of its private child (grandchild package) to provide
--- the visible interface to operations of the system.
---
--- The test itself will utilize the visible interface provided in the
--- public child package to demonstrate a possible solution to file
--- management.
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
---
---!
-
-package CA11011_0 is -- Package OS.
-
- type File_Descriptor_Type is private;
-
- Default_Descriptor : constant File_Descriptor_Type;
- First_File : constant File_Descriptor_Type;
-
- procedure Verify_Initial_Conditions (Key : in File_Descriptor_Type;
- Status : out Boolean);
-
- function Final_Conditions_Valid (Key : File_Descriptor_Type)
- return Boolean;
-
-
-private
-
- type File_Descriptor_Type is new Integer;
- type File_Name_Type is new String (1 .. 11);
- type Permission_Type is (None, User, System);
- type File_Mode_Type is (Read_Only, Write_Only, Read_Write);
- type File_Status_Type is (Open, Closed);
-
- Default_Descriptor : constant File_Descriptor_Type := 0;
- First_File : constant File_Descriptor_Type := 1;
- Default_Permission : constant Permission_Type := None;
- Default_Mode : constant File_Mode_Type := Read_Only;
- Default_Status : constant File_Status_Type := Closed;
- Default_Filename : constant File_Name_Type := " ";
-
- Init_Permission : constant Permission_Type := User;
- Init_Mode : constant File_Mode_Type := Read_Write;
- Init_Status : constant File_Status_Type := Open;
- An_Ada_File_Name : constant File_Name_Type := "AdaFileName";
-
- Max_Files : constant File_Descriptor_Type := 10;
-
- type File_Type is tagged
- record
- Descriptor : File_Descriptor_Type := Default_Descriptor;
- Name : File_Name_Type := Default_Filename;
- Acct_Access : Permission_Type := Default_Permission;
- Mode : File_Mode_Type := Default_Mode;
- Current_Status : File_Status_Type := Default_Status;
- end record;
-
- type File_Array_Type is array (1 .. Max_Files) of File_Type;
-
- File_Table : File_Array_Type;
- File_Counter : Integer := 0;
-
- --
-
- function Get_File_Name return File_Name_Type;
-
-end CA11011_0; -- Package OS.
-
- --=================================================================--
-
-package body CA11011_0 is -- Package body OS.
-
- function Get_File_Name return File_Name_Type is
- begin
- return (An_Ada_File_Name);
- end Get_File_Name;
- ---------------------------------------------------------------------
- procedure Verify_Initial_Conditions (Key : in File_Descriptor_Type;
- Status : out Boolean) is
- begin
- Status := False;
- if (File_Table(Key).Descriptor = Default_Descriptor) and then
- (File_Table(Key).Name = Default_Filename) and then
- (File_Table(Key).Acct_Access = Default_Permission) and then
- (File_Table(Key).Mode = Default_Mode) and then
- (File_Table(Key).Current_Status = Default_Status)
- then
- Status := True;
- end if;
- end Verify_Initial_Conditions;
- ---------------------------------------------------------------------
- function Final_Conditions_Valid (Key : File_Descriptor_Type)
- return Boolean is
- begin
- if ((File_Table(Key).Descriptor = First_File) and then
- (File_Table(Key).Name = An_Ada_File_Name) and then
- (File_Table(Key).Acct_Access = Init_Permission) and then
- not ((File_Table(Key).Mode = Default_Mode) or else
- (File_Table(Key).Current_Status = Default_Status)))
- then
- return (True);
- else
- return (False);
- end if;
- end Final_Conditions_Valid;
-
-end CA11011_0; -- Package body OS.
-
- --=================================================================--
-
-package CA11011_0.CA11011_1 is -- Package OS.File_Manager
-
- procedure Create_File (File_Key : in File_Descriptor_Type);
-
-end CA11011_0.CA11011_1; -- Package OS.File_Manager
-
- --=================================================================--
-
--- The Subprogram that performs the actual file operations is contained in a
--- private package so that it is not accessible to any client.
--- Default parameters are used in most cases in the subprogram calls, since
--- the caller does not have visibility to these private types.
-
- -- Package OS.File_Manager.Internals
-private package CA11011_0.CA11011_1.CA11011_2 is
-
- Private_File_Counter : Integer renames File_Counter; -- Grandparent
- -- object.
- procedure Create
- (Key : in File_Descriptor_Type;
- File_Name : in File_Name_Type := Get_File_Name; -- Grandparent
- -- prvt type,
- -- prvt functn.
- File_Mode : in File_Mode_Type := Init_Mode; -- Grandparent
- -- prvt type,
- -- prvt const.
- File_Access : in Permission_Type := Init_Permission; -- Grandparent
- -- prvt type,
- -- prvt const.
- File_Status : in File_Status_Type := Init_Status); -- Grandparent
- -- prvt type,
- -- prvt const.
-
-end CA11011_0.CA11011_1.CA11011_2; -- Package OS.File_Manager.Internals
-
- --=================================================================--
-
- -- Package Body OS.File_Manager.Internals
-package body CA11011_0.CA11011_1.CA11011_2 is
-
- procedure Create
- (Key : in File_Descriptor_Type;
- File_Name : in File_Name_Type := Get_File_Name;
- File_Mode : in File_Mode_Type := Init_Mode;
- File_Access : in Permission_Type := Init_Permission;
- File_Status : in File_Status_Type := Init_Status) is
- begin
- Private_File_Counter := Private_File_Counter + 1;
- File_Table(Key).Descriptor := Key; -- Grandparent object.
- File_Table(Key).Name := File_Name;
- File_Table(Key).Mode := File_Mode;
- File_Table(Key).Acct_Access := File_Access;
- File_Table(Key).Current_Status := File_Status;
- end Create;
-
-end CA11011_0.CA11011_1.CA11011_2; -- Package body OS.File_Manager.Internals
-
- --=================================================================--
-
-with CA11011_0.CA11011_1.CA11011_2; -- with Child OS.File_Manager.Internals
-
-package body CA11011_0.CA11011_1 is -- Package body OS.File_Manager
-
- package Internal renames CA11011_0.CA11011_1.CA11011_2;
-
- -- This subprogram utilizes a call to a subprogram contained in a private
- -- child to perform the actual processing.
-
- procedure Create_File (File_Key : in File_Descriptor_Type) is
- begin
- Internal.Create (Key => File_Key); -- Other parameters are defaults,
- -- since they are of private types
- -- from the parent package.
- -- File_Descriptor_Type is private,
- -- but declared in visible part of
- -- parent spec.
- end Create_File;
-
-end CA11011_0.CA11011_1; -- Package body OS.File_Manager
-
- --=================================================================--
-
-with CA11011_0.CA11011_1; -- with public Child Package OS.File_Manager
-with Report;
-
-procedure CA11011 is
-
- package OS renames CA11011_0;
- package File_Manager renames CA11011_0.CA11011_1;
-
- Data_Base_File_Key : OS.File_Descriptor_Type := OS.First_File;
- TC_Status : Boolean := False;
-
-begin
-
- -- This test indicates one approach to file management operations.
- -- It is not intended to demonstrate full functionality, but rather
- -- that the use of a private child package can provide a solution
- -- to a typical user situation.
-
- Report.Test ("CA11011", "Check that a private child package can use " &
- "entities declared in the private part of the " &
- "parent unit of its parent unit");
-
- OS.Verify_Initial_Conditions (Data_Base_File_Key, TC_Status);
-
- if not TC_Status then
- Report.Failed ("Initial condition failure");
- end if;
-
- -- Perform file initializations.
-
- File_Manager.Create_File (File_Key => Data_Base_File_Key);
-
- TC_Status := OS.Final_Conditions_Valid (Data_Base_File_Key);
-
- if not TC_Status then
- Report.Failed ("Bad status return from Create_File");
- end if;
-
- Report.Result;
-
-end CA11011;
diff --git a/gcc/testsuite/ada/acats/tests/ca/ca11012.a b/gcc/testsuite/ada/acats/tests/ca/ca11012.a
deleted file mode 100644
index 071b8f8134b..00000000000
--- a/gcc/testsuite/ada/acats/tests/ca/ca11012.a
+++ /dev/null
@@ -1,259 +0,0 @@
--- CA11012.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that a child package of a library level instantiation
--- of a generic can be the instantiation of a child package of
--- the generic. Check that the child instance can use its parent's
--- declarations and operations, including a formal type of the parent.
---
--- TEST DESCRIPTION:
--- Declare a generic package which simulates an integer complex
--- abstraction. Declare a generic child package of this package
--- which defines additional complex operations.
---
--- Instantiate the first generic package, then instantiate the child
--- generic package as a child unit of the first instance. In the main
--- program, check that the operations in both instances perform as
--- expected.
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 21 Dec 94 SAIC Corrected visibility errors for literals
--- 27 Feb 97 PWB.CTA Added elaboration pragma at package CA11012_3
---!
-
-generic -- Complex number abstraction.
- type Int_Type is range <>;
-
-package CA11012_0 is
-
- -- Simulate a generic complex number support package. Complex numbers
- -- are treated as coordinates in the Cartesian plane.
-
- type Complex_Type is private;
-
- Zero : constant Complex_Type; -- Real number (0,0).
-
- function Complex (Real, Imag : Int_Type) -- Create a complex
- return Complex_Type; -- number.
-
- function "-" (Right : Complex_Type) -- Invert a complex
- return Complex_Type; -- number.
-
- function "+" (Left, Right : Complex_Type) -- Add two complex
- return Complex_Type; -- numbers.
-
-private
- type Complex_Type is record
- Real : Int_Type;
- Imag : Int_Type;
- end record;
-
- Zero : constant Complex_Type := (Real => 0, Imag => 0);
-
-end CA11012_0;
-
- --==================================================================--
-
-package body CA11012_0 is
-
- function Complex (Real, Imag : Int_Type) return Complex_Type is
- begin
- return (Real, Imag);
- end Complex;
- ---------------------------------------------------------------
- function "-" (Right : Complex_Type) return Complex_Type is
- begin
- return (-Right.Real, -Right.Imag);
- end "-";
- ---------------------------------------------------------------
- function "+" (Left, Right : Complex_Type) return Complex_Type is
- begin
- return ( (Left.Real + Right.Real, Left.Imag + Right.Imag) );
- end "+";
-
-end CA11012_0;
-
- --==================================================================--
-
--- Generic child of complex number package. Child must be generic since
--- parent is generic.
-
-generic -- Complex additional operations
-
-package CA11012_0.CA11012_1 is
-
- -- More operations on complex number. This child adds a layer of
- -- functionality to the parent generic.
-
- function Real_Part (Complex_No : Complex_Type)
- return Int_Type;
-
- function Imag_Part (Complex_No : Complex_Type)
- return Int_Type;
-
- function "*" (Factor : Int_Type;
- C : Complex_Type) return Complex_Type;
-
- function Vector_Magnitude (Complex_No : Complex_Type)
- return Int_Type;
-
-end CA11012_0.CA11012_1;
-
- --==================================================================--
-
-package body CA11012_0.CA11012_1 is
-
- function Real_Part (Complex_No : Complex_Type) return Int_Type is
- begin
- return (Complex_No.Real);
- end Real_Part;
- ---------------------------------------------------------------
- function Imag_Part (Complex_No : Complex_Type) return Int_Type is
- begin
- return (Complex_No.Imag);
- end Imag_Part;
- ---------------------------------------------------------------
- function "*" (Factor : Int_Type;
- C : Complex_Type) return Complex_Type is
- Result : Complex_Type := Zero; -- Zero is declared in parent,
- -- Complex_Number
- begin
- for I in 1 .. abs (Factor) loop
- Result := Result + C; -- Complex_Number "+"
- end loop;
-
- if Factor < 0 then
- Result := - Result; -- Complex_Number "-"
- end if;
-
- return Result;
- end "*";
- ---------------------------------------------------------------
- function Vector_Magnitude (Complex_No : Complex_Type)
- return Int_Type is -- Not a real vector magnitude.
- begin
- return (Complex_No.Real + Complex_No.Imag);
- end Vector_Magnitude;
-
-end CA11012_0.CA11012_1;
-
- --==================================================================--
-
-package CA11012_2 is
-
- subtype My_Integer is integer range -100 .. 100;
-
- -- ... Various other types used by the application.
-
-end CA11012_2;
-
--- No body for CA11012_2;
-
- --==================================================================--
-
--- Declare instances of the generic complex packages for integer type.
--- The instance of the child must itself be declared as a child of the
--- instance of the parent.
-
-with CA11012_0; -- Complex number abstraction
-with CA11012_2; -- Package containing integer type
-pragma Elaborate (CA11012_0);
-package CA11012_3 is new CA11012_0 (Int_Type => CA11012_2.My_Integer);
-
-with CA11012_0.CA11012_1; -- Complex additional operations
-with CA11012_3;
-package CA11012_3.CA11012_4 is new CA11012_3.CA11012_1;
-
- --==================================================================--
-
-with CA11012_2; -- Package containing integer type
-with CA11012_3.CA11012_4; -- Complex abstraction + additional operations
-with Report;
-
-procedure CA11012 is
-
- package My_Complex_Pkg renames CA11012_3;
-
- package My_Complex_Operation renames CA11012_3.CA11012_4;
-
- use My_Complex_Pkg, -- All user-defined
- My_Complex_Operation; -- operators directly
- -- visible.
- Complex_One, Complex_Two : Complex_Type;
-
-begin
-
- Report.Test ("CA11012", "Check that child instance can use its parent's " &
- "declarations and operations, including a formal " &
- "type of the parent");
-
- Correct_Range_Test:
- declare
- My_Literal : CA11012_2.My_Integer := -3;
-
- begin
- Complex_One := Complex (-4, 7); -- Operation from the generic
- -- parent package.
-
- Complex_Two := My_Literal * Complex_One; -- Operation from the generic
- -- child package.
-
- if Real_Part (Complex_Two) /= 12 -- Operation from the generic
- or Imag_Part (Complex_Two) /= -21 -- child package.
- then
- Report.Failed ("Incorrect results from complex operation");
- end if;
-
- end Correct_Range_Test;
-
- ---------------------------------------------------------------
-
- Out_Of_Range_Test:
- declare
- My_Vector : CA11012_2.My_Integer;
-
- begin
- Complex_One := Complex (70, 70); -- Operation from the generic
- -- parent package.
- My_Vector := Vector_Magnitude (Complex_One);
- -- Operation from the generic child package.
-
- Report.Failed ("Exception not raised in child package");
-
- exception
- when Constraint_Error =>
- Report.Comment ("Exception is raised as expected");
-
- when others =>
- Report.Failed ("Others exception is raised");
-
- end Out_Of_Range_Test;
-
- Report.Result;
-
-end CA11012;
diff --git a/gcc/testsuite/ada/acats/tests/ca/ca11013.a b/gcc/testsuite/ada/acats/tests/ca/ca11013.a
deleted file mode 100644
index c7f442788c1..00000000000
--- a/gcc/testsuite/ada/acats/tests/ca/ca11013.a
+++ /dev/null
@@ -1,201 +0,0 @@
--- CA11013.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that a child function of a library level instantiation
--- of a generic can be the instantiation of a child function of
--- the generic. Check that the child instance can use its parent's
--- declarations and operations, including a formal subprogram of the
--- parent.
---
--- TEST DESCRIPTION:
--- Declare a generic package which simulates a real complex
--- abstraction. Declare a generic child function of this package
--- which builds a random complex number. Declare a second
--- package which defines a random complex number generator. This
--- package provides actual parameters for the generic parent package.
---
--- Instantiate the first generic package, then instantiate the child
--- generic function as a child unit of the first instance. In the main
--- program, check that the operations in both instances perform as
--- expected.
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 16 Nov 95 SAIC Update and repair for ACVC 2.0.1
--- 19 Oct 96 SAIC ACVC 2.1: Added pragma Elaborate to context
--- clause of CA11013_3.
--- 27 Feb 97 CTA.PWB Added elaboration pragma at package CA11013_3
---!
-
-generic -- Complex number abstraction.
- type Real_Type is digits <>;
- with function Random_Generator (Seed : Real_Type) return Real_Type;
-
-package CA11013_0 is
-
- -- Simulate a generic complex number support package. Complex numbers
- -- are treated as coordinates in the Cartesian plane.
-
- type Complex_Type is
- record
- Real : Real_Type;
- Imag : Real_Type;
- end record;
-
- function Make (Real, Imag : Real_Type) -- Create a complex
- return Complex_Type; -- number.
-
- procedure Components (Complex_No : in Complex_Type;
- Real_Part, Imag_Part : out Real_Type);
-
-end CA11013_0;
-
- --==================================================================--
-
-package body CA11013_0 is
-
- function Make (Real, Imag : Real_Type) return Complex_Type is
- begin
- return (Real, Imag);
- end Make;
- -------------------------------------------------------------
- procedure Components (Complex_No : in Complex_Type;
- Real_Part, Imag_Part : out Real_Type) is
- begin
- Real_Part := Complex_No.Real;
- Imag_Part := Complex_No.Imag;
- end Components;
-
-end CA11013_0;
-
- --==================================================================--
-
--- Generic child of complex number package. This child adds a layer of
--- functionality to the parent generic.
-
-generic -- Random complex number operation.
-
-function CA11013_0.CA11013_1 (Seed : Real_Type) return Complex_Type;
-
- --==============================================--
-
-function CA11013_0.CA11013_1 (Seed : Real_Type) return Complex_Type is
-
- Random_Real_Part : Real_Type := Random_Generator (Seed);
- -- parent's formal subprogram
- Random_Imag_Part : Real_Type
- := Random_Generator (Random_Generator (Seed));
- -- parent's formal subprogram
- Random_Complex_No : Complex_Type;
-
-begin -- CA11013_0.CA11013_1
-
- Random_Complex_No := Make (Random_Real_Part, Random_Imag_Part);
- -- operation from parent
- return (Random_Complex_No);
-
-end CA11013_0.CA11013_1;
-
- --==================================================================--
-
-package CA11013_2 is
-
- -- To be used as actual parameters for random number generator
- -- in the parent package.
-
- type My_Float is digits 6 range -10.0 .. 100.0;
-
- function Random_Complex (Seed : My_float) return My_Float;
-
-end CA11013_2;
-
- --==================================================================--
-
-package body CA11013_2 is
-
- -- Not a real random number generator.
- function Random_Complex (Seed : My_float) return My_Float is
- begin
- return (Seed + 3.0);
- end Random_Complex;
-
-end CA11013_2;
-
- --==================================================================--
-
--- Declare instances of the generic complex packages for real type.
--- The instance of the child must itself be declared as a child of the
--- instance of the parent.
-
-with CA11013_0; -- Complex number.
-with CA11013_2; -- Random number generator.
-pragma Elaborate (CA11013_0);
-package CA11013_3 is new
- CA11013_0 (Random_Generator => CA11013_2.Random_Complex,
- Real_Type => CA11013_2.My_Float);
-
-with CA11013_0.CA11013_1; -- Random complex number operation.
-with CA11013_3;
-pragma Elaborate (CA11013_3);
-function CA11013_3.CA11013_4 is new CA11013_3.CA11013_1;
-
- --==================================================================--
-
-with Report;
-with CA11013_2; -- Random number generator.
-with CA11013_3.CA11013_4; -- Complex abstraction + Random complex
- -- number operation.
-procedure CA11013 is
-
- package My_Complex_Pkg renames CA11013_3;
- use type CA11013_2.My_Float;
-
- My_Complex : My_Complex_Pkg.Complex_Type;
- My_Literal : CA11013_2.My_Float := 3.0;
- My_Real_Part, My_Imag_Part : CA11013_2.My_Float;
-
-begin
-
- Report.Test ("CA11013", "Check that child instance can use its parent's " &
- "declarations and operations, including a formal " &
- "subprogram of the parent");
-
- My_Complex := CA11013_3.CA11013_4 (My_Literal);
- -- Operation from the generic child function.
-
- My_Complex_Pkg.Components (My_Complex, My_Real_Part, My_Imag_Part);
- -- Operation from the generic parent package.
-
- if My_Real_Part /= 6.0 -- Operation from the generic
- or My_Imag_Part /= 9.0 -- parent package.
- then
- Report.Failed ("Incorrect results from complex operation");
- end if;
-
- Report.Result;
-
-end CA11013;
diff --git a/gcc/testsuite/ada/acats/tests/ca/ca11014.a b/gcc/testsuite/ada/acats/tests/ca/ca11014.a
deleted file mode 100644
index 7847a5067c1..00000000000
--- a/gcc/testsuite/ada/acats/tests/ca/ca11014.a
+++ /dev/null
@@ -1,302 +0,0 @@
--- CA11014.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that an instantiation of a child package of a generic package
--- can use its parent's declarations and operations, including a formal
--- package of the parent.
---
--- TEST DESCRIPTION:
--- Declare a list abstraction in a generic package which manages lists of
--- elements of any discrete type. Declare a generic package which
--- operates on lists of elements of integer types. Declare a generic
--- child of this package which defines additional list operations.
--- Use the formal discrete type as the generic formal actual part for the
--- parent formal package.
---
--- Declare an instance of parent, then declare an instance of the child
--- which is itself a child the parent's instance. In the main program,
--- check that the operations in both instances perform as expected.
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 15 Nov 95 SAIC Update and repair for ACVC 2.0.1
--- 07 Sep 96 SAIC Change formal param E to be out only.
--- 19 Oct 96 SAIC ACVC 2.1: Added pragma Elaborate to context
--- clauses of CA11014_0, CA11014_1, and CA11014_5.
--- 27 Feb 97 PWB.CTA Added elaboration pragma at package CA11014_4
---!
-
--- Actual package for the parent's formal.
-generic
-
- type Element_Type is (<>); -- List elems may be of any discrete types.
-
-package CA11014_0 is
-
- type Node_Type;
- type Node_Pointer is access Node_Type;
-
- type Node_Type is record
- Item : Element_Type;
- Next : Node_Pointer := null;
- end record;
-
- type List_Type is record
- First : Node_Pointer := null;
- Current : Node_Pointer := null;
- Last : Node_Pointer := null;
- end record;
-
- -- Return true if current element is last in the list.
- function End_Of_List (L : List_Type) return boolean;
-
- -- Set "current" pointer to first list element.
- procedure Reset (L : in out List_Type);
-
-end CA11014_0;
-
- --==================================================================--
-
-package body CA11014_0 is
-
- function End_Of_List (L : List_Type) return boolean is
- begin
- return (L.Current = null);
- end End_Of_List;
- -------------------------------------------------------
- procedure Reset (L : in out List_Type) is
- begin
- L.Current := L.First; -- Set "current" pointer to first
- end Reset; -- list element.
-
-end CA11014_0;
-
- --==================================================================--
-
-with CA11014_0; -- Generic list abstraction.
-pragma Elaborate (CA11014_0);
-generic
-
- -- Import the list abstraction defined in CA11014_0.
- with package List_Mgr is new CA11014_0 (<>);
-
-package CA11014_1 is
-
- -- Write to current element and advance "current" pointer.
- procedure Write_Element (L : in out List_Mgr.List_Type;
- E : in List_Mgr.Element_Type);
-
- -- Read from current element and advance "current" pointer.
- procedure Read_Element (L : in out List_Mgr.List_Type;
- E : out List_Mgr.Element_Type);
-
- -- Add element to end of list.
- procedure Add_Element (L : in out List_Mgr.List_Type;
- E : in List_Mgr.Element_Type);
-
-end CA11014_1;
-
- --==================================================================--
-
-package body CA11014_1 is
-
- procedure Write_Element (L : in out List_Mgr.List_Type;
- E : in List_Mgr.Element_Type) is
- begin
- L.Current.Item := E; -- Write to current element.
- L.Current := L.Current.Next; -- Advance "current" pointer.
- end Write_Element;
- -------------------------------------------------------
- procedure Read_Element (L : in out List_Mgr.List_Type;
- E : out List_Mgr.Element_Type) is
- begin
- E := L.Current.Item; -- Retrieve current element.
- L.Current := L.Current.Next; -- Advance "current" pointer.
- end Read_Element;
- -------------------------------------------------------
- procedure Add_Element (L : in out List_Mgr.List_Type;
- E : in List_Mgr.Element_Type) is
- New_Node : List_Mgr.Node_Pointer := new List_Mgr.Node_Type'(E, null);
- use type List_Mgr.Node_Pointer;
- begin
- if L.First = null then -- No elements in list, so add new
- L.First := New_Node; -- element at beginning of list.
- else
- L.Last.Next := New_Node; -- Add new element at end of list.
- end if;
- L.Last := New_Node; -- Set last-in-list pointer.
- end Add_Element;
-
-end CA11014_1;
-
- --==================================================================--
-
--- Generic child of list operation. This child adds a layer of
--- functionality to the parent generic.
-
-generic
-
-package CA11014_1.CA11014_2 is
-
- procedure Write_First_To_List (L : in out List_Mgr.List_Type);
-
- -- ... Various other operations used by the application.
-
-end CA11014_1.CA11014_2;
-
- --==================================================================--
-
-package body CA11014_1.CA11014_2 is
-
- procedure Write_First_To_List (L : in out List_Mgr.List_Type) is
- begin
- List_Mgr.Reset (L); -- Parent's formal package.
-
- while not List_Mgr.End_Of_List (L) loop -- Parent's formal package.
- Write_Element (L, List_Mgr.Element_Type'First);
- -- Parent's operation,
- end loop; -- parent's formal.
-
- end Write_First_To_List;
-
-end CA11014_1.CA11014_2;
-
- --==================================================================--
-
-package CA11014_3 is
-
- type Points is range 0 .. 100;
-
- -- ... Various other types used by the application.
-
-end CA11014_3;
-
-
--- No body for CA11014_3;
-
- --==================================================================--
-
--- Declare instances of the generic list packages for the discrete type.
--- The instance of the child must itself be declared as a child of the
--- instance of the parent.
-
-with CA11014_0; -- Generic list abstraction.
-with CA11014_3; -- Package containing discrete type declaration.
-pragma Elaborate (CA11014_0);
-package CA11014_4 is new CA11014_0 (CA11014_3.Points); -- Points list.
-
-with CA11014_4; -- Points list.
-with CA11014_1; -- Generic list operation.
-pragma Elaborate (CA11014_1);
-package CA11014_5 is new CA11014_1 (CA11014_4); -- Scores list.
-
-with CA11014_1.CA11014_2; -- Additional generic list operation,
-with CA11014_5;
-pragma Elaborate (CA11014_5);
-package CA11014_5.CA11014_6 is new CA11014_5.CA11014_2;
- -- Points list operation.
-
- --==================================================================--
-
-with CA11014_1.CA11014_2; -- Additional generic list operation,
- -- implicitly with list operation.
-with CA11014_3; -- Package containing discrete type declaration.
-with CA11014_4; -- Points list.
-with CA11014_5.CA11014_6; -- Points list operation.
-with Report;
-
-procedure CA11014 is
-
- package Lists_Of_Scores renames CA11014_4;
- package Score_Ops renames CA11014_5;
- package Point_Ops renames CA11014_5.CA11014_6;
-
- Scores : Lists_Of_Scores.List_Type; -- List of points.
-
- type TC_Score_Array is array (1 .. 3) of CA11014_3.Points;
-
- TC_Initial_Values : constant TC_Score_Array := (10, 21, 49);
- TC_Final_Values : constant TC_Score_Array := (0, 0, 0);
-
- TC_Initial_Values_Are_Correct : boolean := false;
- TC_Final_Values_Are_Correct : boolean := false;
-
- --------------------------------------------------
-
- -- Initial list contains 3 scores with the values 10, 21, and 49.
- procedure TC_Initialize_List (L : in out Lists_of_Scores.List_Type) is
- begin
- for I in TC_Score_Array'range loop
- Score_Ops.Add_Element (L, TC_Initial_Values(I));
- -- Operation from generic parent.
- end loop;
- end TC_Initialize_List;
-
- --------------------------------------------------
-
- -- Verify that all scores have been set to zero.
- procedure TC_Verify_List (L : in out Lists_of_Scores.List_Type;
- Expected : in TC_Score_Array;
- OK : out boolean) is
- Actual : TC_Score_Array;
- begin
- Lists_of_Scores.Reset (L); -- Operation from parent's formal.
- for I in TC_Score_Array'range loop
- Score_Ops.Read_Element (L, Actual(I));
- -- Operation from generic parent.
- end loop;
- OK := (Actual = Expected);
- end TC_Verify_List;
-
- --------------------------------------------------
-
-begin -- CA11014
-
- Report.Test ("CA11014", "Check that an instantiation of a child package " &
- "of a generic package can use its parent's " &
- "declarations and operations, including a " &
- "formal package of the parent");
-
- TC_Initialize_List (Scores);
- TC_Verify_List (Scores, TC_Initial_Values, TC_Initial_Values_Are_Correct);
-
- if not TC_Initial_Values_Are_Correct then
- Report.Failed ("List contains incorrect initial values");
- end if;
-
- Point_Ops.Write_First_To_List (Scores);
- -- Operation from generic child package.
-
- TC_Verify_List (Scores, TC_Final_Values, TC_Final_Values_Are_Correct);
-
- if not TC_Final_Values_Are_Correct then
- Report.Failed ("List contains incorrect final values");
- end if;
-
- Report.Result;
-
-end CA11014;
diff --git a/gcc/testsuite/ada/acats/tests/ca/ca11015.a b/gcc/testsuite/ada/acats/tests/ca/ca11015.a
deleted file mode 100644
index 79b99ede82c..00000000000
--- a/gcc/testsuite/ada/acats/tests/ca/ca11015.a
+++ /dev/null
@@ -1,312 +0,0 @@
--- CA11015.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that a generic child of a non-generic package can use its
--- parent's declarations and operations. Check that the instantiation
--- of the generic child can correctly use the operations.
---
--- TEST DESCRIPTION:
--- Declare a map abstraction in a package which manages basic physical
--- maps. Declare a generic child of this package which defines copies
--- of maps of any discrete type, i.e., population, density, or weather.
---
--- In the main program, declare an instance of the child. Check that
--- the operations in the parent and instance of the child package
--- perform as expected.
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
---
---!
-
--- Simulates map of physical features, i.e., desert, forest, water,
--- or plains.
-
-package CA11015_0 is
- type Map_Type is private;
- subtype Latitude is integer range 1 .. 9;
- subtype Longitude is integer range 1 .. 7;
-
- type Physical_Features is (Desert, Forest, Water, Plains, Unexplored);
- type Page_Type is range 0 .. 80;
-
- Terra_Incognita : exception;
-
- -- Use geographic database to initialize the basic map.
-
- procedure Initialize_Basic_Map (Map : in out Map_Type);
-
- function Get_Physical_Feature (Lat : Latitude;
- Long : Longitude;
- Map : Map_Type) return Physical_Features;
-
- function Next_Page return Page_Type;
-
-private
- type Map_Type is array (Latitude, Longitude) of Physical_Features;
- Basic_Map : Map_Type;
- Page : Page_Type := 0; -- Location for each copy of Map.
-
-end CA11015_0;
-
- --==================================================================--
-
-package body CA11015_0 is
-
- procedure Initialize_Basic_Map (Map : in out Map_Type) is
- -- Not a real initialization. Real application can use geographic
- -- database to create the basic map.
- begin
- for I in Latitude'first .. Latitude'last loop
- for J in 1 .. 2 loop
- Map (I, J) := Unexplored;
- end loop;
- for J in 3 .. 4 loop
- Map (I, J) := Desert;
- end loop;
- for J in 5 .. 7 loop
- Map (I, J) := Plains;
- end loop;
- end loop;
-
- end Initialize_Basic_Map;
- ---------------------------------------------------
- function Get_Physical_Feature (Lat : Latitude;
- Long : Longitude;
- Map : Map_Type)
- return Physical_Features is
- begin
- return (Map (Lat, Long));
- end Get_Physical_Feature;
- ---------------------------------------------------
- function Next_Page return Page_Type is
- begin
- Page := Page + 1;
- return (Page);
- end Next_Page;
-
- ---------------------------------------------------
- begin -- CA11015_0
- -- Initialize a basic map.
- Initialize_Basic_Map (Basic_Map);
-
-end CA11015_0;
-
- --==================================================================--
-
--- Generic child package of physical map. Instantiate this package to
--- create map copy with a new geographic feature, i.e., population, density,
--- or weather.
-
-generic
-
- type Generic_Feature is (<>); -- Any geographic feature, i.e., population,
- -- density, or weather that can be
- -- characterized by a scalar value.
-
-package CA11015_0.CA11015_1 is
-
- type Feature_Map is private;
-
- function Get_Feature_Val (Lat : Latitude;
- Long : Longitude;
- Map : Feature_Map) return Generic_Feature;
-
- procedure Set_Feature_Val (Lat : in Latitude;
- Long : in Longitude;
- Fea : in Generic_Feature;
- Map : in out Feature_Map);
-
- function Check_Page (Map : Feature_Map;
- Page_No : Page_Type) return boolean;
-
-private
- type Feature_Type is array (Latitude, Longitude) of Generic_Feature;
-
- type Feature_Map is
- record
- Feature : Feature_Type;
- Page : Page_Type := Next_Page; -- Operation from parent.
- end record;
-
-end CA11015_0.CA11015_1;
-
- --==================================================================--
-
-package body CA11015_0.CA11015_1 is
-
- function Get_Feature_Val (Lat : Latitude;
- Long : Longitude;
- Map : Feature_Map) return Generic_Feature is
- begin
- return (Map.Feature (Lat, Long));
- end Get_Feature_Val;
- ---------------------------------------------------
- procedure Set_Feature_Val (Lat : in Latitude;
- Long : in Longitude;
- Fea : in Generic_Feature;
- Map : in out Feature_Map) is
- begin
- if Get_Physical_Feature (Lat, Long, Basic_Map) = Unexplored
- -- Parent's operation,
- -- Parent's private object.
- then
- raise Terra_Incognita; -- Exception from parent.
- else
- Map.Feature (Lat, Long) := Fea;
- end if;
- end Set_Feature_Val;
- ---------------------------------------------------
- function Check_Page (Map : Feature_Map;
- Page_No : Page_Type) return boolean is
- begin
- return (Map.Page = Page_No);
- end Check_Page;
-
-end CA11015_0.CA11015_1;
-
- --==================================================================--
-
-with CA11015_0.CA11015_1; -- Generic map operation,
- -- implicitly withs parent, basic map
- -- application.
-with Report;
-
-procedure CA11015 is
-
-begin
-
- Report.Test ("CA11015", "Check that an instantiation of a child package " &
- "of a non-generic package can use its parent's " &
- "declarations and operations");
-
--- An application creates a population map using an integer type.
-
- Population_Map_Subtest:
- declare
- type Population_Type is range 0 .. 10_000;
-
- -- Declare instance of the child generic map package for one
- -- particular integer type.
-
- package Population is new CA11015_0.CA11015_1 (Population_Type);
-
- Population_Map_Latitude : CA11015_0.Latitude := 1;
- -- parent's type
- Population_Map_Longitude : CA11015_0.Longitude := 5;
- -- parent's type
- Pop_Map : Population.Feature_Map;
- Pop : Population_Type := 1000;
-
- begin
- Population.Set_Feature_Val (Population_Map_Latitude,
- Population_Map_Longitude,
- Pop,
- Pop_Map);
-
- If not ( (Population.Get_Feature_Val (Population_Map_Latitude,
- Population_Map_Longitude, Pop_Map) = Pop) or
- (Population.Check_Page (Pop_Map, 1)) ) then
- Report.Failed ("Population map contains incorrect values");
- end if;
-
- end Population_Map_Subtest;
-
--- An application creates a weather map using an enumeration type.
-
- Weather_Map_Subtest:
- declare
- type Weather_Type is (Hot, Cold, Mild);
-
- -- Declare instance of the child generic map package for one
- -- particular enumeration type.
-
- package Weather_Pkg is new CA11015_0.CA11015_1 (Weather_Type);
-
- Weather_Map_Latitude : CA11015_0.Latitude := 2;
- -- parent's type
- Weather_Map_Longitude : CA11015_0.Longitude := 6;
- -- parent's type
- Weather_Map : Weather_Pkg.Feature_Map;
- Weather : Weather_Type := Mild;
-
- begin
- Weather_Pkg.Set_Feature_Val (Weather_Map_Latitude,
- Weather_Map_Longitude,
- Weather,
- Weather_Map);
-
- if ( (Weather_Pkg.Get_Feature_Val (Weather_Map_Latitude,
- Weather_Map_Longitude, Weather_Map) /= Weather) or
- not (Weather_Pkg.Check_Page (Weather_Map, 2)) )
- then
- Report.Failed ("Weather map contains incorrect values");
- end if;
-
- end Weather_Map_Subtest;
-
--- During processing, the application may erroneously attempts to create
--- a density map on an unexplored area. This would result in the raising
--- of an exception.
-
- Density_Map_Subtest:
- declare
- type Density_Type is (High, Medium, Low);
-
- -- Declare instance of the child generic map package for one
- -- particular enumeration type.
-
- package Density_Pkg is new CA11015_0.CA11015_1 (Density_Type);
-
- Density_Map_Latitude : CA11015_0.Latitude := 7;
- -- parent's type
- Density_Map_Longitude : CA11015_0.Longitude := 2;
- -- parent's type
- Density : Density_Type := Low;
- Density_Map : Density_Pkg.Feature_Map;
-
- begin
- Density_Pkg.Set_Feature_Val (Density_Map_Latitude,
- Density_Map_Longitude,
- Density,
- Density_Map);
-
- Report.Failed ("Exception not raised in child generic package");
-
- exception
-
- when CA11015_0.Terra_Incognita => -- parent's exception,
- null; -- raised in child.
-
- when others =>
- Report.Failed ("Others exception is raised");
-
- end Density_Map_Subtest;
-
- Report.Result;
-
-end CA11015;
diff --git a/gcc/testsuite/ada/acats/tests/ca/ca11016.a b/gcc/testsuite/ada/acats/tests/ca/ca11016.a
deleted file mode 100644
index d6d4089a959..00000000000
--- a/gcc/testsuite/ada/acats/tests/ca/ca11016.a
+++ /dev/null
@@ -1,321 +0,0 @@
--- CA11016.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that a child of a non-generic package can be a private generic
--- package. Check that the private child instance can use its parent's
--- declarations and operations. Check that the body of a public child
--- package can instantiate its sibling private generic package.
---
--- TEST DESCRIPTION:
--- Declare a map abstraction in a package which manages basic physical
--- map[s]. Declare a private generic child of this package which can be
--- instantiated for any display device which has display locations of
--- the physical map that can be characterized by any integer type, i.e.,
--- the intensity of the display point.
---
--- Declare a public child of the physical map which specifies the
--- display device. In the body of this child, declare an instance of
--- its generic sibling to display the geographic locations.
---
--- In the main program, check that the operations in the parent, public
--- child and instance of the private child package perform as expected.
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 17 Apr 96 SAIC ACVC 2.1: Added pragma Elaborate.
---
---!
-
--- Simulates map of physical features, i.e., desert, forest, or water.
-
-package CA11016_0 is
- type Map_Type is private;
- subtype Latitude is integer range 1 .. 9;
- subtype Longitude is integer range 1 .. 7;
-
- type Physical_Features is (Desert, Forest, Water);
-
- -- Use geographic database to initialize the basic map.
-
- procedure Initialize_Basic_Map (Map : in out Map_Type);
-
- function Get_Physical_Feature (Lat : Latitude;
- Long : Longitude;
- Map : Map_Type) return Physical_Features;
-
-private
- type Map_Type is array (Latitude, Longitude) of Physical_Features;
- Basic_Map : Map_Type;
-
-end CA11016_0;
-
- --==================================================================--
-
-package body CA11016_0 is
-
- procedure Initialize_Basic_Map (Map : in out Map_Type) is
- -- Not a real initialization. Real application can use geographic
- -- database to create the basic map.
-
- begin
- for I in Latitude'first .. Latitude'last loop
- for J in 1 .. 2 loop
- Map (I, J) := Desert;
- end loop;
- for J in 3 .. 4 loop
- Map (I, J) := Forest;
- end loop;
- for J in 5 .. 7 loop
- Map (I, J) := Water;
- end loop;
- end loop;
-
- end Initialize_Basic_Map;
- --------------------------------------------------------
- function Get_Physical_Feature (Lat : Latitude;
- Long : Longitude;
- Map : Map_Type)
- return Physical_Features is
- begin
- return (Map (Lat, Long));
- end Get_Physical_Feature;
- --------------------------------------------------------
-
- begin
- -- Initialize a basic map.
- Initialize_Basic_Map (Basic_Map);
-
-end CA11016_0;
-
- --==================================================================--
-
--- Private generic child package of physical map. This generic package may
--- be instantiated for any display device which has display locations
--- (latitude, longitude) that can be characterized by an integer value.
--- For example, the intensity of the display point might be so characterized.
--- It can be instantiated for any desired range of values (which would
--- correspond to the range accepted by the display device).
-
-
-private
-
-generic
-
- type Display_Value is range <>; -- Any display feature that is
- -- represented by an integer.
-
-package CA11016_0.CA11016_1 is
-
- function Get_Display_Value (Lat : Latitude;
- Long : Longitude;
- Map : Map_Type) return Display_Value;
-
-end CA11016_0.CA11016_1;
-
-
- --==================================================================--
-
-
-package body CA11016_0.CA11016_1 is
-
- function Get_Display_Value (Lat : Latitude;
- Long : Longitude;
- Map : Map_Type)
- return Display_Value is
- begin
- case Get_Physical_Feature (Lat, Long, Map) is
- -- Parent's operation,
- when Forest => return (Display_Value'first);
- -- Parent's type.
- when Desert => return (Display_Value'last);
- -- Parent's type.
- when others => return
- ( (Display_Value'last - Display_Value'first) / 2 );
- -- NOTE: Results are truncated.
- end case;
-
- end Get_Display_Value;
-
-end CA11016_0.CA11016_1;
-
-
- --==================================================================--
-
--- Map display operation, public child of physical map.
-
-package CA11016_0.CA11016_2 is
-
- -- Super-duper Ultra Geographic Display Device (SDUGD) can display
- -- geographic locations with light intensity values ranging from 1 to 7.
-
- type Display_Val is range 1 .. 7;
-
- type Device_Color is (Brown, Blue, Green);
-
- type IO_Packet is
- record
- Lat : Latitude; -- Parent's type.
- Long : Longitude; -- Parent's type.
- Color : Device_Color;
- Intensity : Display_Val;
- end record;
-
- procedure Data_For_SDUGD (Lat : in Latitude;
- Long : in Longitude;
- Output_Packet : in out IO_Packet);
-
-end CA11016_0.CA11016_2;
-
- --==================================================================--
-
-
-with CA11016_0.CA11016_1; -- Private generic sibling.
-pragma Elaborate (CA11016_0.CA11016_1);
-
-package body CA11016_0.CA11016_2 is
-
- -- Declare instance of the private generic sibling for
- -- an integer type that represents color intensity.
-
- package SDUGD is new CA11016_0.CA11016_1 (Display_Val);
-
- procedure Data_For_SDUGD (Lat : in Latitude;
- Long : in Longitude;
- Output_Packet : in out IO_Packet) is
-
- -- Simulates sending control information to a display device.
- -- Control information consists of latitude, longitude, a
- -- color, and an intensity.
-
- begin
- case Get_Physical_Feature (Lat, Long, Basic_Map) is
- -- Parent's operation.
- when Water => Output_Packet.Color := Blue;
- Output_Packet.Intensity := SDUGD.Get_Display_Value
- (Lat, Long, Basic_Map);
- -- Sibling's operation.
- when Forest => Output_Packet.Color := Green;
- Output_Packet.Intensity := SDUGD.Get_Display_Value
- (Lat, Long, Basic_Map);
- -- Sibling's operation.
- when others => Output_Packet.Color := Brown;
- Output_Packet.Intensity := SDUGD.Get_Display_Value
- (Lat, Long, Basic_Map);
- -- Sibling's operation.
- end case;
-
- end Data_For_SDUGD;
-
-end CA11016_0.CA11016_2;
-
- --==================================================================--
-
-with CA11016_0.CA11016_2; -- Map display device operation,
- -- implicitly withs parent, physical map
- -- application.
-
-use CA11016_0.CA11016_2; -- Allows direct visibility to the simple
- -- name of CA11016_0.CA11016_2.
-
-with Report;
-
-procedure CA11016 is
-
- TC_Packet : IO_Packet;
-
-begin
-
- Report.Test ("CA11016", "Check that body of a public child package can " &
- "use its sibling private generic package " &
- "declarations and operations");
-
--- Simulate control information at coordinates 3 and 7 of the
--- basic map for the SDUGD.
-
- Water_Display_Subtest:
- begin
- TC_Packet.Lat := 3;
- TC_Packet.Long := 7;
-
- -- Build color and light intensity of the basic map at
- -- latitude 3 and longitude 7.
-
- Data_For_SDUGD (TC_Packet.Lat, TC_Packet.Long, TC_Packet);
-
- if ( (TC_Packet.Color /= Blue) or
- (TC_Packet.Intensity /= 3) ) then
- Report.Failed ("Map display device contains " &
- "incorrect values for water subtest");
- end if;
-
- end Water_Display_Subtest;
-
--- Simulate control information at coordinates 2 and 1 of the
--- basic map for the SDUGD.
-
- Desert_Display_Subtest:
- begin
- TC_Packet.Lat := 9;
- TC_Packet.Long := 2;
-
- -- Build color and light intensity of the basic map at
- -- latitude 9 and longitude 2.
-
- Data_For_SDUGD (TC_Packet.Lat, TC_Packet.Long, TC_Packet);
-
- if ( (TC_Packet.Color /= Brown) or
- (TC_Packet.Intensity /= 7) ) then
- Report.Failed ("Map display device contains " &
- "incorrect values for desert subtest");
- end if;
-
- end Desert_Display_Subtest;
-
--- Simulate control information at coordinates 8 and 4 of the
--- basic map for the SDUGD.
-
- Forest_Display_Subtest:
- begin
- TC_Packet.Lat := 8;
- TC_Packet.Long := 4;
-
- -- Build color and light intensity of the basic map at
- -- latitude 8 and longitude 4.
-
- Data_For_SDUGD (TC_Packet.Lat, TC_Packet.Long, TC_Packet);
-
- if ( (TC_Packet.Color /= Green) or
- (TC_Packet.Intensity /= 1) ) then
- Report.Failed ("Map display device contains " &
- "incorrect values for forest subtest");
- end if;
-
- end Forest_Display_Subtest;
-
- Report.Result;
-
-end CA11016;
diff --git a/gcc/testsuite/ada/acats/tests/ca/ca11017.a b/gcc/testsuite/ada/acats/tests/ca/ca11017.a
deleted file mode 100644
index cbcce701d37..00000000000
--- a/gcc/testsuite/ada/acats/tests/ca/ca11017.a
+++ /dev/null
@@ -1,246 +0,0 @@
--- CA11017.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that body of the parent package may depend on one of its own
--- public children.
---
--- TEST DESCRIPTION:
--- A scenario is created that demonstrates the potential of adding a
--- public child during code maintenance without distubing a large
--- subsystem. After child is added to the subsystem, a maintainer
--- decides to take advantage of the new functionality and rewrites
--- the parent's body.
---
--- Declare a string abstraction in a package which manipulates string
--- replacement. Define a parent package which provides operations for
--- a record type with discriminant. Declare a public child of this
--- package which adds functionality to the original subsystem. In the
--- parent body, call operations from the public child.
---
--- In the main program, check that operations in the parent and public
--- child perform as expected.
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
---
---!
-
--- Simulates application which manipulates strings.
-
-package CA11017_0 is
-
- type String_Rec (The_Size : positive) is private;
-
- type Substring is new string;
-
- -- ... Various other types used by the application.
-
- procedure Replace (In_The_String : in out String_Rec;
- At_The_Position : in positive;
- With_The_String : in String_Rec);
-
- -- ... Various other operations used by the application.
-
-private
- -- Different size for each individual record.
-
- type String_Rec (The_Size : positive) is
- record
- The_Length : natural := 0;
- The_Content : Substring (1 .. The_Size);
- end record;
-
-end CA11017_0;
-
- --=================================================================--
-
--- Public child added during code maintenance without disturbing a
--- large system. This public child would add functionality to the
--- original system.
-
-package CA11017_0.CA11017_1 is
-
- Position_Error : exception;
-
- function Equal_Length (Left : in String_Rec;
- Right : in String_Rec) return boolean;
-
- function Same_Content (Left : in String_Rec;
- Right : in String_Rec) return boolean;
-
- procedure Copy (From_The_Substring : in Substring;
- To_The_String : in out String_Rec);
-
- -- ... Various other operations used by the application.
-
-end CA11017_0.CA11017_1;
-
- --=================================================================--
-
-package body CA11017_0.CA11017_1 is
-
- function Equal_Length (Left : in String_Rec;
- Right : in String_Rec) return boolean is
- -- Quick comparison between the lengths of the input strings.
-
- begin
- return (Left.The_Length = Right.The_Length); -- Parent's private
- -- type.
- end Equal_Length;
- --------------------------------------------------------------------
- function Same_Content (Left : in String_Rec;
- Right : in String_Rec) return boolean is
-
- begin
- for I in 1 .. Left.The_Length loop
- if Left.The_Content (I) = Right.The_Content (I) then
- return true;
- else
- return false;
- end if;
- end loop;
-
- end Same_Content;
- --------------------------------------------------------------------
- procedure Copy (From_The_Substring : in Substring;
- To_The_String : in out String_Rec) is
- begin
- To_The_String.The_Content -- Parent's private type.
- (1 .. From_The_Substring'length) := From_The_Substring;
-
- To_The_String.The_Length -- Parent's private type.
- := From_The_Substring'length;
- end Copy;
-
-end CA11017_0.CA11017_1;
-
- --=================================================================--
-
--- After child is added to the subsystem, a maintainer decides
--- to take advantage of the new functionality and rewrites the
--- parent's body.
-
-with CA11017_0.CA11017_1;
-
-package body CA11017_0 is
-
- -- Calls functions from public child for a quick comparison of the
- -- input strings. If their lengths are the same, do the replacement.
-
- procedure Replace (In_The_String : in out String_Rec;
- At_The_Position : in positive;
- With_The_String : in String_Rec) is
- End_Position : natural := At_The_Position +
- With_The_String.The_Length - 1;
-
- begin
- if not CA11017_0.CA11017_1.Equal_Length -- Public child's operation.
- (With_The_String, In_The_String) then
- raise CA11017_0.CA11017_1.Position_Error;
- -- Public child's exception.
- else
- In_The_String.The_Content (At_The_Position .. End_Position) :=
- With_The_String.The_Content (1 .. With_The_String.The_Length);
- end if;
-
- end Replace;
-
-end CA11017_0;
-
- --=================================================================--
-
-with Report;
-
-with CA11017_0.CA11017_1; -- Explicit with public child package,
- -- implicit with parent package (CA11017_0).
-
-procedure CA11017 is
-
- package String_Pkg renames CA11017_0;
- use String_Pkg;
-
-begin
-
- Report.Test ("CA11017", "Check that body of the parent package can " &
- "depend on one of its own public children");
-
--- Both input strings have the same size. Replace the first string by the
--- second string.
-
- Replace_Subtest:
- declare
- The_First_String, The_Second_String : String_Rec (16);
- -- Parent's private type.
- The_Position : positive := 1;
- begin
- CA11017_1.Copy ("This is the time",
- To_The_String => The_First_String);
-
- CA11017_1.Copy ("For all good men", The_Second_String);
-
- Replace (The_First_String, The_Position, The_Second_String);
-
- -- Compare results using function from public child since
- -- the type is private.
-
- if not CA11017_1.Same_Content
- (The_First_String, The_Second_String) then
- Report.Failed ("Incorrect results");
- end if;
-
- end Replace_Subtest;
-
--- During processing, the application may erroneously attempt to replace
--- strings of different size. This would result in the raising of an
--- exception.
-
- Exception_Subtest:
- declare
- The_First_String : String_Rec (17);
- -- Parent's private type.
- The_Second_String : String_Rec (13);
- -- Parent's private type.
- The_Position : positive := 2;
- begin
- CA11017_1.Copy (" ACVC Version 2.0", The_First_String);
-
- CA11017_1.Copy (From_The_Substring => "ACVC 9X Basic",
- To_The_String => The_Second_String);
-
- Replace (The_First_String, The_Position, The_Second_String);
-
- Report.Failed ("Exception was not raised");
-
- exception
- when CA11017_1.Position_Error =>
- Report.Comment ("Exception is raised as expected");
-
- end Exception_Subtest;
-
- Report.Result;
-
-end CA11017;
diff --git a/gcc/testsuite/ada/acats/tests/ca/ca11018.a b/gcc/testsuite/ada/acats/tests/ca/ca11018.a
deleted file mode 100644
index a01ebfc32a4..00000000000
--- a/gcc/testsuite/ada/acats/tests/ca/ca11018.a
+++ /dev/null
@@ -1,366 +0,0 @@
--- CA11018.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that body of the parent package may depend on one of its own
--- public generic children.
---
--- TEST DESCRIPTION:
--- A scenario is created that demonstrates the potential of adding a
--- public generic child during code maintenance without distubing a large
--- subsystem. After child is added to the subsystem, a maintainer
--- decides to take advantage of the new functionality and rewrites
--- the parent's body.
---
--- Declare a message application in a package which highlights some
--- key words. Declare a public generic child of this package which adds
--- functionality to the original subsystem. In the parent body,
--- instantiate the child.
---
--- In the main program, check that the operations in the parent,
--- and instances of the public child package perform as expected.
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 14 Dec 94 SAIC Modified Copy_Particularly_Designated_Pkg inst.
--- 17 Nov 95 SAIC Update and repair for ACVC 2.0.1
---
---!
-
--- Simulates application which displays messages.
-
-package CA11018_0 is
-
- type Designated_Num is new Integer range 0 .. 100;
-
- type Particularly_Designated_Num is new Integer range 0 .. 100;
-
- type Message is new String;
-
- type Message_Rec is tagged private;
-
- type Designated_Msg is new Message_Rec with private;
-
- type Particularly_Designated_Msg is new Message_Rec with private;
-
- -- Analyzes message for presence of word in the secret message. If found,
- -- word is highlighted.
-
- procedure Highlight_Designated (The_Word : in Message;
- In_The_Message : in out Designated_Msg);
-
-
- -- Analyzes message for presence of word in the secret message. If found,
- -- word is highlighted and do other actions.
-
- procedure Highlight_Particularly_Designated
- (The_Word : in Message;
- In_The_Message : in out Particularly_Designated_Msg);
-
-
- -- Begin test code declarations: -----------------------
-
- TC_Designated_Not_Zero : Boolean := false;
-
- TC_Particularly_Designated_Not_Zero : Boolean := false;
-
- -- The following two functions are used to check for function
- -- calls from the public generic child.
-
- function TC_Designated_Success return Boolean;
-
- function TC_Particularly_Designated_Success return Boolean;
-
- -- End test code declarations. -------------------------
-
-private
- type Message_Rec is tagged
- record
- The_Length : natural := 0;
- The_Content : Message (1 .. 60);
- end record;
-
- type Designated_Msg is new Message_Rec with null record;
- -- ... More components in real application.
-
- type Particularly_Designated_Msg is new Message_Rec with null record;
- -- ... More components in real application.
-
-end CA11018_0;
-
- --=================================================================--
-
-
--- Public generic child package of message display application. Imagine that
--- messages of one security level are associated with a type derived from
--- integer. For overall system security, messages of a different security
--- level are associated with a different type derived from integer. By
--- instantiating this package for each security level, the results of Count
--- applied to one kind of message cannot inadvertently be compared with the
--- results applied to a different kind.
-
-generic
- type Msg_Type is new Message_Rec with private;
- -- Derived from parent's type.
- type Count is range <>;
-
-package CA11018_0.CA11018_1 is
-
- TC_Function_Called : Boolean := false;
-
- function Find_Word (Wrd : in Message;
- Msg : in Msg_Type) return Count;
-
-end CA11018_0.CA11018_1;
-
- --=================================================================--
-
-package body CA11018_0.CA11018_1 is
-
- function Find_Word (Wrd : in Message;
- Msg : in Msg_Type) return Count is
-
- Num : Count := Count'first;
-
- -- Count how many time the word appears within the given message.
-
- begin
- -- ... Error-checking code omitted for brevity.
-
- for I in 1 .. (Msg.The_Length - Wrd'length + 1) loop
- -- Parent's private type
- if Msg.The_Content (I .. I + Wrd'length - 1) = Wrd
- -- Parent's private type
- then
- Num := Num + 1;
- end if;
-
- end loop;
-
- TC_Function_Called := true;
-
- return (Num);
-
- end Find_Word;
-
-end CA11018_0.CA11018_1;
-
- --=================================================================--
-
-with CA11018_0.CA11018_1; -- Public generic child.
-
-pragma Elaborate (CA11018_0.CA11018_1);
-package body CA11018_0 is
-
- ----------------------------------------------------
- -- Parent's body depends on public generic child. --
- ----------------------------------------------------
-
- -- Instantiate the public child for the secret message.
-
- package Designated_Pkg is new CA11018_0.CA11018_1
- (Msg_Type => Designated_Msg, Count => Designated_Num);
-
- -- Instantiate the public child for the top secret message.
-
- package Particularly_Designated_Pkg is new CA11018_0.CA11018_1
- (Particularly_Designated_Msg, Particularly_Designated_Num);
-
- -- End instantiations. -----------------------------
-
-
- function TC_Designated_Success return Boolean is
- -- Check to see if the function in the public generic child is called.
-
- begin
- return Designated_Pkg.TC_Function_Called;
- end TC_Designated_Success;
- --------------------------------------------------------------
- function TC_Particularly_Designated_Success return Boolean is
- -- Check to see if the function in the public generic child is called.
-
- begin
- return Particularly_Designated_Pkg.TC_Function_Called;
- end TC_Particularly_Designated_Success;
- --------------------------------------------------------------
- -- Calls functions from public child to search for a key word.
- -- If the word appears more than once in each message,
- -- highlight all of them.
-
- procedure Highlight_Designated (The_Word : in Message;
- In_The_Message : in out Designated_Msg) is
-
- -- Not a real highlight procedure. Real application can use graphic
- -- device to highlight all occurrences of words.
-
- begin
- --------------------------------------------------------------
- -- Parent's body uses function from instantiation of public --
- -- generic child. --
- --------------------------------------------------------------
-
- if Designated_Pkg.Find_Word -- Child's operation.
- (The_Word, In_The_Message) > 0 then
-
- -- Highlight all occurrences in lavender.
-
- TC_Designated_Not_Zero := true;
- end if;
-
- end Highlight_Designated;
- --------------------------------------------------------------
- procedure Highlight_Particularly_Designated
- (The_Word : in Message;
- In_The_Message : in out Particularly_Designated_Msg) is
-
- -- Not a real highlight procedure. Real application can use graphic
- -- device to highlight all occurrences of words.
-
- begin
- --------------------------------------------------------------
- -- Parent's body uses function from instantiation of public --
- -- generic child. --
- --------------------------------------------------------------
-
- if Particularly_Designated_Pkg.Find_Word -- Child's operation.
- (The_Word, In_The_Message) > 0 then
-
- -- Highlight all occurrences in chartreuse.
- -- Do other more secret stuff.
-
- TC_Particularly_Designated_Not_Zero := true;
- end if;
-
- end Highlight_Particularly_Designated;
-
-end CA11018_0;
-
- --=================================================================--
-
--- Public generic child to copy words to the messages.
-
-generic
- type Message_Type is new Message_Rec with private;
- -- Derived from parent's type.
-
-package CA11018_0.CA11018_2 is
-
- procedure Copy (From_The_Word : in Message;
- To_The_Message : in out Message_Type);
-
-end CA11018_0.CA11018_2;
-
- --=================================================================--
-
-package body CA11018_0.CA11018_2 is
-
- procedure Copy (From_The_Word : in Message;
- To_The_Message : in out Message_Type) is
-
- -- Copy words to the appropriate messages.
-
- begin
- To_The_Message.The_Content -- Parent's private type.
- (1 .. From_The_Word'length) := From_The_Word;
-
- To_The_Message.The_Length -- Parent's private type.
- := From_The_Word'length;
- end Copy;
-
-end CA11018_0.CA11018_2;
-
- --=================================================================--
-
-with Report;
-
-with CA11018_0.CA11018_2; -- Public generic child package, copy words
- -- to the message.
- -- Implicit with parent package (CA11018_0).
-
-procedure CA11018 is
-
- package Message_Pkg renames CA11018_0;
-
-begin
-
- Report.Test ("CA11018", "Check that body of the parent package can " &
- "depend on one of its own public generic children");
-
--- Highlight the word "Alert" from the secret message.
-
- Designated_Subtest:
- declare
- The_Message : Message_Pkg.Designated_Msg; -- Parent's private type.
-
- -- Instantiate the public child to copy words to the secret message.
-
- package Copy_Designated_Pkg is new CA11018_0.CA11018_2
- (Message_Pkg.Designated_Msg);
-
- begin
- Copy_Designated_Pkg.Copy ("Alert Level 1 : Alert The Guard",
- To_The_Message => The_Message);
-
- Message_Pkg.Highlight_Designated ("Alert", The_Message);
-
- if not Message_Pkg.TC_Designated_Not_Zero and
- Message_Pkg.TC_Designated_Success then
- Report.Failed ("Alert should have been highlighted");
- end if;
-
- end Designated_Subtest;
-
--- Highlight the word "Push The Alarm" from the top secret message.
-
- Particularly_Designated_Subtest:
- declare
- The_Message : Message_Pkg.Particularly_Designated_Msg ;
- -- Parent's private type.
-
- -- Instantiate the public child to copy words to the top secret
- -- message.
-
- package Copy_Particularly_Designated_Pkg is new
- CA11018_0.CA11018_2 (Message_Pkg.Particularly_Designated_Msg);
-
- begin
- Copy_Particularly_Designated_Pkg.Copy
- ("Alert Level 10 : Alert The Guard and Push The Alarm",
- The_Message);
-
- Message_Pkg.Highlight_Particularly_Designated
- ("Push The Alarm", The_Message);
-
- if not Message_Pkg.TC_Particularly_Designated_Not_Zero and
- Message_Pkg.TC_Particularly_Designated_Success then
- Report.Failed ("Key words should have been highlighted");
- end if;
-
- end Particularly_Designated_Subtest;
-
- Report.Result;
-
-end CA11018;
diff --git a/gcc/testsuite/ada/acats/tests/ca/ca11019.a b/gcc/testsuite/ada/acats/tests/ca/ca11019.a
deleted file mode 100644
index 92b3ba5358b..00000000000
--- a/gcc/testsuite/ada/acats/tests/ca/ca11019.a
+++ /dev/null
@@ -1,306 +0,0 @@
--- CA11019.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that body of the parent package may depend on one of its own
--- private generic children.
---
--- TEST DESCRIPTION:
--- A scenario is created that demonstrates the potential of adding a
--- generic private child during code maintenance without distubing a
--- large subsystem. After child is added to the subsystem, a maintainer
--- decides to take advantage of the new functionality and rewrites
--- the parent's body.
---
--- Declare a data collection abstraction in a package. Declare a private
--- generic child of this package which provides parameterized code that
--- have been written once and will be used three times to implement the
--- services of the parent package. In the parent body, instantiate the
--- private child.
---
--- In the main program, check that the operations in the parent,
--- and instance of the private child package perform as expected.
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 17 Nov 95 SAIC Update and repair for ACVC 2.0.1
---
---!
-
-package CA11019_0 is
- -- parent
-
- type Data_Record is tagged private;
- type Data_Collection is private;
- ---
- ---
- subtype Data_1 is integer range 0 .. 100;
- procedure Add_1 (Data : Data_1; To : in out Data_Collection);
- function Statistical_Op_1 (Data : Data_Collection) return Data_1;
- ---
- subtype Data_2 is integer range -100 .. 1000;
- procedure Add_2 (Data : Data_2; To : in out Data_Collection);
- function Statistical_Op_2 (Data : Data_Collection) return Data_2;
- ---
- subtype Data_3 is integer range -10_000 .. 10_000;
- procedure Add_3 (Data : Data_3; To : in out Data_Collection);
- function Statistical_Op_3 (Data : Data_Collection) return Data_3;
- ---
-
-private
-
- type Data_Ptr is access Data_Record'class;
- subtype Sequence_Number is positive range 1 .. 512;
-
- type Data_Record is tagged
- record
- Next : Data_Ptr := null;
- Seq : Sequence_Number;
- end record;
- ---
- type Data_Collection is
- record
- First : Data_Ptr := null;
- Last : Data_Ptr := null;
- end record;
-
-end CA11019_0;
- -- parent
-
- --=================================================================--
-
--- This generic package provides parameterized code that has been
--- written once and will be used three times to implement the services
--- of the parent package.
-
-private
-generic
- type Data_Type is range <>;
-
-package CA11019_0.CA11019_1 is
- -- parent.child
-
- type Data_Elem is new Data_Record with
- record
- Value : Data_Type;
- end record;
-
- Next_Avail_Seq_No : Sequence_Number := 1;
-
- procedure Sequence (Ptr : Data_Ptr);
- -- the child must be private for this procedure to know details of
- -- the implementation of data collections
-
- procedure Add (Datum : Data_Type; To : in out Data_Collection);
-
- function Op (Data : Data_Collection) return Data_Type;
- -- op models a complicated operation that whose code can be
- -- used for various data types
-
-
-end CA11019_0.CA11019_1;
- -- parent.child
-
- --=================================================================--
-
-
-package body CA11019_0.CA11019_1 is
- -- parent.child
-
- procedure Sequence (Ptr : Data_Ptr) is
- begin
- Ptr.Seq := Next_Avail_Seq_No;
- Next_Avail_Seq_No := Next_Avail_Seq_No + 1;
- end Sequence;
-
- ---------------------------------------------------------
-
- procedure Add (Datum : Data_Type; To : in out Data_Collection) is
- Ptr : Data_Ptr;
- begin
- if To.First = null then
- -- assign new record with data value to
- -- to.next <- null;
- To.First := new Data_Elem'(Next => null,
- Value => Datum,
- Seq => 1);
- Sequence (To.First);
- To.Last := To.First;
- else
- -- chase to end of list
- Ptr := To.First;
- while Ptr.Next /= null loop
- Ptr := Ptr.Next;
- end loop;
- -- and add element there
- Ptr.Next := new Data_Elem'(Next => null,
- Value => Datum,
- Seq => 1);
- Sequence (Ptr.Next);
- To.Last := Ptr.Next;
- end if;
-
- end Add;
-
- ---------------------------------------------------------
-
- function Op (Data : Data_Collection) return Data_Type is
- -- for simplicity, just return the maximum of the data set
- Max : Data_Type := Data_Elem( Data.First.all ).Value;
- -- assuming non-empty collection
- Ptr : Data_Ptr := Data.First;
-
- begin
- -- no error checking
- while Ptr.Next /= null loop
- if Data_Elem( Ptr.Next.all ).Value > Max then
- Max := Data_Elem( Ptr.Next.all ).Value;
- end if;
- Ptr := Ptr.Next;
- end loop;
- return Max;
- end Op;
-
-end CA11019_0.CA11019_1;
- -- parent.child
-
- --=================================================================--
-
--- parent body depends on private generic child
-with CA11019_0.CA11019_1; -- Private generic child.
-
-pragma Elaborate (CA11019_0.CA11019_1);
-package body CA11019_0 is
-
- -- instantiate the generic child with data types needed by the
- -- package interface services
- package Data_1_Ops is new CA11019_1
- (Data_Type => Data_1);
-
- package Data_2_Ops is new CA11019_1
- (Data_Type => Data_2);
-
- package Data_3_Ops is new CA11019_1
- (Data_Type => Data_3);
-
- ---------------------------------------------------------
-
- procedure Add_1 (Data : Data_1; To : in out Data_Collection) is
- begin
- -- maybe do other stuff here
- Data_1_Ops.Add (Data, To);
- -- and here
- end;
-
- ---------------------------------------------------------
-
- function Statistical_Op_1 (Data : Data_Collection) return Data_1 is
- begin
- -- maybe use generic operation(s) in some complicated ways
- -- (but simplified out, for the sake of testing)
- return Data_1_Ops.Op (Data);
- end;
-
- ---------------------------------------------------------
-
- procedure Add_2 (Data : Data_2; To : in out Data_Collection) is
- begin
- Data_2_Ops.Add (Data, To);
- end;
-
- ---------------------------------------------------------
-
- function Statistical_Op_2 (Data : Data_Collection) return Data_2 is
- begin
- return Data_2_Ops.Op (Data);
- end;
-
- ---------------------------------------------------------
-
- procedure Add_3 (Data : Data_3; To : in out Data_Collection) is
- begin
- Data_3_Ops.Add (Data, To);
- end;
-
- ---------------------------------------------------------
-
- function Statistical_Op_3 (Data : Data_Collection) return Data_3 is
- begin
- return Data_3_Ops.Op (Data);
- end;
-
-end CA11019_0;
-
-
- --=================================================--
-
-with CA11019_0,
- -- Main,
- -- Main.Child is private
- Report;
-
-procedure CA11019 is
-
- package Main renames CA11019_0;
-
- Col_1,
- Col_2,
- Col_3 : Main.Data_Collection;
-
-begin
-
- Report.Test ("CA11019", "Check that body of a (non-generic) package " &
- "may depend on its private generic child");
-
- -- build a data collection
-
- for I in 1 .. 10 loop
- Main.Add_1 ( Main.Data_1(I), Col_1);
- end loop;
-
- if Main.Statistical_Op_1 (Col_1) /= 10 then
- Report.Failed ("Wrong data_1 value returned");
- end if;
-
- for I in reverse 10 .. 20 loop
- Main.Add_2 ( Main.Data_2(I * 10), Col_2);
- end loop;
-
- if Main.Statistical_Op_2 (Col_2) /= 200 then
- Report.Failed ("Wrong data_2 value returned");
- end if;
-
- for I in 0 .. 10 loop
- Main.Add_3 ( Main.Data_3(I + 5), Col_3);
- end loop;
-
- if Main.Statistical_Op_3 (Col_3) /= 15 then
- Report.Failed ("Wrong data_3 value returned");
- end if;
-
- Report.Result;
-
-end CA11019;
diff --git a/gcc/testsuite/ada/acats/tests/ca/ca11020.a b/gcc/testsuite/ada/acats/tests/ca/ca11020.a
deleted file mode 100644
index 4949ce9feee..00000000000
--- a/gcc/testsuite/ada/acats/tests/ca/ca11020.a
+++ /dev/null
@@ -1,238 +0,0 @@
--- CA11020.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that body of the generic parent package can depend on one of
--- its own public generic children.
---
--- TEST DESCRIPTION:
--- A scenario is created that demonstrates the potential of adding a
--- public generic child during code maintenance without distubing a large
--- subsystem. After child is added to the subsystem, a maintainer
--- decides to take advantage of the new functionality and rewrites
--- the parent's body.
---
--- Declare a bag abstraction in a generic package. Declare a public
--- generic child of this package which adds a generic procedure to the
--- original subsystem. In the parent body, instantiate the public
--- child. Then instantiate the procedure as a child instance of the
--- public child instance.
---
--- In the main program, declare an instance of parent. Check that the
--- operations in both parent and child packages perform as expected.
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
---
---!
-
--- Simulates bag application.
-
-generic
- type Element is private;
- with function Image (E : Element) return String;
-
-package CA11020_0 is
-
- type Bag is limited private;
-
- procedure Add (E : in Element; To_The_Bag : in out Bag);
-
- function Bag_Image (B : Bag) return string;
-
-private
- type Node_Type;
- type Bag is access Node_Type;
-
- type Node_Type is
- record
- The_Element : Element;
-
- -- Other components in real application, i.e.,
- -- The_Count : positive;
-
- Next : Bag;
- end record;
-
-end CA11020_0;
-
- --==================================================================--
-
--- More operations on Bag.
-
-generic
-
--- Parameters go here.
-
-package CA11020_0.CA11020_1 is
-
- -- ... Other declarations.
-
- generic -- Generic iterator procedure.
- with procedure Use_Element (E : in Element);
-
- procedure Iterate (B : in Bag); -- Called once per element in the bag.
-
- -- ... Various other operations.
-
-end CA11020_0.CA11020_1;
-
- --==================================================================--
-
-package body CA11020_0.CA11020_1 is
-
- procedure Iterate (B : in Bag) is
-
- -- Traverse each element in the bag.
-
- Elem : Bag := B;
-
- begin
- while Elem /= null loop
- Use_Element (Elem.The_Element);
- Elem := Elem.Next;
- end loop;
-
- end Iterate;
-
-end CA11020_0.CA11020_1;
-
- --==================================================================--
-
-with CA11020_0.CA11020_1; -- Public generic child package.
-
-package body CA11020_0 is
-
- ----------------------------------------------------
- -- Parent's body depends on public generic child. --
- ----------------------------------------------------
-
- -- Instantiate the public child.
-
- package MS is new CA11020_1;
-
- function Bag_Image (B : Bag) return string is
-
- Buffer : String (1 .. 10_000);
- Last : Integer := 0;
-
- -----------------------------------------------------
-
- -- Will be called by the iterator.
-
- procedure Append_Image (E : in Element) is
- Im : constant String := Image (E);
-
- begin -- Append_Image
- if Last /= 0 then -- Insert a comma.
- Last := Last + 1;
- Buffer (Last) := ',';
- end if;
-
- Buffer (Last + 1 .. Last + Im'Length) := Im;
- Last := Last + Im'Length;
-
- end Append_Image;
-
- -----------------------------------------------------
-
- -- Instantiate procedure Iterate as a child of instance MS.
-
- procedure Append_All is new MS.Iterate (Use_Element => Append_Image);
-
- begin -- Bag_Image
-
- Append_All (B);
-
- return Buffer (1 .. Last);
-
- end Bag_Image;
-
- -----------------------------------------------------
-
- procedure Add (E : in Element; To_The_Bag : in out Bag) is
-
- -- Not a real bag addition.
-
- Index : Bag := To_The_Bag;
-
- begin
- -- ... Error-checking code omitted for brevity.
-
- if Index = null then
- To_The_Bag := new Node_Type' (The_Element => E,
- Next => null);
- else
- -- Goto the end of the list.
-
- while Index.Next /= null loop
- Index := Index.Next;
- end loop;
-
- -- Add element to the end of the list.
-
- Index.Next := new Node_Type' (The_Element => E,
- Next => null);
- end if;
-
- end Add;
-
-end CA11020_0;
-
- --==================================================================--
-
-with CA11020_0; -- Bag application.
-
-with Report;
-
-procedure CA11020 is
-
- -- Instantiate the bag application for integer type and attribute
- -- Image.
-
- package Bag_Of_Integers is new CA11020_0 (Integer, Integer'Image);
-
- My_Bag : Bag_Of_Integers.Bag;
-
-begin
-
- Report.Test ("CA11020", "Check that body of the generic parent package " &
- "can depend on one of its own public generic children");
-
- -- Add 10 consecutive integers to the bag.
-
- for I in 1 .. 10 loop
- Bag_Of_Integers.Add (I, My_Bag);
- end loop;
-
- if Bag_Of_Integers.Bag_Image (My_Bag)
- /= " 1, 2, 3, 4, 5, 6, 7, 8, 9, 10" then
- Report.Failed ("Incorrect results");
- end if;
-
- Report.Result;
-
-end CA11020;
diff --git a/gcc/testsuite/ada/acats/tests/ca/ca11021.a b/gcc/testsuite/ada/acats/tests/ca/ca11021.a
deleted file mode 100644
index f4da2f91334..00000000000
--- a/gcc/testsuite/ada/acats/tests/ca/ca11021.a
+++ /dev/null
@@ -1,245 +0,0 @@
--- CA11021.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that body of the generic parent package can depend on one of
--- its own private generic children.
---
--- TEST DESCRIPTION:
--- A scenario is created that demonstrates the potential of adding a
--- public generic child during code maintenance without distubing a large
--- subsystem. After child is added to the subsystem, a maintainer
--- decides to take advantage of the new functionality and rewrites
--- the parent's body.
---
--- Declare a generic package which declares high level operations for a
--- complex number abstraction. Declare a private generic child package
--- of this package which defines low level complex operations. In the
--- parent body, instantiate the private child. Use the low level
--- operation to complete the high level operation.
---
--- In the main program, instantiate the parent generic package.
--- Check that the operations in both packages perform as expected.
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
---
---!
-
-generic -- Complex number abstraction.
- type Int_Type is range <>;
-
-package CA11021_0 is
-
- -- Simulate a generic complex number support package. Complex numbers
- -- are treated as coordinates in the Cartesian plane.
-
- type Complex_Type is private;
-
- Zero : constant Complex_Type; -- Real number (0,0).
-
- function Real_Part (Complex_No : Complex_Type)
- return Int_Type;
-
- function Imag_Part (Complex_No : Complex_Type)
- return Int_Type;
-
- function Complex (Real, Imag : Int_Type)
- return Complex_Type;
-
- -- High level operation for complex number.
- function "*" (Factor : Int_Type;
- C : Complex_Type) return Complex_Type;
-
- -- ... and other complicated ones.
-
-private
- type Complex_Type is record
- Real : Int_Type;
- Imag : Int_Type;
- end record;
-
- Zero : constant Complex_Type := (Real => 0, Imag => 0);
-
-end CA11021_0;
-
- --==================================================================--
-
--- Private generic child of Complex_Number.
-
-private
-
-generic
-
--- No parameter.
-
-package CA11021_0.CA11021_1 is
-
- -- ... Other declarations.
-
- -- Low level operation on complex number.
- function "+" (Left, Right : Complex_Type)
- return Complex_Type;
-
- function "-" (Right : Complex_Type)
- return Complex_Type;
-
- -- ... Various other operations in real application.
-
-end CA11021_0.CA11021_1;
-
- --==================================================================--
-
-package body CA11021_0.CA11021_1 is
-
- function "+" (Left, Right : Complex_Type)
- return Complex_Type is
-
- begin
- return ( (Left.Real + Right.Real, Left.Imag + Right.Imag) );
- end "+";
-
- --------------------------------------------------
-
- function "-" (Right : Complex_Type) return Complex_Type is
- begin
- return (-Right.Real, -Right.Imag);
- end "-";
-
-end CA11021_0.CA11021_1;
-
- --==================================================================--
-
-with CA11021_0.CA11021_1; -- Private generic child package.
-
-package body CA11021_0 is
-
- -----------------------------------------------------
- -- Parent's body depends on private generic child. --
- -----------------------------------------------------
-
- -- Instantiate the private child.
-
- package Complex_Ops is new CA11021_1;
- use Complex_Ops; -- All user-defined operators
- -- directly visible.
-
- --------------------------------------------------
-
- function "*" (Factor : Int_Type;
- C : Complex_Type) return Complex_Type is
- Result : Complex_Type := Zero;
-
- begin
- for I in 1 .. abs (Factor) loop
- Result := Result + C; -- Private generic child "+".
- end loop;
-
- if Factor < 0 then
- Result := - Result; -- Private generic child "-".
- end if;
-
- return Result;
- end "*";
-
- --------------------------------------------------
-
- function Real_Part (Complex_No : Complex_Type) return Int_Type is
- begin
- return (Complex_No.Real);
- end Real_Part;
-
- --------------------------------------------------
-
- function Imag_Part (Complex_No : Complex_Type) return Int_Type is
- begin
- return (Complex_No.Imag);
- end Imag_Part;
-
- --------------------------------------------------
-
- function Complex (Real, Imag : Int_Type) return Complex_Type is
- begin
- return (Real, Imag);
- end Complex;
-
-end CA11021_0;
-
- --==================================================================--
-
-with CA11021_0; -- Complex number abstraction.
-
-with Report;
-
-procedure CA11021 is
-
- type My_Integer is range -100 .. 100;
-
- --------------------------------------------------
-
--- Declare instance of the generic complex package for one particular
--- integer type.
-
- package My_Complex_Pkg is new
- CA11021_0 (Int_Type => My_Integer);
-
- use My_Complex_Pkg; -- All user-defined operators
- -- directly visible.
-
- --------------------------------------------------
-
- Complex_One, Complex_Two : Complex_Type;
-
- My_Literal : My_Integer := -3;
-
-begin
-
- Report.Test ("CA11021", "Check that body of the generic parent package " &
- "can depend on its private generic child");
-
- Complex_One := Complex (11, 6);
-
- Complex_Two := 5 * Complex_One;
-
- if Real_Part (Complex_Two) /= 55
- and Imag_Part (Complex_Two) /= 30
- then
- Report.Failed ("Incorrect results from complex operation");
- end if;
-
- Complex_One := Complex (-4, 7);
-
- Complex_Two := My_Literal * Complex_One;
-
- if Real_Part (Complex_Two) /= 12
- and Imag_Part (Complex_Two) /= -21
- then
- Report.Failed ("Incorrect results from complex operation");
- end if;
-
- Report.Result;
-
-end CA11021;
diff --git a/gcc/testsuite/ada/acats/tests/ca/ca11022.a b/gcc/testsuite/ada/acats/tests/ca/ca11022.a
deleted file mode 100644
index 60cbc08ce0a..00000000000
--- a/gcc/testsuite/ada/acats/tests/ca/ca11022.a
+++ /dev/null
@@ -1,242 +0,0 @@
--- CA11022.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that body of a child unit can instantiate its generic sibling.
---
--- TEST DESCRIPTION:
--- Declare a package that provides some types for the graphic
--- application. Add a generic child package with a subprogram parameter
--- to provide algorithms that can be used by different terminal types
--- but that have to be customized to the specific terminal. Add child
--- packages to take advantage of the parent types and to provide a
--- customized operation for each of the different terminals. The
--- customized operation will be passed as a generic subprogram parameter
--- to the child package's sibling.
---
--- The main program "with"s the child packages. Check that the
--- operations in child units perform as expected.
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
---
---!
-
-package CA11022_0 is -- Graphic Manager
-
- type Row is range 1 .. 66;
- type Column is range 1 .. 80;
- type Radius is range 1 .. 3;
- type Length is range 5 .. 10;
-
- -- Testing artifice.
- TC_Screen : array (Row, Column) of boolean := (others => (others => false));
- TC_Draw_Circle : boolean := false;
- TC_Draw_Square : boolean := false;
-
- -- ... and other complicated ones.
-
-end CA11022_0;
-
--- No bodies required for CA11022_0.
-
- --==================================================================--
-
--- Child package to provide general graphic functionalities.
-
-generic
-
- with procedure Put_Dot (X : in Column;
- Y : in Row);
-
-package CA11022_0.CA11022_1 is
-
- procedure Draw_Square (At_Col : in Column;
- At_Row : in Row;
- Len : in Length);
-
- procedure Draw_Circle (At_Col : in Column;
- At_Row : in Row;
- Rad : in Radius);
-
- -- procedure Draw_Ellipse ...
- -- and other drawings ...
-
-end CA11022_0.CA11022_1;
-
- --==================================================================--
-
-package body CA11022_0.CA11022_1 is
-
- procedure Draw_Square (At_Col : in Column;
- At_Row : in Row;
- Len : in Length) is
- begin
- -- use square drawing algorithm
- -- call
- Put_Dot (At_Col + Column (Len), At_Row + Row(Len));
- -- as needed in the algorithm.
- TC_Draw_Square := true;
- end Draw_Square;
-
- -------------------------------------------------------
- procedure Draw_Circle (At_Col : in Column;
- At_Row : in Row;
- Rad : in Radius) is
- begin
- -- use circle drawing algorithm
- -- call
- for I in 1 .. Rad loop
- Put_Dot (At_Col + Column(I), At_Row + Row(I));
- end loop;
- -- as needed in the algorithm.
- TC_Draw_Circle := true;
- end Draw_Circle;
-
-end CA11022_0.CA11022_1;
-
- --==================================================================--
-
-with CA11022_0.CA11022_1; -- Generic sibling.
-
--- Child package to provide customized graphic functions for the
--- VT100.
-package CA11022_0.CA11022_2 is -- VT100 Graphic.
-
- X : Column := 8;
- Y : Row := 3;
- R : Radius := 2;
- L : Length := 6;
-
- procedure VT100_Graphic;
-
-end CA11022_0.CA11022_2;
-
- --==================================================================--
-
-package body CA11022_0.CA11022_2 is
-
- procedure VT100_Graphic is
- procedure VT100_Putdot (X : in Column;
- Y : in Row) is
- begin
- -- Light a pixel at location (X, Y);
- TC_Screen (Y, X) := true;
- end VT100_Putdot;
-
- ------------------------------------
-
- -- Declare instance of the generic sibling package to draw a circle,
- -- a square, or an ellipse customized for the VT100.
- package VT100_Graphic is new CA11022_0.CA11022_1 (VT100_Putdot);
-
- begin
- VT100_Graphic.Draw_Circle (X, Y, R);
- VT100_Graphic.Draw_Square (X, Y, L);
- end VT100_Graphic;
-
-end CA11022_0.CA11022_2;
-
- --==================================================================--
-
-with CA11022_0.CA11022_1; -- Generic sibling.
-
--- Child package to provide customized graphic functions for the
--- IBM3270.
-package CA11022_0.CA11022_3 is -- IBM3270 Graphic.
-
- X : Column := 39;
- Y : Row := 11;
- R : Radius := 3;
- L : Length := 7;
-
- procedure IBM3270_Graphic;
-
-end CA11022_0.CA11022_3;
-
- --==================================================================--
-
-package body CA11022_0.CA11022_3 is
-
- procedure IBM3270_Graphic is
- procedure IBM3270_Putdot (X : in Column;
- Y : in Row) is
- begin
- -- Light a pixel at location (X + 2, Y);
- TC_Screen (Y, X + Column(2)) := true;
- end IBM3270_Putdot;
-
- ------------------------------------
-
- -- Declare instance of the generic sibling package to draw a circle,
- -- a square, or an ellipse customized for the IBM3270.
- package IBM3270_Graphic is new CA11022_0.CA11022_1 (IBM3270_Putdot);
-
- begin
- IBM3270_Graphic.Draw_Circle (X, Y, R);
- IBM3270_Graphic.Draw_Square (X, Y, L);
- end IBM3270_Graphic;
-
-end CA11022_0.CA11022_3;
-
- --==================================================================--
-
-with CA11022_0.CA11022_2; -- VT100 Graphic, implicitly with
- -- CA11022_0, Graphic Manager.
-with CA11022_0.CA11022_3; -- IBM3270 Graphic.
-with Report;
-
-procedure CA11022 is
-
-begin
-
- Report.Test ("CA11022", "Check that body of a child unit can depend on " &
- "its generic sibling");
-
- -- Customized graphic functions for the VT100 terminal.
- CA11022_0.CA11022_2.VT100_Graphic;
-
- if not CA11022_0.TC_Screen (4,9) and not CA11022_0.TC_Screen (5,10)
- and not CA11022_0.TC_Screen (9,14) and not CA11022_0.TC_Draw_Circle
- and not CA11022_0.TC_Draw_Square then
- Report.Failed ("Wrong results for the VT100");
- end if;
-
- CA11022_0.TC_Draw_Circle := false;
- CA11022_0.TC_Draw_Square := false;
-
- -- Customized graphic functions for the IBM3270 terminal.
- CA11022_0.CA11022_3.IBM3270_Graphic;
-
- if not CA11022_0.TC_Screen (12,42) and not CA11022_0.TC_Screen (13,43)
- and not CA11022_0.TC_Screen (14,44) and not CA11022_0.TC_Screen (46,18)
- and not CA11022_0.TC_Draw_Circle and not CA11022_0.TC_Draw_Square then
- Report.Failed ("Wrong results for the IBM3270");
- end if;
-
- Report.Result;
-
-end CA11022;
diff --git a/gcc/testsuite/ada/acats/tests/ca/ca11a01.a b/gcc/testsuite/ada/acats/tests/ca/ca11a01.a
deleted file mode 100644
index a84c6b84f44..00000000000
--- a/gcc/testsuite/ada/acats/tests/ca/ca11a01.a
+++ /dev/null
@@ -1,228 +0,0 @@
--- CA11A01.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that type extended in a public child inherits primitive
--- operations from its ancestor.
---
--- TEST DESCRIPTION:
--- Declare a root tagged type in a package specification. Declare two
--- primitive subprograms for the type (foundation code).
---
--- Add a public child to the above package. Extend the root type with
--- a record extension in the specification. Declare a new primitive
--- subprogram to write to the child extension.
---
--- Add a public grandchild to the above package. Extend the extension of
--- the parent type with a record extension in the private part of the
--- specification. Declare a new primitive subprogram for this grandchild
--- extension.
---
--- In the main program, "with" the grandchild. Access the primitive
--- operations from grandparent and parent package.
---
--- TEST FILES:
--- This test depends on the following foundation code:
---
--- FA11A00.A
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
---
---!
-
-package FA11A00.CA11A01_0 is -- Color_Widget_Pkg
--- This public child declares an extension from its parent. It
--- represents processing of widgets in a window system.
-
- type Widget_Color_Enum is (Black, Green, White);
-
- type Color_Widget is new Widget with -- Record extension of
- record -- parent tagged type.
- Color : Widget_Color_Enum;
- end record;
-
- -- Inherits procedure Set_Width from Widget.
- -- Inherits procedure Set_Height from Widget.
-
- -- To be inherited by its derivatives.
- procedure Set_Color (The_Widget : in out Color_Widget;
- C : in Widget_Color_Enum);
-
- procedure Set_Color_Widget (The_Widget : in out Color_Widget;
- The_Width : in Widget_Length;
- The_Height : in Widget_Length;
- The_Color : in Widget_Color_Enum);
-
-end FA11A00.CA11A01_0; -- Color_Widget_Pkg
-
---=======================================================================--
-
-package body FA11A00.CA11A01_0 is -- Color_Widget_Pkg
-
- procedure Set_Color (The_Widget : in out Color_Widget;
- C : in Widget_Color_Enum) is
- begin
- The_Widget.Color := C;
- end Set_Color;
- ---------------------------------------------------------------
- procedure Set_Color_Widget (The_Widget : in out Color_Widget;
- The_Width : in Widget_Length;
- The_Height : in Widget_Length;
- The_Color : in Widget_Color_Enum) is
- begin
- Set_Width (The_Widget, The_Width); -- Inherited from parent.
- Set_Height (The_Widget, The_Height); -- Inherited from parent.
- Set_Color (The_Widget, The_Color);
- end Set_Color_Widget;
-
-end FA11A00.CA11A01_0; -- Color_Widget_Pkg
-
---=======================================================================--
-
-package FA11A00.CA11A01_0.CA11A01_1 is -- Label_Widget_Pkg
--- This public grandchild extends the extension from its parent. It
--- represents processing of widgets in a window system.
-
- -- Declaration used by private extension component.
- subtype Widget_Label_Str is string (1 .. 10);
-
- type Label_Widget is new Color_Widget with private;
- -- Record extension of parent tagged type.
-
- -- Inherits (inherited) procedure Set_Width from Color_Widget.
- -- Inherits (inherited) procedure Set_Height from Color_Widget.
- -- Inherits procedure Set_Color from Color_Widget.
- -- Inherits procedure Set_Color_Widget from Color_Widget.
-
- procedure Set_Label_Widget (The_Widget : in out Label_Widget;
- The_Width : in Widget_Length;
- The_Height : in Widget_Length;
- The_Color : in Widget_Color_Enum;
- The_Label : in Widget_Label_Str);
-
- -- The following function is needed to verify the value of the
- -- extension's private component.
-
- function Verify_Label (The_Widget : in Label_Widget;
- The_Label : in Widget_Label_Str) return Boolean;
-
-private
- type Label_Widget is new Color_Widget with
- record
- Label : Widget_Label_Str;
- end record;
-
-end FA11A00.CA11A01_0.CA11A01_1; -- Label_Widget_Pkg
-
---=======================================================================--
-
-package body FA11A00.CA11A01_0.CA11A01_1 is -- Label_Widget_Pkg
-
- procedure Set_Label (The_Widget : in out Label_Widget;
- L : in Widget_Label_Str) is
- begin
- The_Widget.Label := L;
- end Set_Label;
- --------------------------------------------------------------
- procedure Set_Label_Widget (The_Widget : in out Label_Widget;
- The_Width : in Widget_Length;
- The_Height : in Widget_Length;
- The_Color : in Widget_Color_Enum;
- The_Label : in Widget_Label_Str) is
- begin
- Set_Width (The_Widget, The_Width); -- Twice inherited.
- Set_Height (The_Widget, The_Height); -- Twice inherited.
- Set_Color (The_Widget, The_Color); -- Inherited from parent.
- Set_Label (The_Widget, The_Label);
- end Set_Label_Widget;
- --------------------------------------------------------------
- function Verify_Label (The_Widget : in Label_Widget;
- The_Label : in Widget_Label_Str) return Boolean is
- begin
- return (The_Widget.Label = The_Label);
- end Verify_Label;
-
-end FA11A00.CA11A01_0.CA11A01_1; -- Label_Widget_Pkg
-
---=======================================================================--
-
-with FA11A00.CA11A01_0.CA11A01_1; -- Label_Widget_Pkg,
- -- implicitly with Widget_Pkg,
- -- implicitly with Color_Widget_Pkg
-with Report;
-
-procedure CA11A01 is
-
- package Widget_Pkg renames FA11A00;
- package Color_Widget_Pkg renames FA11A00.CA11A01_0;
- package Label_Widget_Pkg renames FA11A00.CA11A01_0.CA11A01_1;
-
- use Widget_Pkg; -- All user-defined operators directly visible.
-
- Mail_Label : Label_Widget_Pkg.Widget_Label_Str := "Quick_Mail";
-
- Default_Widget : Widget;
- Black_Widget : Color_Widget_Pkg.Color_Widget;
- Mail_Widget : Label_Widget_Pkg.Label_Widget;
-
-begin
-
- Report.Test ("CA11A01", "Check that type extended in a public " &
- "child inherits primitive operations from its " &
- "ancestor");
-
- Set_Width (Default_Widget, 9); -- Call from parent.
- Set_Height (Default_Widget, 10); -- Call from parent.
-
- If Default_Widget.Width /= Widget_Length (Report.Ident_Int (9)) or
- Default_Widget.Height /= Widget_Length (Report.Ident_Int (10)) then
- Report.Failed ("Incorrect result for Default_Widget");
- end if;
-
- Color_Widget_Pkg.Set_Color_Widget
- (Black_Widget, 17, 18, Color_Widget_Pkg.Black); -- Explicitly declared.
-
- If Black_Widget.Width /= Widget_Length (Report.Ident_Int (17)) or
- Black_Widget.Height /= Widget_Length (Report.Ident_Int (18)) or
- Color_Widget_Pkg."/=" (Black_Widget.Color, Color_Widget_Pkg.Black) then
- Report.Failed ("Incorrect result for Black_Widget");
- end if;
-
- Label_Widget_Pkg.Set_Label_Widget
- (Mail_Widget, 15, 21, Color_Widget_Pkg.White,
- "Quick_Mail"); -- Explicitly declared.
-
- If Mail_Widget.Width /= Widget_Length (Report.Ident_Int (15)) or
- Mail_Widget.Height /= Widget_Length (Report.Ident_Int (21)) or
- Color_Widget_Pkg."/=" (Mail_Widget.Color, Color_Widget_Pkg.White) or
- not Label_Widget_Pkg.Verify_Label (Mail_Widget, Mail_Label) then
- Report.Failed ("Incorrect result for Mail_Widget");
- end if;
-
- Report.Result;
-
-end CA11A01;
diff --git a/gcc/testsuite/ada/acats/tests/ca/ca11a02.a b/gcc/testsuite/ada/acats/tests/ca/ca11a02.a
deleted file mode 100644
index e7c161423fb..00000000000
--- a/gcc/testsuite/ada/acats/tests/ca/ca11a02.a
+++ /dev/null
@@ -1,156 +0,0 @@
--- CA11A02.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that a type extended in a client of a public child inherits
--- primitive operations from parent.
---
--- TEST DESCRIPTION:
--- Declare a root tagged type in a package specification. Declare two
--- primitive subprograms for the type (foundation code).
---
--- Add a public child to the above package. Extend the root type with
--- a record extension in the specification. Declare a new primitive
--- subprogram to write to the child extension.
---
--- In the main program, "with" the child. Declare an extension of
--- the child extension. Access the primitive operations from both
--- parent and child packages.
---
--- TEST FILES:
--- This test depends on the following foundation code:
---
--- FA11A00.A
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 20 Dec 94 SAIC Moved declaration of Label_Widget to library level
---
---!
-
-package FA11A00.CA11A02_0 is -- Color_Widget_Pkg
--- This public child declares an extension from its parent. It
--- represents processing of widgets in a window system.
-
- type Widget_Color_Enum is (Black, Green, White);
-
- type Color_Widget is new Widget with -- Record extension of
- record -- parent tagged type.
- Color : Widget_Color_Enum;
- end record;
-
- -- Inherits procedure Set_Width from parent.
- -- Inherits procedure Set_Height from parent.
-
- -- To be inherited by its derivatives.
- procedure Set_Color (The_Widget : in out Color_Widget;
- C : in Widget_Color_Enum);
-
-end FA11A00.CA11A02_0; -- Color_Widget_Pkg
-
---=======================================================================--
-
-package body FA11A00.CA11A02_0 is -- Color_Widget_Pkg
-
- procedure Set_Color (The_Widget : in out Color_Widget;
- C : in Widget_Color_Enum) is
- begin
- The_Widget.Color := C;
- end Set_Color;
-
-end FA11A00.CA11A02_0; -- Color_Widget_Pkg
-
---=======================================================================--
-
-with FA11A00.CA11A02_0; -- Color_Widget_Pkg.
-
-package CA11A02_1 is
-
- type Label_Widget (Str_Disc : Integer) is new
- FA11A00.CA11A02_0.Color_Widget with
- record
- Label : String (1 .. Str_Disc);
- end record;
-
- -- Inherits (inherited) procedure Set_Width from Color_Widget.
- -- Inherits (inherited) procedure Set_Height from Color_Widget.
- -- Inherits procedure Set_Color from Color_Widget.
-
-end CA11A02_1;
-
---=======================================================================--
-
-with FA11A00.CA11A02_0; -- Color_Widget_Pkg,
- -- implicitly with Widget_Pkg
-with CA11A02_1;
-
-with Report;
-
-procedure CA11A02 is
-
- package Widget_Pkg renames FA11A00;
- package Color_Widget_Pkg renames FA11A00.CA11A02_0;
-
- use Widget_Pkg; -- All user-defined operators directly visible.
-
- procedure Set_Label (The_Widget : in out CA11A02_1.Label_Widget;
- L : in String) is
- begin
- The_Widget.Label := L;
- end Set_Label;
- ---------------------------------------------------------
- procedure Set_Widget (The_Widget : in out CA11A02_1.Label_Widget;
- The_Width : in Widget_Length;
- The_Height : in Widget_Length;
- The_Color : in
- Color_Widget_Pkg.Widget_Color_Enum;
- The_Label : in String) is
- begin
- CA11A02_1.Set_Width (The_Widget, The_Width); -- Twice inherited.
- CA11A02_1.Set_Height (The_Widget, The_Height); -- Twice inherited.
- CA11A02_1.Set_Color (The_Widget, The_Color); -- Inherited.
- Set_Label (The_Widget, The_Label); -- Explicitly declared.
- end Set_Widget;
-
- White_Widget : CA11A02_1.Label_Widget (11);
-
-begin
-
- Report.Test ("CA11A02", "Check that a type extended in a client of " &
- "a public child inherits primitive operations from parent");
-
- Set_Widget (White_Widget, 15, 21, Color_Widget_Pkg.White, "Alarm_Clock");
-
- If White_Widget.Width /= Widget_Length (Report.Ident_Int (15)) or
- White_Widget.Height /= Widget_Length (Report.Ident_Int (21)) or
- Color_Widget_Pkg."/=" (White_Widget.Color, Color_Widget_Pkg.White) or
- White_Widget.Label /= "Alarm_Clock" then
- Report.Failed ("Incorrect result for White_Widget");
- end if;
-
- Report.Result;
-
-end CA11A02;
diff --git a/gcc/testsuite/ada/acats/tests/ca/ca11b01.a b/gcc/testsuite/ada/acats/tests/ca/ca11b01.a
deleted file mode 100644
index 8d6de02f1b6..00000000000
--- a/gcc/testsuite/ada/acats/tests/ca/ca11b01.a
+++ /dev/null
@@ -1,208 +0,0 @@
--- CA11B01.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that a type derived in a public child inherits primitive
--- operations from parent.
---
--- TEST DESCRIPTION:
--- Declare a root record type with discriminant in a package
--- specification. Declare a primitive subprogram for the type
--- (foundation code).
---
--- Add a public child to the above package. Derive a new type
--- with constraint to the discriminant record type from the parent
--- package. Declare a new primitive subprogram to write to the child
--- derived type.
---
--- Add a new public child to the above package. This grandchild package
--- derives a new type using the record type from the above package.
--- Declare a new primitive subprogram to write to the grandchild derived
--- type.
---
--- In the main program, "with" the grandchild. Access the inherited
--- operations from grandparent, parent, and grandchild packages.
---
--- TEST FILES:
--- This test depends on the following foundation code:
---
--- FA11B00.A
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
---
---!
-
--- Child package of FA11B00.
-package FA11B00.CA11B01_0 is -- Application_Two_Widget
--- This public child declares a derived type from its parent. It
--- represents processing of widgets in a window system.
-
- type App2_Widget is new App1_Widget (Maximum_Size => 5000);
- -- Inherits procedure Create_Widget from parent.
-
- -- Primitive operation of type App2_Widget.
- -- To be inherited by its children derivatives.
- procedure App2_Widget_Specific_Oper (The_Widget : in out App2_Widget;
- Loc : in Widget_Location);
-
-end FA11B00.CA11B01_0; -- Application_Two_Widget
-
---=======================================================================--
-
-package body FA11B00.CA11B01_0 is -- Application_Two_Widget
-
- procedure App2_Widget_Specific_Oper
- (The_Widget : in out App2_Widget;
- Loc : in Widget_Location) is
- begin
- The_Widget.Location := Loc;
- end App2_Widget_Specific_Oper;
-
-end FA11B00.CA11B01_0; -- Application_Two_Widget
-
---=======================================================================--
-
--- Grandchild package of FA11B00, child package of FA11B00.CA11B01_0.
-package FA11B00.CA11B01_0.CA11B01_1 is -- Application_Three_Widget
--- This public grandchild declares a derived type from its parent. It
--- represents processing of widgets in a window system.
-
- type App3_Widget is new App2_Widget; -- Derived record of App2_Widget.
-
- -- Inherits (inherited) procedure Create_Widget from Application_One_Widget.
- -- Inherits procedure App2_Widget_Specific_Oper from App2_Widget.
-
- -- Primitive operation of type App3_Widget.
- procedure App3_Widget_Specific_Oper (The_Widget : in out App3_Widget;
- S : in Widget_Size);
-
-end FA11B00.CA11B01_0.CA11B01_1; -- Application_Three_Widget
-
---=======================================================================--
-
-package body FA11B00.CA11B01_0.CA11B01_1 is -- Application_Three_Widget
-
- procedure App3_Widget_Specific_Oper
- (The_Widget : in out App3_Widget;
- S : in Widget_Size) is
- begin
- The_Widget.Size := S;
- end App3_Widget_Specific_Oper;
-
-end FA11B00.CA11B01_0.CA11B01_1; -- Application_Three_Widget
-
---=======================================================================--
-
-with FA11B00.CA11B01_0.CA11B01_1; -- Application_Three_Widget,
- -- implicitly with Application_Two_Widget,
- -- implicitly with Application_Three_Widget.
-with Report;
-
-procedure CA11B01 is
-
- package Application_One_Widget renames FA11B00;
- package Application_Two_Widget renames FA11B00.CA11B01_0;
- package Application_Three_Widget renames FA11B00.CA11B01_0.CA11B01_1;
-
- use Application_One_Widget;
- use Application_Two_Widget;
- use Application_Three_Widget;
-
-begin
-
- Report.Test ("CA11B01", "Check that a type derived in a public " &
- "child inherits primitive operations from parent");
-
- Application_One_Subtest:
- declare
- White_Widget : App1_Widget;
-
- begin
- -- perform an App1_Widget specific operation.
- App1_Widget_Specific_Oper (C => White, L => "Line Editor ",
- The_Widget => White_Widget, I => 10);
-
- If White_Widget.Color /= White or
- White_Widget.Id /= Widget_ID
- (Report.Ident_Int (10)) or
- White_Widget.Label /= "Line Editor " then
- Report.Failed ("Incorrect result for White_Widget");
- end if;
-
- end Application_One_Subtest;
- ---------------------------------------------------------------
- Application_Two_Subtest:
- declare
- Amber_Widget : App2_Widget;
-
- begin
- App1_Widget_Specific_Oper (Amber_Widget, I => 11,
- C => Amber, L => "Alarm_Clock ");
- -- Inherited from Application_One_Widget.
-
- -- perform an App2_Widget specific operation.
- App2_Widget_Specific_Oper (The_Widget => Amber_Widget, Loc => (380,512));
-
- If Amber_Widget.Color /= Amber or
- Amber_Widget.Id /= Widget_ID (Report.Ident_Int (11)) or
- Amber_Widget.Label /= "Alarm_Clock " or
- Amber_Widget.Location /= (380,512) then
- Report.Failed ("Incorrect result for Amber_Widget");
- end if;
-
- end Application_Two_Subtest;
- ---------------------------------------------------------------
- Application_Three_Subtest:
- declare
- Green_Widget : App3_Widget;
-
- begin
- App1_Widget_Specific_Oper (Green_Widget, 100, Green,
- "Screen Editor ");
- -- Inherited (inherited) from Basic_Widget.
-
- -- perform an App2_Widget specific operation.
- App2_Widget_Specific_Oper (Loc => (1024,760),
- The_Widget => Green_Widget);
- -- Inherited from App_1_Widget.
-
- -- perform an App3_Widget specific operation.
- App3_Widget_Specific_Oper (Green_Widget, S => (100,100));
-
- If Green_Widget.Color /= Green or
- Green_Widget.Id /= Widget_ID (Report.Ident_Int (100)) or
- Green_Widget.Label /= "Screen Editor " or
- Green_Widget.Location /= (1024,760) or
- Green_Widget.Size /= (100,100) then
- Report.Failed ("Incorrect result for Green_Widget");
- end if;
-
- end Application_Three_Subtest;
-
- Report.Result;
-
-end CA11B01;
diff --git a/gcc/testsuite/ada/acats/tests/ca/ca11b02.a b/gcc/testsuite/ada/acats/tests/ca/ca11b02.a
deleted file mode 100644
index 0743f73336b..00000000000
--- a/gcc/testsuite/ada/acats/tests/ca/ca11b02.a
+++ /dev/null
@@ -1,169 +0,0 @@
--- CA11B02.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that a type derived in a client of a public child inherits
--- primitive operations from parent.
---
--- TEST DESCRIPTION:
--- Declare a root record type with discriminant in a package
--- specification. Declare a primitive subprogram for the type
--- (foundation code).
---
--- Add a public child to the above package. Derive a new type
--- with constraint to the discriminant record type from the parent
--- package. Declare a new primitive subprogram to write to the child
--- derived type.
---
--- In the main program, "with" the child. Derive a new type using the
--- record type from the child package. Access the inherited operations
--- from both parent and child packages.
---
--- TEST FILES:
--- This test depends on the following foundation code:
---
--- FA11B00.A
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
---
---!
-
--- Child package of FA11B00.
-package FA11B00.CA11B02_0 is -- Application_Two_Widget
--- This public child declares a derived type from its parent. It
--- represents processing of widgets in a window system.
-
- -- Dimension of app2_widget is limited to 5000 pixels.
-
- type App2_Widget is new App1_Widget (Maximum_Size => 5000);
- -- Derived record of parent type.
-
- -- Inherits procedure App1_Widget_Specific_Oper from parent.
-
-
- -- Primitive operation of type App2_Widget.
-
- procedure App2_Widget_Specific_Op1 (The_Widget : in out App2_Widget;
- S : in Widget_Size);
-
- -- Primitive operation of type App2_Widget.
-
- procedure App2_Widget_Specific_Op2 (The_Widget : in out App2_Widget;
- Loc : in Widget_Location);
-
-end FA11B00.CA11B02_0; -- Application_Two_Widget
-
-
---=======================================================================--
-
-
-package body FA11B00.CA11B02_0 is -- Application_Two_Widget
-
- procedure App2_Widget_Specific_Op1 (The_Widget : in out App2_Widget;
- S : in Widget_Size) is
- begin
- The_Widget.Size := S;
- end App2_Widget_Specific_Op1;
-
- --==============================================--
-
- procedure App2_Widget_Specific_Op2 (The_Widget : in out App2_Widget;
- Loc : in Widget_Location) is
- begin
- The_Widget.Location := Loc;
- end App2_Widget_Specific_Op2;
-
-end FA11B00.CA11B02_0; -- Application_Two_Widget
-
-
---=======================================================================--
-
-with FA11B00.CA11B02_0; -- Application_Two_Widget
- -- implicitly with Application_One_Widget.
-with Report;
-
-procedure CA11B02 is
-
- package Application_One_Widget renames FA11B00;
-
- package Application_Two_Widget renames FA11B00.CA11B02_0;
-
- use Application_One_Widget ;
- use Application_Two_Widget ;
-
- type Emulator_Widget is new App2_Widget; -- Derived record of
- -- parent type.
-
- White_Widget, Amber_Widget : Emulator_Widget;
-
-
-begin
-
- Report.Test ("CA11B02", "Check that a type derived in client of a " &
- "public child inherits primitive operations from parent");
-
- App1_Widget_Specific_Oper (C => White, L => "Line Editor ",
- The_Widget => White_Widget, I => 10);
- -- Inherited from Application_One_Widget.
- If White_Widget.Color /= White or
- White_Widget.Id /= Widget_ID (Report.Ident_Int (10)) or
- White_Widget.Label /= "Line Editor "
- then
- Report.Failed ("Incorrect result for White_Widget");
- end if;
-
- -- perform an App2_Widget specific operation.
-
- App2_Widget_Specific_Op1 (White_Widget, S => (100, 200));
-
- If White_Widget.Size.X_Length /= 100 or
- White_Widget.Size.Y_Length /= 200
- then
- Report.Failed ("Incorrect size for White_Widget");
- end if;
-
- App1_Widget_Specific_Oper (Amber_Widget, 5, Amber, "Screen Editor ");
- -- Inherited from Application_One_Widget.
-
- -- perform an App2_Widget specific operations.
-
- App2_Widget_Specific_Op1 (S => (1024,100), The_Widget => Amber_Widget);
- App2_Widget_Specific_Op2 (Amber_Widget, (1024, 760));
-
- If Amber_Widget.Color /= Amber or
- Amber_Widget.Id /= Widget_ID (Report.Ident_Int (5)) or
- Amber_Widget.Label /= "Screen Editor " or
- Amber_Widget.Size /= (1024,100) or
- Amber_Widget.Location.X_Location /= 1024 or
- Amber_Widget.Location.Y_Location /= 760
- then
- Report.Failed ("Incorrect result for Amber_Widget");
- end if;
-
- Report.Result;
-
-end CA11B02;
diff --git a/gcc/testsuite/ada/acats/tests/ca/ca11c01.a b/gcc/testsuite/ada/acats/tests/ca/ca11c01.a
deleted file mode 100644
index 195ec2d40e8..00000000000
--- a/gcc/testsuite/ada/acats/tests/ca/ca11c01.a
+++ /dev/null
@@ -1,170 +0,0 @@
--- CA11C01.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that when primitive operations declared in a child package
--- override operations declared in ancestor packages, a client of the
--- child package inherits the operations correctly.
---
--- TEST DESCRIPTION:
---
--- This test builds on the foundation code file (FA11C00) that contains
--- a parent package, child package, and grandchild package. The parent
--- package declares a tagged type and primitive operation. The child
--- package extends the type, and overrides the primitive operation. The
--- grandchild package does the same.
---
--- The test procedure "withs" the grandchild package, and receives
--- visibility to all of its ancestor packages, types and operations.
--- Three procedures, each with a formal parameter of a specific type are
--- defined. Each of these invokes a particular version of the overridden
--- primitive operation Image. Calls to these local procedures are made,
--- with objects of each of the tagged types as parameters, and the global
--- variable is finally examined to ensure that the correct version of
--- primitive operation was inherited by the client and invoked by the
--- call.
---
--- TEST FILES:
--- This test depends on the following foundation code:
---
--- FA11C00.A
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
---
---!
-
-with FA11C00_0.FA11C00_1.FA11C00_2; -- Package Animal.Mammal.Primate
-with Report;
-
-procedure CA11C01 is
-
- package Animal_Package renames FA11C00_0;
- package Mammal_Package renames FA11C00_0.FA11C00_1;
- package Primate_Package renames FA11C00_0.FA11C00_1.FA11C00_2;
-
- Max_Animals : constant := 3;
-
- subtype Data_String is String (1 .. 37);
- type Data_Base_Type is array (1 .. Max_Animals) of Data_String;
-
- Zoo_Data_Base : Data_Base_Type := (others => (others => ' '));
- -- Global variable.
-
- Salmon : Animal_Package.Animal := (Common_Name => "Chinook Salmon ",
- Weight => 10);
-
- Platypus : Mammal_Package.Mammal := (Common_Name => "Tasmanian Platypus ",
- Weight => 13,
- Hair_Color => Mammal_Package.Brown);
-
- Orangutan : Primate_Package.Primate :=
- (Common_Name => "Sumatran Orangutan ",
- Weight => 220,
- Hair_Color => Mammal_Package.Red,
- Habitat => Primate_Package.Arboreal);
-begin
-
- Report.Test ("CA11C01", "Check that when primitive operations declared " &
- "in a child package override operations declared " &
- "in ancestor packages, a client of the child " &
- "package inherits the operations correctly");
-
- declare
-
- use Animal_Package, Mammal_Package, Primate_Package;
-
- -- The function Image has been overridden in the child and grandchild
- -- packages, but the client has inherited all versions of the function,
- -- and can successfully use them to enter data into the database.
- -- Each of the following procedures updates the global variable
- -- Zoo_Data_Base.
-
- procedure Enter_Animal_Data (A : Animal; I : Integer) is
- begin
- Zoo_Data_Base (I) := Image (A);
- end Enter_Animal_Data;
-
- procedure Enter_Mammal_Data (M : Mammal; I : Integer) is
- begin
- Zoo_Data_Base (I) := Image (M);
- end Enter_Mammal_Data;
-
- procedure Enter_Primate_Data (P : Primate; I : Integer) is
- begin
- Zoo_Data_Base (I) := Image (P);
- end Enter_Primate_Data;
-
- begin
-
- -- Verify initial test conditions.
-
- if not (Zoo_Data_Base(1)(1..6) = " ")
- or else
- (Zoo_Data_Base(2)(1..6) /= " ")
- or else
- (Zoo_Data_Base(3)(1..6) /= " ")
- then
- Report.Failed ("Initial condition failure");
- end if;
-
-
- -- Enter data from all three animals into the zoo database.
-
- Enter_Animal_Data (A => Salmon, I => 1); -- First entry in database.
- Enter_Mammal_Data (M => Platypus, I => 2); -- Second entry.
- Enter_Primate_Data (P => Orangutan, I => 3); -- Third entry.
-
- -- Verify the correct version of the overridden function Image was used
- -- for entering the specific data.
-
- if Zoo_Data_Base(1)(1 .. 6) /= "Animal"
- or else
- Zoo_Data_Base(1)(26 .. 31) /= "Salmon"
- then
- Report.Failed ("Incorrect version of Image for parent type");
- end if;
-
- if (Zoo_Data_Base(2)(1 .. 6) /= "Mammal")
- or
- (Zoo_Data_Base(2)(28 .. 35) /= "Platypus")
- then
- Report.Failed ("Incorrect version of Image for child type");
- end if;
-
- if ((Zoo_Data_Base(3)(1 .. 7) /= "Primate")
- or
- (Zoo_Data_Base(3)(27 .. 35) /= "Orangutan"))
- then
- Report.Failed ("Incorrect version of Image for grandchild type");
- end if;
-
- end;
-
-
- Report.Result;
-
-end CA11C01;
diff --git a/gcc/testsuite/ada/acats/tests/ca/ca11c02.a b/gcc/testsuite/ada/acats/tests/ca/ca11c02.a
deleted file mode 100644
index 7d8749328c0..00000000000
--- a/gcc/testsuite/ada/acats/tests/ca/ca11c02.a
+++ /dev/null
@@ -1,158 +0,0 @@
--- CA11C02.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that primitive operations declared in a child package
--- override operations declared in ancestor packages, and that
--- operations on class-wide types defined in the ancestor packages
--- dispatch as appropriate to these overriding implementations.
---
--- TEST DESCRIPTION:
---
--- This test builds on the foundation code file (FA11C00) that contains
--- a parent package, child package, and grandchild package. The parent
--- package declares a tagged type and primitive operation. The child
--- package extends the type, and overrides the primitive operation. The
--- grandchild package does the same.
---
--- The test procedure "withs" the grandchild package, and receives
--- visibility to all of its ancestor packages, types and operations.
--- A procedure with a formal class-wide parameter is defined that will
--- allow for dispatching calls to the overridden primitive operations,
--- based on the specific type of the actual parameter. The primitive
--- operations provide a string value to update a global string array
--- variable. Calls to the local procedure are made, with objects of each
--- of the tagged types as parameters, and the global variable is finally
--- examined to ensure that the correct version of primitive operation was
--- dispatched correctly.
---
--- TEST FILES:
--- This test depends on the following foundation code:
---
--- FA11C00.A
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
---
---!
-
-with FA11C00_0.FA11C00_1.FA11C00_2; -- Package Animal.Mammal.Primate
-with Report;
-
-procedure CA11C02 is
-
- package Animal_Package renames FA11C00_0;
- package Mammal_Package renames FA11C00_0.FA11C00_1;
- package Primate_Package renames FA11C00_0.FA11C00_1.FA11C00_2;
-
- Max_Animals : constant := 3;
-
- type Data_Base_Type is array (1 .. Max_Animals) of String (1 .. 37);
-
- Zoo_Data_Base : Data_Base_Type := (others => (others => ' '));
- -- Global variable.
-
- Macaw : Animal_Package.Animal := (Common_Name => "Scarlet Macaw ",
- Weight => 2);
-
- Manatee : Mammal_Package.Mammal := (Common_Name => "Southern Manatee ",
- Weight => 230,
- Hair_Color => Mammal_Package.Brown);
-
- Lemur : Primate_Package.Primate :=
- (Common_Name => "Ring-Tailed Lemur ",
- Weight => 5,
- Hair_Color => Mammal_Package.Black,
- Habitat => Primate_Package.Arboreal);
-begin
-
- Report.Test ("CA11C02", "Check that primitive operations declared " &
- "in a child package override operations declared " &
- "in ancestor packages, and that operations " &
- "on class-wide types defined in the ancestor " &
- "packages dispatch as appropriate to these " &
- "overriding implementations");
-
- declare
-
- use Animal_Package, Mammal_Package, Primate_Package;
-
- -- The following procedure updates the global variable Zoo_Data_Base.
-
- procedure Enter_Data (A : Animal'Class; I : Integer) is
- begin
- Zoo_Data_Base (I) := Image (A);
- end Enter_Data;
-
- begin
-
- -- Verify initial test conditions.
-
- if not (Zoo_Data_Base(1)(1..6) = " ")
- or not
- (Zoo_Data_Base(2)(1..6) = " ")
- or not
- (Zoo_Data_Base(3)(1..6) = " ")
- then
- Report.Failed ("Initial condition failure");
- end if;
-
-
- -- Enter data from all three animals into the zoo database.
-
- Enter_Data (Macaw, 1); -- First entry in database.
- Enter_Data (A => Manatee, I => 2); -- Second entry.
- Enter_Data (Lemur, I => 3); -- Third entry.
-
- -- Verify the correct version of the overridden function Image was used
- -- for entering the specific data.
-
- if not (Zoo_Data_Base(1)(1 .. 6) = "Animal")
- or not
- (Zoo_Data_Base(1)(26 .. 30) = "Macaw")
- then
- Report.Failed ("Incorrect version of Image for parent type");
- end if;
-
- if not (Zoo_Data_Base(2)(1 .. 6) = "Mammal"
- and
- Zoo_Data_Base(2)(27 .. 33) = "Manatee")
- then
- Report.Failed ("Incorrect version of Image for child type");
- end if;
-
- if not ((Zoo_Data_Base(3)(1 .. 7) = "Primate")
- and
- (Zoo_Data_Base(3)(30 .. 34) = "Lemur"))
- then
- Report.Failed ("Incorrect version of Image for grandchild type");
- end if;
-
- end;
-
- Report.Result;
-
-end CA11C02;
diff --git a/gcc/testsuite/ada/acats/tests/ca/ca11c03.a b/gcc/testsuite/ada/acats/tests/ca/ca11c03.a
deleted file mode 100644
index b75a6603483..00000000000
--- a/gcc/testsuite/ada/acats/tests/ca/ca11c03.a
+++ /dev/null
@@ -1,186 +0,0 @@
--- CA11C03.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that when a child unit is "withed", visibility is obtained to
--- all ancestor units named in the expanded name of the "withed" child
--- unit. Check that when the parent unit is "used", the simple name of
--- a "withed" child unit is made directly visible.
---
--- TEST DESCRIPTION:
--- To satisfy the first part of the objective, various references are
--- made to types and functions declared in the ancestor packages of the
--- foundation code package hierarchy. Since the grandchild library unit
--- package has been "withed" by this test, the visibility of these
--- components demonstrates that visibility of the ancestor package names
--- is provided when the expanded name of a child library unit is "withed".
---
--- The declare block in the test program includes a "use" clause of the
--- parent package (FA11C00_0.FA11C00_1) of the "withed" child package.
--- As a result, the simple name of the child package (FA11C00_2) is
--- directly visible. The type and function declared in the child
--- package are now visible when qualified with the simple name of the
--- "withed" package (FA11C00_2).
---
--- This test simulates the formatting of data strings, based on the
--- component fields of a "doubly-extended" tagged record type.
---
--- TEST FILES:
--- This test depends on the following foundation code:
---
--- FA11C00.A
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
---
---!
-
-with FA11C00_0.FA11C00_1.FA11C00_2; -- "with" of child library package
- -- Animal.Mammal.Primate.
- -- This will be used in conjunction with
- -- a "use" of FA11C00_0.FA11C00_1 below
- -- to verify a portion of the objective.
-with Report;
-
-procedure CA11C03 is
-
- Blank_Name_String : constant FA11C00_0.Species_Name_Type := (others => ' ');
- -- Visibility of grandparent package.
- -- The package FA11C00_0 is visible since
- -- it is an ancestor that is mentioned in
- -- the expanded name of its "withed"
- -- grandchild package.
-
- Blank_Hair_Color :
- String (1..FA11C00_0.FA11C00_1.Hair_Color_Type'Width) := (others => ' ');
- -- Visibility of parent package.
- -- The package FA11C00_0.FA11C00_1 is
- -- visible due to the "with" of its
- -- child package.
-
- subtype Data_String_Type is String (1 .. 60);
-
- TC_Result_String : Data_String_Type := (others => ' ');
-
- --
-
- function Format_Primate_Data (Name : String := Blank_Name_String;
- Hair : String := Blank_Hair_Color)
- return Data_String_Type is
-
- Pos : Integer := 1;
- Hair_Color_Field_Separator : constant String := " Hair Color: ";
-
- Result_String : Data_String_Type := (others => ' ');
-
- begin
- Result_String (Pos .. Name'Length) := Name; -- Enter name at start
- -- of string.
- Pos := Pos + Name'Length; -- Increment counter to
- -- next blank position.
- Result_String
- (Pos .. Pos + Hair_Color_Field_Separator'Length + Hair'Length - 1) :=
- Hair_Color_Field_Separator & Hair; -- Include hair color data
- -- in result string.
- return (Result_String);
- end Format_Primate_Data;
-
-
-begin
-
- Report.Test ("CA11C03", "Check that when a child unit is WITHED, " &
- "visibility is obtained to all ancestor units " &
- "named in the expanded name of the WITHED child " &
- "unit. Check that when the parent unit is USED, " &
- "the simple name of a WITHED child unit is made " &
- "directly visible" );
-
- declare
- use FA11C00_0.FA11C00_1; -- This "use" clause will allow direct
- -- visibility to the simple name of
- -- package FA11C00_0.FA11C00_1.FA11C00_2,
- -- since this child package was "withed" by
- -- the main program.
-
- Tarsier : FA11C00_2.Primate := (Common_Name => "East-Indian Tarsier ",
- Weight => 7,
- Hair_Color => Brown,
- Habitat => FA11C00_2.Arboreal);
-
- -- Demonstrates visibility of package
- -- FA11C00_0.FA11C00_1.FA11C00_2.
- --
- -- Type Primate referenced with the simple
- -- name of package FA11C00_2 only.
- --
- -- Simple name of package FA11C00_2 is
- -- directly visible through "use" of parent.
-
- begin
-
- -- Verify that the Format_Primate_Data function will return a blank
- -- filled string when no parameters are provided in the call.
-
- TC_Result_String := Format_Primate_Data;
-
- if (TC_Result_String (1 .. 20) /= Blank_Name_String) then
- Report.Failed ("Incorrect initialization value from function");
- end if;
-
-
- -- Use function Format_Primate_Data to return a formatted data string.
-
- TC_Result_String :=
- Format_Primate_Data
- (Name => FA11C00_2.Image (Tarsier),
- -- Function returns a 37 character string
- -- value.
- Hair => Hair_Color_Type'Image(Tarsier.Hair_Color));
- -- The Hair_Color_Type is referenced
- -- directly, without package
- -- FA11C00_0.FA11C00_1 qualifier.
- -- No qualification of Hair_Color_Type is
- -- needed due to "use" clause.
-
- -- Note that the result of calling 'Image
- -- with an enumeration type argument
- -- results in an upper-case string.
- -- (See conditional statement below.)
-
- -- Verify the results of the function call.
-
- if not (TC_Result_String (1 .. 37) =
- "Primate Species: East-Indian Tarsier " and then
- TC_Result_String (38 .. 55) =
- " Hair Color: BROWN") then
- Report.Failed ("Incorrect result returned from function call");
- end if;
-
- end;
-
- Report.Result;
-
-end CA11C03;
diff --git a/gcc/testsuite/ada/acats/tests/ca/ca11d010.a b/gcc/testsuite/ada/acats/tests/ca/ca11d010.a
deleted file mode 100644
index 7ea0e226775..00000000000
--- a/gcc/testsuite/ada/acats/tests/ca/ca11d010.a
+++ /dev/null
@@ -1,119 +0,0 @@
--- CA11D010.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- See CA11D013.AM
---
--- TEST DESCRIPTION:
--- See CA11D013.AM
---
--- TEST FILES:
--- The following files comprise this test:
---
--- FA11D00.A
--- => CA11D010.A
--- CA11D011.A
--- CA11D012.A
--- CA11D013.AM
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 26 Apr 96 SAIC ACVC 2.1: Modified prologue.
---
---!
-
--- Child package of FA11D00.
-
-package FA11D00.CA11D010 is -- Add_Subtract_Complex
-
- procedure Add (Left, Right : in Complex_Type; -- Add two complex
- C : out Complex_Type); -- numbers.
-
- function Subtract (Left, Right : Complex_Type) -- Subtract two
- return Complex_Type; -- complex numbers.
-
-
-
-end FA11D00.CA11D010; -- Add_Subtract_Complex
-
---=======================================================================--
-
-with Report;
-
-package body FA11D00.CA11D010 is -- Add_Subtract_Complex
-
- procedure Add (Left, Right : in Complex_Type;
- C : out Complex_Type) is
- begin
- -- Zero is declared in parent package.
-
- if Left.Real < Zero.Real or else Right.Real < Zero.Real
- or else Left.Imag < Zero.Imag or else Right.Imag < Zero.Imag then
- raise Add_Error; -- Reference to exception in parent package.
- Report.Failed ("Program control not transferred by raise in " &
- "procedure Add");
- else
- C.Real := (Left.Real + Right.Real);
- C.Imag := (Left.Imag + Right.Imag);
- end if;
-
- exception
- when Add_Error =>
- TC_Handled_In_Child_Pkg_Proc := true;
- C := Check_Value; -- Reference to object in parent package.
- raise; -- Reraise the Add_Error exception in the subtest.
- Report.Failed ("Exception not reraised in handler");
-
- when others =>
- Report.Failed ("Unexpected exception raised in Add");
-
- end Add;
- -----------------------------------------------------------
- function Subtract (Left, Right : Complex_Type)
- return Complex_Type is
- begin
- -- Zero is declared in parent package.
- if Left.Real < Zero.Real or Right.Real < Zero.Real
- or Left.Imag < Zero.Imag or Right.Imag < Zero.Imag then
- raise Subtract_Error; -- Reference to exception in parent package.
- Report.Failed ("Program control not transferred by raise in " &
- "function Subtract");
- else
- return ( Real => (Left.Real - Right.Real),
- Imag => (Left.Imag - Right.Imag) );
- end if;
-
- exception
- when Subtract_Error =>
- Report.Comment ("Exception is properly handled in Subtract");
- TC_Handled_In_Child_Pkg_Func := true;
- return Check_Value;
-
- when others =>
- Report.Failed ("Unexpected exception raised in Subtract");
-
- end Subtract;
-
-end FA11D00.CA11D010; -- Add_Subtract_Complex
diff --git a/gcc/testsuite/ada/acats/tests/ca/ca11d011.a b/gcc/testsuite/ada/acats/tests/ca/ca11d011.a
deleted file mode 100644
index 014f74be78a..00000000000
--- a/gcc/testsuite/ada/acats/tests/ca/ca11d011.a
+++ /dev/null
@@ -1,79 +0,0 @@
--- CA11D011.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- See CA11D013.AM
---
--- TEST DESCRIPTION:
--- See CA11D013.AM
---
--- TEST FILES:
--- The following files comprise this test:
---
--- FA11D00.A
--- CA11D010.A
--- => CA11D011.A
--- CA11D012.A
--- CA11D013.AM
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 21 Dec 94 SAIC Declared child procedure specification
--- 26 Apr 96 SAIC ACVC 2.1: Modified prologue.
---
---!
-
-with Report;
-
-
--- Child procedure of FA11D00.
-
-procedure FA11D00.CA11D011 (Left, Right : in Complex_Type;
- C : out Complex_Type);
-
---=======================================================================--
-
-procedure FA11D00.CA11D011 (Left, Right : in Complex_Type;
- C : out Complex_Type) is
--- Multiply_Complex.
-
-begin
- -- Zero is declared in parent package.
-
- if Left.Real < Zero.Real or Right.Imag < Zero.Imag then
- raise Multiply_Error; -- Reference to exception in parent package.
- Report.Failed ("Program control not transferred by raise in " &
- "child procedure FA11D00.CA11D011");
- else
- C.Real := (Left.Real * Right.Real);
- C.Imag := (Left.Imag * Right.Imag);
- end if;
-
- exception
- when others =>
- TC_Handled_In_Child_Sub := true;
- C := Check_Value; -- Reference to object in parent package.
-
-end FA11D00.CA11D011; -- Multiply_Complex
diff --git a/gcc/testsuite/ada/acats/tests/ca/ca11d012.a b/gcc/testsuite/ada/acats/tests/ca/ca11d012.a
deleted file mode 100644
index 1bb3bd7ac02..00000000000
--- a/gcc/testsuite/ada/acats/tests/ca/ca11d012.a
+++ /dev/null
@@ -1,73 +0,0 @@
--- CA11D012.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- See CA11D013.AM
---
--- TEST DESCRIPTION:
--- See CA11D013.AM
---
--- TEST FILES:
--- The following files comprise this test:
---
--- FA11D00.A
--- CA11D010.A
--- CA11D011.A
--- => CA11D012.A
--- CA11D013.AM
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 21 Dec 94 SAIC Declared child function specification
--- 26 Apr 96 SAIC ACVC 2.1: Modified prologue.
---
---!
-
-with Report;
-
--- Child function of FA11D00.
--- Does not divide zero complex numbers.
-
-function FA11D00.CA11D012 (Left, Right : Complex_Type)
- return Complex_Type;
-
---=======================================================================--
-
-function FA11D00.CA11D012 (Left, Right : Complex_Type)
- return Complex_Type is -- Divide_Complex
-
-begin
- -- Zero is declared in parent package.
-
- if Right.Real = Zero.Real or Right.Imag = Zero.Imag then
- raise Divide_Error; -- Reference to exception in parent package.
- Report.Failed ("Program control not transferred by raise in " &
- "child function FA11D00.CA11D012");
- else
- return ( Real => (Left.Real / Right.Real),
- Imag => (Left.Imag / Right.Imag) );
- end if;
-
-end FA11D00.CA11D012; -- Divide_Complex
diff --git a/gcc/testsuite/ada/acats/tests/ca/ca11d02.a b/gcc/testsuite/ada/acats/tests/ca/ca11d02.a
deleted file mode 100644
index 7b4f48869b2..00000000000
--- a/gcc/testsuite/ada/acats/tests/ca/ca11d02.a
+++ /dev/null
@@ -1,393 +0,0 @@
--- CA11D02.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that an exception declared in a package can be raised by a
--- child of a child package. Check that it can be renamed in the
--- child of the child package and raised with the correct effect.
---
--- TEST DESCRIPTION:
--- Declare a package which defines complex number abstraction with
--- user-defined exceptions (foundation code).
---
--- Add a public child package to the above package. Declare two
--- subprograms for the parent type.
---
--- Add a public grandchild package to the foundation package. Declare
--- subprograms to raise exceptions.
---
--- In the main program, "with" the grandchild package, then check that
--- the exceptions are raised and handled as expected. Ensure that
--- exceptions are:
--- 1) raised in the public grandchild package and handled/reraised to
--- be handled by the main program.
--- 2) raised and handled locally by the "others" handler in the
--- public grandchild package.
--- 3) raised in the public grandchild and propagated to the main
--- program.
---
--- TEST FILES:
--- This test depends on the following foundation code:
---
--- FA11D00.A
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
---
---!
-
--- Child package of FA11D00.
-
-package FA11D00.CA11D02_0 is -- Basic_Complex
-
- function "+" (Left, Right : Complex_Type)
- return Complex_Type; -- Add two complex numbers.
-
- function "*" (Left, Right : Complex_Type)
- return Complex_Type; -- Multiply two complex numbers.
-
-end FA11D00.CA11D02_0; -- Basic_Complex
-
---=======================================================================--
-
-package body FA11D00.CA11D02_0 is -- Basic_Complex
-
- function "+" (Left, Right : Complex_Type) return Complex_Type is
- begin
- return ( (Left.Real + Right.Real, Left.Imag + Right.Imag) );
- end "+";
- --------------------------------------------------------------
- function "*" (Left, Right : Complex_Type) return Complex_Type is
- begin
- return ( Real => (Left.Real * Right.Real),
- Imag => (Left.Imag * Right.Imag) );
- end "*";
-
-end FA11D00.CA11D02_0; -- Basic_Complex
-
---=======================================================================--
-
--- Child package of FA11D00.CA11D02_0.
--- Grandchild package of FA11D00.
-
-package FA11D00.CA11D02_0.CA11D02_1 is -- Array_Complex
-
- Inverse_Error : exception renames Divide_Error; -- Reference to exception
- -- in grandparent package.
- Array_Size : constant := 2;
-
- type Complex_Array_Type is
- array (1 .. Array_Size) of Complex_Type; -- Reference to type
- -- in parent package.
-
- function Multiply (Left : Complex_Array_Type; -- Multiply two complex
- Right : Complex_Array_Type) -- arrays.
- return Complex_Array_Type;
-
- function Add (Left, Right : Complex_Array_Type) -- Add two complex
- return Complex_Array_Type; -- arrays.
-
- procedure Inverse (Right : in Complex_Array_Type; -- Invert a complex
- Left : in out Complex_Array_Type); -- array.
-
-end FA11D00.CA11D02_0.CA11D02_1; -- Array_Complex
-
---=======================================================================--
-
-with Report;
-
-
-package body FA11D00.CA11D02_0.CA11D02_1 is -- Array_Complex
-
- function Multiply (Left : Complex_Array_Type;
- Right : Complex_Array_Type)
- return Complex_Array_Type is
-
- -- This procedure will raise an exception depending on the input
- -- parameter. The exception will be handled locally by the
- -- "others" handler.
-
- Result : Complex_Array_Type := (others => Zero);
-
- subtype Vector_Size is Positive range Left'Range;
-
- begin
- if Left = Result or else Right = Result then -- Do not multiply zero.
- raise Multiply_Error; -- Refence to exception in
- -- grandparent package.
- Report.Failed ("Program control not transferred by raise");
- else
- for I in Vector_Size loop
- Result(I) := ( Left(I) * Right(I) ); -- Basic_Complex."*".
- end loop;
- end if;
- return (Result);
-
- exception
- when others =>
- Report.Comment ("Exception is handled by others in Multiplication");
- TC_Handled_In_Grandchild_Pkg_Func := true;
- return (Zero, Zero);
-
- end Multiply;
- --------------------------------------------------------------
- function Add (Left, Right : Complex_Array_Type)
- return Complex_Array_Type is
-
- -- This function will raise an exception depending on the input
- -- parameter. The exception will be propagated and handled
- -- by the caller.
-
- Result : Complex_Array_Type := (others => Zero);
-
- subtype Vector_Size is Positive range Left'Range;
-
- begin
- if Left = Result or Right = Result then -- Do not add zero.
- raise Add_Error; -- Refence to exception in
- -- grandparent package.
- Report.Failed ("Program control not transferred by raise");
- else
- for I in Vector_Size loop
- Result(I) := ( Left(I) + Right(I) ); -- Basic_Complex."+".
- end loop;
- end if;
- return (Result);
-
- end Add;
- --------------------------------------------------------------
- procedure Inverse (Right : in Complex_Array_Type;
- Left : in out Complex_Array_Type) is
-
- -- This function will raise an exception depending on the input
- -- parameter. The exception will be handled/reraised to be
- -- handled by the caller.
-
- Result : Complex_Array_Type := (others => Zero);
-
- Array_With_Zero : boolean := false;
-
- begin
- for I in 1 .. Right'Length loop
- if Right(I) = Zero then -- Check for zero.
- Array_With_Zero := true;
- end if;
- end loop;
-
- If Array_With_Zero then
- raise Inverse_Error; -- Do not inverse zero.
- Report.Failed ("Program control not transferred by raise");
- else
- for I in 1 .. Array_Size loop
- Left(I).Real := - Right(I).Real;
- Left(I).Imag := - Right(I).Imag;
- end loop;
- end if;
-
- exception
- when Inverse_Error =>
- TC_Handled_In_Grandchild_Pkg_Proc := true;
- Left := Result;
- raise; -- Reraise the Inverse_Error exception in the subtest.
- Report.Failed ("Exception not reraised in handler");
-
- when others =>
- Report.Failed ("Unexpected exception in procedure Inverse");
- end Inverse;
-
-end FA11D00.CA11D02_0.CA11D02_1; -- Array_Complex
-
---=======================================================================--
-
-with FA11D00.CA11D02_0.CA11D02_1; -- Array_Complex,
- -- implicitly with Basic_Complex.
-with Report;
-
-procedure CA11D02 is
-
- package Complex_Pkg renames FA11D00;
- package Array_Complex_Pkg renames FA11D00.CA11D02_0.CA11D02_1;
-
- use Complex_Pkg;
- use Array_Complex_Pkg;
-
-begin
-
- Report.Test ("CA11D02", "Check that an exception declared in a package " &
- "can be raised by a child of a child package");
-
- Multiply_Complex_Subtest:
- declare
- Operand_1 : Complex_Array_Type
- := ( Complex (Int_Type (Report.Ident_Int (3)),
- Int_Type (Report.Ident_Int (5))),
- Complex (Int_Type (Report.Ident_Int (2)),
- Int_Type (Report.Ident_Int (8))) );
- Operand_2 : Complex_Array_Type
- := ( Complex (Int_Type (Report.Ident_Int (1)),
- Int_Type (Report.Ident_Int (2))),
- Complex (Int_Type (Report.Ident_Int (3)),
- Int_Type (Report.Ident_Int (6))) );
- Operand_3 : Complex_Array_Type := ( Zero, Zero);
- Mul_Result : Complex_Array_Type
- := ( Complex (Int_Type (Report.Ident_Int (3)),
- Int_Type (Report.Ident_Int (10))),
- Complex (Int_Type (Report.Ident_Int (6)),
- Int_Type (Report.Ident_Int (48))) );
- Complex_No : Complex_Array_Type := (others => Zero);
-
- begin
- If (Multiply (Operand_1, Operand_2) /= Mul_Result) then
- Report.Failed ("Incorrect results from multiplication");
- end if;
-
- -- Error is raised and exception will be handled in grandchild package.
-
- Complex_No := Multiply (Operand_1, Operand_3);
-
- if Complex_No /= (Zero, Zero) then
- Report.Failed ("Exception was not raised in multiplication");
- end if;
-
- exception
- when Multiply_Error =>
- Report.Failed ("Exception raised in multiplication and " &
- "propagated to caller");
- TC_Handled_In_Grandchild_Pkg_Func := false;
- -- Improper exception handling in caller.
-
- when others =>
- Report.Failed ("Unexpected exception in multiplication");
- TC_Handled_In_Grandchild_Pkg_Func := false;
- -- Improper exception handling in caller.
-
- end Multiply_Complex_Subtest;
-
-
- Add_Complex_Subtest:
- declare
- Operand_1 : Complex_Array_Type
- := ( Complex (Int_Type (Report.Ident_Int (2)),
- Int_Type (Report.Ident_Int (7))),
- Complex (Int_Type (Report.Ident_Int (5)),
- Int_Type (Report.Ident_Int (8))) );
- Operand_2 : Complex_Array_Type
- := ( Complex (Int_Type (Report.Ident_Int (4)),
- Int_Type (Report.Ident_Int (1))),
- Complex (Int_Type (Report.Ident_Int (2)),
- Int_Type (Report.Ident_Int (3))) );
- Operand_3 : Complex_Array_Type := ( Zero, Zero);
- Add_Result : Complex_Array_Type
- := ( Complex (Int_Type (Report.Ident_Int (6)),
- Int_Type (Report.Ident_Int (8))),
- Complex (Int_Type (Report.Ident_Int (7)),
- Int_Type (Report.Ident_Int (11))) );
- Complex_No : Complex_Array_Type := (others => Zero);
-
- begin
- Complex_No := Add (Operand_1, Operand_2);
-
- If (Complex_No /= Add_Result) then
- Report.Failed ("Incorrect results from addition");
- end if;
-
- -- Error is raised in grandchild package and exception
- -- will be propagated to caller.
-
- Complex_No := Add (Operand_1, Operand_3);
-
- if Complex_No = Add_Result then
- Report.Failed ("Exception was not raised in addition");
- end if;
-
- exception
- when Add_Error =>
- TC_Propagated_To_Caller := true; -- Exception is propagated.
-
- when others =>
- Report.Failed ("Unexpected exception in addition subtest");
- TC_Propagated_To_Caller := false; -- Improper exception handling
- -- in caller.
- end Add_Complex_Subtest;
-
- Inverse_Complex_Subtest:
- declare
- Operand_1 : Complex_Array_Type
- := ( Complex (Int_Type (Report.Ident_Int (1)),
- Int_Type (Report.Ident_Int (5))),
- Complex (Int_Type (Report.Ident_Int (3)),
- Int_Type (Report.Ident_Int (11))) );
- Operand_3 : Complex_Array_Type
- := ( Zero, Complex (Int_Type (Report.Ident_Int (3)),
- Int_Type (Report.Ident_Int (6))) );
- Inv_Result : Complex_Array_Type
- := ( Complex (Int_Type (Report.Ident_Int (-1)),
- Int_Type (Report.Ident_Int (-5))),
- Complex (Int_Type (Report.Ident_Int (-3)),
- Int_Type (Report.Ident_Int (-11))) );
- Complex_No : Complex_Array_Type := (others => Zero);
-
- begin
- Inverse (Operand_1, Complex_No);
-
- if (Complex_No /= Inv_Result) then
- Report.Failed ("Incorrect results from inverse");
- end if;
-
- -- Error is raised in grandchild package and exception
- -- will be handled/reraised to caller.
-
- Inverse (Operand_3, Complex_No);
-
- Report.Failed ("Exception was not handled in inverse");
-
- exception
- when Inverse_Error =>
- if not TC_Handled_In_Grandchild_Pkg_Proc then
- Report.Failed ("Exception was not raised in inverse");
- else
- TC_Handled_In_Caller := true; -- Exception is reraised from
- -- child package.
- end if;
-
- when others =>
- Report.Failed ("Unexpected exception in inverse");
- TC_Handled_In_Caller := false;
- -- Improper exception handling in caller.
-
- end Inverse_Complex_Subtest;
-
- if not (TC_Handled_In_Caller and -- Check to see that all
- TC_Handled_In_Grandchild_Pkg_Proc and -- exceptions were handled
- TC_Handled_In_Grandchild_Pkg_Func and -- in proper location.
- TC_Propagated_To_Caller)
- then
- Report.Failed ("Exceptions handled in incorrect locations");
- end if;
-
- Report.Result;
-
-end CA11D02;
diff --git a/gcc/testsuite/ada/acats/tests/ca/ca11d03.a b/gcc/testsuite/ada/acats/tests/ca/ca11d03.a
deleted file mode 100644
index 901b8d2174d..00000000000
--- a/gcc/testsuite/ada/acats/tests/ca/ca11d03.a
+++ /dev/null
@@ -1,174 +0,0 @@
--- CA11D03.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that an exception declared in a package can be raised by a
--- client of a child of the package. Check that it can be renamed in
--- the client of the child of the package and raised with the correct
--- effect.
---
--- TEST DESCRIPTION:
--- Declare a package which defines complex number abstraction with
--- user-defined exceptions (foundation code).
---
--- Add a public child package to the above package. Declare two
--- subprograms for the parent type.
---
--- In the main program, "with" the child package, then check that
--- an exception can be raised and handled as expected.
---
--- TEST FILES:
--- This test depends on the following foundation code:
---
--- FA11D00.A
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
---
---!
-
--- Child package of FA11D00.
-package FA11D00.CA11D03_0 is -- Basic_Complex
-
- function "+" (Left, Right : Complex_Type)
- return Complex_Type; -- Add two complex numbers.
-
- function "*" (Left, Right : Complex_Type)
- return Complex_Type; -- Multiply two complex numbers.
-
-end FA11D00.CA11D03_0; -- Basic_Complex
-
---=======================================================================--
-
-package body FA11D00.CA11D03_0 is -- Basic_Complex
-
- function "+" (Left, Right : Complex_Type) return Complex_Type is
- begin
- return ( (Left.Real + Right.Real, Left.Imag + Right.Imag) );
- end "+";
- --------------------------------------------------------------
- function "*" (Left, Right : Complex_Type) return Complex_Type is
- begin
- return ( Real => (Left.Real * Right.Real),
- Imag => (Left.Imag * Right.Imag) );
- end "*";
-
-end FA11D00.CA11D03_0; -- Basic_Complex
-
---=======================================================================--
-
-with FA11D00.CA11D03_0; -- Basic_Complex,
- -- implicitly with Complex_Definition.
-with Report;
-
-procedure CA11D03 is
-
- package Complex_Pkg renames FA11D00; -- Complex_Definition_Pkg
- package Basic_Complex_Pkg renames FA11D00.CA11D03_0; -- Basic_Complex
-
- use Complex_Pkg;
- use Basic_Complex_Pkg;
-
- TC_Handled_In_Subtest_1,
- TC_Handled_In_Subtest_2 : boolean := false;
-
-begin
-
- Report.Test ("CA11D03", "Check that an exception declared in a package " &
- "can be raised by a client of a child of the package");
-
- Multiply_Complex_Subtest:
- declare
- Operand_1 : Complex_Type := Complex (Int_Type (Report.Ident_Int (3)),
- Int_Type (Report.Ident_Int (2)));
- -- Referenced to function in parent package.
- Operand_2 : Complex_Type := Complex (Int_Type (Report.Ident_Int (10)),
- Int_Type (Report.Ident_Int (8)));
- Mul_Res : Complex_type := Complex (Int_Type (Report.Ident_Int (30)),
- Int_Type (Report.Ident_Int (16)));
- Complex_No : Complex_Type := Zero; -- Zero is declared in parent package.
- begin
- Complex_No := Operand_1 * Operand_2; -- Basic_Complex."*".
- if Complex_No /= Mul_Res then
- Report.Failed ("Incorrect results from multiplication");
- end if;
-
- -- Error is raised and exception will be handled.
- if Complex_No = Mul_Res then
- raise Multiply_Error; -- Reference to exception in
- end if; -- parent package.
-
- exception
- when Multiply_Error =>
- TC_Handled_In_Subtest_1 := true;
- when others =>
- TC_Handled_In_Subtest_1 := false; -- Improper exception handling.
-
- end Multiply_Complex_Subtest;
-
- Add_Complex_Subtest:
- declare
- Error_In_Client : exception renames Add_Error;
- -- Reference to exception in parent package.
- Operand_1 : Complex_Type := Complex (Int_Type (Report.Ident_Int (2)),
- Int_Type (Report.Ident_Int (7)));
- Operand_2 : Complex_Type := Complex (Int_Type (Report.Ident_Int (-4)),
- Int_Type (Report.Ident_Int (1)));
- Add_Res : Complex_type := Complex (Int_Type (Report.Ident_Int (-2)),
- Int_Type (Report.Ident_Int (8)));
- Complex_No : Complex_Type := One; -- One is declared in parent
- -- package.
- begin
- Complex_No := Operand_1 + Operand_2; -- Basic_Complex."+".
-
- if Complex_No /= Add_Res then
- Report.Failed ("Incorrect results from multiplication");
- end if;
-
- -- Error is raised and exception will be handled.
- if Complex_No = Add_Res then
- raise Error_In_Client;
- end if;
-
- exception
- when Error_In_Client =>
- TC_Handled_In_Subtest_2 := true;
-
- when others =>
- TC_Handled_In_Subtest_2 := false; -- Improper exception handling.
-
- end Add_Complex_Subtest;
-
- if not (TC_Handled_In_Subtest_1 and -- Check to see that all
- TC_Handled_In_Subtest_2) -- exceptions were handled
- -- in the proper location.
- then
- Report.Failed ("Exceptions handled in incorrect locations");
- end if;
-
- Report.Result;
-
-end CA11D03;
diff --git a/gcc/testsuite/ada/acats/tests/ca/ca13001.a b/gcc/testsuite/ada/acats/tests/ca/ca13001.a
deleted file mode 100644
index 094bd7a88e0..00000000000
--- a/gcc/testsuite/ada/acats/tests/ca/ca13001.a
+++ /dev/null
@@ -1,370 +0,0 @@
--- CA13001.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that a separate protected unit declared in a non-generic child
--- unit of a private parent have the same visibility into its parent,
--- its siblings, and packages on which its parent depends as is available
--- at the point of their declaration.
---
--- TEST DESCRIPTION:
--- A scenario is created that demonstrates the potential of having all
--- members of one family to take out a transportation. The restriction
--- is depend on each member to determine who can get a car, a clunker,
--- or a bicycle. If no transportation is available, that member has to
--- walk.
---
--- Declare a package with location for each family member. Declare
--- a public parent package. Declare a private child package. Declare a
--- public grandchild of this private package. Declare a protected unit
--- as a subunit in a public grandchild package. This subunit has
--- visibility into it's parent body ancestor and its sibling.
---
--- Declare another public parent package. The body of this package has
--- visibility into its private sibling's descendants.
---
--- In the main program, "with"s the parent package. Check that the
--- protected subunit performs as expected.
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 16 Nov 95 SAIC Update and repair for ACVC 2.0.1
---
---!
-
-package CA13001_0 is
-
- type Location is (School, Work, Beach, Home);
- type Family is (Father, Mother, Teen);
- Destination : array (Family) of Location;
-
- -- Other type definitions and procedure declarations in real application.
-
-end CA13001_0;
-
--- No bodies required for CA13001_0.
-
- --==================================================================--
-
--- Public parent.
-
-package CA13001_1 is
-
- type Transportation is (Bicycle, Clunker, New_Car);
- type Key_Type is private;
- Walking : boolean := false;
-
- -- Other type definitions and procedure declarations in real application.
-
-private
- type Key_Type
- is range Transportation'pos(Bicycle) .. Transportation'pos(New_Car);
-
-end CA13001_1;
-
--- No bodies required for CA13001_1.
-
- --==================================================================--
-
--- Private child.
-
-private package CA13001_1.CA13001_2 is
-
- type Transport is
- record
- In_Use : boolean := false;
- end record;
- Vehicles : array (Transportation) of Transport;
-
- -- Other type definitions and procedure declarations in real application.
-
-end CA13001_1.CA13001_2;
-
--- No bodies required for CA13001_1.CA13001_2.
-
- --==================================================================--
-
--- Public grandchild of a private parent.
-
-package CA13001_1.CA13001_2.CA13001_3 is
-
- Flat_Tire : array (Transportation) of boolean := (others => false);
-
- -- Other type definitions and procedure declarations in real application.
-
-end CA13001_1.CA13001_2.CA13001_3;
-
--- No bodies required for CA13001_1.CA13001_2.CA13001_3.
-
- --==================================================================--
-
--- Context clauses required for visibility needed by a separate subunit.
-
-with CA13001_0;
-use CA13001_0;
-
--- Public grandchild of a private parent.
-
-package CA13001_1.CA13001_2.CA13001_4 is
-
- type Transit is
- record
- Available : boolean := false;
- end record;
- type Keys_Array is array (Transportation) of Transit;
- Fuel : array (Transportation) of boolean := (others => true);
-
- protected Family_Transportation is
-
- procedure Get_Vehicle (Who : in Family;
- Key : out Key_Type);
- procedure Return_Vehicle (Tr : in Transportation);
- function TC_Verify (What : Transportation) return boolean;
-
- private
- Keys : Keys_Array;
-
- end Family_Transportation;
-
-end CA13001_1.CA13001_2.CA13001_4;
-
- --==================================================================--
-
--- Context clause required for visibility needed by a separate subunit.
-
-with CA13001_1.CA13001_2.CA13001_3; -- Public sibling.
-
-package body CA13001_1.CA13001_2.CA13001_4 is
-
- protected body Family_Transportation is separate;
-
-end CA13001_1.CA13001_2.CA13001_4;
-
- --==================================================================--
-
-separate (CA13001_1.CA13001_2.CA13001_4)
-protected body Family_Transportation is
-
- procedure Get_Vehicle (Who : in Family;
- Key : out Key_Type) is
- begin
- case Who is
- when Father|Mother =>
- -- Drive new car to work
-
- -- Reference package with'ed by the subunit parent's body.
- if Destination(Who) = Work then
-
- -- Reference type declared in the private parent of the subunit
- -- parent's body.
- -- Reference type declared in the visible part of the
- -- subunit parent's body.
- if not Vehicles(New_Car).In_Use and Fuel(New_Car)
-
- -- Reference type declared in the public sibling of the
- -- subunit parent's body.
- and not CA13001_1.CA13001_2.CA13001_3.Flat_Tire(New_Car) then
- Vehicles(New_Car).In_Use := true;
-
- -- Reference type declared in the private part of the
- -- protected subunit.
- Keys(New_Car).Available := false;
- Key := Transportation'pos(New_Car);
- else
- -- Reference type declared in the grandparent of the subunit
- -- parent's body.
- Walking := true;
- end if;
-
- -- Drive clunker to other destinations.
- else
- if not Vehicles(Clunker).In_Use and Fuel(Clunker) and not
- CA13001_1.CA13001_2.CA13001_3.Flat_Tire(Clunker) then
- Vehicles(Clunker).In_Use := true;
- Keys(Clunker).Available := false;
- Key := Transportation'pos(Clunker);
- else
- Walking := true;
- Key := Transportation'pos(Bicycle);
- end if;
- end if;
-
- -- Similar for Teen.
- when Teen =>
- if not Vehicles(Clunker).In_Use and Fuel(Clunker) and not
- CA13001_1.CA13001_2.CA13001_3.Flat_Tire(Clunker) then
- Vehicles(Clunker).In_Use := true;
- Keys(Clunker).Available := false;
- Key := Transportation'pos(Clunker);
- else
- Walking := true;
- Key := Transportation'pos(Bicycle);
- end if;
- end case;
-
- end Get_Vehicle;
-
- ----------------------------------------------------------------
-
- -- Any family member can bring back the transportation with the key.
-
- procedure Return_Vehicle (Tr : in Transportation) is
- begin
- Vehicles(Tr).In_Use := false;
- Keys(Tr).Available := true;
- end Return_Vehicle;
-
- ----------------------------------------------------------------
-
- function TC_Verify (What : Transportation) return boolean is
- begin
- return Keys(What).Available;
- end TC_Verify;
-
-end Family_Transportation;
-
- --==================================================================--
-
-with CA13001_0;
-use CA13001_0;
-
--- Public child.
-
-package CA13001_1.CA13001_5 is
-
- -- In a real application, tasks could be used to demonstrate
- -- a family transportation scenario, i.e., each member of
- -- a family can take a vehicle out concurrently, then return
- -- them at the same time. For the purposes of the test, family
- -- transportation happens sequentially.
-
- procedure Provide_Transportation (Who : in Family;
- Get_Key : out Key_Type;
- Get_Veh : out boolean);
- procedure Return_Transportation (What : in Transportation;
- Rt_Veh : out boolean);
-
-end CA13001_1.CA13001_5;
-
- --==================================================================--
-
-with CA13001_1.CA13001_2.CA13001_4; -- Public grandchild of a private parent,
- -- implicitly with CA13001_1.CA13001_2.
-package body CA13001_1.CA13001_5 is
-
- package Transportation_Pkg renames CA13001_1.CA13001_2.CA13001_4;
- use Transportation_Pkg;
-
- -- These two validation subprograms provide the capability to check the
- -- components defined in the private packages from within the client
- -- program.
-
- procedure Provide_Transportation (Who : in Family;
- Get_Key : out Key_Type;
- Get_Veh : out boolean) is
- begin
- -- Goto work, school, or to the beach.
- Family_Transportation.Get_Vehicle (Who, Get_Key);
- if not Family_Transportation.TC_Verify
- (Transportation'Val(Get_Key)) then
- Get_Veh := true;
- else
- Get_Veh := false;
- end if;
-
- end Provide_Transportation;
-
- ----------------------------------------------------------------
-
- procedure Return_Transportation (What : in Transportation;
- Rt_Veh : out boolean) is
- begin
- Family_Transportation.Return_Vehicle (What);
- if Family_Transportation.TC_Verify(What) and
- not CA13001_1.CA13001_2.Vehicles(What).In_Use then
- Rt_Veh := true;
- else
- Rt_Veh := false;
- end if;
-
- end Return_Transportation;
-
-end CA13001_1.CA13001_5;
-
- --==================================================================--
-
-with CA13001_0;
-with CA13001_1.CA13001_5; -- Implicitly with parent, CA13001_1.
-with Report;
-
-procedure CA13001 is
-
- Mommy : CA13001_0.Family := CA13001_0.Mother;
- Daddy : CA13001_0.Family := CA13001_0.Father;
- BG : CA13001_0.Family := CA13001_0.Teen;
- BG_Clunker : CA13001_1.Transportation := CA13001_1.Clunker;
- Get_Key : CA13001_1.Key_Type;
- Get_Transit : boolean := false;
- Return_Transit : boolean := false;
-
-begin
- Report.Test ("CA13001", "Check that a protected subunit declared in " &
- "a child unit of a private parent have the same visibility " &
- "into its parent, its parent's siblings, and packages on " &
- "which its parent depends");
-
- -- Get transportation for mother to go to work.
- CA13001_0.Destination(CA13001_0.Mother) := CA13001_0.Work;
- CA13001_1.CA13001_5.Provide_Transportation (Mommy, Get_Key, Get_Transit);
- if not Get_Transit then
- Report.Failed ("Failed to get mother transportation");
- end if;
-
- -- Get transportation for teen to go to school.
- CA13001_0.Destination(CA13001_0.Teen) := CA13001_0.School;
- Get_Transit := false;
- CA13001_1.CA13001_5.Provide_Transportation (BG, Get_Key, Get_Transit);
- if not Get_Transit then
- Report.Failed ("Failed to get teen transportation");
- end if;
-
- -- Get transportation for father to go to the beach.
- CA13001_0.Destination(CA13001_0.Father) := CA13001_0.Beach;
- Get_Transit := false;
- CA13001_1.CA13001_5.Provide_Transportation (Daddy, Get_Key, Get_Transit);
- if Get_Transit and not CA13001_1.Walking then
- Report.Failed ("Failed to make daddy to walk to the beach");
- end if;
-
- -- Return the clunker.
- CA13001_1.CA13001_5.Return_Transportation (BG_Clunker, Return_Transit);
- if not Return_Transit then
- Report.Failed ("Failed to get back the clunker");
- end if;
-
- Report.Result;
-
-end CA13001;
diff --git a/gcc/testsuite/ada/acats/tests/ca/ca13002.a b/gcc/testsuite/ada/acats/tests/ca/ca13002.a
deleted file mode 100644
index e985174afd4..00000000000
--- a/gcc/testsuite/ada/acats/tests/ca/ca13002.a
+++ /dev/null
@@ -1,259 +0,0 @@
--- CA13002.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that two library child units and/or subunits may have the same
--- simple names if they have distinct expanded names.
---
--- TEST DESCRIPTION:
--- Declare a package that provides some primitive functionality (minimal
--- terminal driver operations in this case). Add child packages to
--- expand the functionality for different but related contexts (different
--- terminal kinds). Add child packages, or subunits, to the children to
--- provide the same high level operation for each of the different
--- contexts (terminals). Since the operations are the same, at the leaf
--- level they are likely to have the same names.
---
--- The main program "with"s the child packages. Check that the
--- child units and subunits perform as expected.
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
---
---!
-
--- Public parent.
-package CA13002_0 is -- Terminal_Driver.
-
- type TC_Name is (First_Child, Second_Child, Third_Child, Fourth_Child);
- type TC_Call_From is (First_Grandchild, Second_Grandchild, First_Subunit,
- Second_Subunit);
- type TC_Calls_Arr is array (TC_Name, TC_Call_From) of boolean;
- TC_Calls : TC_Calls_Arr := (others => (others => false));
-
- -- In real application, Send_Control_Sequence sends keystrokes from
- -- the terminal, i.e., space, escape, etc.
- procedure Send_Control_Sequence (Row : in TC_Name;
- Col : in TC_Call_From);
-
-end CA13002_0;
-
- --==================================================================--
-
--- First child.
-package CA13002_0.CA13002_1 is -- Terminal_Driver.VT100
-
- -- Move cursor up, down, left, or right.
- procedure Move_Cursor (Col : in TC_Call_From);
-
-end CA13002_0.CA13002_1;
-
- --==================================================================--
-
--- First grandchild.
-procedure CA13002_0.CA13002_1.CA13002_5; -- Terminal_Driver.VT100.Cursor_Up
-
- --==================================================================--
-
--- Second child.
-package CA13002_0.CA13002_2 is -- Terminal_Driver.IBM3270
-
- procedure Move_Cursor (Col : in TC_Call_From);
-
-end CA13002_0.CA13002_2;
-
- --==================================================================--
-
--- Second grandchild.
-procedure CA13002_0.CA13002_2.CA13002_5; -- Terminal_Driver.IBM3270.Cursor_Up
-
- --==================================================================--
-
--- Third child.
-package CA13002_0.CA13002_3 is -- Terminal_Driver.DOS_ANSI
-
- procedure Move_Cursor (Col : in TC_Call_From);
-
- procedure CA13002_5; -- Terminal_Driver.DOS_ANSI.Cursor_Up
- -- implementation will be as a
- -- separate subunit.
-end CA13002_0.CA13002_3;
-
- --==================================================================--
-
--- Fourth child.
-package CA13002_0.CA13002_4 is -- Terminal_Driver.WYSE
-
- procedure Move_Cursor (Col : in TC_Call_From);
-
- procedure CA13002_5; -- Terminal_Driver.WYSE.Cursor_Up
- -- implementation will be as a
- -- separate subunit.
-
-end CA13002_0.CA13002_4;
-
- --==================================================================--
-
--- Terminal_Driver.
-package body CA13002_0 is
-
- procedure Send_Control_Sequence (Row : in TC_Name;
- Col : in TC_Call_From) is
- begin
- -- Reads a key and takes action.
- TC_Calls (Row, Col) := true;
- end Send_Control_Sequence;
-
-end CA13002_0;
-
- --==================================================================--
-
--- Terminal_Driver.VT100.
-package body CA13002_0.CA13002_1 is
-
- procedure Move_Cursor (Col : in TC_Call_From) is
- begin
- Send_Control_Sequence (First_Child, Col);
- end Move_Cursor;
-
-end CA13002_0.CA13002_1;
-
- --==================================================================--
-
--- Terminal_Driver.VT100.Cursor_Up.
-procedure CA13002_0.CA13002_1.CA13002_5 is
-begin
- Move_Cursor (First_Grandchild); -- from Terminal_Driver.VT100.
-end CA13002_0.CA13002_1.CA13002_5;
-
- --==================================================================--
-
--- Terminal_Driver.IBM3270.
-package body CA13002_0.CA13002_2 is
-
- procedure Move_Cursor (Col : in TC_Call_From) is
- begin
- Send_Control_Sequence (Second_Child, Col);
- end Move_Cursor;
-
-end CA13002_0.CA13002_2;
-
- --==================================================================--
-
--- Terminal_Driver.IBM3270.Cursor_Up.
-procedure CA13002_0.CA13002_2.CA13002_5 is
-begin
- Move_Cursor (Second_Grandchild); -- from Terminal_Driver.IBM3270.
-end CA13002_0.CA13002_2.CA13002_5;
-
- --==================================================================--
-
--- Terminal_Driver.DOS_ANSI.
-package body CA13002_0.CA13002_3 is
-
- procedure Move_Cursor (Col : in TC_Call_From) is
- begin
- Send_Control_Sequence (Third_Child, Col);
- end Move_Cursor;
-
- procedure CA13002_5 is separate;
-
-end CA13002_0.CA13002_3;
-
- --==================================================================--
-
--- Terminal_Driver.DOS_ANSI.Cursor_Up.
-separate (CA13002_0.CA13002_3)
-procedure CA13002_5 is
-begin
- Move_Cursor (First_Subunit); -- from Terminal_Driver.DOS_ANSI.
-end CA13002_5;
-
- --==================================================================--
-
--- Terminal_Driver.WYSE.
-package body CA13002_0.CA13002_4 is
-
- procedure Move_Cursor (Col : in TC_Call_From) is
- begin
- Send_Control_Sequence (Fourth_Child, Col);
- end Move_Cursor;
-
- procedure CA13002_5 is separate;
-
-end CA13002_0.CA13002_4;
-
- --==================================================================--
-
--- Terminal_Driver.WYSE.Cursor_Up.
-separate (CA13002_0.CA13002_4)
-procedure CA13002_5 is
-begin
- Move_Cursor (Second_Subunit); -- from Terminal_Driver.WYSE.
-end CA13002_5;
-
- --==================================================================--
-
-with CA13002_0.CA13002_1.CA13002_5; -- Terminal_Driver.VT100.Cursor_Up,
- -- implicitly with parent, CA13002_0.
-with CA13002_0.CA13002_2.CA13002_5; -- Terminal_Driver.IBM3270.Cursor_Up.
-with CA13002_0.CA13002_3; -- Terminal_Driver.DOS_ANSI.
-with CA13002_0.CA13002_4; -- Terminal_Driver.WYSE.
-with Report;
-use CA13002_0; -- All primitive subprograms directly
- -- visible.
-
-procedure CA13002 is
- Expected_Calls : constant CA13002_0.TC_Calls_Arr
- := ((true, false, false, false),
- (false, true , false, false),
- (false, false, true , false),
- (false, false, false, true ));
-begin
- Report.Test ("CA13002", "Check that two library units and/or subunits " &
- "may have the same simple names if they have distinct " &
- "expanded names");
-
- -- Note that the leaves all have the same name.
- -- Call the first grandchild.
- CA13002_0.CA13002_1.CA13002_5;
-
- -- Call the second grandchild.
- CA13002_0.CA13002_2.CA13002_5;
-
- -- Call the first subunit.
- CA13002_0.CA13002_3.CA13002_5;
-
- -- Call the second subunit.
- CA13002_0.CA13002_4.CA13002_5;
-
- if TC_Calls /= Expected_Calls then
- Report.Failed ("Wrong result");
- end if;
-
- Report.Result;
-
-end CA13002;
diff --git a/gcc/testsuite/ada/acats/tests/ca/ca13003.a b/gcc/testsuite/ada/acats/tests/ca/ca13003.a
deleted file mode 100644
index 607639efecd..00000000000
--- a/gcc/testsuite/ada/acats/tests/ca/ca13003.a
+++ /dev/null
@@ -1,256 +0,0 @@
--- CA13003.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that separate subunits which share an ancestor may have the
--- same name if they have different fully qualified names. Check
--- the case of separate subunits of separate subunits.
--- This test is a change in semantics from Ada 83 to Ada 9X.
---
--- TEST DESCRIPTION:
--- Declare a package that provides file processing operations. Declare
--- one separate package to do the file processing, and another to do the
--- auditing. These packages contain similar functions declared in
--- separate subunits. Verify that the main program can call the
--- separate subunits with the same name.
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
---
---!
-
--- Simulates a file processing application. The processing package opens
--- files, reads files, does file processing, and generates reports.
--- The auditing package opens files, read files, and generates reports.
-
-package CA13003_0 is
-
- type File_ID is range 1 .. 100;
- subtype File_Name is string (1 .. 10);
-
- TC_Open_For_Process : boolean := false;
- TC_Open_For_Audit : boolean := false;
- TC_Report_From_Process : boolean := false;
- TC_Report_From_Audit : boolean := false;
-
- type File_Rec is
- record
- Name : File_Name;
- ID : File_ID;
- end record;
-
- procedure Initialize_File_Rec (Name_In : in File_Name;
- ID_In : in File_ID;
- File_In : out File_Rec);
-
- ----------------------------------------------------------------------
-
- package CA13003_1 is -- File processing
-
- procedure CA13003_3; -- Open files
- function CA13003_4 (ID_In : File_ID; File_In : File_Rec)
- return File_Name; -- Process files
- package CA13003_5 is -- Generate report
- procedure Generate_Report;
- end CA13003_5;
-
- end CA13003_1;
-
- ----------------------------------------------------------------------
-
- package CA13003_2 is -- File auditing
-
- procedure CA13003_3; -- Open files
- function CA13003_4 (ID_In : File_ID; File_In : File_Rec)
- return File_Name; -- Process files
- package CA13003_5 is -- Generate report
- procedure Generate_Report;
- end CA13003_5;
-
- end CA13003_2;
-
-end CA13003_0;
-
- --==================================================================--
-
-package body CA13003_0 is
-
- procedure Initialize_File_Rec (Name_In : in File_Name;
- ID_In : in File_ID;
- File_In : out File_Rec) is
- -- Not a real initialization. Real application can use file
- -- database to create the file record.
- begin
- File_In.Name := Name_In;
- File_In.ID := ID_In;
- end Initialize_File_Rec;
-
- package body CA13003_1 is separate;
- package body CA13003_2 is separate;
-
-end CA13003_0;
-
- --==================================================================--
-
-separate (CA13003_0)
-package body CA13003_1 is
-
- procedure CA13003_3 is separate; -- Open files
- function CA13003_4 (ID_In : File_ID; File_In : File_Rec)
- return File_Name is separate; -- Process files
- package body CA13003_5 is separate; -- Generate report
-
-end CA13003_1;
-
- --==================================================================--
-
-separate (CA13003_0.CA13003_1)
-procedure CA13003_3 is -- Open files
-begin
- -- In real file processing application, open file from database, setup
- -- data structure, etc.
- TC_Open_For_Process := true;
-end CA13003_3;
-
- --==================================================================--
-
-separate (CA13003_0.CA13003_1)
-function CA13003_4 (ID_In : File_ID; -- Process files
- File_In : File_Rec) return File_Name is
-begin
- -- In real file processing application, process files for more information.
- return File_In.Name;
-end CA13003_4;
-
- --==================================================================--
-
-separate (CA13003_0.CA13003_1)
-package body CA13003_5 is -- Generate report
- procedure Generate_Report is
- begin
- -- In real file processing application, generate various report from the
- -- file database.
- TC_Report_From_Process := true;
- end Generate_Report;
-
-end CA13003_5;
-
- --==================================================================--
-
-separate (CA13003_0)
-package body CA13003_2 is
-
- procedure CA13003_3 is separate; -- Open files
- function CA13003_4 (ID_In : File_ID; File_In : File_Rec)
- return File_Name is separate; -- Process files
- package body CA13003_5 is separate; -- Generate report
-
-end CA13003_2;
-
- --==================================================================--
-
-separate (CA13003_0.CA13003_2)
-procedure CA13003_3 is -- Open files
-begin
- TC_Open_For_Audit := true;
-end CA13003_3;
-
- --==================================================================--
-
-separate (CA13003_0.CA13003_2)
-function CA13003_4 (ID_In : File_ID;
- File_In : File_Rec) return File_Name is
-begin
- return File_In.Name;
-end CA13003_4;
-
- --==================================================================--
-
-separate (CA13003_0.CA13003_2)
-package body CA13003_5 is -- Generate report
- procedure Generate_Report is
- begin
- TC_Report_From_Audit := true;
- end Generate_Report;
-
-end CA13003_5;
-
- --==================================================================--
-
-with CA13003_0;
-with Report;
-
-procedure CA13003 is
- First_File_Name : CA13003_0.File_Name := "Joe Smith ";
- First_File_Id : CA13003_0.File_ID := 11;
- Second_File_Name : CA13003_0.File_Name := "John Schep";
- Second_File_Id : CA13003_0.File_ID := 47;
- Expected_Name : CA13003_0.File_Name := " ";
- Student_File : CA13003_0.File_Rec;
-
- function Process_Input_Files (ID_In : CA13003_0.File_ID;
- File_In : CA13003_0.File_Rec) return
- CA13003_0.File_Name renames CA13003_0.CA13003_1.CA13003_4;
-
- function Process_Audit_Files (ID_In : CA13003_0.File_ID;
- File_In : CA13003_0.File_Rec) return
- CA13003_0.File_Name renames CA13003_0.CA13003_2.CA13003_4;
-begin
- Report.Test ("CA13003", "Check that separate subunits which share " &
- "an ancestor may have the same name if they have " &
- "different fully qualified names");
-
- Student_File := (ID => First_File_Id, Name => First_File_Name);
-
- -- Note that all subunits have the same simple name.
- -- Generate report from file processing.
- CA13003_0.CA13003_1.CA13003_3;
- Expected_Name := Process_Input_Files (First_File_Id, Student_File);
- CA13003_0.CA13003_1.CA13003_5.Generate_Report;
-
- if not CA13003_0.TC_Open_For_Process or
- not CA13003_0.TC_Report_From_Process or
- Expected_Name /= First_File_Name then
- Report.Failed ("Unexpected results in processing file");
- end if;
-
- CA13003_0.Initialize_File_Rec
- (Second_File_Name, Second_File_Id, Student_File);
-
- -- Generate report from file auditing.
- CA13003_0.CA13003_2.CA13003_3;
- Expected_Name := Process_Audit_Files (Second_File_Id, Student_File);
- CA13003_0.CA13003_2.CA13003_5.Generate_Report;
-
- if not CA13003_0.TC_Open_For_Audit or
- not CA13003_0.TC_Report_From_Audit or
- Expected_Name /= Second_File_Name then
- Report.Failed ("Unexpected results in auditing file");
- end if;
-
- Report.Result;
-
-end CA13003;
diff --git a/gcc/testsuite/ada/acats/tests/ca/ca13a01.a b/gcc/testsuite/ada/acats/tests/ca/ca13a01.a
deleted file mode 100644
index 3963bc61f19..00000000000
--- a/gcc/testsuite/ada/acats/tests/ca/ca13a01.a
+++ /dev/null
@@ -1,320 +0,0 @@
--- CA13A01.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that subunits declared in non-generic child units of a public
--- parent have the same visibility into its parent, its siblings
--- (public and private), and packages on which its parent depends
--- as is available at the point of their declaration.
---
--- TEST DESCRIPTION:
--- Declare an check system procedure as a subunit in a private child
--- package of the basic operation package (FA13A00.A). This procedure
--- has visibility into its parent ancestor and its private sibling.
---
--- Declare an emergency procedure as a subunit in a public child package
--- of the basic operation package (FA13A00.A). This procedure has
--- visibility into its parent ancestor and its private sibling.
---
--- Declare an express procedure as a subunit in a public child subprogram
--- of the basic operation package (FA13A00.A). This procedure has
--- visibility into its parent ancestor and its public sibling.
---
--- In the main program, "with"s the child package and subprogram. Check
--- that subunits perform as expected.
---
--- TEST FILES:
--- The following files comprise this test:
---
--- FA13A00.A
--- CA13A01.A
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
---
---!
-
--- Private child package of an elevator application. This package
--- provides maintenance operations.
-
-private package FA13A00_1.CA13A01_4 is -- Maintenance operation
-
- One_Floor : Floor_No := 1; -- Type declared in parent.
-
- procedure Check_System;
-
- -- other type definitions and procedure declarations in real application.
-
-end FA13A00_1.CA13A01_4;
-
- --==================================================================--
-
--- Context clauses required for visibility needed by separate subunit.
-
-with FA13A00_0; -- Building Manager
-
-with FA13A00_1.FA13A00_2; -- Floor Calculation (private)
-
-with FA13A00_1.FA13A00_3; -- Move Elevator
-
-use FA13A00_0;
-
-package body FA13A00_1.CA13A01_4 is
-
- procedure Check_System is separate;
-
-end FA13A00_1.CA13A01_4;
-
- --==================================================================--
-
-separate (FA13A00_1.CA13A01_4)
-
--- Subunit Check_System declared in Maintenance Operation.
-
-procedure Check_System is
-begin
- -- See if regular power is on.
-
- if Power /= V120 then -- Reference package with'ed by
- TC_Operation := false; -- the subunit parent's body.
- end if;
-
- -- Test elevator function.
-
- FA13A00_1.FA13A00_3.Move_Elevator -- Reference public sibling of
- (Penthouse, Call_Waiting); -- the subunit parent's body.
-
- if not Call_Waiting (Penthouse) then -- Reference private part of the
- TC_Operation := false; -- parent of the subunit package's
- -- body.
- end if;
-
- FA13A00_1.FA13A00_2.Down (One_Floor); -- Reference private sibling of
- -- the subunit parent's body.
-
- if Current_Floor /= Floor'pred (Penthouse) then
- TC_Operation := false; -- Reference type declared in the
- end if; -- parent of the subunit parent's
- -- body.
-
-end Check_System;
-
- --==================================================================--
-
--- Public child package of an elevator application. This package provides
--- an emergency operation.
-
-package FA13A00_1.CA13A01_5 is -- Emergency Operation
-
- -- Other type definitions in real application.
-
- procedure Emergency;
-
-private
- type Bell_Type is (Inactive, Active);
-
-end FA13A00_1.CA13A01_5;
-
- --==================================================================--
-
--- Context clauses required for visibility needed by separate subunit.
-
-with FA13A00_0; -- Building Manager
-
-with FA13A00_1.FA13A00_3; -- Move Elevator
-
-with FA13A00_1.CA13A01_4; -- Maintenance Operation (private)
-
-use FA13A00_0;
-
-package body FA13A00_1.CA13A01_5 is
-
- procedure Emergency is separate;
-
-end FA13A00_1.CA13A01_5;
-
- --==================================================================--
-
-separate (FA13A00_1.CA13A01_5)
-
--- Subunit Emergency declared in Maintenance Operation.
-
-procedure Emergency is
- Bell : Bell_Type; -- Reference type declared in the
- -- subunit parent's body.
-
-begin
- -- Calls maintenance operation.
-
- FA13A00_1.CA13A01_4.Check_System; -- Reference private sibling of the
- -- subunit parent 's body.
-
- -- Clear all calls to the elevator.
-
- Clear_Calls (Call_Waiting); -- Reference subprogram declared
- -- in the parent of the subunit
- -- parent's body.
- for I in Floor loop
- if Call_Waiting (I) then -- Reference private part of the
- TC_Operation := false; -- parent of the subunit parent's
- end if; -- body.
- end loop;
-
- -- Move elevator to the basement.
-
- FA13A00_1.FA13A00_3.Move_Elevator -- Reference public sibling of the
- (Basement, Call_Waiting); -- subunit parent's body.
-
- if Current_Floor /= Basement then -- Reference type declared in the
- TC_Operation := false; -- parent of the subunit parent's
- end if; -- body.
-
- -- Shut off power.
-
- Power := Off; -- Reference package with'ed by
- -- the subunit parent's body.
-
- -- Activate bell.
-
- Bell := Active; -- Reference type declared in the
- -- subunit parent's body.
-
-end Emergency;
-
- --==================================================================--
-
--- Public child subprogram of an elevator application. This subprogram
--- provides an express operation.
-
-procedure FA13A00_1.CA13A01_6;
-
- --==================================================================--
-
--- Context clauses required for visibility needed by separate subunit.
-
-with FA13A00_0; -- Building Manager
-
-with FA13A00_1.FA13A00_2; -- Floor Calculation (private)
-
-with FA13A00_1.FA13A00_3; -- Move Elevator
-
-use FA13A00_0;
-
-procedure FA13A00_1.CA13A01_6 is -- Express Operation
-
- -- Other type definitions in real application.
-
- procedure GoTo_Penthouse is separate;
-
-begin
- GoTo_Penthouse;
-
-end FA13A00_1.CA13A01_6;
-
- --==================================================================--
-
-separate (FA13A00_1.CA13A01_6)
-
--- Subunit GoTo_Penthouse declared in Express Operation.
-
-procedure GoTo_Penthouse is
-begin
- -- Go faster.
-
- Power := V240; -- Reference package with'ed by
- -- the subunit parent's body.
-
- -- Call elevator.
-
- Call (Penthouse, Call_Waiting); -- Reference subprogram declared in
- -- the parent of the subunit
- -- parent's body.
-
- if not Call_Waiting (Penthouse) then -- Reference private part of the
- TC_Operation := false; -- parent of the subunit parent's
- end if; -- body.
-
- -- Move elevator to Penthouse.
-
- FA13A00_1.FA13A00_3.Move_Elevator -- Reference public sibling of the
- (Penthouse, Call_Waiting); -- subunit parent's body.
-
- if Current_Floor /= Penthouse then -- Reference type declared in the
- TC_Operation := false; -- parent of the subunit parent's
- end if; -- body.
-
- -- Return slowly
-
- while Current_Floor /= Floor1 loop -- Reference type, subprogram
- FA13A00_1.FA13A00_2.Down (1); -- declared in the parent of the
- -- subunit parent's body.
- end loop;
-
- if Current_Floor /= Floor1 then -- Reference type declared in
- TC_Operation := false; -- the parent of the subunit
- end if; -- parent's body.
-
- -- Back to normal.
-
- Power := V120; -- Reference package with'ed by
- -- the subunit parent's body.
-
-end GoTo_Penthouse;
-
- --==================================================================--
-
-with FA13A00_1.CA13A01_5; -- Emergency Operation
- -- implicitly with Basic Elevator
- -- Operations
-
-with FA13A00_1.CA13A01_6; -- Express Operation
-
-with Report;
-
-procedure CA13A01 is
-
-begin
-
- Report.Test ("CA13A01", "Check that subunits declared in non-generic " &
- "child units of a public parent have the same visibility " &
- "into its parent, its parent's siblings, and packages on " &
- "which its parent depends");
-
- -- Go to Penthouse.
-
- FA13A00_1.CA13A01_6;
-
- -- Call emergency operation.
-
- FA13A00_1.CA13A01_5.Emergency;
-
- if not FA13A00_1.TC_Operation then
- Report.Failed ("Incorrect elevator operation");
- end if;
-
- Report.Result;
-
-end CA13A01;
diff --git a/gcc/testsuite/ada/acats/tests/ca/ca13a02.a b/gcc/testsuite/ada/acats/tests/ca/ca13a02.a
deleted file mode 100644
index 82d1b6ea538..00000000000
--- a/gcc/testsuite/ada/acats/tests/ca/ca13a02.a
+++ /dev/null
@@ -1,301 +0,0 @@
--- CA13A02.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that subunits declared in generic child units of a public
--- parent have the same visibility into its parent, its siblings
--- (public and private), and packages on which its parent depends
--- as is available at the point of their declaration.
---
--- TEST DESCRIPTION:
--- Declare an outside elevator button operation as a subunit in a
--- generic child package of the basic operation package (FA13A00.A).
--- This procedure has visibility into its parent ancestor and its
--- private sibling.
---
--- In the main program, instantiate the child package. Check that
--- subunits perform as expected.
---
--- TEST FILES:
--- The following files comprise this test:
---
--- FA13A00.A
--- CA13A02.A
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
---
---!
-
--- Public generic child package of an elevator application. This package
--- provides outside elevator button operations.
-
-generic -- Instantiate once for each floor.
- Our_Floor : in Floor; -- Reference type declared in parent.
-
-package FA13A00_1.CA13A02_4 is -- Outside Elevator Button Operations
-
- type Light is (Up, Down, Express, Off);
-
- type Direction is (Up, Down, Express);
-
- function Call_Elevator (D : Direction) return Light;
-
- -- other type definitions and procedure declarations in real application.
-
-end FA13A00_1.CA13A02_4;
-
- --==================================================================--
-
--- Context clauses required for visibility needed by separate subunit.
-
-with FA13A00_0; -- Building Manager
-
-with FA13A00_1.FA13A00_2; -- Floor Calculation (private)
-
-with FA13A00_1.FA13A00_3; -- Move Elevator
-
-use FA13A00_0;
-
-package body FA13A00_1.CA13A02_4 is
-
- function Call_Elevator (D : Direction) return Light is separate;
-
-end FA13A00_1.CA13A02_4;
-
- --==================================================================--
-
-separate (FA13A00_1.CA13A02_4)
-
--- Subunit Call_Elevator declared in Outside Elevator Button Operations.
-
-function Call_Elevator (D : Direction) return Light is
- Elevator_Button : Light;
-
-begin
- -- See if power is on.
-
- if Power = Off then -- Reference package with'ed by
- Elevator_Button := Off; -- the subunit parent's body.
-
- else
- case D is
- when Express =>
- FA13A00_1.FA13A00_3.Move_Elevator -- Reference public sibling of
- (Penthouse, Call_Waiting); -- the subunit parent's body.
-
- Elevator_Button := Express;
-
- when Up =>
- if Current_Floor < Our_Floor then
- FA13A00_1.FA13A00_2.Up -- Reference private sibling of
- (Floor'pos (Our_Floor) -- the subunit parent's body.
- - Floor'pos (Current_Floor));
- else
- FA13A00_1.FA13A00_2.Down -- Reference private sibling of
- (Floor'pos (Current_Floor) -- the subunit parent's body.
- - Floor'pos (Our_Floor));
- end if;
-
- -- Call elevator.
-
- Call
- (Current_Floor, Call_Waiting); -- Reference subprogram declared
- -- in the parent of the subunit
- -- parent's body.
- Elevator_Button := Up;
-
- when Down =>
- if Current_Floor > Our_Floor then
- FA13A00_1.FA13A00_2.Down -- Reference private sibling of
- (Floor'pos (Current_Floor) -- the subunit parent's body.
- - Floor'pos (Our_Floor));
- else
- FA13A00_1.FA13A00_2.Up -- Reference private sibling of
- (Floor'pos (Our_Floor) -- the subunit parent's body.
- - Floor'pos (Current_Floor));
- end if;
-
- Elevator_Button := Down;
-
- -- Call elevator.
-
- Call
- (Current_Floor, Call_Waiting); -- Reference subprogram declared
- -- in the parent of the subunit
- -- parent's body.
- end case;
-
- if not Call_Waiting (Current_Floor) -- Reference private part of the
- then -- parent of the subunit parent's
- -- body.
- TC_Operation := false;
- end if;
-
- end if;
-
- return Elevator_Button;
-
-end Call_Elevator;
-
- --==================================================================--
-
-with FA13A00_1.CA13A02_4; -- Outside Elevator Button Operations
- -- implicitly with Basic Elevator
- -- Operations
-with Report;
-
-procedure CA13A02 is
-
-begin
-
- Report.Test ("CA13A02", "Check that subunits declared in generic child " &
- "units of a public parent have the same visibility into " &
- "its parent, its parent's siblings, and packages on " &
- "which its parent depends");
-
--- Going from floor one to penthouse.
-
- Going_To_Penthouse:
- declare
- -- Declare instance of the child generic elevator package for penthouse.
-
- package Call_Elevator_Pkg is new FA13A00_1.CA13A02_4
- (FA13A00_1.Penthouse);
-
- use Call_Elevator_Pkg;
-
- Call_Button_Light : Light;
-
- begin
-
- Call_Button_Light := Call_Elevator (Express);
-
- if not FA13A00_1.TC_Operation or Call_Button_Light /= Express then
- Report.Failed ("Incorrect elevator operation going to penthouse");
- end if;
-
- end Going_To_Penthouse;
-
--- Going from penthouse to basement.
-
- Going_To_Basement:
- declare
- -- Declare instance of the child generic elevator package for basement.
-
- package Call_Elevator_Pkg is new FA13A00_1.CA13A02_4
- (FA13A00_1.Basement);
-
- use Call_Elevator_Pkg;
-
- Call_Button_Light : Light;
-
- begin
-
- Call_Button_Light := Call_Elevator (Down);
-
- if not FA13A00_1.TC_Operation or Call_Button_Light /= Down then
- Report.Failed ("Incorrect elevator operation going to basement");
- end if;
-
- end Going_To_Basement;
-
--- Going from basement to floor three.
-
- Going_To_Floor3:
- declare
- -- Declare instance of the child generic elevator package for floor
- -- three.
-
- package Call_Elevator_Pkg is new FA13A00_1.CA13A02_4
- (FA13A00_1.Floor3);
-
- use Call_Elevator_Pkg;
-
- Call_Button_Light : Light;
-
- begin
-
- Call_Button_Light := Call_Elevator (Up);
-
- if not FA13A00_1.TC_Operation or Call_Button_Light /= Up then
- Report.Failed ("Incorrect elevator operation going to floor 3");
- end if;
-
- end Going_To_Floor3;
-
--- Going from floor three to floor two.
-
- Going_To_Floor2:
- declare
- -- Declare instance of the child generic elevator package for floor two.
-
- package Call_Elevator_Pkg is new FA13A00_1.CA13A02_4
- (FA13A00_1.Floor2);
-
- use Call_Elevator_Pkg;
-
- Call_Button_Light : Light;
-
- begin
-
- Call_Button_Light := Call_Elevator (Up);
-
- if not FA13A00_1.TC_Operation or Call_Button_Light /= Up then
- Report.Failed ("Incorrect elevator operation going to floor 2");
- end if;
-
- end Going_To_Floor2;
-
--- Going to floor one.
-
- Going_To_Floor1:
- declare
- -- Declare instance of the child generic elevator package for floor one.
-
- package Call_Elevator_Pkg is new FA13A00_1.CA13A02_4
- (FA13A00_1.Floor1);
-
- use Call_Elevator_Pkg;
-
- Call_Button_Light : Light;
-
- begin
- -- Calling elevator from floor one.
-
- FA13A00_1.Current_Floor := FA13A00_1.Floor1;
-
- Call_Button_Light := Call_Elevator (Down);
-
- if not FA13A00_1.TC_Operation or Call_Button_Light /= Down then
- Report.Failed ("Incorrect elevator operation going to floor 1");
- end if;
-
- end Going_To_Floor1;
-
- Report.Result;
-
-end CA13A02;
diff --git a/gcc/testsuite/ada/acats/tests/ca/ca140230.a b/gcc/testsuite/ada/acats/tests/ca/ca140230.a
deleted file mode 100644
index 95b72b1ab71..00000000000
--- a/gcc/testsuite/ada/acats/tests/ca/ca140230.a
+++ /dev/null
@@ -1,62 +0,0 @@
--- CA140230.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- See CA140232.AM.
---
--- TEST DESCRIPTION:
--- See CA140232.AM.
---
--- TEST FILES:
--- This test consists of the following files:
--- -> CA140230.A
--- CA140231.A
--- CA140232.AM
--- CA140233.A
---
--- PASS/FAIL CRITERIA:
--- See CA140232.AM.
---
--- CHANGE HISTORY:
--- 07 DEC 96 SAIC ACVC 2.1: Initial version.
--- 13 SEP 99 RLB Changed to C-test (by AI-00077).
--- 20 MAR 00 RLB Removed special requirements, because there
--- aren't any.
---
---!
-
-package CA14023_0 is
- subtype Little_float is float digits 4 range 0.0..100.0;
- type Data_rec is tagged record
- Data : Little_float;
- end record;
-end CA14023_0;
-
---------------------------------------------------------
-
-generic
- type Data_type is digits <>;
- Floor : Data_type;
-function CA14023_1 (P1, P2 : Data_type) return Data_type;
diff --git a/gcc/testsuite/ada/acats/tests/ca/ca140231.a b/gcc/testsuite/ada/acats/tests/ca/ca140231.a
deleted file mode 100644
index 32504b59008..00000000000
--- a/gcc/testsuite/ada/acats/tests/ca/ca140231.a
+++ /dev/null
@@ -1,59 +0,0 @@
--- CA140231.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- See CA140232.AM.
---
--- TEST DESCRIPTION:
--- See CA140232.AM.
---
--- TEST FILES:
--- This test consists of the following files:
--- CA140230.A
--- -> CA140231.A
--- CA140232.AM
--- CA140233.A
---
--- PASS/FAIL CRITERIA:
--- See CA140232.AM.
---
--- CHANGE HISTORY:
--- 07 DEC 96 SAIC ACVC 2.1: Initial version.
--- 13 SEP 99 RLB Changed to C-test (by AI-00077).
--- 20 MAR 00 RLB Removed special requirements, because there
--- aren't any.
---
---!
-
-function CA14023_1 (P1, P2 : Data_type) return Data_type is
-begin
- if Floor > P1 and Floor > P2 then
- return Floor;
- elsif P2 > P1 then
- return P2;
- else
- return P1;
- end if;
-end CA14023_1;
diff --git a/gcc/testsuite/ada/acats/tests/ca/ca140233.a b/gcc/testsuite/ada/acats/tests/ca/ca140233.a
deleted file mode 100644
index a5334379dc9..00000000000
--- a/gcc/testsuite/ada/acats/tests/ca/ca140233.a
+++ /dev/null
@@ -1,68 +0,0 @@
--- CA140233.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- See CA140232.AM.
---
--- TEST DESCRIPTION:
--- See CA140232.AM.
---
--- TEST FILES:
--- This test consists of the following files:
--- CA140230.A
--- CA140231.A
--- CA140232.AM
--- -> CA140233.A
---
--- PASS/FAIL CRITERIA:
--- See CA140232.AM.
---
--- CHANGE HISTORY:
--- 01 MAY 95 ACVC 1.12 LA5008T baseline version
--- 29 JUN 95 SAIC Initial version
--- 05 MAR 96 SAIC First revision after review
--- 18 NOV 96 SAIC Modified unit names and prologue to conform
--- to coding conventions.
--- 07 DEC 96 SAIC Modified prologue to reflect new test
--- file organization.
--- 13 SEP 99 RLB Changed to C-test (by AI-00077).
--- 20 MAR 00 RLB Removed special requirements, because there
--- aren't any.
---!
-
--- here is the replacement body, correcting "errors" in
--- the original
-
-function CA14023_1 (P1, P2 : Data_type) return Data_type is
-begin
- -- return min rather than max
- if Floor < P1 and Floor < P2 then
- return Floor;
- elsif P2 < P1 then
- return P2;
- else
- return P1;
- end if;
-end CA14023_1;
diff --git a/gcc/testsuite/ada/acats/tests/ca/ca140280.a b/gcc/testsuite/ada/acats/tests/ca/ca140280.a
deleted file mode 100644
index 1ffe3cbbf73..00000000000
--- a/gcc/testsuite/ada/acats/tests/ca/ca140280.a
+++ /dev/null
@@ -1,77 +0,0 @@
--- CA140280.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
--- OBJECTIVE:
--- See CA140283.AM.
---
--- TEST DESCRIPTION
--- See CA140283.AM.
---
--- TEST FILES:
--- This test consists of the following files:
--- -> CA140280.A
--- CA140281.A
--- CA140282.A
--- CA140283.AM
---
--- CHANGE HISTORY:
--- JBG 05/28/85 CREATED ORGINAL TEST.
--- RDH 04/18/90 ADDED CASES WHERE SUBPROGRAM PARAMETER TYPES ARE
--- NOT THE SAME.
--- RLB 07/08/99 Reinstated withdrawn test; revised to Ada 95 format.
-
-GENERIC
- C : INTEGER;
-PROCEDURE GENPROC_CA14028 (X : OUT INTEGER);
-
-WITH REPORT; USE REPORT;
-PRAGMA ELABORATE (REPORT);
-PROCEDURE GENPROC_CA14028 (X : OUT INTEGER) IS
-BEGIN
- X := IDENT_INT(C);
-END GENPROC_CA14028;
-
-GENERIC
-FUNCTION GENFUNC_CA14028 RETURN INTEGER;
-
-FUNCTION GENFUNC_CA14028 RETURN INTEGER IS
-BEGIN
- RETURN 2;
-END GENFUNC_CA14028;
-
-WITH GENPROC_CA14028;
-PRAGMA ELABORATE (GENPROC_CA14028);
-PROCEDURE CA14028_PROC1 IS NEW GENPROC_CA14028(1);
-
-WITH GENFUNC_CA14028;
-PRAGMA ELABORATE (GENFUNC_CA14028);
-FUNCTION CA14028_FUNC2 IS NEW GENFUNC_CA14028;
-
-WITH GENPROC_CA14028;
-PRAGMA ELABORATE (GENPROC_CA14028);
-PROCEDURE CA14028_PROC3 IS NEW GENPROC_CA14028(3);
-
-WITH GENFUNC_CA14028;
-PRAGMA ELABORATE (GENFUNC_CA14028);
-FUNCTION CA14028_FUNC3 IS NEW GENFUNC_CA14028;
diff --git a/gcc/testsuite/ada/acats/tests/ca/ca140281.a b/gcc/testsuite/ada/acats/tests/ca/ca140281.a
deleted file mode 100644
index 57360c9ebb9..00000000000
--- a/gcc/testsuite/ada/acats/tests/ca/ca140281.a
+++ /dev/null
@@ -1,67 +0,0 @@
--- CA140281.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
--- OBJECTIVE:
--- See CA140283.AM.
---
--- TEST DESCRIPTION
--- See CA140283.AM.
---
--- TEST FILES:
--- This test consists of the following files:
--- CA140280.A
--- -> CA140281.A
--- CA140282.A
--- CA140283.AM
---
--- CHANGE HISTORY:
--- JBG 05/28/85 CREATED ORGINAL TEST.
--- RDH 04/18/90 ADDED CASES WHERE SUBPROGRAM PARAMETER TYPES ARE
--- NOT THE SAME.
--- RLB 07/08/99 Reinstated withdrawn test; revised to Ada 95 format.
-
-PROCEDURE CA14028_PROC1 (X : OUT INTEGER) IS
-BEGIN
- X := 3;
-END CA14028_PROC1;
-
-WITH REPORT; USE REPORT;
-PRAGMA ELABORATE (REPORT);
-FUNCTION CA14028_FUNC2 RETURN INTEGER IS
-BEGIN
- RETURN IDENT_INT(4);
-END CA14028_FUNC2;
-
-WITH REPORT; USE REPORT;
-PRAGMA ELABORATE (REPORT);
-PROCEDURE CA14028_PROC3 (X : OUT BOOLEAN; Y : OUT INTEGER) IS
-BEGIN
- X := FALSE;
- Y := IDENT_INT(6);
-END CA14028_PROC3;
-
-FUNCTION CA14028_FUNC3 RETURN BOOLEAN IS
-BEGIN
- RETURN FALSE;
-END CA14028_FUNC3;
diff --git a/gcc/testsuite/ada/acats/tests/ca/ca140282.a b/gcc/testsuite/ada/acats/tests/ca/ca140282.a
deleted file mode 100644
index 437f01889c9..00000000000
--- a/gcc/testsuite/ada/acats/tests/ca/ca140282.a
+++ /dev/null
@@ -1,64 +0,0 @@
--- CA140282.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
--- OBJECTIVE:
--- See CA140283.AM.
---
--- TEST DESCRIPTION
--- See CA140283.AM.
---
--- TEST FILES:
--- This test consists of the following files:
--- CA140280.A
--- CA140281.A
--- -> CA140282.A
--- CA140283.AM
---
--- CHANGE HISTORY:
--- JBG 05/28/85 CREATED ORIGINAL TEST.
--- RDH 04/18/90 ADDED CASES WHERE SUBPROGRAM PARAMETER TYPES ARE
--- NOT THE SAME.
--- RLB 07/08/99 Reinstated withdrawn test; revised to Ada 95 format.
-
-WITH GENPROC_CA14028;
-PRAGMA ELABORATE (GENPROC_CA14028);
-PROCEDURE CA14028_PROC5 IS NEW GENPROC_CA14028 (5);
-
-WITH GENFUNC_CA14028;
-PRAGMA ELABORATE (GENFUNC_CA14028);
-FUNCTION CA14028_FUNC22 IS NEW GENFUNC_CA14028;
-
-WITH REPORT; USE REPORT;
-PRAGMA ELABORATE (REPORT);
-PROCEDURE CA14028_PROC3 (X : OUT INTEGER) IS
-BEGIN
- X := IDENT_INT(4);
-END CA14028_PROC3;
-
-WITH REPORT; USE REPORT;
-PRAGMA ELABORATE (REPORT);
-FUNCTION CA14028_FUNC3 RETURN INTEGER IS
-BEGIN
- RETURN IDENT_INT(7);
-END CA14028_FUNC3;
diff --git a/gcc/testsuite/ada/acats/tests/ca/ca15003.a b/gcc/testsuite/ada/acats/tests/ca/ca15003.a
deleted file mode 100644
index 08fe1516ddf..00000000000
--- a/gcc/testsuite/ada/acats/tests/ca/ca15003.a
+++ /dev/null
@@ -1,161 +0,0 @@
--- CA15003.A
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE
--- Check the requirements of 10.1.5(4) and the modified 10.1.5(5)
--- from Technical Corrigendum 1. (Originally discussed as AI95-00136.)
--- Specifically:
--- Check that program unit pragma for a generic package are accepted
--- when given at the beginning of the package specification.
--- Check that a program unit pragma can be given for a generic
--- instantiation by placing the pragma immediately after the instantation.
---
--- TEST DESCRIPTION
--- This test checks the cases that are *not* forbidden by the RM,
--- and makes sure such legal cases actually work.
---
--- CHANGE HISTORY:
--- 29 JUN 1999 RAD Initial Version
--- 08 JUL 1999 RLB Cleaned up and added to test suite.
--- 27 AUG 1999 RLB Repaired errors introduced by me.
---
---!
-
-with System;
-package CA15003A is
- pragma Pure;
-
- type Big_Int is range -System.Max_Int .. System.Max_Int;
- type Big_Positive is new Big_Int range 1..Big_Int'Last;
-end CA15003A;
-
-generic
- type Int is new Big_Int;
-package CA15003A.Pure is
- pragma Pure;
- function F(X: access Int) return Int;
-end CA15003A.Pure;
-
-with CA15003A.Pure;
-package CA15003A.Pure_Instance is new CA15003A.Pure(Int => Big_Positive);
- pragma Pure(CA15003A.Pure_Instance);
-
-package body CA15003A.Pure is
- function F(X: access Int) return Int is
- begin
- X.all := X.all + 1;
- return X.all;
- end F;
-end CA15003A.Pure;
-
-generic
-package CA15003A.Pure.Preelaborate is
- pragma Preelaborate;
- One: Int := 1;
- function F(X: access Int) return Int;
-end CA15003A.Pure.Preelaborate;
-
-package body CA15003A.Pure.Preelaborate is
- function F(X: access Int) return Int is
- begin
- X.all := X.all + One;
- return X.all;
- end F;
-end CA15003A.Pure.Preelaborate;
-
-with CA15003A.Pure_Instance;
-with CA15003A.Pure.Preelaborate;
-package CA15003A.Pure_Preelaborate_Instance is
- new CA15003A.Pure_Instance.Preelaborate;
- pragma Preelaborate(CA15003A.Pure_Preelaborate_Instance);
-
-package CA15003A.Empty_Pure is
- pragma Pure;
- pragma Elaborate_Body;
-end CA15003A.Empty_Pure;
-
-package body CA15003A.Empty_Pure is
-end CA15003A.Empty_Pure;
-
-package CA15003A.Empty_Preelaborate is
- pragma Preelaborate;
- pragma Elaborate_Body;
- One: Big_Int := 1;
-end CA15003A.Empty_Preelaborate;
-
-package body CA15003A.Empty_Preelaborate is
- function F(X: access Big_Int) return Big_Int is
- begin
- X.all := X.all + One;
- return X.all;
- end F;
-end CA15003A.Empty_Preelaborate;
-
-package CA15003A.Empty_Elaborate_Body is
- pragma Elaborate_Body;
- Three: aliased Big_Positive := 1;
- Two, Tres: Big_Positive'Base := 0;
-end CA15003A.Empty_Elaborate_Body;
-
-with Report; use Report; pragma Elaborate_All(Report);
-with CA15003A.Pure_Instance;
-with CA15003A.Pure_Preelaborate_Instance;
-use CA15003A;
-package body CA15003A.Empty_Elaborate_Body is
-begin
- if Two /= Big_Positive'Base(Ident_Int(0)) then
- Failed ("Two should be zero now");
- end if;
- if Tres /= Big_Positive'Base(Ident_Int(0)) then
- Failed ("Tres should be zero now");
- end if;
- if Two /= Tres then
- Failed ("Tres should be zero now");
- end if;
- Two := Pure_Instance.F(Three'Access);
- Tres := Pure_Preelaborate_Instance.F(Three'Access);
- if Two /= Big_Positive(Ident_Int(2)) then
- Failed ("Two should be 2 now");
- end if;
- if Tres /= Big_Positive(Ident_Int(3)) then
- Failed ("Tres should be 3 now");
- end if;
-end CA15003A.Empty_Elaborate_Body;
-
-with Report; use Report;
-with CA15003A.Empty_Pure;
-with CA15003A.Empty_Preelaborate;
-with CA15003A.Empty_Elaborate_Body; use CA15003A.Empty_Elaborate_Body;
-use type CA15003A.Big_Positive'Base;
-procedure CA15003 is
-begin
- Test("CA15003", "Placement of Program Unit Pragmas in Generic Packages");
- if Two /= 2 then
- Failed ("Two should be 2 now");
- end if;
- if Tres /= 3 then
- Failed ("Tres should be 3 now");
- end if;
- Result;
-end CA15003;
diff --git a/gcc/testsuite/ada/acats/tests/ca/ca200020.a b/gcc/testsuite/ada/acats/tests/ca/ca200020.a
deleted file mode 100644
index c9508f4cccb..00000000000
--- a/gcc/testsuite/ada/acats/tests/ca/ca200020.a
+++ /dev/null
@@ -1,70 +0,0 @@
--- CA200020.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687 and
--- F08630-91-C-0015, the U.S. Government obtained unlimited rights in the
--- software and documentation contained herein. Unlimited rights are
--- defined in DFAR 252.227-7013(a)(19). By making this public release,
--- the Government intends to confer upon all recipients unlimited rights
--- equal to those held by the Government. These rights include rights to
--- use, duplicate, release or disclose the released technical data and
--- computer software in whole or in part, in any manner and for any purpose
--- whatsoever, and to have or permit others to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that a partition can be created even if the environment contains
--- two units with the same name. (This is rule 10.2(19)).
---
--- TEST DESCRIPTION:
--- Declare the a parent package (CA20002_0). Declare a child package
--- (CA20002_0.CA20002_1). Declare a subunit in the parent package body
--- (CA20002_1). Declare a main subprogram that does NOT include the
--- child package. Insure that this partition can be created.
---
--- This test is intended to test the effects of program maintenance.
--- After the programmer receives an error from creating a partition
--- like that tested in test LA20001, the programmer may then repair
--- the partition by eliminating the reference of the child unit. The
--- partition should be able to be created.
---
--- To build this test:
--- 1) Compile the file CA200020 (and include the results in the
--- program library).
--- 2) Compile the file CA200021 (and include the results in the
--- program library).
--- 3) Compile the file CA200022 (and include the results in the
--- program library).
--- 4) Build an executable image, and run it.
---
--- TEST FILES:
--- This test consists of the following files:
--- -> CA200020.A
--- CA200021.A
--- CA200022.AM
---
--- CHANGE HISTORY:
--- 27 Jan 99 RLB Initial test.
--- 20 Mar 00 RLB Removed special requirements, because there
--- aren't any.
---!
-
-package CA20002_0 is
- procedure Do_a_Little (A : out Integer);
-
-end CA20002_0;
-
-package CA20002_0.CA20002_1 is
- My_Global : Integer;
-end CA20002_0.CA20002_1;
-
diff --git a/gcc/testsuite/ada/acats/tests/ca/ca200021.a b/gcc/testsuite/ada/acats/tests/ca/ca200021.a
deleted file mode 100644
index 0c5de38253b..00000000000
--- a/gcc/testsuite/ada/acats/tests/ca/ca200021.a
+++ /dev/null
@@ -1,66 +0,0 @@
--- CA200021.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687 and
--- F08630-91-C-0015, the U.S. Government obtained unlimited rights in the
--- software and documentation contained herein. Unlimited rights are
--- defined in DFAR 252.227-7013(a)(19). By making this public release,
--- the Government intends to confer upon all recipients unlimited rights
--- equal to those held by the Government. These rights include rights to
--- use, duplicate, release or disclose the released technical data and
--- computer software in whole or in part, in any manner and for any purpose
--- whatsoever, and to have or permit others to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- See CA200020.A.
---
--- TEST DESCRIPTION:
--- See CA200020.A.
---
--- TEST FILES:
--- This test consists of the following files:
--- CA200020.A
--- -> CA200021.A
--- CA200022.AM
---
--- PASS/FAIL CRITERIA:
--- See CA200020.A.
---
--- CHANGE HISTORY:
--- 27 JAN 99 RLB Initial version.
--- 20 MAR 00 RLB Removed special requirements, because there
--- aren't any.
---
---!
-
-package body CA20002_0 is
-
- function CA20002_1 return Integer is separate; -- Has the same expanded name
- -- as the child.
- -- Note: An implementation may produce a warning about the child
- -- unit at this point, but it must accept the subunit declaration.
-
- procedure Do_a_Little (A : out Integer) is
- begin
- A := CA20002_1;
- end Do_a_Little;
-
-end CA20002_0;
-
-with Report;
-separate (CA20002_0)
-function CA20002_1 return Integer is
-begin
- return Report.Ident_Int(5);
-end CA20002_1;
diff --git a/gcc/testsuite/ada/acats/tests/ca/ca21001.a b/gcc/testsuite/ada/acats/tests/ca/ca21001.a
deleted file mode 100644
index 1056b65bfcc..00000000000
--- a/gcc/testsuite/ada/acats/tests/ca/ca21001.a
+++ /dev/null
@@ -1,152 +0,0 @@
--- CA21001.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687 and
--- F08630-91-C-0015, the U.S. Government obtained unlimited rights in the
--- software and documentation contained herein. Unlimited rights are
--- defined in DFAR 252.227-7013(a)(19). By making this public release,
--- the Government intends to confer upon all recipients unlimited rights
--- equal to those held by the Government. These rights include rights to
--- use, duplicate, release or disclose the released technical data and
--- computer software in whole or in part, in any manner and for any purpose
--- whatsoever, and to have or permit others to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE
--- Check the requirements of the revised 10.2.1(11) from Technical
--- Corrigendum 1 (originally discussed as AI95-00002).
--- A package subunit whose parent is a preelaborated subprogram need
--- not be preelaborable.
---
--- TEST DESCRIPTION
--- We create several preelaborated library procedures with
--- non-preelaborable package body subunits. We try various levels
--- of nesting of package and procedure subunits.
---
--- CHANGE HISTORY:
--- 29 JUN 1999 RAD Initial Version
--- 23 SEP 1999 RLB Improved comments, renamed, issued.
---
---!
-
-procedure CA21001_1(X: out Integer);
- pragma Preelaborate(CA21001_1);
-
-procedure CA21001_1(X: out Integer) is
- function F return Integer is separate;
-
- package Sub is
- function G(X: Integer) return Integer;
- -- Returns X + 1.
- Not_Preelaborable: Integer := F; -- OK, by AI-2.
- end Sub;
-
- package body Sub is separate;
-
-begin
- X := -1;
- X := F;
- X := Sub.G(X);
-end CA21001_1;
-
-separate(CA21001_1)
-package body Sub is
- package Sub_Sub is
- -- Empty.
- end Sub_Sub;
- package body Sub_Sub is separate;
-
- function G(X: Integer) return Integer is separate;
-begin
- Not_Preelaborable := G(F); -- OK, by AI-2.
- if Not_Preelaborable /= 101 then
- raise Program_Error; -- Can't call Report.Failed, here,
- -- because Report is not preelaborated.
- end if;
-end Sub;
-
-separate(CA21001_1.Sub)
-package body Sub_Sub is
-begin
- X := X; -- OK by AI-2.
-end Sub_Sub;
-
-separate(CA21001_1.Sub)
-function G(X: Integer) return Integer is
-
- package G_Sub is
- function H(X: Integer) return Integer;
- -- Returns X + 1.
- Not_Preelaborable: Integer := F; -- OK, by AI-2.
- end G_Sub;
- package body G_Sub is separate;
-
-begin
- return G_Sub.H(X);
-end G;
-
-separate(CA21001_1.Sub.G)
-package body G_Sub is
- function H(X: Integer) return Integer is separate;
-begin
- Not_Preelaborable := H(F); -- OK, by AI-2.
- if Not_Preelaborable /= 101 then
- raise Program_Error; -- Can't call Report.Failed, here,
- -- because Report is not preelaborated.
- end if;
-end G_Sub;
-
-separate(CA21001_1.Sub.G.G_Sub)
-function H(X: Integer) return Integer is
-begin
- return X + 1;
-end H;
-
-separate(CA21001_1)
-function F return Integer is
-
- package F_Sub is
- -- Empty.
- end F_Sub;
-
- package body F_Sub is separate;
-begin
- return 100;
-end F;
-
-separate(CA21001_1.F)
-package body F_Sub is
- True_Var: Boolean;
-begin
- True_Var := True;
- if True_Var then -- OK by AI-2.
- X := X;
- else
- X := X + 2;
- end if;
-end F_Sub;
-
-with Report; use Report;
-with CA21001_1;
-procedure CA21001 is
- X: Integer := 0;
-begin
- Test("CA21001",
- "Test that a package subunit whose parent is a preelaborated"
- & " subprogram need not be preelaborable");
- CA21001_1(X);
- if X /= 101 then
- Failed("Bad value for X");
- end if;
- Result;
-end CA21001;
diff --git a/gcc/testsuite/ada/acats/tests/cb/cb10002.a b/gcc/testsuite/ada/acats/tests/cb/cb10002.a
deleted file mode 100644
index f3099d4a26c..00000000000
--- a/gcc/testsuite/ada/acats/tests/cb/cb10002.a
+++ /dev/null
@@ -1,128 +0,0 @@
--- CB10002.A
-
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that Storage_Error is raised when storage for allocated objects
--- is exceeded.
---
--- TEST DESCRIPTION:
--- This test allocates a very large data structure.
---
--- In order to avoid running forever on virtual memory targets, the
--- data structure is bounded in size, and elements are larger the longer
--- the program runs.
---
--- The program attempts to allocate about 8,600,000 integers, or about
--- 32 Megabytes on a typical 32-bit machine.
---
--- If Storage_Error is raised, the data structure is deallocated.
--- (Otherwise, Report.Result may fail as memory is exhausted).
-
--- CHANGE HISTORY:
--- 30 Aug 85 JRK Ada 83 test created.
--- 14 Sep 99 RLB Created Ada 95 test.
-
-
-with Report;
-with Ada.Unchecked_Deallocation;
-procedure CB10002 is
-
- type Data_Space is array (Positive range <>) of Integer;
-
- type Element (Size : Positive);
-
- type Link is access Element;
-
- type Element (Size : Positive) is
- record
- Parent : Link;
- Child : Link;
- Sibling: Link;
- Data : Data_Space (1 .. Size);
- end record;
-
- procedure Free is new Ada.Unchecked_Deallocation (Element, Link);
-
- Holder : array (1 .. 430) of Link;
- Last_Allocated : Natural := 0;
-
- procedure Allocator (Count : in Positive) is
- begin
- -- Allocate various sized objects similar to what a real application
- -- would do.
- if Count in 1 .. 20 then
- Holder(Count) := new Element (Report.Ident_Int(10));
- elsif Count in 21 .. 40 then
- Holder(Count) := new Element (Report.Ident_Int(79));
- elsif Count in 41 .. 60 then
- Holder(Count) := new Element (Report.Ident_Int(250));
- elsif Count in 61 .. 80 then
- Holder(Count) := new Element (Report.Ident_Int(520));
- elsif Count in 81 .. 100 then
- Holder(Count) := new Element (Report.Ident_Int(1000));
- elsif Count in 101 .. 120 then
- Holder(Count) := new Element (Report.Ident_Int(2048));
- elsif Count in 121 .. 140 then
- Holder(Count) := new Element (Report.Ident_Int(4200));
- elsif Count in 141 .. 160 then
- Holder(Count) := new Element (Report.Ident_Int(7999));
- elsif Count in 161 .. 180 then
- Holder(Count) := new Element (Report.Ident_Int(15000));
- else -- 181..430
- Holder(Count) := new Element (Report.Ident_Int(32000));
- end if;
- Last_Allocated := Count;
- end Allocator;
-
-
-begin
- Report.Test ("CB10002", "Check that Storage_Error is raised when " &
- "storage for allocated objects is exceeded");
-
- begin
- for I in Holder'range loop
- Allocator (I);
- end loop;
- Report.Not_Applicable ("Unable to exhaust memory");
- for I in 1 .. Last_Allocated loop
- Free (Holder(I));
- end loop;
- exception
- when Storage_Error =>
- if Last_Allocated = 0 then
- Report.Failed ("Unable to allocate anything");
- else -- Clean up, so we have enough memory to report on the result.
- for I in 1 .. Last_Allocated loop
- Free (Holder(I));
- end loop;
- Report.Comment (Natural'Image(Last_Allocated) & " items allocated");
- end if;
- when others =>
- Report.Failed ("Wrong exception raised by heap overflow");
- end;
-
- Report.Result;
-
-end CB10002;
diff --git a/gcc/testsuite/ada/acats/tests/cb/cb20001.a b/gcc/testsuite/ada/acats/tests/cb/cb20001.a
deleted file mode 100644
index ccfad52e41e..00000000000
--- a/gcc/testsuite/ada/acats/tests/cb/cb20001.a
+++ /dev/null
@@ -1,228 +0,0 @@
--- CB20001.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that exceptions can be handled in accept bodies, and that a
--- task object that has an exception handled in an accept body is still
--- viable for future use.
---
--- TEST DESCRIPTION:
--- Declare a task that has exception handlers within an accept
--- statement in the task body. Declare a task object, and make entry
--- calls with data that will cause various exceptions to be raised
--- by the accept statement. Ensure that the exceptions are:
--- 1) raised and handled locally in the accept body
--- 2) raised in the accept body and handled/reraised to be handled
--- by the task body
--- 3) raised in the accept body and propagated to the calling
--- procedure.
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
---
---!
-
-with Report;
-
-package CB20001_0 is
-
- Incorrect_Data,
- Location_Error,
- Off_Screen_Data : exception;
-
- TC_Handled_In_Accept,
- TC_Reraised_In_Accept,
- TC_Handled_In_Task_Block,
- TC_Handled_In_Caller : boolean := False;
-
- type Location_Type is range 0 .. 2000;
-
- task type Submarine_Type is
- entry Contact (Location : in Location_Type);
- end Submarine_Type;
-
- Current_Position : Location_Type := 0;
-
-end CB20001_0;
-
-
- --=================================================================--
-
-
-package body CB20001_0 is
-
-
- task body Submarine_Type is
- begin
- loop
-
- Task_Block:
- begin
- select
- accept Contact (Location : in Location_Type) do
- if Location > 1000 then
- raise Off_Screen_Data;
- elsif (Location > 500) and (Location <= 1000) then
- raise Location_Error;
- elsif (Location > 100) and (Location <= 500) then
- raise Incorrect_Data;
- else
- Current_Position := Location;
- end if;
- exception
- when Off_Screen_Data =>
- TC_Handled_In_Accept := True;
- when Location_Error =>
- TC_Reraised_In_Accept := True;
- raise; -- Reraise the Location_Error exception
- -- in the task block.
- end Contact;
- or
- terminate;
- end select;
-
- exception
-
- when Off_Screen_Data =>
- TC_Handled_In_Accept := False;
- Report.Failed ("Off_Screen_Data exception " &
- "improperly handled in task block");
-
- when Location_Error =>
- TC_Handled_In_Task_Block := True;
- end Task_Block;
-
- end loop;
-
- exception
-
- when Location_Error | Off_Screen_Data =>
- TC_Handled_In_Accept := False;
- TC_Handled_In_Task_Block := False;
- Report.Failed ("Exception improperly propagated out to task body");
- when others =>
- null;
- end Submarine_Type;
-
-end CB20001_0;
-
-
- --=================================================================--
-
-
-with CB20001_0;
-with Report;
-with ImpDef;
-
-procedure CB20001 is
-
- package Submarine_Tracking renames CB20001_0;
-
- Trident : Submarine_Tracking.Submarine_Type; -- Declare task
- Sonar_Contact : Submarine_Tracking.Location_Type;
-
- TC_LEB_Error,
- TC_Main_Handler_Used : Boolean := False;
-
-begin
-
- Report.Test ("CB20001", "Check that exceptions can be handled " &
- "in accept bodies");
-
-
- Off_Screen_Block:
- begin
- Sonar_Contact := 1500;
- Trident.Contact (Sonar_Contact); -- Cause Off_Screen_Data exception
- -- to be raised and handled in a task
- -- accept body.
- exception
- when Submarine_Tracking.Off_Screen_Data =>
- TC_Main_Handler_Used := True;
- Report.Failed ("Off_Screen_Data exception improperly handled " &
- "in calling procedure");
- when others =>
- Report.Failed ("Exception handled unexpectedly in " &
- "Off_Screen_Block");
- end Off_Screen_Block;
-
-
- Location_Error_Block:
- begin
- Sonar_Contact := 700;
- Trident.Contact (Sonar_Contact); -- Cause Location_Error exception
- -- to be raised in task accept body,
- -- propogated to a task block, and
- -- handled there. Corresponding
- -- exception propagated here also.
- Report.Failed ("Expected exception not raised");
- exception
- when Submarine_Tracking.Location_Error =>
- TC_LEB_Error := True;
- when others =>
- Report.Failed ("Exception handled unexpectedly in " &
- "Location_Error_Block");
- end Location_Error_Block;
-
-
- Incorrect_Data_Block:
- begin
- Sonar_Contact := 200;
- Trident.Contact (Sonar_Contact); -- Cause Incorrect_Data exception
- -- to be raised in task accept body,
- -- propogated to calling procedure.
- Report.Failed ("Expected exception not raised");
- exception
- when Submarine_Tracking.Incorrect_Data =>
- Submarine_Tracking.TC_Handled_In_Caller := True;
- when others =>
- Report.Failed ("Exception handled unexpectedly in " &
- "Incorrect_Data_Block");
- end Incorrect_Data_Block;
-
-
- if TC_Main_Handler_Used or
- not (Submarine_Tracking.TC_Handled_In_Caller and -- Check to see that
- Submarine_Tracking.TC_Handled_In_Task_Block and -- all exceptions
- Submarine_Tracking.TC_Handled_In_Accept and -- were handled in
- Submarine_Tracking.TC_Reraised_In_Accept and -- proper locations.
- TC_LEB_Error)
- then
- Report.Failed ("Exceptions handled in incorrect locations");
- end if;
-
- if Integer(Submarine_Tracking.Current_Position) /= 0 then
- Report.Failed ("Variable incorrectly written in task processing");
- end if;
-
- delay ImpDef.Minimum_Task_Switch;
- if Trident'Callable then
- Report.Failed ("Task didn't terminate with exception propagation");
- end if;
-
- Report.Result;
-
-end CB20001;
diff --git a/gcc/testsuite/ada/acats/tests/cb/cb20003.a b/gcc/testsuite/ada/acats/tests/cb/cb20003.a
deleted file mode 100644
index daaf9ffe5c5..00000000000
--- a/gcc/testsuite/ada/acats/tests/cb/cb20003.a
+++ /dev/null
@@ -1,286 +0,0 @@
--- CB20003.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that exceptions can be raised, reraised, and handled in an
--- accessed subprogram.
---
---
--- TEST DESCRIPTION:
--- Declare a record type, with one component being an access to
--- subprogram type. Various subprograms are defined to fit the profile
--- of this access type, such that the record component can refer to
--- any of the subprograms.
---
--- Each of the subprograms raises a different exception, based on the
--- value of an input parameter. Exceptions are 1) raised, handled with
--- an others handler, reraised and propagated to main to be handled in
--- a specific handler; 2) raised, handled in a specific handler, reraised
--- and propagated to the main to be handled in an others handler there,
--- and 3) raised and propagated directly to the caller by the subprogram.
---
--- Boolean variables are set throughout the test to ensure that correct
--- exception processing has occurred, and these variables are verified at
--- the conclusion of the test.
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
---
---!
-
-package CB20003_0 is -- package Push_Buttons
-
-
- Non_Default_Priority,
- Non_Alert_Priority,
- Non_Emergency_Priority : exception;
-
- Handled_With_Others,
- Reraised_In_Subprogram,
- Handled_In_Caller : Boolean := False;
-
- subtype Priority_Type is Integer range 1 .. 10;
-
- Default_Priority : Priority_Type := 1;
- Alert_Priority : Priority_Type := 3;
- Emergency_Priority : Priority_Type := 5;
-
-
- type Button is tagged private; -- Private tagged type.
-
- type Button_Response_Ptr is access procedure (P : in Priority_Type;
- B : in out Button);
-
-
- -- Procedures accessible with Button_Response_Ptr type.
-
- procedure Default_Response (P : in Priority_Type;
- B : in out Button);
-
- procedure Alert_Response (P : in Priority_Type;
- B : in out Button);
-
- procedure Emergency_Response (P : in Priority_Type;
- B : in out Button);
-
-
-
- procedure Push (B : in out Button;
- P : in Priority_Type);
-
- procedure Set_Response (B : in out Button;
- R : in Button_Response_Ptr);
-
-private
-
- type Button is tagged
- record
- Priority : Priority_Type := Default_Priority;
- Response : Button_Response_Ptr := Default_Response'Access;
- end record;
-
-
-end CB20003_0; -- package Push_Buttons
-
-
- --=================================================================--
-
-
-with Report;
-
-package body CB20003_0 is -- package Push_Buttons
-
-
- procedure Push (B : in out Button;
- P : in Priority_Type) is
- begin -- Invoking subprogram designated
- B.Response (P, B); -- by access value.
- end Push;
-
-
- procedure Set_Response (B : in out Button;
- R : in Button_Response_Ptr) is
- begin
- B.Response := R; -- Set procedure value in record
- end Set_Response;
-
-
- procedure Default_Response (P : in Priority_Type;
- B : in out Button) is
- begin
- if (P > Default_Priority) then
- raise Non_Default_Priority;
- Report.Failed ("Exception not raised in procedure body");
- else
- B.Priority := P;
- end if;
- exception
- when others => -- Catch exception with others handler
- Handled_With_Others := True; -- Successfully caught with "others"
- raise;
- Report.Failed ("Exception not reraised in handler");
- end Default_Response;
-
-
-
- procedure Alert_Response (P : in Priority_Type;
- B : in out Button) is
- begin
- if (P > Alert_Priority) then
- raise Non_Alert_Priority;
- Report.Failed ("Exception not raised in procedure body");
- else
- B.Priority := P;
- end if;
- exception
- when Non_Alert_Priority =>
- Reraised_In_Subprogram := True;
- raise; -- Propagate to caller.
- Report.Failed ("Exception not reraised in procedure excpt handler");
- when others =>
- Report.Failed ("Incorrect exception raised/handled");
- end Alert_Response;
-
-
-
- procedure Emergency_Response (P : in Priority_type;
- B : in out Button) is
- begin
- if (P > Emergency_Priority) then
- raise Non_Emergency_Priority;
- Report.Failed ("Exception not raised in procedure body");
- else
- B.Priority := P;
- end if;
- -- No exception handler here, exception will be propagated to caller.
- end Emergency_Response;
-
-
-end CB20003_0; -- package Push_Buttons
-
-
- --=================================================================--
-
-
-with Report;
-with CB20003_0; -- package Push_Buttons
-
-procedure CB20003 is
-
- package Push_Buttons renames CB20003_0;
-
- Console_Button : Push_Buttons.Button;
-
-begin
-
- Report.Test ("CB20003", "Check that exceptions can be raised, " &
- "reraised, and handled in a subprogram " &
- "referenced by an access to subprogram value");
-
-
- Default_Response_Processing: -- The exception
- -- Handled_With_Others is to
- -- be caught with an others
- -- handler in Default_Resp.,
- -- reraised, and handled with
- -- a specific handler here.
- begin
-
- Push_Buttons.Push (Console_Button, -- Raise exception that will
- Report.Ident_Int(2)); -- be handled in procedure.
- exception
- when Push_Buttons.Non_Default_Priority =>
- if not Push_Buttons.Handled_With_Others then -- Not reraised in
- -- procedure.
- Report.Failed
- ("Exception not handled/reraised in procedure");
- end if;
- when others =>
- Report.Failed ("Exception handled in " &
- " Default_Response_Processing block");
- end Default_Response_Processing;
-
-
-
- Alert_Response_Processing:
- begin
-
- Push_Buttons.Set_Response (Console_Button,
- Push_Buttons.Alert_Response'access);
-
- Push_Buttons.Push (Console_Button, -- Raise exception that will
- Report.Ident_Int(4)); -- be handled in procedure,
- -- reraised, and propagated
- -- to caller.
- Report.Failed ("Exception not propagated to caller " &
- "in Alert_Response_Processing block");
-
- exception
- when Push_Buttons.Non_Alert_Priority =>
- if not Push_Buttons.Reraised_In_Subprogram then -- Not reraised in
- -- procedure.
- Report.Failed ("Exception not reraised in procedure");
- end if;
- when others =>
- Report.Failed ("Exception handled in " &
- " Alert_Response_Processing block");
- end Alert_Response_Processing;
-
-
-
- Emergency_Response_Processing:
- begin
-
- Push_Buttons.Set_Response (Console_Button,
- Push_Buttons.Emergency_Response'access);
-
- Push_Buttons.Push (Console_Button, -- Raise exception that will
- Report.Ident_Int(6)); -- be propagated directly to
- -- caller.
- Report.Failed ("Exception not propagated to caller " &
- "in Emergency_Response_Processing block");
-
- exception
- when Push_Buttons.Non_Emergency_Priority =>
- Push_Buttons.Handled_In_Caller := True;
- when others =>
- Report.Failed ("Exception handled in " &
- " Emergency_Response_Processing block");
- end Emergency_Response_Processing;
-
-
-
- if not (Push_Buttons.Handled_With_Others and
- Push_Buttons.Reraised_In_Subprogram and
- Push_Buttons.Handled_In_Caller )
- then
- Report.Failed ("Incorrect exception handling in referenced subprograms");
- end if;
-
-
- Report.Result;
-
-end CB20003;
diff --git a/gcc/testsuite/ada/acats/tests/cb/cb20004.a b/gcc/testsuite/ada/acats/tests/cb/cb20004.a
deleted file mode 100644
index 42c0d767254..00000000000
--- a/gcc/testsuite/ada/acats/tests/cb/cb20004.a
+++ /dev/null
@@ -1,203 +0,0 @@
--- CB20004.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that exceptions propagate correctly from objects of
--- protected types. Check propagation from protected entry bodies.
---
--- TEST DESCRIPTION:
--- Declare a package with a protected type, including entries and private
--- data, simulating a bounded buffer abstraction. In the main procedure,
--- perform entry calls on an object of the protected type that raises
--- exceptions.
--- Ensure that the exceptions are:
--- 1) raised and handled locally in the entry body
--- 2) raised in the entry body and handled/reraised to be handled
--- by the caller.
--- 3) raised in the entry body and propagated directly to the calling
--- procedure.
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
---
---!
-
-package CB20004_0 is -- Package Buffer.
-
- Max_Buffer_Size : constant := 2;
-
- Handled_In_Body,
- Propagated_To_Caller,
- Handled_In_Caller : Boolean := False;
-
- Data_Over_5,
- Data_Degradation : exception;
-
- type Data_Item is range 0 .. 100;
-
- type Item_Array_Type is array (1 .. Max_Buffer_Size) of Data_Item;
-
- protected type Bounded_Buffer is
- entry Put (Item : in Data_Item);
- entry Get (Item : out Data_Item);
- private
- Item_Array : Item_Array_Type;
- I, J : Integer range 1 .. Max_Buffer_Size := 1;
- Count : Integer range 0 .. Max_Buffer_Size := 0;
- end Bounded_Buffer;
-
-end CB20004_0;
-
- --=================================================================--
-
-with Report;
-
-package body CB20004_0 is -- Package Buffer.
-
- protected body Bounded_Buffer is
-
- entry Put (Item : in Data_Item) when Count < Max_Buffer_Size is
- begin
- if Item > 10 then
- Item_Array (I) := Item * 8; -- Constraint_Error will be raised
- elsif Item > 5 then -- and handled in entry body.
- raise Data_Over_5; -- Exception handled/reraised in
- else -- entry body, propagated to caller.
- Item_Array (I) := Item; -- Store data item in buffer.
- I := (I mod Max_Buffer_Size) + 1;
- Count := Count + 1;
- end if;
- exception
- when Constraint_Error =>
- Handled_In_Body := True;
- when Data_Over_5 =>
- Propagated_To_Caller := True;
- raise; -- Propagate the exception to the caller.
- end Put;
-
-
- entry Get (Item : out Data_Item) when Count > 0 is
- begin
- Item := Item_Array(J);
- J := (J mod Max_Buffer_Size) + 1;
- Count := Count - 1;
- if Count = 0 then
- raise Data_Degradation; -- Exception to propagate to caller.
- end if;
- end Get;
-
- end Bounded_Buffer;
-
-end CB20004_0;
-
-
- --=================================================================--
-
-
-with CB20004_0; -- Package Buffer.
-with Report;
-
-procedure CB20004 is
-
- package Buffer renames CB20004_0;
-
- Data : Buffer.Data_Item := Buffer.Data_Item'First;
- Data_Buffer : Buffer.Bounded_Buffer; -- an object of protected type.
-
- Handled_In_Caller : Boolean := False; -- same name as boolean declared
- -- in package Buffer.
-begin
-
- Report.Test ("CB20004", "Check that exceptions propagate correctly " &
- "from objects of protected types" );
-
- Initial_Data_Block:
- begin -- Data causes Constraint_Error.
- Data_Buffer.Put (CB20004_0.Data_Item(Report.Ident_Int(51)));
-
- exception
- when Constraint_Error =>
- Buffer.Handled_In_Body := False; -- Improper exception handling
- -- in entry body.
- Report.Failed ("Exception propagated to caller " &
- " from Initial_Data_Block");
- when others =>
- Report.Failed ("Exception raised in processing and " &
- "propagated to caller from Initial_Data_Block");
- end Initial_Data_Block;
-
-
- Data_Entry_Block:
- begin
- -- Valid data. No exception.
- Data_Buffer.Put (CB20004_0.Data_Item(Report.Ident_Int(3)));
-
- -- Data will cause exception.
- Data_Buffer.Put (7); -- Call protected object entry,
- -- exception to be handled/
- -- reraised in entry body.
- Report.Failed ("Data_Over_5 Exception not raised in processing");
- exception
- when Buffer.Data_Over_5 =>
- if Buffer.Propagated_To_Caller then -- Reraised in entry body?
- Buffer.Handled_In_Caller := True;
- else
- Report.Failed ("Exception not reraised in entry body");
- end if;
- when others =>
- Report.Failed ("Exception raised in processing and propagated " &
- "to caller from Data_Entry_Block");
- end Data_Entry_Block;
-
-
- Data_Retrieval_Block:
- begin
-
- Data_Buffer.Get (Data); -- Retrieval of buffer data, buffer now empty.
- -- Exception will be raised in entry body, with
- -- propagation to caller.
- Report.Failed ("Data_Degradation Exception not raised in processing");
- exception
- when Buffer.Data_Degradation =>
- Handled_In_Caller := True; -- Local Boolean used here.
- when others =>
- Report.Failed ("Exception raised in processing and propagated " &
- "to caller from Data_Retrieval_Block");
- end Data_Retrieval_Block;
-
-
- if not (Buffer.Handled_In_Body and -- Validate proper exception
- Buffer.Propagated_To_Caller and -- handling in entry bodies.
- Buffer.Handled_In_Caller and
- Handled_In_Caller)
- then
- Report.Failed ("Improper exception handling by entry bodies");
- end if;
-
-
- Report.Result;
-
-end CB20004;
diff --git a/gcc/testsuite/ada/acats/tests/cb/cb20005.a b/gcc/testsuite/ada/acats/tests/cb/cb20005.a
deleted file mode 100644
index 898d2a2c644..00000000000
--- a/gcc/testsuite/ada/acats/tests/cb/cb20005.a
+++ /dev/null
@@ -1,210 +0,0 @@
--- CB20005.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that exceptions are raised and properly handled locally in
--- protected operations.
---
--- TEST DESCRIPTION:
--- Declare a package with a protected type, including protected operation
--- declarations and private data, simulating a counting semaphore.
--- In the main procedure, perform calls on protected operations
--- of the protected object designed to induce the raising of exceptions.
---
--- Ensure that the exceptions are raised and handled locally in a
--- protected procedures and functions, and that in this case the
--- exceptions will not propagate to the calling unit. Use specific
--- exception handlers in the protected functions.
---
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
---
---!
-
-package CB20005_0 is -- Package Semaphore.
-
- Handled_In_Function,
- Handled_In_Procedure : Boolean := False;
-
- Resource_Overflow,
- Resource_Underflow : exception;
-
- protected type Counting_Semaphore (Max_Resources : Integer) is
- procedure Secure;
- function Resource_Limit_Exceeded return Boolean;
- procedure Release;
- private
- Count : Integer := Max_Resources;
- end Counting_Semaphore;
-
-end CB20005_0;
-
- --=================================================================--
-
-with Report;
-
-package body CB20005_0 is -- Package Semaphore.
-
- protected body Counting_Semaphore is
-
- procedure Secure is
- begin
- if (Count = 0) then -- No resources left to secure.
- raise Resource_Underflow;
- Report.Failed
- ("Program control not transferred by raise in Secure");
- else
- Count := Count - 1; -- Avail resources decremented.
- end if;
- exception
- when Resource_Underflow => -- Exception handled locally in
- Handled_In_Procedure := True; -- this protected operation.
- when others =>
- Report.Failed ("Unexpected exception raised in Secure");
- end Secure;
-
-
- function Resource_Limit_Exceeded return Boolean is
- begin
- if (Count > Max_Resources) then
- raise Resource_Overflow; -- Exception used as control flow
- -- mechanism.
- Report.Failed
- ("Program control not transferred by raise in " &
- "Resource_Limit_Exceeded");
- else
- return (False);
- end if;
- exception
- when Resource_Overflow => -- Handle its own raised
- Handled_In_Function := True; -- exception.
- return (True);
- when others =>
- Report.Failed
- ("Unexpected exception raised in Resource_Limit_Exceeded");
- end Resource_Limit_Exceeded;
-
-
- procedure Release is
- begin
- Count := Count + 1; -- Count of resources available
- -- incremented.
- if Resource_Limit_Exceeded then -- Call to protected operation
- Count := Count - 1; -- function that raises/handles
- end if; -- an exception.
- exception
- when Resource_Overflow =>
- Handled_In_Function := False;
- Report.Failed ("Exception propagated to Function Release");
- when others =>
- Report.Failed ("Unexpected exception raised in Function Release");
- end Release;
-
-
- end Counting_Semaphore;
-
-end CB20005_0;
-
-
- --=================================================================--
-
-
-with CB20005_0; -- Package Semaphore.
-with Report;
-
-procedure CB20005 is
-begin
-
- Report.Test ("CB20005", "Check that exceptions are raised and handled " &
- "correctly in protected operations" );
-
- Test_Block:
- declare
-
- package Semaphore renames CB20005_0;
-
- Total_Resources_Available : constant := 1;
-
- Resources : Semaphore.Counting_Semaphore(Total_Resources_Available);
- -- An object of protected type.
-
- begin
-
- Allocate_Resources:
- declare
- Loop_Count : Integer := Total_Resources_Available + 1;
- begin
- for I in 1..Loop_Count loop -- Force exception.
- Resources.Secure;
- end loop;
- exception
- when Semaphore.Resource_Underflow =>
- Semaphore.Handled_In_Procedure := False; -- Excptn not handled
- Report.Failed -- in prot. operation.
- ("Resource_Underflow exception not handled " &
- "in Allocate_Resources");
- when others =>
- Report.Failed
- ("Exception unexpectedly raised during resource allocation");
- end Allocate_Resources;
-
-
- Deallocate_Resources:
- declare
- Loop_Count : Integer := Total_Resources_Available + 1;
- begin
- for I in 1..Loop_Count loop -- Force excptn.
- Resources.Release;
- end loop;
- exception
- when Semaphore.Resource_Overflow =>
- Semaphore.Handled_In_Function := False; -- Exception not handled
- Report.Failed -- in prot. operation.
- ("Resource overflow not handled by function");
- when others =>
- Report.Failed
- ("Exception raised during resource deallocation");
- end Deallocate_Resources;
-
-
- if not (Semaphore.Handled_In_Procedure and -- Incorrect excpt. handling
- Semaphore.Handled_In_Function) -- in protected operations.
- then
- Report.Failed
- ("Improper exception handling by protected operations");
- end if;
-
-
- exception
- when others =>
- Report.Failed ("Exception raised and propagated in test");
-
- end Test_Block;
-
- Report.Result;
-
-end CB20005;
diff --git a/gcc/testsuite/ada/acats/tests/cb/cb20006.a b/gcc/testsuite/ada/acats/tests/cb/cb20006.a
deleted file mode 100644
index f2b3c70a911..00000000000
--- a/gcc/testsuite/ada/acats/tests/cb/cb20006.a
+++ /dev/null
@@ -1,217 +0,0 @@
--- CB20006.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that exceptions are raised and properly handled (including
--- propagation by reraise) in protected operations.
---
--- TEST DESCRIPTION:
--- Declare a package with a protected type, including protected operation
--- declarations and private data, simulating a counting semaphore.
--- In the main procedure, perform calls on protected operations
--- of the protected object designed to induce the raising of exceptions.
---
--- The exceptions raised are to be initially handled in the protected
--- operations, but this handling involves the reraise of the exception
--- and the propagation of the exception to the caller.
---
--- Ensure that the exceptions are raised, handled / reraised successfully
--- in protected procedures and functions. Use "others" handlers in the
--- protected operations.
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
---
---!
-
-package CB20006_0 is -- Package Semaphore.
-
- Reraised_In_Function,
- Reraised_In_Procedure,
- Handled_In_Function_Caller,
- Handled_In_Procedure_Caller : Boolean := False;
-
- Resource_Overflow,
- Resource_Underflow : exception;
-
- protected type Counting_Semaphore (Max_Resources : Integer) is
- procedure Secure;
- function Resource_Limit_Exceeded return Boolean;
- procedure Release;
- private
- Count : Integer := Max_Resources;
- end Counting_Semaphore;
-
-end CB20006_0;
-
- --=================================================================--
-
-with Report;
-
-package body CB20006_0 is -- Package Semaphore.
-
- protected body Counting_Semaphore is
-
- procedure Secure is
- begin
- if (Count = 0) then -- No resources left to secure.
- raise Resource_Underflow;
- Report.Failed
- ("Program control not transferred by raise in Procedure Secure");
- else
- Count := Count - 1; -- Available resources decremented.
- end if;
- exception
- when Resource_Underflow =>
- Reraised_In_Procedure := True;
- raise; -- Exception propagated to caller.
- Report.Failed ("Exception not propagated to caller from Secure");
- when others =>
- Report.Failed ("Unexpected exception raised in Secure");
- end Secure;
-
-
- function Resource_Limit_Exceeded return Boolean is
- begin
- if (Count > Max_Resources) then
- raise Resource_Overflow; -- Exception used as control flow
- -- mechanism.
- Report.Failed
- ("Specific raise did not alter program control" &
- " from Resource_Limit_Exceeded");
- else
- return (False);
- end if;
- exception
- when others =>
- Reraised_In_Function := True;
- raise; -- Exception propagated to caller.
- Report.Failed ("Exception not propagated to caller" &
- " from Resource_Limit_Exceeded");
- end Resource_Limit_Exceeded;
-
-
- procedure Release is
- begin
- Count := Count + 1; -- Count of resources available
- -- incremented.
- if Resource_Limit_Exceeded then -- Call to protected operation
- Count := Count - 1; -- function that raises/reraises
- -- an exception.
- Report.Failed("Resource limit exceeded");
- end if;
-
- exception
- when others =>
- raise; -- Reraised and propagated again.
- Report.Failed ("Exception not reraised by procedure Release");
- end Release;
-
-
- end Counting_Semaphore;
-
-end CB20006_0;
-
-
- --=================================================================--
-
-
-with CB20006_0; -- Package Semaphore.
-with Report;
-
-procedure CB20006 is
-begin
-
- Report.Test ("CB20006", "Check that exceptions are raised and " &
- "handled / reraised and propagated " &
- "correctly by protected operations" );
-
- Test_Block:
- declare
-
- package Semaphore renames CB20006_0;
-
- Total_Resources_Available : constant := 1;
-
- Resources : Semaphore.Counting_Semaphore (Total_Resources_Available);
- -- An object of protected type.
-
- begin
-
- Allocate_Resources:
- declare
- Loop_Count : Integer := Total_Resources_Available + 1;
- begin
- for I in 1..Loop_Count loop -- Force exception
- Resources.Secure;
- end loop;
- Report.Failed
- ("Exception not propagated from protected operation Secure");
- exception
- when Semaphore.Resource_Underflow => -- Exception propagated
- Semaphore.Handled_In_Procedure_Caller := True; -- from protected
- when others => -- procedure.
- Semaphore.Handled_In_Procedure_Caller := False;
- end Allocate_Resources;
-
-
- Deallocate_Resources:
- declare
- Loop_Count : Integer := Total_Resources_Available + 1;
- begin
- for I in 1..Loop_Count loop -- Force exception
- Resources.Release;
- end loop;
- Report.Failed
- ("Exception not propagated from protected operation Release");
- exception
- when Semaphore.Resource_Overflow => -- Exception propagated
- Semaphore.Handled_In_Function_Caller := True; -- from protected
- when others => -- function.
- Semaphore.Handled_In_Function_Caller := False;
- end Deallocate_Resources;
-
-
- if not (Semaphore.Reraised_In_Procedure and
- Semaphore.Reraised_In_Function and
- Semaphore.Handled_In_Procedure_Caller and
- Semaphore.Handled_In_Function_Caller)
- then -- Incorrect excpt. handling
- Report.Failed -- in protected operations.
- ("Improper exception handling/reraising by protected operations");
- end if;
-
- exception
-
- when others =>
- Report.Failed ("Unexpected exception " &
- " raised and propagated in test");
- end Test_Block;
-
- Report.Result;
-
-
-end CB20006;
diff --git a/gcc/testsuite/ada/acats/tests/cb/cb20007.a b/gcc/testsuite/ada/acats/tests/cb/cb20007.a
deleted file mode 100644
index 6d052517e3b..00000000000
--- a/gcc/testsuite/ada/acats/tests/cb/cb20007.a
+++ /dev/null
@@ -1,196 +0,0 @@
--- CB20007.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that exceptions are raised and can be directly propagated to
--- the calling unit by protected operations.
---
--- TEST DESCRIPTION:
--- Declare a package with a protected type, including protected operation
--- declarations and private data, simulating a counting semaphore.
--- In the main procedure, perform calls on protected operations
--- of the protected object designed to induce the raising of exceptions.
---
--- The exceptions raised are to be propagated directly from the protected
--- operations to the calling unit.
---
--- Ensure that the exceptions are raised and correctly propagated directly
--- to the calling unit from protected procedures and functions.
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
---
---!
-
-package CB20007_0 is -- Package Semaphore.
-
- Handled_In_Function_Caller,
- Handled_In_Procedure_Caller : Boolean := False;
-
- Resource_Overflow,
- Resource_Underflow : exception;
-
- protected type Counting_Semaphore (Max_Resources : Integer) is
- procedure Secure;
- function Resource_Limit_Exceeded return Boolean;
- procedure Release;
- private
- Count : Integer := Max_Resources;
- end Counting_Semaphore;
-
-end CB20007_0;
-
- --=================================================================--
-
-with Report;
-
-package body CB20007_0 is -- Package Semaphore.
-
- protected body Counting_Semaphore is
-
- procedure Secure is
- begin
- if (Count = 0) then -- No resources left to secure.
- raise Resource_Underflow;
- Report.Failed ("Program control not transferred by raise");
- else
- Count := Count - 1; -- Available resources decremented.
- end if;
- -- No exception handlers here, direct propagation to calling unit.
- end Secure;
-
-
- function Resource_Limit_Exceeded return Boolean is
- begin
- if (Count > Max_Resources) then
- raise Resource_Overflow; -- Exception used as control flow
- -- mechanism.
- Report.Failed ("Program control not transferred by raise");
- else
- return (False);
- end if;
- -- No exception handlers here, direct propagation to calling unit.
- end Resource_Limit_Exceeded;
-
-
- procedure Release is
- begin
- Count := Count + 1; -- Count of resources available
- -- incremented.
- if Resource_Limit_Exceeded then -- Call to protected operation
- Count := Count - 1; -- function that raises an
- -- exception.
- Report.Failed("Resource limit exceeded");
- end if;
- -- No exception handler here for exception raised in function.
- -- Exception will propagate directly to calling unit.
- end Release;
-
-
- end Counting_Semaphore;
-
-end CB20007_0;
-
-
- --=================================================================--
-
-
-with CB20007_0; -- Package Semaphore.
-with Report;
-
-procedure CB20007 is
-begin
-
- Test_Block:
- declare
-
- package Semaphore renames CB20007_0;
-
- Total_Resources_Available : constant := 1;
-
- Resources : Semaphore.Counting_Semaphore (Total_Resources_Available);
- -- An object of protected type.
-
- begin
-
- Report.Test ("CB20007", "Check that exceptions are raised and can " &
- "be directly propagated to the calling unit " &
- "by protected operations" );
-
- Allocate_Resources:
- declare
- Loop_Count : Integer := Total_Resources_Available + 1;
- begin -- Force exception.
- for I in 1..Loop_Count loop
- Resources.Secure;
- end loop;
- Report.Failed ("Exception not propagated from protected " &
- " operation in Allocate_Resources");
- exception
- when Semaphore.Resource_Underflow => -- Exception prop.
- Semaphore.Handled_In_Procedure_Caller := True; -- from protected
- -- procedure.
- when others =>
- Report.Failed ("Unknown exception during resource allocation");
- end Allocate_Resources;
-
-
- Deallocate_Resources:
- declare
- Loop_Count : Integer := Total_Resources_Available + 1;
- begin -- Force exception.
- for I in 1..Loop_Count loop
- Resources.Release;
- end loop;
- Report.Failed ("Exception not propagated from protected " &
- "operation in Deallocate_Resources");
- exception
- when Semaphore.Resource_Overflow => -- Exception prop
- Semaphore.Handled_In_Function_Caller := True; -- from protected
- -- function.
- when others =>
- Report.Failed ("Exception raised during resource deallocation");
- end Deallocate_Resources;
-
-
- if not (Semaphore.Handled_In_Procedure_Caller and -- Incorrect exception
- Semaphore.Handled_In_Function_Caller) -- handling in
- then -- protected ops.
- Report.Failed
- ("Improper exception propagation by protected operations");
- end if;
-
- exception
-
- when others =>
- Report.Failed ("Unexpected exception " &
- " raised and propagated in test");
- end Test_Block;
-
-
- Report.Result;
-
-end CB20007;
diff --git a/gcc/testsuite/ada/acats/tests/cb/cb20a02.a b/gcc/testsuite/ada/acats/tests/cb/cb20a02.a
deleted file mode 100644
index 4c8537086cf..00000000000
--- a/gcc/testsuite/ada/acats/tests/cb/cb20a02.a
+++ /dev/null
@@ -1,155 +0,0 @@
--- CB20A02.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that the name and pertinent information about a user defined
--- exception are available to an enclosing program unit even when the
--- enclosing unit has no visibility into the scope where the exception
--- is declared and raised.
---
--- TEST DESCRIPTION:
--- Declare a subprogram nested within the test subprogram. The enclosing
--- subprogram does not have visibility into the nested subprogram.
--- Declare and raise an exception in the nested subprogram, and allow
--- the exception to propagate to the enclosing scope. Use the function
--- Exception_Name in the enclosing subprogram to produce exception
--- specific information when the exception is handled in an others
--- handler.
---
--- TEST FILES:
---
--- This test depends on the following foundation code file:
--- FB20A00.A
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
---
---!
-
-with FB20A00; -- Package containing Function Find
-with Ada.Exceptions;
-with Report;
-
-procedure CB20A02 is
-
- Seed_Number : Integer;
- Random_Number : Integer := 0;
-
- --=================================================================--
-
- function Random_Number_Generator (Seed : Integer) return Integer is
-
- Result : Integer := 0;
-
- HighSeedError,
- Mid_Seed_Error,
- L_o_w_S_e_e_d_E_r_r_o_r : exception;
-
- begin -- Random_Number_Generator
-
-
- if (Report.Ident_Int (Seed) > 1000) then
- raise HighSeedError;
- elsif (Report.Ident_Int (Seed) > 100) then
- raise Mid_Seed_Error;
- elsif (Report.Ident_Int (Seed) > 10) then
- raise L_o_w_S_e_e_d_E_r_r_o_r;
- else
- Seed_Number := ((Seed_Number * 417) + 231) mod 53;
- Result := Seed_Number / 52;
- end if;
-
- return Result;
-
- end Random_Number_Generator;
-
- --=================================================================--
-
-begin
-
- Report.Test ("CB20A02", "Check that the name " &
- "of a user defined exception is available " &
- "to an enclosing program unit even when the " &
- "enclosing unit has no visibility into the " &
- "scope where the exception is declared and " &
- "raised" );
-
- High_Seed:
- begin
- -- This seed value will result in the raising of a HighSeedError
- -- exception.
- Seed_Number := 1001;
- Random_Number := Random_Number_Generator (Seed_Number);
- Report.Failed ("Exception not raised in High_Seed block");
- exception
- when Error : others =>
- if not FB20A00.Find (Ada.Exceptions.Exception_Name (Error),
- "HighSeedError")
- then
- Report.Failed ("Expected HighSeedError, but found " &
- Ada.Exceptions.Exception_Name (Error));
- end if;
- end High_Seed;
-
-
- Mid_Seed:
- begin
- -- This seed value will generate a Mid_Seed_Error exception.
- Seed_Number := 101;
- Random_Number := Random_Number_Generator (Seed_Number);
- Report.Failed ("Exception not raised in Mid_Seed block");
- exception
- when Error : others =>
- if not FB20A00.Find (Ada.Exceptions.Exception_Name (Error),
- "Mid_Seed_Error")
- then
- Report.Failed ("Expected Mid_Seed_Error, but found " &
- Ada.Exceptions.Exception_Name (Error));
- end if;
- end Mid_Seed;
-
-
- Low_Seed:
- begin
- -- This seed value will result in the raising of a
- -- L_o_w_S_e_e_d_E_r_r_o_r exception.
- Seed_Number := 11;
- Random_Number := Random_Number_Generator (Seed_Number);
- Report.Failed ("Exception not raised in Low_Seed block");
- exception
- when Error : others =>
- if not FB20A00.Find (Ada.Exceptions.Exception_Name (Error),
- "L_o_w_S_e_e_d_E_r_r_o_r")
- then
- Report.Failed ("Expected L_o_w_S_e_e_d_E_r_r_o_r but found " &
- Ada.Exceptions.Exception_Name (Error));
- end if;
- end Low_Seed;
-
-
- Report.Result;
-
-end CB20A02;
diff --git a/gcc/testsuite/ada/acats/tests/cb/cb40005.a b/gcc/testsuite/ada/acats/tests/cb/cb40005.a
deleted file mode 100644
index 681ec18ff28..00000000000
--- a/gcc/testsuite/ada/acats/tests/cb/cb40005.a
+++ /dev/null
@@ -1,339 +0,0 @@
--- CB40005.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that exceptions raised in non-generic code can be handled by
--- a procedure in a generic package. Check that the exception identity
--- can be properly retrieved from the generic code and used by the
--- non-generic code.
---
--- TEST DESCRIPTION:
--- This test models a possible usage paradigm for the type:
--- Ada.Exceptions.Exception_Occurrence.
---
--- A generic package takes access to procedure types (allowing it to
--- be used at any accessibility level) and defines a "fail soft"
--- procedure that takes designators to a procedure to call, a
--- procedure to call in the event that it fails, and a function to
--- call to determine the next action.
---
--- In the event an exception occurs on the call to the first procedure,
--- the exception is stored in a stack; along with the designator to the
--- procedure that caused it; allowing the procedure to be called again,
--- or the exception to be re-raised.
---
--- A full implementation of such a tool would use a more robust storage
--- mechanism, and would provide a more flexible interface.
---
---
--- CHANGE HISTORY:
--- 29 MAR 96 SAIC Initial version
--- 12 NOV 96 SAIC Revised for 2.1 release
---
---!
-
------------------------------------------------------------------ CB40005_0
-
-with Ada.Exceptions;
-generic
- type Proc_Pointer is access procedure;
- type Func_Pointer is access function return Proc_Pointer;
-package CB40005_0 is -- Fail_Soft
-
-
- procedure Fail_Soft_Call( Proc_To_Call : Proc_Pointer;
- Proc_To_Call_On_Exception : Proc_Pointer := null;
- Retry_Routine : Func_Pointer := null );
-
- function Top_Event_Exception return Ada.Exceptions.Exception_Occurrence;
-
- function Top_Event_Procedure return Proc_Pointer;
-
- procedure Pop_Event;
-
- function Event_Stack_Size return Natural;
-
-end CB40005_0; -- Fail_Soft
-
--- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- CB40005_0
-
-with Report;
-package body CB40005_0 is
-
- type History_Event is record
- Exception_Event : Ada.Exceptions.Exception_Occurrence_Access;
- Procedure_Called : Proc_Pointer;
- end record;
-
- procedure Store_Event( Proc_Called : Proc_Pointer;
- Error : Ada.Exceptions.Exception_Occurrence );
-
- procedure Fail_Soft_Call( Proc_To_Call : Proc_Pointer;
- Proc_To_Call_On_Exception : Proc_Pointer := null;
- Retry_Routine : Func_Pointer := null ) is
-
- Current_Proc_To_Call : Proc_Pointer := Proc_To_Call;
-
- begin
- while Current_Proc_To_Call /= null loop
- begin
- Current_Proc_To_Call.all; -- call procedure through pointer
- Current_Proc_To_Call := null;
- exception
- when Capture: others =>
- Store_Event( Current_Proc_To_Call, Capture );
- if Proc_To_Call_On_Exception /= null then
- Proc_To_Call_On_Exception.all;
- end if;
- if Retry_Routine /= null then
- Current_Proc_To_Call := Retry_Routine.all;
- else
- Current_Proc_To_Call := null;
- end if;
- end;
- end loop;
- end Fail_Soft_Call;
-
- Stack : array(1..10) of History_Event; -- minimal, sufficient for testing
-
- Stack_Top : Natural := 0;
-
- procedure Store_Event( Proc_Called : Proc_Pointer;
- Error : Ada.Exceptions.Exception_Occurrence )
- is
- begin
- Stack_Top := Stack_Top +1;
- Stack(Stack_Top) := ( Ada.Exceptions.Save_Occurrence(Error),
- Proc_Called );
- end Store_Event;
-
- function Top_Event_Exception return Ada.Exceptions.Exception_Occurrence is
- begin
- if Stack_Top > 0 then
- return Stack(Stack_Top).Exception_Event.all;
- else
- return Ada.Exceptions.Null_Occurrence;
- end if;
- end Top_Event_Exception;
-
- function Top_Event_Procedure return Proc_Pointer is
- begin
- if Stack_Top > 0 then
- return Stack(Stack_Top).Procedure_Called;
- else
- return null;
- end if;
- end Top_Event_Procedure;
-
- procedure Pop_Event is
- begin
- if Stack_Top > 0 then
- Stack_Top := Stack_Top -1;
- else
- Report.Failed("Stack Error");
- end if;
- end Pop_Event;
-
- function Event_Stack_Size return Natural is
- begin
- return Stack_Top;
- end Event_Stack_Size;
-
-end CB40005_0;
-
-------------------------------------------------------------------- CB40005
-
-with Report;
-with TCTouch;
-with CB40005_0;
-with Ada.Exceptions;
-procedure CB40005 is
-
- type Proc_Pointer is access procedure;
- type Func_Pointer is access function return Proc_Pointer;
-
- package Fail_Soft is new CB40005_0(Proc_Pointer, Func_Pointer);
-
- procedure Cause_Standard_Exception;
-
- procedure Cause_Visible_Exception;
-
- procedure Cause_Invisible_Exception;
-
- Exception_Procedure_Pointer : Proc_Pointer;
-
- Visible_Exception : exception;
-
- procedure Action_On_Exception;
-
- function Retry_Procedure return Proc_Pointer;
-
- Raise_Error : Boolean;
-
- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
-
- procedure Cause_Standard_Exception is
- begin
- TCTouch.Touch('S'); --------------------------------------------------- S
- if Raise_Error then
- raise Constraint_Error;
- end if;
- end Cause_Standard_Exception;
-
- procedure Cause_Visible_Exception is
- begin
- TCTouch.Touch('V'); --------------------------------------------------- V
- if Raise_Error then
- raise Visible_Exception;
- end if;
- end Cause_Visible_Exception;
-
- procedure Cause_Invisible_Exception is
- Invisible_Exception : exception;
- begin
- TCTouch.Touch('I'); --------------------------------------------------- I
- if Raise_Error then
- raise Invisible_Exception;
- end if;
- end Cause_Invisible_Exception;
-
- procedure Action_On_Exception is
- begin
- TCTouch.Touch('A'); --------------------------------------------------- A
- end Action_On_Exception;
-
- function Retry_Procedure return Proc_Pointer is
- begin
- TCTouch.Touch('R'); --------------------------------------------------- R
- return Action_On_Exception'Access;
- end Retry_Procedure;
-
- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
-
-begin -- Main test procedure.
-
- Report.Test ("CB40005", "Check that exceptions raised in non-generic " &
- "code can be handled by a procedure in a generic " &
- "package. Check that the exception identity can " &
- "be properly retrieved from the generic code and " &
- "used by the non-generic code" );
-
- -- first, check that the no exception cases cause no action on the stack
- Raise_Error := False;
-
- Fail_Soft.Fail_Soft_Call( Cause_Standard_Exception'Access ); -- S
-
- Fail_Soft.Fail_Soft_Call( Cause_Visible_Exception'Access, -- V
- Action_On_Exception'Access,
- Retry_Procedure'Access );
-
- Fail_Soft.Fail_Soft_Call( Cause_Invisible_Exception'Access, -- I
- null,
- Retry_Procedure'Access );
-
- TCTouch.Assert( Fail_Soft.Event_Stack_Size = 0, "Empty stack");
-
- TCTouch.Validate( "SVI", "Non error case check" );
-
- -- second, check that error cases add to the stack
- Raise_Error := True;
-
- Fail_Soft.Fail_Soft_Call( Cause_Standard_Exception'Access ); -- S
-
- Fail_Soft.Fail_Soft_Call( Cause_Visible_Exception'Access, -- V
- Action_On_Exception'Access, -- A
- Retry_Procedure'Access ); -- RA
-
- Fail_Soft.Fail_Soft_Call( Cause_Invisible_Exception'Access, -- I
- null,
- Retry_Procedure'Access ); -- RA
-
- TCTouch.Assert( Fail_Soft.Event_Stack_Size = 3, "Stack = 3");
-
- TCTouch.Validate( "SVARAIRA", "Error case check" );
-
- -- check that the exceptions and procedure were stored correctly
- -- on the stack
- Raise_Error := False;
-
- -- return procedure pointer from top of stack and call the procedure
- -- through that pointer:
-
- Fail_Soft.Top_Event_Procedure.all;
-
- TCTouch.Validate( "I", "Invisible case unwind" );
-
- begin
- Ada.Exceptions.Raise_Exception(
- Ada.Exceptions.Exception_Identity(Fail_Soft.Top_Event_Exception) );
- Report.Failed("1: Exception not raised");
- exception
- when Constraint_Error => Report.Failed("1: Raised Constraint_Error");
- when Visible_Exception => Report.Failed("1: Raised Visible_Exception");
- when others => null; -- expected case
- end;
-
- Fail_Soft.Pop_Event;
-
- -- return procedure pointer from top of stack and call the procedure
- -- through that pointer:
-
- Fail_Soft.Top_Event_Procedure.all;
-
- TCTouch.Validate( "V", "Visible case unwind" );
-
- begin
- Ada.Exceptions.Raise_Exception(
- Ada.Exceptions.Exception_Identity(Fail_Soft.Top_Event_Exception) );
- Report.Failed("2: Exception not raised");
- exception
- when Constraint_Error => Report.Failed("2: Raised Constraint_Error");
- when Visible_Exception => null; -- expected case
- when others => Report.Failed("2: Raised Invisible_Exception");
- end;
-
- Fail_Soft.Pop_Event;
-
- Fail_Soft.Top_Event_Procedure.all;
-
- TCTouch.Validate( "S", "Standard case unwind" );
-
- begin
- Ada.Exceptions.Raise_Exception(
- Ada.Exceptions.Exception_Identity(Fail_Soft.Top_Event_Exception) );
- Report.Failed("3: Exception not raised");
- exception
- when Constraint_Error => null; -- expected case
- when Visible_Exception => Report.Failed("3: Raised Visible_Exception");
- when others => Report.Failed("3: Raised Invisible_Exception");
- end;
-
- Fail_Soft.Pop_Event;
-
- TCTouch.Assert( Fail_Soft.Event_Stack_Size = 0, "Stack empty after pops");
-
- Report.Result;
-
-end CB40005;
diff --git a/gcc/testsuite/ada/acats/tests/cb/cb40a01.a b/gcc/testsuite/ada/acats/tests/cb/cb40a01.a
deleted file mode 100644
index 1c569119afb..00000000000
--- a/gcc/testsuite/ada/acats/tests/cb/cb40a01.a
+++ /dev/null
@@ -1,135 +0,0 @@
--- CB40A01.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that a user defined exception is correctly propagated out of
--- a public child package.
---
--- TEST DESCRIPTION:
--- Declare a public child package containing a procedure used to
--- analyze the alphanumeric content of a particular text string.
--- The procedure contains a processing loop that continues until the
--- range of the text string is exceeded, at which time a user defined
--- exception is raised. This exception propagates out of the procedure
--- through the parent package, to the main test program.
---
--- Exception Type Raised:
--- * User Defined
--- Predefined
---
--- Hierarchical Structure Employed For This Test:
--- * Parent Package
--- * Public Child Package
--- Private Child Package
--- Public Child Subprogram
--- Private Child Subprogram
---
--- TEST FILES:
--- This test depends on the following foundation code:
--- FB40A00.A
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
---
---!
-
-
-package FB40A00.CB40A01_0 is -- package Text_Parser.Processing
-
- procedure Process_Text (Text : in String_Pointer_Type);
-
-end FB40A00.CB40A01_0;
-
-
- --=================================================================--
-
-
-with Report;
-
-package body FB40A00.CB40A01_0 is
-
- procedure Process_Text (Text : in String_Pointer_Type) is
- Pos : Natural := Text'First - 1;
- begin
- loop -- Process string, raise exception upon completion.
- Pos := Pos + 1;
- if Pos > Text.all'Last then
- raise Completed_Text_Processing;
- elsif (Text.all (Pos) in 'A' .. 'Z') or
- (Text.all (Pos) in 'a' .. 'z') or
- (Text.all (Pos) in '0' .. '9') then
- Increment_AlphaNumeric_Count;
- else
- Increment_Non_AlphaNumeric_Count;
- end if;
- end loop;
- -- No exception handler here, exception propagates.
- Report.Failed ("No exception raised in child package subprogram");
- end Process_Text;
-
-end FB40A00.CB40A01_0;
-
-
- --=================================================================--
-
-
-with FB40A00.CB40A01_0;
-with Report;
-
-procedure CB40A01 is
-
- String_Pointer : FB40A00.String_Pointer_Type :=
- new String'("'Twas the night before Christmas, " &
- "and all through the house...");
-
-begin
-
- Process_Block:
- begin
-
- Report.Test ("CB40A01", "Check that a user defined exception " &
- "is correctly propagated out of a " &
- "public child package");
-
- FB40A00.CB40A01_0.Process_Text (String_Pointer);
-
- Report.Failed ("Exception should have been handled");
-
- exception
-
- when FB40A00.Completed_Text_Processing => -- Correct exception
- if FB40A00.AlphaNumeric_Count /= 48 then -- propagation.
- Report.Failed ("Incorrect string processing");
- end if;
-
- when others =>
- Report.Failed ("Exception handled in an others handler");
-
- end Process_Block;
-
- Report.Result;
-
-end CB40A01;
diff --git a/gcc/testsuite/ada/acats/tests/cb/cb40a020.a b/gcc/testsuite/ada/acats/tests/cb/cb40a020.a
deleted file mode 100644
index 09830b87f5a..00000000000
--- a/gcc/testsuite/ada/acats/tests/cb/cb40a020.a
+++ /dev/null
@@ -1,95 +0,0 @@
--- CB40A020.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- See CB40A021.AM.
---
--- TEST DESCRIPTION:
--- See CB40A021.AM.
---
--- TEST FILES:
--- This test consists of the following files:
---
--- FB40A00.A
--- => CB40A020.A
--- CB40A021.AM
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 02 Nov 96 SAIC ACVC 2.1: Modified prologue.
---
---!
-
-
-package FB40A00.CB40A020_0 is -- package Text_Parser.Processing
-
- function Count_AlphaNumerics (Text : in String) return Natural;
-
-end FB40A00.CB40A020_0;
-
-
- --=================================================================--
-
-
--- Text_Parser.Processing.Process_Text
-with Report;
-private procedure FB40A00.CB40A020_0.CB40A020_1 (Text : in String);
-
-procedure FB40A00.CB40A020_0.CB40A020_1 (Text : in String) is
- Pos : Natural := Text'First - 1;
-begin
- loop -- Process string, raise exception upon completion.
- Pos := Pos + 1;
- if Pos > Text'Last then
- raise Completed_Text_Processing;
- elsif (Text (Pos) in 'A' .. 'Z') or
- (Text (Pos) in 'a' .. 'z') or
- (Text (Pos) in '0' .. '9') then
- Increment_AlphaNumeric_Count;
- else
- Increment_Non_AlphaNumeric_Count;
- end if;
- end loop;
- -- No exception handler here, exception propagates.
- Report.Failed ("No exception raised in child package subprogram");
-end FB40A00.CB40A020_0.CB40A020_1;
-
-
- --=================================================================--
-
-
-with FB40A00.CB40A020_0.CB40A020_1; -- "with" of private child subprogram
- -- Text_Parser.Processing.Process_Text
-package body FB40A00.CB40A020_0 is
-
- function Count_AlphaNumerics (Text : in String) return Natural is
- begin
- FB40A00.CB40A020_0.CB40A020_1 (Text); -- Call prvt child proc.
- return (AlphaNumeric_Count); -- Global maintained in parent.
- -- No exception handler here, exception propagates.
- end Count_AlphaNumerics;
-
-end FB40A00.CB40A020_0;
diff --git a/gcc/testsuite/ada/acats/tests/cb/cb40a030.a b/gcc/testsuite/ada/acats/tests/cb/cb40a030.a
deleted file mode 100644
index 8b053e2f0af..00000000000
--- a/gcc/testsuite/ada/acats/tests/cb/cb40a030.a
+++ /dev/null
@@ -1,105 +0,0 @@
--- CB40A030.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- See CB40A031.AM.
---
--- TEST DESCRIPTION:
--- See CB40A031.AM.
---
--- TEST FILES:
--- This test consists of the following files:
---
--- FB40A00.A
--- => CB40A030.A
--- CB40A031.AM
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 02 Nov 96 SAIC ACVC 2.1: Modified prologue.
---
---!
-
-
-package FB40A00.CB40A030_0 is -- package Text_Parser.Character_Counting
-
- function Count_AlphaNumerics (Text : in String) return Natural;
-
-end FB40A00.CB40A030_0;
-
-
- --=================================================================--
-
-
-private package FB40A00.CB40A030_1 is -- package Text_Parser.Processing
-
- procedure Process_Text (Text : in String);
-
-end FB40A00.CB40A030_1;
-
-
- --=================================================================--
-
-
-package body FB40A00.CB40A030_1 is
-
- procedure Process_Text (Text : in String) is
- Loop_Count : Integer := Text'Length + 1;
- begin
- for Pos in 1..Loop_Count loop -- Process string, force the
- -- raise of Constraint_Error.
- if (Text (Pos) in 'a'..'z') or
- (Text (Pos) in 'A'..'Z') or
- (Text (Pos) in '0'..'9') then
- Increment_AlphaNumeric_Count;
- else
- Increment_Non_AlphaNumeric_Count;
- end if;
-
- end loop;
- -- No exception handler here, exception propagates.
- end Process_Text;
-
-end FB40A00.CB40A030_1;
-
-
- --=================================================================--
-
-
-with FB40A00.CB40A030_1; -- private sibling package Text_Parser.Processing;
-
-package body FB40A00.CB40A030_0 is
-
- function Count_AlphaNumerics (Text : in String) return Natural is
- begin
- FB40A00.CB40A030_1.Process_Text (Text); -- Call proc in prvt child
- -- package that is a
- -- sibling of this package.
- return (AlphaNumeric_Count);
- -- No exception handler here, exception propagates.
- end Count_AlphaNumerics;
-
-end FB40A00.CB40A030_0;
diff --git a/gcc/testsuite/ada/acats/tests/cb/cb40a04.a b/gcc/testsuite/ada/acats/tests/cb/cb40a04.a
deleted file mode 100644
index 45209b9beab..00000000000
--- a/gcc/testsuite/ada/acats/tests/cb/cb40a04.a
+++ /dev/null
@@ -1,119 +0,0 @@
--- CB40A04.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that a predefined exception is correctly propagated out of a
--- public child function to a client.
---
--- TEST DESCRIPTION:
--- Declare a public child subprogram. Define the processing loop
--- inside the subprogram to expect a string with index starting at 1.
--- From the test procedure, call the child subprogram with a slice
--- from the middle of a string variable. This will cause an exception
--- to be raised in the child and propagated to the caller.
---
--- Exception Type Raised:
--- User Defined
--- * Predefined
---
--- Hierarchical Structure Employed For This Test:
--- * Parent Package
--- Public Child Package
--- Private Child Package
--- * Public Child Subprogram
--- Private Child Subprogram
---
--- TEST FILES:
--- This test depends on the following foundation code:
--- FB40A00.A
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
---
---!
-
-
--- Child subprogram Text_Parser.Count_AlphaNumerics
-
-function FB40A00.CB40A04_0 (Text : string) return Natural is
-begin
-
- for I in 1 .. Text'Last loop -- Raise immediate Constraint_Error
- if (Text (I) in 'a'..'z') or -- with String slice passed from
- (Text (I) in 'A'..'Z') or -- caller. (Slice'first /= 1)
- (Text (I) in '0'..'9') then
- Increment_AlphaNumeric_Count;
- else
- Increment_Non_AlphaNumeric_Count;
- end if;
- end loop;
-
- return (AlphaNumeric_Count); -- Global in parent package.
-
- -- No exception handler here, exception propagates.
-
-end FB40A00.CB40A04_0;
-
-
- --=================================================================--
-
-
-with FB40A00.CB40A04_0; -- Explicit "with" of Text_Parser.Count_AlphaNumerics
-with Report; -- Implicit "with" of Text_Parser.
-
-procedure CB40A04 is
-
- String_Var : String (1..19) := "The quick brown fox";
-
- Number_Of_AlphaNumeric_Characters : Natural := 0;
-
-begin
-
- Report.Test ("CB40A04", "Check that a predefined exception is " &
- "correctly propagated out of a public " &
- "child function to a client");
-
- Process_Block:
- begin
-
- Number_Of_AlphaNumeric_Characters := -- Provide slice of string
- FB40A00.CB40A04_0 (String_Var (5..10)); -- to subprogram.
-
- Report.Failed ("Exception should have been handled");
-
- exception
-
- when Constraint_Error => -- Correct exception
- null; -- propagation.
-
- when others =>
- Report.Failed ("Exception handled in an others handler");
-
- end Process_Block;
-
- Report.Result;
-
-end CB40A04;
diff --git a/gcc/testsuite/ada/acats/tests/cb/cb41001.a b/gcc/testsuite/ada/acats/tests/cb/cb41001.a
deleted file mode 100644
index 95ad868feaf..00000000000
--- a/gcc/testsuite/ada/acats/tests/cb/cb41001.a
+++ /dev/null
@@ -1,213 +0,0 @@
--- CB41001.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that the 'Identity attribute returns the unique identity of an
--- exception. Check that the Raise_Exception procedure can raise an
--- exception that is specified through the use of the 'Identity attribute,
--- and that Reraise_Occurrence can re-raise an exception occurrence
--- using an exception choice parameter.
---
--- TEST DESCRIPTION:
--- This test uses the capability of the 'Identity attribute, which
--- returns the unique identity of an exception, as an Exception_Id
--- result. This result is used as an input parameter to the procedure
--- Raise_Exception. The exception that results is handled, propagated
--- using the Reraise_Occurrence procedure, and handled again.
--- The above actions are performed for both a user-defined and a
--- predefined exception.
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 11 Nov 96 SAIC ACVC 2.1: Modified Propagate_User_Exception.
---
---!
-
-with Report;
-with Ada.Exceptions;
-
-procedure CB41001 is
-
-begin
-
- Report.Test ("CB41001", "Check that the 'Identity attribute returns " &
- "the unique identity of an exception. Check " &
- "that the 'Identity attribute is of type " &
- "Exception_Id. Check that the " &
- "Raise_Exception procedure can raise an " &
- "exception that is specified through the " &
- "use of the 'Identity attribute");
- Test_Block:
- declare
-
- Check_Points : constant := 5;
-
- type Check_Point_Array_Type is array (1..Check_Points) of Boolean;
-
- -- Global array used to track the processing path through the test.
- TC_Check_Points : Check_Point_Array_Type := (others => False);
-
- A_User_Defined_Exception : Exception;
- An_Exception_ID : Ada.Exceptions.Exception_Id :=
- Ada.Exceptions.Null_Id;
-
- procedure Propagate_User_Exception is
- Hidden_Exception : Exception;
- begin
- -- Use the 'Identity function to store the unique identity of a
- -- user defined exception into a variable of type Exception_Id.
-
- An_Exception_ID := A_User_Defined_Exception'Identity;
-
- -- Raise this user defined exception using the result of the
- -- 'Identity attribute.
-
- Ada.Exceptions.Raise_Exception(E => An_Exception_Id);
-
- Report.Failed("User defined exception not raised by " &
- "procedure Propagate_User_Exception");
-
- exception
- when Proc_Excpt : A_User_Defined_Exception => -- Expected exception.
- begin
-
- -- By raising a different exception at this point, the
- -- information associated with A_User_Defined_Exception must
- -- be correctly stacked internally.
-
- Ada.Exceptions.Raise_Exception(Hidden_Exception'Identity);
- Report.Failed("Hidden_Exception not raised by " &
- "procedure Propagate_User_Exception");
- exception
- when others =>
- TC_Check_Points(1) := True;
-
- -- Reraise the original exception, which will be propagated
- -- outside the scope of this procedure.
-
- Ada.Exceptions.Reraise_Occurrence(Proc_Excpt);
- Report.Failed("User defined exception not reraised");
-
- end;
-
- when others =>
- Report.Failed("Unexpected exception raised by " &
- "Procedure Propagate_User_Exception");
- end Propagate_User_Exception;
-
- begin
-
- User_Exception_Block:
- begin
- -- Call procedure to raise, handle, and reraise a user defined
- -- exception.
- Propagate_User_Exception;
-
- Report.Failed("User defined exception not propagated from " &
- "procedure Propagate_User_Exception");
-
- exception
- when A_User_Defined_Exception => -- Expected exception.
- TC_Check_Points(2) := True;
- when others =>
- Report.Failed
- ("Unexpected exception handled in User_Exception_Block");
- end User_Exception_Block;
-
-
- Predefined_Exception_Block:
- begin
-
- Inner_Block:
- begin
-
- begin
- -- Use the 'Identity attribute as an input parameter to the
- -- Raise_Exception procedure.
-
- Ada.Exceptions.Raise_Exception(Constraint_Error'Identity);
- Report.Failed("Constraint_Error not raised in Inner_Block");
-
- exception
- when Excpt : Constraint_Error => -- Expected exception.
- TC_Check_Points(3) := True;
-
- -- Reraise the exception.
- Ada.Exceptions.Reraise_Occurrence(X => Excpt);
- Report.Failed("Predefined exception not raised from " &
- "within the exception handler - 1");
- when others =>
- Report.Failed("Incorrect result from attempt to raise " &
- "Constraint_Error using the 'Identity " &
- "attribute - 1");
- end;
-
- Report.Failed("Constraint_Error not reraised in Inner_Block");
-
- exception
- when Block_Excpt : Constraint_Error => -- Expected exception.
- TC_Check_Points(4) := True;
-
- -- Reraise the exception in a scope where the exception
- -- was not originally raised.
-
- Ada.Exceptions.Reraise_Occurrence(X => Block_Excpt);
- Report.Failed("Predefined exception not raised from " &
- "within the exception handler - 2");
-
- when others =>
- Report.Failed("Incorrect result from attempt to raise " &
- "Constraint_Error using the 'Identity " &
- "attribute - 2");
- end Inner_Block;
-
- Report.Failed("Exception not propagated from Inner_Block");
-
- exception
- when Constraint_Error => -- Expected exception.
- TC_Check_Points(5) := True;
- when others =>
- Report.Failed("Unexpected exception handled after second " &
- "reraise of Constraint_Error");
- end Predefined_Exception_Block;
-
-
- -- Verify the processing path taken through the test.
-
- for i in 1..Check_Points loop
- if not TC_Check_Points(i) then
- Report.Failed("Incorrect processing path taken through test, " &
- "didn't pass check point #" & Integer'Image(i));
- end if;
- end loop;
-
- exception
- when others => Report.Failed ("Exception raised in Test_Block");
- end Test_Block;
-
- Report.Result;
-
-end CB41001;
diff --git a/gcc/testsuite/ada/acats/tests/cb/cb41002.a b/gcc/testsuite/ada/acats/tests/cb/cb41002.a
deleted file mode 100644
index 1b3898154de..00000000000
--- a/gcc/testsuite/ada/acats/tests/cb/cb41002.a
+++ /dev/null
@@ -1,283 +0,0 @@
--- CB41002.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that the message string input parameter in a call to the
--- Raise_Exception procedure is associated with the raised exception
--- occurrence, and that the message string can be obtained using the
--- Exception_Message function with the associated Exception_Occurrence
--- object. Check that Function Exception_Information is available
--- to provide implementation-defined information about the exception
--- occurrence.
---
--- TEST DESCRIPTION:
--- This test checks that a message associated with a raised exception
--- is propagated with the exception, and can be retrieved using the
--- Exception_Message function. The exception will be raised using the
--- 'Identity attribute as a parameter to the Raise_Exception procedure,
--- and an associated message string will be provided. The exception
--- will be handled, and the message associated with the occurrence will
--- be compared to the original source message (non-default).
---
--- The test also includes a simulated logging procedure
--- (Check_Exception_Information) that checks that Exception_Information
--- can be called.
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 22 Jun 00 RLB Added a check at Exception_Information can be
--- called.
---
---!
-
-with Report;
-with Ada.Exceptions;
-
-procedure CB41002 is
-begin
-
- Report.Test ("CB41002", "Check that the message string input parameter " &
- "in a call to the Raise_Exception procedure is " &
- "associated with the raised exception " &
- "occurrence, and that the message string can " &
- "be obtained using the Exception_Message " &
- "function with the associated " &
- "Exception_Occurrence object. Also check that " &
- "the Exception_Information function can be called");
-
- Test_Block:
- declare
-
- Number_Of_Exceptions : constant := 3;
-
- User_Exception_1,
- User_Exception_2,
- User_Exception_3 : exception;
-
- type String_Ptr is access String;
-
- User_Messages : constant array (1..Number_Of_Exceptions)
- of String_Ptr :=
- (new String'("Msg"),
- new String'("This message will override the default " &
- "message provided by the implementation"),
- new String'("The message can be captured by procedure" & -- 200 chars
- " Exception_Message. It is designed to b" &
- "e exactly 200 characters in length, sinc" &
- "e there is a permission concerning the " &
- "truncation of a message over 200 chars. "));
-
- procedure Check_Exception_Information (
- Occur : in Ada.Exceptions.Exception_Occurrence) is
- -- Simulates an error logging routine.
- Info : constant String :=
- Ada.Exceptions.Exception_Information (Occur);
- function Is_Substring_of (Target, Search : in String) return Boolean is
- -- Returns True if Search is a substring of Target, and False
- -- otherwise.
- begin
- for I in Report.Ident_Int(Target'First) ..
- Target'Last - Search'Length + 1 loop
- if Target(I .. I+Search'Length-1) = Search then
- return True;
- end if;
- end loop;
- return False;
- end Is_Substring_of;
- begin
- -- We can't display Info, as it often contains line breaks
- -- (confusing Report), and might look much like the failure of a test
- -- with an unhandled exception (thus confusing grading tools).
- --
- -- We don't particular care if the implementation advice is followed,
- -- but we make these checks to insure that a compiler cannot optimize
- -- away Info or the rest of this routine.
- if not Is_Substring_of (Info,
- Ada.Exceptions.Exception_Name (Occur)) then
- Report.Comment ("Exception_Information does not contain " &
- "Exception_Name - see 11.4.1(19)");
- elsif not Is_Substring_of (Info,
- Ada.Exceptions.Exception_Message (Occur)) then
- Report.Comment ("Exception_Information does not contain " &
- "Exception_Message - see 11.4.1(19)");
- end if;
- end Check_Exception_Information;
-
- begin
-
- for i in 1..Number_Of_Exceptions loop
- begin
-
- -- Raise a user-defined exception with a specific message string.
- case i is
- when 1 =>
- Ada.Exceptions.Raise_Exception(User_Exception_1'Identity,
- User_Messages(i).all);
- when 2 =>
- Ada.Exceptions.Raise_Exception(User_Exception_2'Identity,
- User_Messages(i).all);
- when 3 =>
- Ada.Exceptions.Raise_Exception(User_Exception_3'Identity,
- User_Messages(i).all);
- when others =>
- Report.Failed("Incorrect result from Case statement");
- end case;
-
- Report.Failed
- ("Exception not raised by procedure Exception_With_Message " &
- "for User_Exception #" & Integer'Image(i));
-
- exception
- when Excptn : others =>
-
- begin
- -- The message that is associated with the raising of each
- -- exception is captured here using the Exception_Message
- -- function.
-
- if User_Messages(i).all /=
- Ada.Exceptions.Exception_Message(Excptn)
- then
- Report.Failed
- ("Message captured from exception is not the " &
- "message provided when the exception was raised, " &
- "User_Exception #" & Integer'Image(i));
- end if;
-
- Check_Exception_Information(Excptn);
- end;
- end;
- end loop;
-
-
-
- -- Verify that the exception specific message is carried across
- -- various boundaries:
-
- begin
-
- begin
- Ada.Exceptions.Raise_Exception(User_Exception_1'Identity,
- User_Messages(1).all);
- Report.Failed("User_Exception_1 not raised");
- end;
- Report.Failed("User_Exception_1 not propagated");
- exception
- when Excptn : User_Exception_1 =>
-
- if User_Messages(1).all /=
- Ada.Exceptions.Exception_Message(Excptn)
- then
- Report.Failed("User_Message_1 not found");
- end if;
- Check_Exception_Information(Excptn);
-
- when others => Report.Failed("Unexpected exception handled - 1");
- end;
-
-
-
- begin
-
- begin
- Ada.Exceptions.Raise_Exception(User_Exception_2'Identity,
- User_Messages(2).all);
- Report.Failed("User_Exception_2 not raised");
- exception
- when Exc : User_Exception_2 =>
-
- -- The exception is reraised here; message should propagate
- -- with exception occurrence.
-
- Ada.Exceptions.Reraise_Occurrence(Exc);
- when others => Report.Failed("User_Exception_2 not handled");
- end;
- Report.Failed("User_Exception_2 not propagated");
- exception
- when Excptn : User_Exception_2 =>
-
- if User_Messages(2).all /=
- Ada.Exceptions.Exception_Message(Excptn)
- then
- Report.Failed("User_Message_2 not found");
- end if;
- Check_Exception_Information(Excptn);
-
- when others => Report.Failed("Unexpected exception handled - 2");
- end;
-
-
- -- Check exception and message propagation across task boundaries.
-
- declare
-
- task Raise_An_Exception is -- single task
- entry Raise_It;
- end Raise_An_Exception;
-
- task body Raise_An_Exception is
- begin
- accept Raise_It do
- Ada.Exceptions.Raise_Exception(User_Exception_3'Identity,
- User_Messages(3).all);
- end Raise_It;
- Report.Failed("User_Exception_3 not raised");
- exception
- when Excptn : User_Exception_3 =>
- if User_Messages(3).all /=
- Ada.Exceptions.Exception_Message(Excptn)
- then
- Report.Failed
- ("User_Message_3 not returned inside task body");
- end if;
- Check_Exception_Information(Excptn);
- when others =>
- Report.Failed("Incorrect exception raised in task body");
- end Raise_An_Exception;
-
- begin
- Raise_An_Exception.Raise_It; -- Exception will be propagated here.
- Report.Failed("User_Exception_3 not propagated to caller");
- exception
- when Excptn : User_Exception_3 =>
- if User_Messages(3).all /=
- Ada.Exceptions.Exception_Message(Excptn)
- then
- Report.Failed("User_Message_3 not returned to caller of task");
- end if;
- Check_Exception_Information(Excptn);
- when others =>
- Report.Failed("Incorrect exception raised by task");
- end;
-
-
- exception
- when others => Report.Failed ("Exception raised in Test_Block");
- end Test_Block;
-
- Report.Result;
-
-end CB41002;
diff --git a/gcc/testsuite/ada/acats/tests/cb/cb41003.a b/gcc/testsuite/ada/acats/tests/cb/cb41003.a
deleted file mode 100644
index aee0b094ce5..00000000000
--- a/gcc/testsuite/ada/acats/tests/cb/cb41003.a
+++ /dev/null
@@ -1,358 +0,0 @@
--- CB41003.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that an exception occurrence can be saved into an object of
--- type Exception_Occurrence using the procedure Save_Occurrence.
--- Check that a saved exception occurrence can be used to reraise
--- another occurrence of the same exception using the procedure
--- Reraise_Occurrence. Check that the function Save_Occurrence will
--- allocate a new object of type Exception_Occurrence_Access, and saves
--- the source exception to the new object which is returned as the
--- function result.
---
--- TEST DESCRIPTION:
--- This test verifies that an occurrence of an exception can be saved,
--- using either of two overloaded versions of Save_Occurrence. The
--- procedure version of Save_Occurrence is used to save an occurrence
--- of a user defined exception into an object of type
--- Exception_Occurrence. This object is then used as an input
--- parameter to procedure Reraise_Occurrence, the expected exception is
--- handled, and the exception id of the handled exception is compared
--- to the id of the originally raised exception.
--- The function version of Save_Occurrence returns a result of
--- Exception_Occurrence_Access, and is used to store the value of another
--- occurrence of the user defined exception. The resulting access value
--- is dereferenced and used as an input to Reraise_Occurrence. The
--- resulting exception is handled, and the exception id of the handled
--- exception is compared to the id of the originally raised exception.
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
---
---!
-
-with Report;
-with Ada.Exceptions;
-
-procedure CB41003 is
-
-begin
-
- Report.Test ("CB41003", "Check that an exception occurrence can " &
- "be saved into an object of type " &
- "Exception_Occurrence using the procedure " &
- "Save_Occurrence");
-
- Test_Block:
- declare
-
- use Ada.Exceptions;
-
- User_Exception_1,
- User_Exception_2 : Exception;
-
- Saved_Occurrence : Exception_Occurrence;
- Occurrence_Ptr : Exception_Occurrence_Access;
-
- User_Message : constant String := -- 200 character string.
- "The string returned by Exception_Message may be tr" &
- "uncated (to no less then 200 characters) by the Sa" &
- "ve_Occurrence procedure (not the function), the Re" &
- "raise_Occurrence proc, and the re-raise statement.";
-
- begin
-
- Raise_And_Save_Block_1 :
- begin
-
- -- This nested exception structure is designed to ensure that the
- -- appropriate exception occurrence is saved using the
- -- Save_Occurrence procedure.
-
- raise Program_Error;
- Report.Failed("Program_Error not raised");
-
- exception
- when Program_Error =>
-
- begin
- -- Use the procedure Raise_Exception, along with the 'Identity
- -- attribute to raise the first user defined exception. Note
- -- that a 200 character message is included in the call.
-
- Raise_Exception(User_Exception_1'Identity, User_Message);
- Report.Failed("User_Exception_1 not raised");
-
- exception
- when Exc : User_Exception_1 =>
-
- -- This exception occurrence is saved into a variable using
- -- procedure Save_Occurrence. This saved occurrence should
- -- not be confused with the raised occurrence of
- -- Program_Error above.
-
- Save_Occurrence(Target => Saved_Occurrence, Source => Exc);
-
- when others =>
- Report.Failed("Unexpected exception handled, expecting " &
- "User_Exception_1");
- end;
-
- when others =>
- Report.Failed("Incorrect exception generated by raise statement");
-
- end Raise_And_Save_Block_1;
-
-
- Reraise_And_Handle_Saved_Exception_1 :
- begin
- -- Reraise the exception that was saved in the previous block.
-
- Reraise_Occurrence(X => Saved_Occurrence);
-
- exception
- when Exc : User_Exception_1 => -- Expected exception.
- -- Check the exception id of the handled id by using the
- -- Exception_Identity function, and compare with the id of the
- -- originally raised exception.
-
- if User_Exception_1'Identity /= Exception_Identity(Exc) then
- Report.Failed("Exception_Ids do not match - 1");
- end if;
-
- -- Check that the message associated with this exception occurrence
- -- has not been truncated (it was originally 200 characters).
-
- if User_Message /= Exception_Message(Exc) then
- Report.Failed("Exception messages do not match - 1");
- end if;
-
- when others =>
- Report.Failed
- ("Incorrect exception raised by Reraise_Occurrence - 1");
- end Reraise_And_Handle_Saved_Exception_1;
-
-
- Raise_And_Save_Block_2 :
- begin
-
- Raise_Exception(User_Exception_2'Identity, User_Message);
- Report.Failed("User_Exception_2 not raised");
-
- exception
- when Exc : User_Exception_2 =>
-
- -- This exception occurrence is saved into an access object
- -- using function Save_Occurrence.
-
- Occurrence_Ptr := Save_Occurrence(Source => Exc);
-
- when others =>
- Report.Failed("Unexpected exception handled, expecting " &
- "User_Exception_2");
- end Raise_And_Save_Block_2;
-
-
- Reraise_And_Handle_Saved_Exception_2 :
- begin
- -- Reraise the exception that was saved in the previous block.
- -- Dereference the access object for use as input parameter.
-
- Reraise_Occurrence(X => Occurrence_Ptr.all);
-
- exception
- when Exc : User_Exception_2 => -- Expected exception.
- -- Check the exception id of the handled id by using the
- -- Exception_Identity function, and compare with the id of the
- -- originally raised exception.
-
- if User_Exception_2'Identity /= Exception_Identity(Exc) then
- Report.Failed("Exception_Ids do not match - 2");
- end if;
-
- -- Check that the message associated with this exception occurrence
- -- has not been truncated (it was originally 200 characters).
-
- if User_Message /= Exception_Message(Exc) then
- Report.Failed("Exception messages do not match - 2");
- end if;
-
- when others =>
- Report.Failed
- ("Incorrect exception raised by Reraise_Occurrence - 2");
- end Reraise_And_Handle_Saved_Exception_2;
-
-
- -- Another example of the use of saving an exception occurrence
- -- is demonstrated in the following block, where the ability to
- -- save an occurrence into a data structure, for later processing,
- -- is modeled.
-
- Store_And_Handle_Block:
- declare
-
- Exc_Number : constant := 3;
- Exception_1,
- Exception_2,
- Exception_3 : exception;
-
- Exception_Storage : array (1..Exc_Number) of Exception_Occurrence;
- Messages : array (1..Exc_Number) of String(1..9) :=
- ("Message 1", "Message 2", "Message 3");
-
- begin
-
- Outer_Block:
- begin
-
- Inner_Block:
- begin
-
- for i in 1..Exc_Number loop
- begin
-
- begin
- -- Exceptions all raised in a deep scope.
- if i = 1 then
- Raise_Exception(Exception_1'Identity, Messages(i));
- elsif i = 2 then
- Raise_Exception(Exception_2'Identity, Messages(i));
- elsif i = 3 then
- Raise_Exception(Exception_3'Identity, Messages(i));
- end if;
- Report.Failed("Exception not raised on loop #" &
- Integer'Image(i));
- end;
- Report.Failed("Exception not propagated on loop #" &
- Integer'Image(i));
- exception
- when Exc : others =>
-
- -- Save each occurrence into a storage array for
- -- later processing.
-
- Save_Occurrence(Exception_Storage(i), Exc);
- end;
- end loop;
-
- end Inner_Block;
- end Outer_Block;
-
- -- Raise the exceptions from the stored occurrences, and handle.
-
- for i in 1..Exc_Number loop
- begin
- Reraise_Occurrence(Exception_Storage(i));
- Report.Failed("No exception reraised for " &
- "exception #" & Integer'Image(i));
- exception
- when Exc : others =>
- -- The following sequence of checks ensures that the
- -- correct occurrence was stored, and the associated
- -- exception was raised and handled in the proper order.
- if i = 1 then
- if Exception_1'Identity /= Exception_Identity(Exc) then
- Report.Failed("Exception_1 not raised");
- end if;
- elsif i = 2 then
- if Exception_2'Identity /= Exception_Identity(Exc) then
- Report.Failed("Exception_2 not raised");
- end if;
- elsif i = 3 then
- if Exception_3'Identity /= Exception_Identity(Exc) then
- Report.Failed("Exception_3 not raised");
- end if;
- end if;
-
- if Exception_Message(Exc) /= Messages(i) then
- Report.Failed("Incorrect message associated with " &
- "exception #" & Integer'Image(i));
- end if;
- end;
- end loop;
- exception
- when others =>
- Report.Failed("Unexpected exception in Store_And_Handle_Block");
- end Store_And_Handle_Block;
-
-
- Reraise_Out_Of_Scope:
- declare
-
- TC_Value : constant := 5;
- The_Exception : exception;
- Saved_Exc_Occ : Exception_Occurrence;
-
- procedure Handle_It (Exc_Occ : in Exception_Occurrence) is
- Must_Be_Raised : exception;
- begin
- if Exception_Identity(Exc_Occ) = The_Exception'Identity then
- raise Must_Be_Raised;
- Report.Failed("Exception Must_Be_Raised was not raised");
- else
- Report.Failed("Incorrect exception handled in " &
- "Procedure Handle_It");
- end if;
- end Handle_It;
-
- begin
-
- if Report.Ident_Int(5) = TC_Value then
- raise The_Exception;
- end if;
-
- exception
- when Exc : others =>
- Save_Occurrence (Saved_Exc_Occ, Exc);
- begin
- Handle_It(Saved_Exc_Occ); -- Raise another exception, in a
- exception -- different scope.
- when others => -- Handle this new exception.
- begin
- Reraise_Occurrence (Saved_Exc_Occ); -- Reraise the
- -- original excptn.
- Report.Failed("Saved Exception was not raised");
- exception
- when Exc_2 : others =>
- if Exception_Identity (Exc_2) /=
- The_Exception'Identity
- then
- Report.Failed
- ("Incorrect exception occurrence reraised");
- end if;
- end;
- end;
- end Reraise_Out_Of_Scope;
-
-
- exception
- when others => Report.Failed ("Exception raised in Test_Block");
- end Test_Block;
-
- Report.Result;
-
-end CB41003;
diff --git a/gcc/testsuite/ada/acats/tests/cb/cb41004.a b/gcc/testsuite/ada/acats/tests/cb/cb41004.a
deleted file mode 100644
index 09dfa9bfabc..00000000000
--- a/gcc/testsuite/ada/acats/tests/cb/cb41004.a
+++ /dev/null
@@ -1,316 +0,0 @@
--- CB41004.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that Raise_Exception and Reraise_Occurrence have no effect in
--- the case of Null_Id or Null_Occurrence. Check that Exception_Message,
--- Exception_Identity, Exception_Name, and Exception_Information raise
--- Constraint_Error for a Null_Occurrence input parameter.
--- Check that calling the Save_Occurrence subprograms with the
--- Null_Occurrence input parameter saves the Null_Occurrence to the
--- appropriate target object, and does not raise Constraint_Error.
--- Check that Null_Id is the default initial value of type Exception_Id.
---
--- TEST DESCRIPTION:
--- This test performs a series of calls to many of the subprograms
--- defined in package Ada.Exceptions, using either Null_Id or
--- Null_Occurrence (based on their parameter profile). In the cases of
--- Raise_Exception and Reraise_Occurrence, these null input values
--- should result in no exceptions being raised, and Constraint_Error
--- should not be raised in response to these calls. Test failure will
--- result if any exception is raised in these cases.
--- For the Save_Occurrence subprograms, calling them with the
--- Null_Occurrence input parameter does not raise Constraint_Error, but
--- simply results in the Null_Occurrence being saved into the appropriate
--- target (either a Exception_Occurrence out parameter, or as an
--- Exception_Occurrence_Access value).
--- In the cases of the other mentioned subprograms, calls performed with
--- a Null_Occurrence input parameter must result in Constraint_Error
--- being raised. This exception will be handled, with test failure the
--- result if the exception is not raised.
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 08 Dec 00 RLB Removed Exception_Identity subtest, pending
--- resolution of AI95-00241.
--- 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 Raise_Exception has no effect in the case of Null_Id.
- begin
- Ada.Exceptions.Raise_Exception(A_Null_Exception_Id);
- TC_Flag := True;
- exception
- when others =>
- Report.Failed("Exception raised by procedure Raise_Exception " &
- "when called with a Null_Id input parameter");
- end;
-
- if not TC_Flag then
- Report.Failed("Incorrect processing following the call to " &
- "Raise_Exception with a Null_Id input parameter");
- end if;
- TC_Flag := False;
-
-
- -- Verify that Reraise_Occurrence has no effect in the case of
- -- Null_Occurrence.
- begin
- Ada.Exceptions.Reraise_Occurrence(A_Null_Exception_Occurrence);
- TC_Flag := True;
- exception
- when others =>
- Report.Failed
- ("Exception raised by procedure Reraise_Occurrence " &
- "when called with a Null_Occurrence input parameter");
- end;
-
- if not TC_Flag then
- Report.Failed("Incorrect processing following the call to " &
- "Reraise_Occurrence with a Null_Occurrence " &
- "input parameter");
- end if;
-
-
- -- Verify that function Exception_Message raises Constraint_Error for
- -- a Null_Occurrence input parameter.
- begin
- declare
- Msg : constant String :=
- Ada.Exceptions.Exception_Message(A_Null_Exception_Occurrence);
- begin
- Report.Failed
- ("Constraint_Error not raised by Function Exception_Message " &
- "when called with a Null_Occurrence input parameter");
- end;
- exception
- when Constraint_Error => null; -- OK, expected exception.
- when others =>
- Report.Failed
- ("Unexpected exception raised by Function Exception_Message " &
- "when called with a Null_Occurrence input parameter");
- end;
-
-
--- -- Verify that function Exception_Identity raises Constraint_Error for
--- -- a Null_Occurrence input parameter.
--- -- 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/cc/cc30001.a b/gcc/testsuite/ada/acats/tests/cc/cc30001.a
deleted file mode 100644
index 69010e421fa..00000000000
--- a/gcc/testsuite/ada/acats/tests/cc/cc30001.a
+++ /dev/null
@@ -1,219 +0,0 @@
--- CC30001.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that if a non-overriding primitive subprogram is declared for
--- a type derived from a formal derived tagged type, the copy of that
--- subprogram in an instance can override a subprogram inherited from the
--- actual type.
---
--- TEST DESCRIPTION:
--- User writes program to handle both mail messages and system messages.
---
--- Mail messages are created by instantiating a generic "mail" package
--- with a root message type. System messages are created by
--- instantiating the generic with a system message type derived from the
--- root in a separate package. The system message type has a primitive
--- subprogram called Send.
---
--- Inside the generic, a "mail" type is derived from the generic formal
--- derived type, and a "Send" operation is declared.
---
--- Declare a root tagged type T. Declare a generic package with a formal
--- derived type using the root tagged type as ancestor. In the generic,
--- derive a type from the formal derived type and declare a primitive
--- subprogram for it. In a separate package, declare a derivative DT of
--- the root tagged type T and declare a primitive subprogram which is
--- type conformant with (and hence, overridable for) the primitive
--- declared in the generic. Instantiate the generic for DT. Make both
--- dispatching and non-dispatching calls to the primitive subprogram. In
--- both cases the version of the subprogram in the instance should be
--- called (since it overrides the implementation inherited from the
--- actual).
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 13 Apr 95 SAIC Replaced call involving instance for root tagged
--- type with a dispatching call involving instance
--- for derived type. Updated commentary. Moved
--- instantiations (and related commentary) to
--- library-level to avoid accessibility violation.
--- Commented out instantiation for root tagged type.
--- 27 Feb 97 PWB.CTA Added elaboration pragma.
---!
-
-package CC30001_0 is -- Root message type.
-
- type Msg_Type is tagged record
- Text : String (1 .. 20);
- Message_Sent : Boolean;
- end record;
-
-end CC30001_0;
-
-
- --==================================================================--
-
-
-with CC30001_0; -- Root message type.
-generic -- Generic "mail" package.
- type Message is new CC30001_0.Msg_Type with private;
-package CC30001_1 is
-
- type Mail_Type is new Message with record -- Derived from formal type.
- To : String (1 .. 8);
- end record;
-
- procedure Send (M : in out Mail_Type); -- For this test, this version
- -- of Send should be called in
- -- ... Other operations. -- all cases.
-
-end CC30001_1;
-
-
- --==================================================================--
-
-
-package body CC30001_1 is
-
- procedure Send (M : in out Mail_Type) is
- begin
- -- ... Code to send message omitted for brevity.
- M.Message_Sent := True;
- end Send;
-
-end CC30001_1;
-
-
- --==================================================================--
-
-
-with CC30001_0; -- Root message type.
-package CC30001_2 is -- System message type and operations.
-
- type Signal_Type is (Note, Warning, Error);
-
- type Sys_Message is new CC30001_0.Msg_Type with record -- Derived from
- Signal : Signal_Type := Warning; -- root type.
- end record;
-
- procedure Send (Item : in out Sys_Message); -- For this test, this version
- -- of Send should never be
- -- ... Other operations. -- called (it will have been
- -- overridden).
-end CC30001_2;
-
-
- --==================================================================--
-
-
-package body CC30001_2 is
-
- procedure Send (Item : in out Sys_Message) is
- begin
- -- ... Code to send message omitted for brevity.
- Item.Message_Sent := False; -- Ensure this procedure gives a different
- end Send; -- result than CC30001_1.Send.
-
-end CC30001_2;
-
-
- --==================================================================--
-
-
--- User first sets up support for mail messages by instantiating the
--- generic mail package for the root message type. An operation "Send" is
--- declared for the mail message type in the instance.
---
--- with CC30001_0; -- Root message type.
--- with CC30001_1; -- Generic "mail" package.
--- package Mail_Messages is new CC30001_1 (CC30001_0.Msg_Type);
-
-
- --==================================================================--
-
-
--- Next, the user sets up support for system messages by instantiating the
--- generic mail package with the system message type. An operation "Send"
--- is declared for the "system" mail message type in the instance. This
--- operation overrides the "Send" operation inherited from the system
--- message type actual (a situation the user may not have intended).
-
-with CC30001_1; -- Generic "mail" package.
-with CC30001_2; -- System message type and operations.
-pragma Elaborate (CC30001_1);
-package CC30001_3 is new CC30001_1 (CC30001_2.Sys_Message);
-
-
- --==================================================================--
-
-with CC30001_2; -- System message type and operations.
-with CC30001_3; -- Instance with mail type and operations.
-
-with Report;
-procedure CC30001 is
-
- package System_Messages renames CC30001_3;
-
-
- Sys_Msg1 : System_Messages.Mail_Type := (Text => "System shutting down",
- Signal => CC30001_2.Warning,
- To => "AllUsers",
- Message_Sent => False);
-
- Sys_Msg2 : System_Messages.Mail_Type'Class := Sys_Msg1;
-
-
- use System_Messages, CC30001_2; -- All versions of "Send"
- -- directly visible.
-
-begin
-
- Report.Test ("CC30001", "Check that if a non-overriding primitive " &
- "subprogram is declared for a type derived from a formal " &
- "derived tagged type, the copy of that subprogram in an " &
- "instance can override a subprogram inherited from the " &
- "actual type");
-
-
- Send (Sys_Msg1); -- Calls version declared in instance (version declared
- -- in CC30001_2 has been overridden).
-
- if not Sys_Msg1.Message_Sent then
- Report.Failed ("Non-dispatching call: instance operation not called");
- end if;
-
-
- Send (Sys_Msg2); -- Calls version declared in instance (version declared
- -- in CC30001_2 has been overridden).
-
- if not Sys_Msg2.Message_Sent then
- Report.Failed ("Dispatching call: instance operation not called");
- end if;
-
-
- Report.Result;
-end CC30001;
diff --git a/gcc/testsuite/ada/acats/tests/cc/cc30002.a b/gcc/testsuite/ada/acats/tests/cc/cc30002.a
deleted file mode 100644
index 5132f8cae90..00000000000
--- a/gcc/testsuite/ada/acats/tests/cc/cc30002.a
+++ /dev/null
@@ -1,349 +0,0 @@
--- CC30002.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that an explicit declaration in the private part of an instance
--- does not override an implicit declaration in the instance, unless the
--- corresponding explicit declaration in the generic overrides a
--- corresponding implicit declaration in the generic. Check for primitive
--- subprograms of tagged types.
---
--- TEST DESCRIPTION:
--- Consider the following:
---
--- type Ancestor is tagged null record;
--- procedure R (X: in Ancestor);
---
--- generic
--- type Formal is new Ancestor with private;
--- package G is
--- type T is new Formal with null record;
--- -- Implicit procedure R (X: in T);
--- procedure P (X: in T); -- (1)
--- private
--- procedure Q (X: in T); -- (2)
--- procedure R (X: in T); -- (3) Overrides implicit R in generic.
--- end G;
---
--- type Actual is new Ancestor with null record;
--- procedure P (X: in Actual);
--- procedure Q (X: in Actual);
--- procedure R (X: in Actual);
---
--- package Instance is new G (Formal => Actual);
---
--- In the instance, the copy of P at (1) overrides Actual's P, since it
--- is declared in the visible part of the instance. The copy of Q at (2)
--- does not override anything. The copy of R at (3) overrides Actual's
--- R, even though it is declared in the private part, because within
--- the generic the explicit declaration of R overrides an implicit
--- declaration.
---
--- Thus, for calls involving a parameter with tag T:
--- - Calls to P will execute the body declared for T.
--- - Calls to Q from within Instance will execute the body declared
--- for T.
--- - Calls to Q from outside Instance will execute the body declared
--- for Actual.
--- - Calls to R will execute the body declared for T.
---
--- Verify this behavior for both dispatching and nondispatching calls to
--- Q and R.
---
---
--- CHANGE HISTORY:
--- 24 Feb 95 SAIC Initial prerelease version.
---
---!
-
-package CC30002_0 is
-
- type TC_Body_Kind is (Body_Of_Ancestor, Body_In_Instance,
- Body_Of_Actual, Initial_Value);
-
- type Camera is tagged record
- -- ... Camera components.
- TC_Focus_Called : TC_Body_Kind := Initial_Value;
- TC_Shutter_Called : TC_Body_Kind := Initial_Value;
- end record;
-
- procedure Focus (C: in out Camera);
-
- -- ...Other operations.
-
-end CC30002_0;
-
-
- --==================================================================--
-
-
-package body CC30002_0 is
-
- procedure Focus (C: in out Camera) is
- begin
- -- Artificial for testing purposes.
- C.TC_Focus_Called := Body_Of_Ancestor;
- end Focus;
-
-end CC30002_0;
-
-
- --==================================================================--
-
-
-with CC30002_0;
-use CC30002_0;
-generic
- type Camera_Type is new CC30002_0.Camera with private;
-package CC30002_1 is
-
- type Speed_Camera is new Camera_Type with record
- Diag_Code: Positive;
- -- ...Other components.
- end record;
-
- -- Implicit procedure Focus (C: in out Speed_Camera) declared in generic.
- procedure Self_Test_NonDisp (C: in out Speed_Camera);
- procedure Self_Test_Disp (C: in out Speed_Camera'Class);
-
-private
-
- -- The following explicit declaration of Set_Shutter_Speed does NOT override
- -- a corresponding implicit declaration in the generic. Therefore, its copy
- -- does NOT override the implicit declaration (inherited from the actual)
- -- in the instance.
-
- procedure Set_Shutter_Speed (C: in out Speed_Camera);
-
- -- The following explicit declaration of Focus DOES override a
- -- corresponding implicit declaration (inherited from the parent) in the
- -- generic. Therefore, its copy overrides the implicit declaration
- -- (inherited from the actual) in the instance.
-
- procedure Focus (C: in out Speed_Camera); -- Overrides implicit Focus
- -- in generic.
-end CC30002_1;
-
-
- --==================================================================--
-
-
-package body CC30002_1 is
-
- procedure Self_Test_NonDisp (C: in out Speed_Camera) is
- begin
- -- Nondispatching calls:
- Focus (C);
- Set_Shutter_Speed (C);
- end Self_Test_NonDisp;
-
- procedure Self_Test_Disp (C: in out Speed_Camera'Class) is
- begin
- -- Dispatching calls:
- Focus (C);
- Set_Shutter_Speed (C);
- end Self_Test_Disp;
-
- procedure Set_Shutter_Speed (C: in out Speed_Camera) is
- begin
- -- Artificial for testing purposes.
- C.TC_Shutter_Called := Body_In_Instance;
- end Set_Shutter_Speed;
-
- procedure Focus (C: in out Speed_Camera) is
- begin
- -- Artificial for testing purposes.
- C.TC_Focus_Called := Body_In_Instance;
- end Focus;
-
-end CC30002_1;
-
-
- --==================================================================--
-
-
-with CC30002_0;
-package CC30002_2 is
-
- type Aperture_Camera is new CC30002_0.Camera with record
- FStop: Natural;
- -- ...Other components.
- end record;
-
- procedure Set_Shutter_Speed (C: in out Aperture_Camera);
- procedure Focus (C: in out Aperture_Camera);
-
-end CC30002_2;
-
-
- --==================================================================--
-
-
-package body CC30002_2 is
-
- procedure Set_Shutter_Speed (C: in out Aperture_Camera) is
- use CC30002_0;
- begin
- -- Artificial for testing purposes.
- C.TC_Shutter_Called := Body_Of_Actual;
- end Set_Shutter_Speed;
-
- procedure Focus (C: in out Aperture_Camera) is
- use CC30002_0;
- begin
- -- Artificial for testing purposes.
- C.TC_Focus_Called := Body_Of_Actual;
- end Focus;
-
-end CC30002_2;
-
-
- --==================================================================--
-
-
--- Instance declaration.
-
-with CC30002_1;
-with CC30002_2;
-package CC30002_3 is new CC30002_1 (Camera_Type => CC30002_2.Aperture_Camera);
-
-
- --==================================================================--
-
-
-with CC30002_0;
-with CC30002_1;
-with CC30002_2;
-with CC30002_3; -- Instance.
-
-with Report;
-procedure CC30002 is
-
- package Speed_Cameras renames CC30002_3;
-
- use CC30002_0;
-
- TC_Camera1: Speed_Cameras.Speed_Camera;
- TC_Camera2: Speed_Cameras.Speed_Camera'Class := TC_Camera1;
- TC_Camera3: Speed_Cameras.Speed_Camera;
- TC_Camera4: Speed_Cameras.Speed_Camera;
-
-begin
- Report.Test ("CC30002", "Check that an explicit declaration in the " &
- "private part of an instance does not override an implicit " &
- "declaration in the instance, unless the corresponding " &
- "explicit declaration in the generic overrides a " &
- "corresponding implicit declaration in the generic. Check " &
- "for primitive subprograms of tagged types");
-
---
--- Check non-dispatching calls outside instance:
---
-
- -- Non-overriding primitive operation:
-
- Speed_Cameras.Set_Shutter_Speed (TC_Camera1);
- if TC_Camera1.TC_Shutter_Called /= Body_Of_Actual then
- Report.Failed ("Wrong body executed: non-dispatching call to " &
- "Set_Shutter_Speed outside instance");
- end if;
-
-
- -- Overriding primitive operation:
-
- Speed_Cameras.Focus (TC_Camera1);
- if TC_Camera1.TC_Focus_Called /= Body_In_Instance then
- Report.Failed ("Wrong body executed: non-dispatching call to " &
- "Focus outside instance");
- end if;
-
-
---
--- Check dispatching calls outside instance:
---
-
- -- Non-overriding primitive operation:
-
- Speed_Cameras.Set_Shutter_Speed (TC_Camera2);
- if TC_Camera2.TC_Shutter_Called /= Body_Of_Actual then
- Report.Failed ("Wrong body executed: dispatching call to " &
- "Set_Shutter_Speed outside instance");
- end if;
-
-
- -- Overriding primitive operation:
-
- Speed_Cameras.Focus (TC_Camera2);
- if TC_Camera2.TC_Focus_Called /= Body_In_Instance then
- Report.Failed ("Wrong body executed: dispatching call to " &
- "Focus outside instance");
- end if;
-
-
-
---
--- Check non-dispatching calls within instance:
---
-
- Speed_Cameras.Self_Test_NonDisp (TC_Camera3);
-
- -- Non-overriding primitive operation:
-
- if TC_Camera3.TC_Shutter_Called /= Body_In_Instance then
- Report.Failed ("Wrong body executed: non-dispatching call to " &
- "Set_Shutter_Speed inside instance");
- end if;
-
- -- Overriding primitive operation:
-
- if TC_Camera3.TC_Focus_Called /= Body_In_Instance then
- Report.Failed ("Wrong body executed: non-dispatching call to " &
- "Focus inside instance");
- end if;
-
-
-
---
--- Check dispatching calls within instance:
---
-
- Speed_Cameras.Self_Test_Disp (TC_Camera4);
-
- -- Non-overriding primitive operation:
-
- if TC_Camera4.TC_Shutter_Called /= Body_In_Instance then
- Report.Failed ("Wrong body executed: dispatching call to " &
- "Set_Shutter_Speed inside instance");
- end if;
-
- -- Overriding primitive operation:
-
- if TC_Camera4.TC_Focus_Called /= Body_In_Instance then
- Report.Failed ("Wrong body executed: dispatching call to " &
- "Focus inside instance");
- end if;
-
- Report.Result;
-end CC30002;
diff --git a/gcc/testsuite/ada/acats/tests/cc/cc40001.a b/gcc/testsuite/ada/acats/tests/cc/cc40001.a
deleted file mode 100644
index bf42470e65b..00000000000
--- a/gcc/testsuite/ada/acats/tests/cc/cc40001.a
+++ /dev/null
@@ -1,403 +0,0 @@
--- CC40001.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that adjust is called on the value of a constant object created
--- by the evaluation of a generic association for a formal object of
--- mode in.
---
--- Check that those values are also subsequently finalized.
---
--- TEST DESCRIPTION:
--- Create a backdrop of a controlled type sufficient to check that the
--- correct operations get called at appropriate times. Create a generic
--- unit that takes a formal parameter of a formal type. Create instances
--- of this generic using various "levels" of the controlled type. Check
--- the same case for a generic child unit.
---
--- The cases tested are where the type of the formal object is:
--- a visible classwide type : CC40001_2
--- a formal private type : CC40001_3
--- a formal tagged type : CC40001_4
---
--- To more fully take advantage of the features of the language, and
--- present a test which is "user oriented" this test utilizes multiple
--- aspects of the language in combination. Using Ada.Strings.Unbounded
--- in combination with Ada.Finalization and Ada.Calendar to build layers
--- of an object oriented system will likely be very common in actual
--- practice. A common paradigm in the language will also be the use of
--- a parent package defining "basic" tagged types, and child packages
--- will expand on those types via derivation. The model used in this
--- test is a simple type containing a character identity (used in the
--- identity). The next level of type add a timestamp. Further levels
--- might add location information, etc. however for the purposes of this
--- test we stop at the second layer, as it is sufficient to test the
--- stated objective.
---
---
--- CHANGE HISTORY:
--- 06 FEB 96 SAIC Initial version
--- 30 APR 96 SAIC Added finalization checks for 2.1
--- 13 FEB 97 PWB.CTA Moved global objects into bodies, after Initialize
--- body is elaborated; counted finalizations correctly.
---!
-
------------------------------------------------------------------ CC40001_0
-
-with Ada.Finalization;
-with Ada.Strings.Unbounded;
-package CC40001_0 is
-
- type States is ( Erroneous, Defaulted, Initialized, Reset, Adjusted );
-
- type Simple_Object(ID: Character) is
- new Ada.Finalization.Controlled with
- record
- TC_Current_State : States := Defaulted;
- Name : Ada.Strings.Unbounded.Unbounded_String;
- end record;
-
- procedure User_Operation( COB: in out Simple_Object; Name : String );
- procedure Initialize( COB: in out Simple_Object );
- procedure Adjust ( COB: in out Simple_Object );
- procedure Finalize ( COB: in out Simple_Object );
-
- Finalization_Count : Natural;
-
-end CC40001_0;
-
--- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
-
-with Report;
-with TCTouch;
-package body CC40001_0 is
-
- procedure User_Operation( COB: in out Simple_Object; Name : String ) is
- begin
- COB.Name := Ada.Strings.Unbounded.To_Unbounded_String(Name);
- end User_Operation;
-
- procedure Initialize( COB: in out Simple_Object ) is
- begin
- COB.TC_Current_State := Initialized;
- end Initialize;
-
- procedure Adjust ( COB: in out Simple_Object ) is
- begin
- COB.TC_Current_State := Adjusted;
- TCTouch.Touch('A'); -------------------------------------------------- A
- TCTouch.Touch(COB.ID); ------------------------------------------------ ID
- -- note that the calls to touch will not be directly validated, it is
- -- expected that some number > 0 of calls will be made to this procedure,
- -- the subtests then clear (Flush) the Touch buffer and perform actions
- -- where an incorrect implementation might call this procedure. Such a
- -- call will fail on the attempt to "Validate" the null string.
- end Adjust;
-
- procedure Finalize ( COB: in out Simple_Object ) is
- begin
- COB.TC_Current_State := Erroneous;
- Finalization_Count := Finalization_Count +1;
- end Finalize;
-
- TC_Global_Object : Simple_Object('G');
-
-end CC40001_0;
-
------------------------------------------------------------------ CC40001_1
-
-with Ada.Calendar;
-package CC40001_0.CC40001_1 is
-
- type Object_In_Time(ID: Character) is
- new Simple_Object(ID) with
- record
- Birth : Ada.Calendar.Time;
- Activity : Ada.Calendar.Time;
- end record;
-
- procedure User_Operation( COB: in out Object_In_Time;
- Name: String );
-
- procedure Initialize( COB: in out Object_In_Time );
- procedure Adjust ( COB: in out Object_In_Time );
- procedure Finalize ( COB: in out Object_In_Time );
-
-end CC40001_0.CC40001_1;
-
--- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
-
-with Report;
-with TCTouch;
-package body CC40001_0.CC40001_1 is
-
- procedure Initialize( COB: in out Object_In_Time ) is
- begin
- COB.TC_Current_State := Initialized;
- COB.Birth := Ada.Calendar.Clock;
- end Initialize;
-
- procedure Adjust ( COB: in out Object_In_Time ) is
- begin
- COB.TC_Current_State := Adjusted;
- TCTouch.Touch('a'); ------------------------------------------------ a
- TCTouch.Touch(COB.ID); ------------------------------------------------ ID
- end Adjust;
-
- procedure Finalize ( COB: in out Object_In_Time ) is
- begin
- COB.TC_Current_State := Erroneous;
- Finalization_Count := Finalization_Count +1;
- end Finalize;
-
- procedure User_Operation( COB: in out Object_In_Time;
- Name: String ) is
- begin
- CC40001_0.User_Operation( Simple_Object(COB), Name );
- COB.Activity := Ada.Calendar.Clock;
- COB.TC_Current_State := Reset;
- end User_Operation;
-
- TC_Time_Object : Object_In_Time('g');
-
-end CC40001_0.CC40001_1;
-
------------------------------------------------------------------ CC40001_2
-
-generic
- TC_Check_Object : in CC40001_0.Simple_Object'Class;
-package CC40001_0.CC40001_2 is
- procedure TC_Verify_State;
-end CC40001_0.CC40001_2;
-
--- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
-
-with Report;
-package body CC40001_0.CC40001_2 is
-
- procedure TC_Verify_State is
- begin
- if TC_Check_Object.TC_Current_State /= Adjusted then
- Report.Failed( "CC40001_2 : Formal Object not adjusted" );
- end if;
- end TC_Verify_State;
-
-end CC40001_0.CC40001_2;
-
------------------------------------------------------------------ CC40001_3
-
-generic
- type Formal_Private(<>) is private;
- TC_Check_Object : in Formal_Private;
- with function Bad_Status( O: Formal_Private ) return Boolean;
-package CC40001_0.CC40001_3 is
- procedure TC_Verify_State;
-end CC40001_0.CC40001_3;
-
--- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
-
-with Report;
-package body CC40001_0.CC40001_3 is
-
- procedure TC_Verify_State is
- begin
- if Bad_Status( TC_Check_Object ) then
- Report.Failed( "CC40001_3 : Formal Object not adjusted" );
- end if;
- end TC_Verify_State;
-
-end CC40001_0.CC40001_3;
-
------------------------------------------------------------------ CC40001_4
-
-generic
- type Formal_Tagged_Private(<>) is tagged private;
- TC_Check_Object : in Formal_Tagged_Private;
- with function Bad_Status( O: Formal_Tagged_Private ) return Boolean;
-package CC40001_0.CC40001_4 is
- procedure TC_Verify_State;
-end CC40001_0.CC40001_4;
-
--- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
-
-with Report;
-package body CC40001_0.CC40001_4 is
-
- procedure TC_Verify_State is
- begin
- if Bad_Status( TC_Check_Object ) then
- Report.Failed( "CC40001_4 : Formal Object not adjusted" );
- end if;
- end TC_Verify_State;
-
-end CC40001_0.CC40001_4;
-
-------------------------------------------------------------------- CC40001
-
-with Report;
-with TCTouch;
-with CC40001_0.CC40001_1;
-with CC40001_0.CC40001_2;
-with CC40001_0.CC40001_3;
-with CC40001_0.CC40001_4;
-procedure CC40001 is
-
- function Not_Adjusted( CO : CC40001_0.Simple_Object )
- return Boolean is
- use type CC40001_0.States;
- begin
- return CO.TC_Current_State /= CC40001_0.Adjusted;
- end Not_Adjusted;
-
- function Not_Adjusted( CO : CC40001_0.CC40001_1.Object_In_Time )
- return Boolean is
- use type CC40001_0.States;
- begin
- return CO.TC_Current_State /= CC40001_0.Adjusted;
- end Not_Adjusted;
-
- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- Subtest 1
-
- procedure Subtest_1 is
- Object_0 : CC40001_0.Simple_Object('T');
- Object_1 : CC40001_0.CC40001_1.Object_In_Time('t');
-
- package Subtest_1_1 is
- new CC40001_0.CC40001_2( Object_0 ); -- classwide generic formal object
-
- package Subtest_1_2 is
- new CC40001_0.CC40001_2( Object_1 ); -- classwide generic formal object
- begin
- TCTouch.Flush; -- clear out all "A" and "T" entries, no further calls
- -- to Touch should occur before the call to Validate
-
- -- set the objects TC_Current_State to "Reset"
- CC40001_0.User_Operation( Object_0, "Subtest 1" );
- CC40001_0.CC40001_1.User_Operation( Object_1, "Subtest 1" );
-
- -- check that the objects TC_Current_State is "Adjusted"
- Subtest_1_1.TC_Verify_State;
- Subtest_1_2.TC_Verify_State;
-
- TCTouch.Validate( "", "No actions should occur here, subtest 1" );
-
- end Subtest_1;
-
- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- Subtest 2
-
- procedure Subtest_2 is
- Object_0 : CC40001_0.Simple_Object('T');
- Object_1 : CC40001_0.CC40001_1.Object_In_Time('t');
-
- package Subtest_2_1 is -- generic formal object is discriminated private
- new CC40001_0.CC40001_3( CC40001_0.Simple_Object,
- Object_0,
- Not_Adjusted );
-
- package Subtest_2_2 is -- generic formal object is discriminated private
- new CC40001_0.CC40001_3( CC40001_0.CC40001_1.Object_In_Time,
- Object_1,
- Not_Adjusted );
-
- begin
- TCTouch.Flush; -- clear out all "A" and "T" entries
-
- -- set the objects state to "Reset"
- CC40001_0.User_Operation( Object_0, "Subtest 2" );
- CC40001_0.CC40001_1.User_Operation( Object_1, "Subtest 2" );
-
- Subtest_2_1.TC_Verify_State;
- Subtest_2_2.TC_Verify_State;
-
- TCTouch.Validate( "", "No actions should occur here, subtest 2" );
-
- end Subtest_2;
-
- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- Subtest 3
-
- procedure Subtest_3 is
- Object_0 : CC40001_0.Simple_Object('T');
- Object_1 : CC40001_0.CC40001_1.Object_In_Time('t');
-
- package Subtest_3_1 is -- generic formal object is discriminated tagged
- new CC40001_0.CC40001_4( CC40001_0.Simple_Object,
- Object_0,
- Not_Adjusted );
-
- package Subtest_3_2 is -- generic formal object is discriminated tagged
- new CC40001_0.CC40001_4( CC40001_0.CC40001_1.Object_In_Time,
- Object_1,
- Not_Adjusted );
- begin
- TCTouch.Flush; -- clear out all "A" and "T" entries
-
- -- set the objects state to "Reset"
- CC40001_0.User_Operation( Object_0, "Subtest 3" );
- CC40001_0.CC40001_1.User_Operation( Object_1, "Subtest 3" );
-
- Subtest_3_1.TC_Verify_State;
- Subtest_3_2.TC_Verify_State;
-
- TCTouch.Validate( "", "No actions should occur here, subtest 3" );
-
- end Subtest_3;
-
-begin -- Main test procedure.
-
- Report.Test ("CC40001", "Check that adjust and finalize are called on " &
- "the constant object created by the " &
- "evaluation of a generic association for a " &
- "formal object of mode in" );
-
- -- check that the created constant objects are properly adjusted
- -- and subsequently finalized
-
- CC40001_0.Finalization_Count := 0;
-
- Subtest_1;
-
- if CC40001_0.Finalization_Count < 4 then
- Report.Failed("Insufficient Finalizations for Subtest 1");
- end if;
-
- CC40001_0.Finalization_Count := 0;
-
- Subtest_2;
-
- if CC40001_0.Finalization_Count < 4 then
- Report.Failed("Insufficient Finalizations for Subtest 2");
- end if;
-
- CC40001_0.Finalization_Count := 0;
-
- Subtest_3;
-
- if CC40001_0.Finalization_Count < 4 then
- Report.Failed("Insufficient Finalizations for Subtest 3");
- end if;
-
- Report.Result;
-
-end CC40001;
diff --git a/gcc/testsuite/ada/acats/tests/cc/cc50001.a b/gcc/testsuite/ada/acats/tests/cc/cc50001.a
deleted file mode 100644
index 32a1afeb38c..00000000000
--- a/gcc/testsuite/ada/acats/tests/cc/cc50001.a
+++ /dev/null
@@ -1,257 +0,0 @@
--- CC50001.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that, in an instance, each implicit declaration of a predefined
--- operator of a formal tagged private type declares a view of the
--- corresponding predefined operator of the actual type (even if the
--- operator has been overridden for the actual type). Check that the
--- body executed is determined by the type and tag of the operands.
---
--- TEST DESCRIPTION:
--- The formal tagged private type has an unknown discriminant part, and
--- is thus indefinite. This allows both definite and indefinite types
--- to be passed as actuals. For tagged types, definite implies
--- nondiscriminated, and indefinite implies discriminated (with known
--- or unknown discriminants).
---
--- Only nonlimited tagged types are tested, since equality operators
--- are not predefined for limited types.
---
--- A tagged type is passed as an actual to a generic formal tagged
--- private type. The tagged type overrides the predefined equality
--- operator. A subprogram within the generic calls the equality operator
--- of the formal type. In an instance, the equality operator denotes
--- a view of the predefined operator of the actual type, but the
--- call dispatches to the body of the overriding operator.
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 21 Nov 95 SAIC ACVC 2.0.1 fixes: Corrected expected result on
--- calls to "=" within the instance. Modified
--- commentary.
---
---!
-
-package CC50001_0 is
-
- type Count_Type is tagged record -- Nondiscriminated
- Count : Integer := 0; -- tagged type.
- end record;
-
- function "="(Left, Right : Count_Type) -- User-defined
- return Boolean; -- equality operator.
-
-
- subtype Str_Len is Natural range 0 .. 100;
- subtype Stu_ID is String (1 .. 5);
- subtype Dept_ID is String (1 .. 4);
- subtype Emp_ID is String (1 .. 9);
- type Status is (Student, Faculty, Staff);
-
- type Person_Type (Stat : Status; -- Discriminated
- NameLen, AddrLen : Str_Len) is -- tagged type.
- tagged record
- Name : String (1 .. NameLen);
- Address : String (1 .. AddrLen);
- case Stat is
- when Student =>
- Student_ID : Stu_ID;
- when Faculty =>
- Department : Dept_ID;
- when Staff =>
- Employee_ID : Emp_ID;
- end case;
- end record;
-
- function "="(Left, Right : Person_Type) -- User-defined
- return Boolean; -- equality operator.
-
-
- -- Testing entities: ------------------------------------------------
-
- TC_Count_Item : constant Count_Type := (Count => 111);
-
- TC_Person_Item : constant Person_Type :=
- (Faculty, 18, 17, "Eccles, John Scott", "Popham House, Lee", "0931");
-
- ---------------------------------------------------------------------
-
-
-end CC50001_0;
-
-
- --===================================================================--
-
-
-package body CC50001_0 is
-
- function "="(Left, Right : Count_Type) return Boolean is
- begin
- return False; -- Return FALSE even if Left = Right.
- end "=";
-
-
- function "="(Left, Right : Person_Type) return Boolean is
- begin
- return False; -- Return FALSE even if Left = Right.
- end "=";
-
-end CC50001_0;
-
-
- --===================================================================--
-
-
-with CC50001_0; -- Tagged (actual) type declarations.
-generic -- Generic stack abstraction.
-
- type Item (<>) is tagged private; -- Formal tagged private type.
-
-package CC50001_1 is
-
- -- Simulate a generic stack abstraction. In a real application, the
- -- second operand of Push might be of type Stack, and type Stack
- -- would have at least one component (pointing to the top stack item).
-
- type Stack is private;
-
- procedure Push (I : in Item; TC_Check : out Boolean);
-
- -- ... Other stack operations.
-
-private
-
- -- ... Stack and ancillary type declarations.
-
- type Stack is record -- Artificial.
- null;
- end record;
-
-end CC50001_1;
-
-
- --===================================================================--
-
-
-package body CC50001_1 is
-
- -- For the sake of brevity, the implementation of Push is completely
- -- artificial; the goal is to model a call of the equality operator within
- -- the generic.
- --
- -- A real application might implement Push such that it does not add new
- -- items to the stack if they are identical to the top item; in that
- -- case, the equality operator would be called as part of an "if"
- -- condition.
-
- procedure Push (I : in Item; TC_Check : out Boolean) is
- begin
- TC_Check := not (I = I); -- Call user-defined "="; should
- -- return FALSE. Negation of
- -- result makes TC_Check TRUE.
- end Push;
-
-end CC50001_1;
-
-
- --==================================================================--
-
-
-with CC50001_0; -- Tagged (actual) type declarations.
-with CC50001_1; -- Generic stack abstraction.
-
-use CC50001_0; -- Overloaded "=" directly visible.
-
-with Report;
-procedure CC50001 is
-
- package Count_Stacks is new CC50001_1 (CC50001_0.Count_Type);
- package Person_Stacks is new CC50001_1 (CC50001_0.Person_Type);
-
- User_Defined_Op_Called : Boolean;
-
-begin
- Report.Test ("CC50001", "Check that, in an instance, each implicit " &
- "declaration of a primitive subprogram of a formal tagged " &
- "private type declares a view of the corresponding " &
- "predefined operator of the actual type (even if the " &
- "operator has been overridden or hidden for the actual type)");
-
---
--- Test which "=" is called inside generic:
---
-
- User_Defined_Op_Called := False;
-
- Count_Stacks.Push (CC50001_0.TC_Count_Item,
- User_Defined_Op_Called);
-
-
- if not User_Defined_Op_Called then
- Report.Failed ("User-defined ""="" not called inside generic for Count");
- end if;
-
-
- User_Defined_Op_Called := False;
-
- Person_Stacks.Push (CC50001_0.TC_Person_Item,
- User_Defined_Op_Called);
-
- if not User_Defined_Op_Called then
- Report.Failed ("User-defined ""="" not called inside generic " &
- "for Person");
- end if;
-
-
---
--- Test which "=" is called outside generic:
---
-
- User_Defined_Op_Called := False;
-
- User_Defined_Op_Called :=
- not (CC50001_0.TC_Count_Item = CC50001_0.TC_Count_Item);
-
- if not User_Defined_Op_Called then
- Report.Failed ("User-defined ""="" not called outside generic "&
- "for Count");
- end if;
-
-
- User_Defined_Op_Called := False;
-
- User_Defined_Op_Called :=
- not (CC50001_0.TC_Person_Item = CC50001_0.TC_Person_Item);
-
- if not User_Defined_Op_Called then
- Report.Failed ("User-defined ""="" not called outside generic "&
- "for Person");
- end if;
-
-
- Report.Result;
-end CC50001;
diff --git a/gcc/testsuite/ada/acats/tests/cc/cc50a01.a b/gcc/testsuite/ada/acats/tests/cc/cc50a01.a
deleted file mode 100644
index 4d5dfdfd50d..00000000000
--- a/gcc/testsuite/ada/acats/tests/cc/cc50a01.a
+++ /dev/null
@@ -1,313 +0,0 @@
--- CC50A01.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that a formal parameter of a library-level generic unit may be
--- a formal tagged private type. Check that a nonlimited tagged type may
--- be passed as an actual. Check that if the formal type is indefinite,
--- both indefinite and definite types may be passed as actuals.
---
--- TEST DESCRIPTION:
--- The generic package declares a formal tagged private type (this can
--- be considered the parent "mixin" class). This type is extended in
--- the generic to provide support for stacks of items of any nonlimited
--- tagged type. Stacks are modeled as singly linked lists, with the list
--- nodes being objects of the extended type.
---
--- A generic testing procedure pushes items onto a stack, and pops them
--- back off, verifying the state of the stack at various points along the
--- way. The push and pop routines exercise functionality important to
--- tagged types, such as type conversion toward the root of the derivation
--- class and extension aggregates.
---
--- The formal tagged private type has an unknown discriminant part, and
--- is thus indefinite. This allows both definite and indefinite types
--- to be passed as actuals. For tagged types, definite implies
--- nondiscriminated, and indefinite implies discriminated (with known
--- or unknown discriminants).
---
--- TEST FILES:
--- This test consists of the following files:
---
--- FC50A00.A
--- -> CC50A01.A
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 21 Nov 95 SAIC ACVC 2.0.1 fixes: Moved instantiations of
--- BC50A01_0 to library level.
--- 11 Aug 96 SAIC ACVC 2.1: Updated prologue. Added pragma
--- Elaborate to context clauses for CC50A01_2 & _3.
---
---!
-
-with FC50A00; -- Tagged (actual) type declarations.
-generic -- Generic stack abstraction.
-
- type Item (<>) is tagged private; -- Formal tagged private type.
- TC_Default_Value : Item; -- Needed in View_Top (see
- -- below).
-package CC50A01_0 is
-
- type Stack is private;
-
--- Note that because the actual type corresponding to Item may be
--- unconstrained, the functions of removing the top item from the stack and
--- returning the value of the top item of the stack have been separated into
--- Pop and View_Top, respectively. This is necessary because otherwise the
--- returned value would have to be an out parameter of Pop, which would
--- require the user (in the unconstrained case) to create an uninitialized
--- unconstrained object to serve as the actual, which is illegal.
-
- procedure Push (I : in Item; S : in out Stack);
- procedure Pop (S : in out Stack);
- function View_Top (S : Stack) return Item;
-
- function Size_Of (S : Stack) return Natural;
-
-private
-
- type Stack_Item;
- type Stack_Ptr is access Stack_Item;
-
- type Stack_Item is new Item with record -- Extends formal type.
- Next : Stack_Ptr := null;
- end record;
-
- type Stack is record
- Top : Stack_Ptr := null;
- Size : Natural := 0;
- end record;
-
-end CC50A01_0;
-
-
- --==================================================================--
-
-
-package body CC50A01_0 is
-
- -- Link NewItem in at the top of the stack (the extension aggregate within
- -- the allocator initializes the inherited portion of NewItem to equal I,
- -- and NewItem.Next to point to what S.Top points to).
-
- procedure Push (I : in Item; S : in out Stack) is
- NewItem : Stack_Ptr;
- begin
- NewItem := new Stack_Item'(I with S.Top); -- Extension aggregate.
- S.Top := NewItem;
- S.Size := S.Size + 1;
- end Push;
-
-
- -- Remove item from top of stack. This procedure only updates the state of
- -- the stack; it does not return the value of the popped item. Hence, in
- -- order to accomplish a "true" pop, both View_Top and Pop must be called
- -- consecutively.
- --
- -- If the stack is empty, the Pop is ignored (for simplicity; in a true
- -- application this might be treated as an error condition).
-
- procedure Pop (S : in out Stack) is
- begin
- if S.Top = null then -- Stack is empty.
- null;
- -- Raise exception.
- else
- S.Top := S.Top.Next;
- S.Size := S.Size - 1;
- -- Deallocate discarded node.
- end if;
- end Pop;
-
-
- -- Return the value of the top item on the stack. This procedure only
- -- returns the value; it does not remove the top item from the stack.
- -- Hence, in order to accomplish a "true" pop, both View_Top and Pop must
- -- be called consecutively.
- --
- -- Since items on the stack are of a type (Stack_Item) derived from Item,
- -- which is a (tagged) private type, type conversion toward the root is the
- -- only way to get a value of type Item for return to the caller.
- --
- -- If the stack is empty, View_Top returns a pre-specified default value.
- -- (In a true application, an exception might be raised instead).
-
- function View_Top (S : Stack) return Item is
- begin
- if S.Top = null then -- Stack is empty.
- return TC_Default_Value; -- Testing artifice.
- -- Raise exception.
- else
- return Item(S.Top.all); -- Type conversion.
- end if;
- end View_Top;
-
-
- function Size_Of (S : Stack) return Natural is
- begin
- return (S.Size);
- end Size_Of;
-
-
-end CC50A01_0;
-
-
- --==================================================================--
-
-
--- The formal package Stacker below is needed to gain access to the
--- appropriate version of the "generic" type Stack. It is provided with an
--- explicit actual part in order to restrict the packages that can be passed
--- as actuals to those which have been instantiated with the same actuals
--- which this generic procedure has been instantiated with.
-
-with CC50A01_0; -- Generic stack abstraction.
-generic
- type Item_Type (<>) is tagged private; -- Formal tagged private type.
- Default : Item_Type;
- with package Stacker is new CC50A01_0 (Item_Type, Default);
-procedure CC50A01_1 (S : in out Stacker.Stack; I : in Item_Type);
-
-
- --==================================================================--
-
---
--- This generic procedure performs all of the testing of the
--- stack abstraction.
---
-
-with Report;
-procedure CC50A01_1 (S : in out Stacker.Stack; I : in Item_Type) is
-begin
- Stacker.Push (I, S); -- Push onto empty stack.
- Stacker.Push (I, S); -- Push onto nonempty stack.
-
- if Stacker.Size_Of (S) /= 2 then
- Report.Failed (" Wrong stack size after 2 Pushes");
- end if;
-
- -- Calls to View_Top must initialize a declared object of type Item_Type
- -- because the type may be unconstrained.
-
- declare
- Buffer1 : Item_Type := Stacker.View_Top (S);
- begin
- Stacker.Pop (S); -- Pop item off nonempty stack.
- if Buffer1 /= I then
- Report.Failed (" Wrong stack item value after 1st Pop");
- end if;
- end;
-
- declare
- Buffer2 : Item_Type := Stacker.View_Top (S);
- begin
- Stacker.Pop (S); -- Pop last item off stack.
- if Buffer2 /= I then
- Report.Failed (" Wrong stack item value after 2nd Pop");
- end if;
- end;
-
- if Stacker.Size_Of (S) /= 0 then
- Report.Failed (" Wrong stack size after 2 Pops");
- end if;
-
- declare
- Buffer3 : Item_Type := Stacker.View_Top (S);
- begin
- if Buffer3 /= Default then
- Report.Failed (" Wrong result after Pop of empty stack");
- end if;
- Stacker.Pop (S); -- Pop off empty stack.
- end;
-
-end CC50A01_1;
-
-
- --==================================================================--
-
-
-with FC50A00;
-
-with CC50A01_0;
-pragma Elaborate (CC50A01_0);
-
-package CC50A01_2 is new CC50A01_0 (FC50A00.Count_Type,
- FC50A00.TC_Default_Count);
-
-
- --==================================================================--
-
-
-with FC50A00;
-
-with CC50A01_0;
-pragma Elaborate (CC50A01_0);
-
-package CC50A01_3 is new CC50A01_0 (FC50A00.Person_Type,
- FC50A00.TC_Default_Person);
-
-
- --==================================================================--
-
-
-with FC50A00; -- Tagged (actual) type declarations.
-with CC50A01_0; -- Generic stack abstraction.
-with CC50A01_1; -- Generic stack testing procedure.
-with CC50A01_2;
-with CC50A01_3;
-
-with Report;
-procedure CC50A01 is
-
- package Count_Stacks renames CC50A01_2;
- package Person_Stacks renames CC50A01_3;
-
-
- procedure TC_Count_Test is new CC50A01_1 (FC50A00.Count_Type,
- FC50A00.TC_Default_Count,
- Count_Stacks);
- Count_Stack : Count_Stacks.Stack;
-
-
- procedure TC_Person_Test is new CC50A01_1 (FC50A00.Person_Type,
- FC50A00.TC_Default_Person,
- Person_Stacks);
- Person_Stack : Person_Stacks.Stack;
-
-begin
- Report.Test ("CC50A01", "Check that a formal parameter of a " &
- "library-level generic unit may be a formal tagged " &
- "private type");
-
- Report.Comment ("Testing definite tagged type..");
- TC_Count_Test (Count_Stack, FC50A00.TC_Count_Item);
-
- Report.Comment ("Testing indefinite tagged type..");
- TC_Person_Test (Person_Stack, FC50A00.TC_Person_Item);
-
- Report.Result;
-end CC50A01;
diff --git a/gcc/testsuite/ada/acats/tests/cc/cc50a02.a b/gcc/testsuite/ada/acats/tests/cc/cc50a02.a
deleted file mode 100644
index 6c2bf5fb0fd..00000000000
--- a/gcc/testsuite/ada/acats/tests/cc/cc50a02.a
+++ /dev/null
@@ -1,227 +0,0 @@
--- CC50A02.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that a nonlimited tagged type may be passed as an actual to a
--- formal (non-tagged) private type. Check that if the formal type has
--- an unknown discriminant part, a class-wide type may also be passed as
--- an actual.
---
--- TEST DESCRIPTION:
--- A generic package declares a formal private type and defines a
--- stack abstraction. Stacks are modeled as singly linked lists of
--- pointers to elements. Pointers are used because the elements may
--- be unconstrained.
---
--- A generic testing procedure pushes an item onto a stack, then views
--- the item on top of the stack.
---
--- The formal private type has an unknown discriminant part, and
--- is thus indefinite. This allows both definite and indefinite types
--- (including class-wide types) to be passed as actuals. For tagged types,
--- definite implies nondiscriminated, and indefinite implies discriminated
--- (with known/unknown discriminants).
---
--- TEST FILES:
--- The following files comprise this test:
---
--- FC50A00.A
--- -> CC50A02.A
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 10 Nov 95 SAIC ACVC 2.0.1 fixes: Removed use of formal package
--- exception name in exception choice.
---
---!
-
-generic -- Generic stack abstraction.
- type Item (<>) is private; -- Formal private type.
-package CC50A02_0 is
-
- type Stack is private;
-
- procedure Push (I : in Item; S : in out Stack);
- function View_Top (S : Stack) return Item;
-
- -- ...Other stack operations...
-
- Stack_Empty : exception;
-
-private
-
- type Item_Ptr is access Item;
-
- type Stack_Item;
- type Stack_Ptr is access Stack_Item;
-
- type Stack_Item is record
- Item : Item_Ptr;
- Next : Stack_Ptr;
- end record;
-
- type Stack is record
- Top : Stack_Ptr := null;
- Size : Natural := 0;
- end record;
-
-end CC50A02_0;
-
-
- --==================================================================--
-
-
-package body CC50A02_0 is
-
- -- Link NewItem in at the top of the stack.
-
- procedure Push (I : in Item; S : in out Stack) is
- NewItem : Item_Ptr := new Item'(I);
- Element : Stack_Ptr := new Stack_Item'(Item => NewItem, Next => S.Top);
- begin
- S.Top := Element;
- S.Size := S.Size + 1;
- end Push;
-
-
- -- Return (copy) of top item on stack. Do NOT remove from stack.
-
- function View_Top (S : Stack) return Item is
- begin
- if S.Top = null then
- raise Stack_Empty;
- else
- return S.Top.Item.all;
- end if;
- end View_Top;
-
-end CC50A02_0;
-
-
- --==================================================================--
-
-
--- The formal package Stacker below is needed to gain access to the
--- appropriate version of the "generic" type Stack. It is provided with an
--- explicit actual part in order to restrict the packages that can be passed
--- as actuals to those which have been instantiated with the same actuals
--- which this generic procedure has been instantiated with.
-
-with CC50A02_0; -- Generic stack abstraction.
-generic
- type Item_Type (<>) is private; -- Formal private type.
- with package Stacker is new CC50A02_0 (Item_Type);
-procedure CC50A02_1 (S : in out Stacker.Stack; I : in Item_Type);
-
-
- --==================================================================--
-
---
--- This generic procedure performs all of the testing of the
--- stack abstraction.
---
-
-with Report;
-procedure CC50A02_1 (S : in out Stacker.Stack; I : in Item_Type) is
-begin
- Stacker.Push (I, S); -- Push onto empty stack.
-
- -- Calls to View_Top must initialize a declared object of type Item_Type
- -- because the type may be unconstrained.
-
- declare
- Buffer : Item_Type := Stacker.View_Top (S);
- begin
- if Buffer /= I then
- Report.Failed (" Expected item not on stack");
- end if;
- exception
- when Constraint_Error =>
- Report.Failed (" Unexpected error: Tags of pushed and popped " &
- "items don't match");
- end;
-
-
-exception
- when others =>
- Report.Failed (" Unexpected error: Item not pushed onto stack");
-end CC50A02_1;
-
-
- --==================================================================--
-
-
-with FC50A00; -- Tagged (actual) type declarations.
-with CC50A02_0; -- Generic stack abstraction.
-with CC50A02_1; -- Generic stack testing procedure.
-
-with Report;
-procedure CC50A02 is
-
- --
- -- Pass a nondiscriminated tagged actual:
- --
-
- package Count_Stacks is new CC50A02_0 (FC50A00.Count_Type);
- procedure TC_Count_Test is new CC50A02_1 (FC50A00.Count_Type,
- Count_Stacks);
- Count_Stack : Count_Stacks.Stack;
-
-
- --
- -- Pass a discriminated tagged actual:
- --
-
- package Person_Stacks is new CC50A02_0 (FC50A00.Person_Type);
- procedure TC_Person_Test is new CC50A02_1 (FC50A00.Person_Type,
- Person_Stacks);
- Person_Stack : Person_Stacks.Stack;
-
-
- --
- -- Pass a class-wide actual:
- --
-
- package People_Stacks is new CC50A02_0 (FC50A00.Person_Type'Class);
- procedure TC_People_Test is new CC50A02_1 (FC50A00.Person_Type'Class,
- People_Stacks);
- People_Stack : People_Stacks.Stack;
-
-begin
- Report.Test ("CC50A02", "Check that tagged actuals may be passed " &
- "to a formal (nontagged) private type");
-
- Report.Comment ("Testing definite tagged type..");
- TC_Count_Test (Count_Stack, FC50A00.TC_Count_Item);
-
- Report.Comment ("Testing indefinite tagged type..");
- TC_Person_Test (Person_Stack, FC50A00.TC_Person_Item);
-
- Report.Comment ("Testing class-wide type..");
- TC_People_Test (People_Stack, FC50A00.TC_VIPerson_Item);
-
- Report.Result;
-end CC50A02;
diff --git a/gcc/testsuite/ada/acats/tests/cc/cc51001.a b/gcc/testsuite/ada/acats/tests/cc/cc51001.a
deleted file mode 100644
index 6aa76a6f8e6..00000000000
--- a/gcc/testsuite/ada/acats/tests/cc/cc51001.a
+++ /dev/null
@@ -1,186 +0,0 @@
--- CC51001.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that a formal parameter of a generic package may be a formal
--- derived type. Check that the formal derived type may have an unknown
--- discriminant part. Check that the ancestor type in a formal derived
--- type definition may be a tagged type, and that the actual parameter
--- may be a descendant of the ancestor type. Check that the formal derived
--- type belongs to the derivation class rooted at the ancestor type;
--- specifically, that components of the ancestor type may be referenced
--- within the generic. Check that if a formal derived subtype is
--- indefinite then the actual may be either definite or indefinite.
---
--- TEST DESCRIPTION:
--- Define a class of tagged types with a definite root type. Extend the
--- root type with a discriminated component. Since discriminants of
--- tagged types may not have defaults, the type is indefinite.
---
--- Extend the extension with a second discriminated component, but with
--- a new discriminant part. Declare a generic package with a formal
--- derived type using the root type of the class as ancestor, and an
--- unknown discriminant part. Declare an operation in the generic which
--- accesses the common component of types in the class.
---
--- In the main program, instantiate the generic with each type in the
--- class and verify that the operation correctly accesses the common
--- component.
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
---
---!
-
-package CC51001_0 is -- Root type for message class.
-
- subtype Msg_String is String (1 .. 20);
-
- type Msg_Type is tagged record -- Root type of
- Text : Msg_String := (others => ' '); -- class (definite).
- end record;
-
-end CC51001_0;
-
-
--- No body for CC51001_0.
-
-
- --==================================================================--
-
-
-with CC51001_0; -- Root type for message class.
-package CC51001_1 is -- Extensions to message class.
-
- subtype Source_Length is Natural range 0 .. 10;
-
- type From_Msg_Type (SLen : Source_Length) is -- Direct derivative
- new CC51001_0.Msg_Type with record -- of root type
- From : String (1 .. SLen); -- (indefinite).
- end record;
-
- subtype Dest_Length is Natural range 0 .. 10;
-
-
-
- type To_From_Msg_Type (DLen : Dest_Length) is -- Indirect
- new From_Msg_Type (SLen => 10) with record -- derivative of
- To : String (1 .. DLen); -- root type
- end record; -- (indefinite).
-
-end CC51001_1;
-
-
--- No body for CC51001_1.
-
-
- --==================================================================--
-
-
-with CC51001_0; -- Root type for message class.
-generic -- I/O operations for message class.
- type Message_Type (<>) is new CC51001_0.Msg_Type with private;
-package CC51001_2 is
-
- -- This subprogram contains an artificial result for testing purposes:
- -- the function returns the text of the message to the caller as a string.
-
- function Print_Message (M : in Message_Type) return String;
-
- -- ... Other operations.
-
-end CC51001_2;
-
-
- --==================================================================--
-
-
-package body CC51001_2 is
-
- -- The implementations of the operations below are purely artificial; the
- -- validity of their implementations in the context of the abstraction is
- -- irrelevant to the feature being tested.
-
- function Print_Message (M : in Message_Type) return String is
- begin
- return M.Text;
- end Print_Message;
-
-end CC51001_2;
-
-
- --==================================================================--
-
-
-with CC51001_0; -- Root type for message class.
-with CC51001_1; -- Extensions to message class.
-with CC51001_2; -- I/O operations for message class.
-
-with Report;
-procedure CC51001 is
-
- -- Instantiate for various types in the class:
-
- package Msgs is new CC51001_2 (CC51001_0.Msg_Type); -- Definite.
- package FMsgs is new CC51001_2 (CC51001_1.From_Msg_Type); -- Indefinite.
- package TFMsgs is new CC51001_2 (CC51001_1.To_From_Msg_Type); -- Indefinite.
-
-
-
- Msg : CC51001_0.Msg_Type := (Text => "This is message #001");
- FMsg : CC51001_1.From_Msg_Type := (Text => "This is message #002",
- SLen => 2,
- From => "Me");
- TFMsg : CC51001_1.To_From_Msg_Type := (Text => "This is message #003",
- From => "You ",
- DLen => 4,
- To => "Them");
-
- Expected_Msg : constant String := "This is message #001";
- Expected_FMsg : constant String := "This is message #002";
- Expected_TFMsg : constant String := "This is message #003";
-
-begin
- Report.Test ("CC51001", "Check that the formal derived type may have " &
- "an unknown discriminant part. Check that the ancestor " &
- "type in a formal derived type definition may be a " &
- "tagged type, and that the actual parameter may be any " &
- "definite or indefinite descendant of the ancestor type");
-
- if (Msgs.Print_Message (Msg) /= Expected_Msg) then
- Report.Failed ("Wrong result for definite root type");
- end if;
-
- if (FMsgs.Print_Message (FMsg) /= Expected_FMsg) then
- Report.Failed ("Wrong result for direct indefinite derivative");
- end if;
-
- if (TFMsgs.Print_Message (TFMsg) /= Expected_TFMsg) then
- Report.Failed ("Wrong result for Indirect indefinite derivative");
- end if;
-
- Report.Result;
-end CC51001;
diff --git a/gcc/testsuite/ada/acats/tests/cc/cc51002.a b/gcc/testsuite/ada/acats/tests/cc/cc51002.a
deleted file mode 100644
index 1083d18a8f8..00000000000
--- a/gcc/testsuite/ada/acats/tests/cc/cc51002.a
+++ /dev/null
@@ -1,198 +0,0 @@
--- CC51002.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that, for formal derived tagged types, the formal parameter
--- names and default expressions for a primitive subprogram in an
--- instance are determined by the primitive subprogram of the ancestor
--- type, but that the primitive subprogram body executed is that of the
--- actual type.
---
--- TEST DESCRIPTION:
--- Define a root tagged type in a library-level package and give it a
--- primitive subprogram. Provide a default expression for a non-tagged
--- parameter of the subprogram. Declare a library-level generic subprogram
--- with a formal derived type using the root type as ancestor. Call
--- the primitive subprogram of the root type using named association for
--- the tagged parameter, and provide no actual for the defaulted
--- parameter. Extend the root type in a second package and override the
--- root type's subprogram with one which has different parameter names
--- and no default expression for the non-tagged parameter. Instantiate
--- the generic subprogram for each of the tagged types in the class and
--- call the instances.
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
---
---!
-
-package CC51002_0 is -- Root message type and operations.
-
- type Recipients is (None, Root, Sysop, Local, Remote);
-
- type Msg_Type is tagged record -- Root type of
- Text : String (1 .. 10); -- class.
- end record;
-
- function Send (Msg : in Msg_Type; -- Primitive
- To : Recipients := Local) return Boolean; -- subprogram.
-
- -- ...Other message operations.
-
-end CC51002_0;
-
-
- --==================================================================--
-
-
-package body CC51002_0 is
-
- -- The implementation of Send is purely artificial; the validity of
- -- its implementation in the context of the abstraction is irrelevant to
- -- the feature being tested.
-
- function Send (Msg : in Msg_Type;
- To : Recipients := Local) return Boolean is
- begin
- return (Msg.Text = "Greetings!" and To = Local);
- end Send;
-
-end CC51002_0;
-
-
- --==================================================================--
-
-
-with CC51002_0; -- Root message type and operations.
-generic -- Message class function.
- type Msg_Block is new CC51002_0.Msg_Type with private;
-function CC51002_1 (M : in Msg_Block) return Boolean;
-
-
- --==================================================================--
-
-
-function CC51002_1 (M : in Msg_Block) return Boolean is
- Okay : Boolean := False;
-begin
-
- -- The call to Send below uses the ancestor type's parameter name, which
- -- should be legal even if the actual subprogram called does not have a
- -- parameter of that name. Furthermore, it uses the ancestor type's default
- -- expression for the second parameter, which should be legal even if the
- -- the actual subprogram called has no such default expression.
-
- Okay := Send (Msg => M);
- -- ...Other processing.
- return Okay;
-
-end CC51002_1;
-
-
- --==================================================================--
-
-
-with CC51002_0; -- Root message type and operations.
-package CC51002_2 is -- Extended message type and operations.
-
- type Sender_Type is (Inside, Outside);
-
- type Who_Msg_Type is new CC51002_0.Msg_Type with record -- Derivative of
- From : Sender_Type; -- root type of
- end record; -- class.
-
-
- -- Note: this overriding version of Send has different parameter names
- -- from the root type's function. It also has no default expression.
-
- function Send (M : Who_Msg_Type; -- Overrides
- R : CC51002_0.Recipients) return Boolean; -- root type's
- -- operation.
- -- ...Other extended message operations.
-
-end CC51002_2;
-
-
- --==================================================================--
-
-
-package body CC51002_2 is
-
- -- The implementation of Send is purely artificial; the validity of
- -- its implementation in the context of the abstraction is irrelevant to
- -- the feature being tested.
-
- function Send (M : Who_Msg_Type; R : CC51002_0.Recipients) return Boolean is
- use type CC51002_0.Recipients;
- begin
- return (M.Text = "Willkommen" and
- M.From = Outside and
- R = CC51002_0.Local);
- end Send;
-
-end CC51002_2;
-
-
- --==================================================================--
-
-
-with CC51002_0; -- Root message type and operations.
-with CC51002_1; -- Message class function.
-with CC51002_2; -- Extended message type and operations.
-
-with Report;
-procedure CC51002 is
-
- function Send_Msg is new CC51002_1 (CC51002_0.Msg_Type);
- function Send_WMsg is new CC51002_1 (CC51002_2.Who_Msg_Type);
-
- Mess : CC51002_0.Msg_Type := (Text => "Greetings!");
- WMess : CC51002_2.Who_Msg_Type := (Text => "Willkommen",
- From => CC51002_2.Outside);
-
- TC_Okay_MStatus : Boolean := False;
- TC_Okay_WMStatus : Boolean := False;
-
-begin
- Report.Test ("CC51002", "Check that, for formal derived tagged types, " &
- "the formal parameter names and default expressions for " &
- "a primitive subprogram in an instance are determined by " &
- "the primitive subprogram of the ancestor type, but that " &
- "the primitive subprogram body executed is that of the" &
- "actual type");
-
- TC_Okay_MStatus := Send_Msg (Mess);
- if not TC_Okay_MStatus then
- Report.Failed ("Wrong result from call to root type's operation");
- end if;
-
- TC_Okay_WMStatus := Send_WMsg (WMess);
- if not TC_Okay_WMStatus then
- Report.Failed ("Wrong result from call to derived type's operation");
- end if;
-
- Report.Result;
-end CC51002;
diff --git a/gcc/testsuite/ada/acats/tests/cc/cc51003.a b/gcc/testsuite/ada/acats/tests/cc/cc51003.a
deleted file mode 100644
index 68ea32ebd78..00000000000
--- a/gcc/testsuite/ada/acats/tests/cc/cc51003.a
+++ /dev/null
@@ -1,187 +0,0 @@
--- CC51003.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that if the ancestor type of a formal derived type is a composite
--- type that is not an array type, the formal type inherits components,
--- including discriminants, from the ancestor type.
---
--- Check for the case where the ancestor type is a record type, and the
--- formal derived type is declared in a generic subprogram.
---
--- TEST DESCRIPTION:
--- Define a discriminated record type in a package. Declare a
--- library-level generic subprogram with a formal derived type using the
--- record type as ancestor. Give the generic subprogram an in out
--- parameter of the formal derived type. Inside the generic, use the
--- discriminant component and modify the remaining components of the
--- record parameter. In the main program, declare record objects with two
--- different discriminant values. Derive an indefinite type from the
--- record type with a new discriminant part. Instantiate the generic
--- subprogram for the root record subtype and the derived subtype. Call
--- the root subtype instance with actual parameters having the two
--- discriminant values. Also call the derived subtype instance with
--- an appropriate actual.
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 03 Jan 95 SAIC Removed unknown discriminant part from formal
--- derived type.
--- 05 Nov 95 SAIC ACVC 2.0.1 fixes: Removed constrained subtype
--- instantiation and associated declarations.
--- Modified commentary.
---
---!
-
-
--- Simulate a fragment of a matrix manipulation application.
-
-package CC51003_0 is -- Matrix types.
-
- type Matrix is array (Natural range <>, Natural range <>) of Integer;
-
- type Square (Side : Natural) is record
- Mat : Matrix (1 .. Side, 1 .. Side);
- end record;
-
- type Double_Square (Number : Natural) is record
- Left : Square (Number);
- Right : Square (Number);
- end record;
-
-end CC51003_0;
-
-
--- No body for CC51003_0;
-
-
- --==================================================================--
-
-
-with CC51003_0; -- Matrix types.
-generic -- Generic double-matrix "clear" operation.
- type Dbl_Square is new CC51003_0.Double_Square; -- Indefinite
-procedure CC51003_1 (Dbl : in out Dbl_Square); -- formal.
-
-
- --==================================================================--
-
-
-procedure CC51003_1 (Dbl : in out Dbl_Square) is
-begin
- for I in 1 .. Dbl.Number loop -- Discriminants inherited from ancestor
- for J in 1 .. Dbl.Number loop -- type (should work even for derived type
- -- declaring new discriminant part).
- Dbl.Left.Mat (I, J) := 0; -- Other components inherited from
- Dbl.Right.Mat (I, J) := 0; -- ancestor type.
-
- end loop;
- end loop;
-end CC51003_1;
-
-
- --==================================================================--
-
-
-with CC51003_0; -- Matrix types.
-with CC51003_1; -- Generic double-matrix "clear" operation.
-
-with Report;
-procedure CC51003 is
-
- use CC51003_0; -- "/=" operator directly visible for Double_Square.
-
- -- Matrices of root type:
-
- Mat_2x2 : Square(Side => 2) := (Side => 2,
- Mat => ( (1, 2), (3, 4) ));
- Dbl_Mat_2x2 : Double_Square(Number => 2) := (2, Mat_2x2, Mat_2x2);
-
-
- Zero_2x2 : constant Square(2) := (2, Mat => ( (0, 0), (0, 0) ));
- Expected_2x2 : constant Double_Square(2) := (Number => 2,
- others => Zero_2x2);
-
-
-
- Mat_3x3 : Square(Side => 3) := (Side => 3,
- Mat => (1 => (1, 4, 9),
- others => (1 => 5,
- others => 7)));
- Dbl_Mat_3x3 : Double_Square(3) := (Number => 3, others => Mat_3x3);
-
-
- Zero_3x3 : constant Square(3) := (3, Mat => (others => (0,0,0)));
- Expected_3x3 : constant Double_Square(Number => 3) :=
- (3, Zero_3x3, Zero_3x3);
-
-
- -- Derived type with new discriminant part (which constrains parent):
-
- type New_Dbl_Sq (Num : Natural) is new Double_Square(Num);
-
- New_Dbl_2x2 : New_Dbl_Sq (Num => 2) := (2, Mat_2x2, Mat_2x2);
- Expected_New_2x2 : constant New_Dbl_Sq := (Num => 2, others => Zero_2x2);
-
-
-
- -- Instantiations:
-
- procedure Clr_Dbl is new CC51003_1 (Double_Square);
- procedure Clr_New_Dbl is new CC51003_1 (New_Dbl_Sq);
-
-
-begin
- Report.Test ("CC51003", "Check that a formal derived record type " &
- "inherits components, including discriminants, " &
- "from its ancestor type");
-
- -- Simulate use of matrix manipulation operations.
-
- Clr_Dbl (Dbl_Mat_2x2);
-
- if (Dbl_Mat_2x2 /= Expected_2x2) then
- Report.Failed ("Wrong result for root type (2x2 matrix)");
- end if;
-
-
- Clr_Dbl (Dbl_Mat_3x3);
-
- if (Dbl_Mat_3x3 /= Expected_3x3) then
- Report.Failed ("Wrong result for root type (3x3 matrix)");
- end if;
-
-
- Clr_New_Dbl (New_Dbl_2x2);
-
- if (New_Dbl_2x2 /= Expected_New_2x2) then
- Report.Failed ("Wrong result for derived type (2x2 matrix)");
- end if;
-
-
- Report.Result;
-
-end CC51003;
diff --git a/gcc/testsuite/ada/acats/tests/cc/cc51004.a b/gcc/testsuite/ada/acats/tests/cc/cc51004.a
deleted file mode 100644
index 09b1b57fae7..00000000000
--- a/gcc/testsuite/ada/acats/tests/cc/cc51004.a
+++ /dev/null
@@ -1,181 +0,0 @@
--- CC51004.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that if the ancestor type of a formal derived type is a composite
--- type that is not an array type, the formal type inherits components,
--- including discriminants, from the ancestor type.
---
--- Check for the case where the ancestor type is a tagged type, and the
--- formal derived type is declared in a generic subprogram.
---
--- TEST DESCRIPTION:
--- Define a discriminated tagged type in a package. Declare a
--- library-level generic subprogram with a formal derived type using the
--- tagged type as ancestor. Give the generic subprogram an in out
--- parameter of the formal derived type. Inside the generic, use the
--- discriminant component and modify the remaining components of the
--- tagged parameter. In the main program, declare tagged record objects
--- with two different discriminant values. Derive an indefinite type from
--- the tagged type with a new discriminant part. Instantiate the
--- generic subprogram for the root tagged subtype and the derived subtype.
--- Call the root subtype instance with actual parameters having the two
--- discriminant values. Also call the derived subtype instance with an
--- appropriate actual.
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 05 Jan 94 SAIC Removed unknown discriminant part from formal
--- derived type. Moved declaration of type
--- New_Dbl_Sq from main subprogram to CC51004_0.
--- 05 Nov 95 SAIC ACVC 2.0.1 fixes: Removed constrained subtype
--- instantiation and associated declarations.
--- Modified commentary.
---
---!
-
--- Simulate a fragment of a matrix manipulation application.
-
-package CC51004_0 is -- Matrix types.
-
- type Matrix is array (Natural range <>, Natural range <>) of Integer;
-
- type Square (Side : Natural) is record
- Mat : Matrix (1 .. Side, 1 .. Side);
- end record;
-
- type Sq_Type (Num1 : Natural) is tagged record
- One : Square (Num1);
- end record;
-
- -- Extended type with new discriminant part (which constrains parent):
-
- type New_Dbl_Sq (Num2 : Natural) is new Sq_Type(Num2) with record
- Two : Square (Num2);
- end record;
-
-end CC51004_0;
-
-
--- No body for CC51004_0;
-
-
- --==================================================================--
-
-
-with CC51004_0; -- Matrix types.
-generic -- Generic matrix "clear" operation.
- type Squares is new CC51004_0.Sq_Type with private; -- Indefinite
-procedure CC51004_1 (Sq : in out Squares); -- formal.
-
-
- --==================================================================--
-
-
-procedure CC51004_1 (Sq : in out Squares) is
-begin
- for I in 1 .. Sq.Num1 loop -- Discriminants inherited from ancestor
- for J in 1 .. Sq.Num1 loop -- type (should work even for derived type
- -- declaring new discriminant part).
- Sq.One.Mat (I, J) := 0; -- Other components inherited from
- -- ancestor type.
- end loop;
- end loop;
-end CC51004_1;
-
-
- --==================================================================--
-
-
-with CC51004_0; -- Matrix types.
-with CC51004_1; -- Generic double-matrix "clear" operation.
-
-with Report;
-procedure CC51004 is
-
- use CC51004_0; -- "/=" operator directly visible for Sq_Type.
-
- -- Matrices of root type:
-
- Mat_2x2 : Square(Side => 2) := (Side => 2, Mat => ( (1, 2), (3, 4) ));
- One_Mat_2x2 : Sq_Type(Num1 => 2) := (2, Mat_2x2);
-
- Zero_2x2 : constant Square(2) := (2, Mat => ( (0, 0), (0, 0) ));
- Expected_2x2 : constant Sq_Type(2) := (Num1 => 2, One => Zero_2x2);
-
-
- Mat_3x3 : Square(Side => 3) := (Side => 3,
- Mat => (1 => (5, 2, 7),
- others => (1 => 4,
- others => 9)));
- One_Mat_3x3 : Sq_Type(3) := (Num1 => 3, One => Mat_3x3);
-
- Zero_3x3 : constant Square(3) := (3, Mat => (others => (0,0,0)));
- Expected_3x3 : constant Sq_Type(Num1 => 3) := (3, Zero_3x3);
-
-
- New_Dbl_2x2 : New_Dbl_Sq(Num2 => 2) := (2, others => Mat_2x2);
- Expected_New_2x2 : constant New_Dbl_Sq := (2, Zero_2x2, Mat_2x2);
-
-
-
- -- Instantiations:
-
- procedure Clr_Mat is new CC51004_1 (Sq_Type);
- procedure Clr_New_Dbl is new CC51004_1 (New_Dbl_Sq);
-
-
-begin
- Report.Test ("CC51004", "Check that a formal derived tagged type " &
- "inherits components, including discriminants, " &
- "from its ancestor type");
-
- -- Simulate use of matrix manipulation operations.
-
-
- Clr_Mat (One_Mat_2x2);
-
- if (One_Mat_2x2 /= Expected_2x2) then
- Report.Failed ("Wrong result root type (2x2 matrix)");
- end if;
-
-
- Clr_Mat (One_Mat_3x3);
-
- if (One_Mat_3x3 /= Expected_3x3) then
- Report.Failed ("Wrong result root type (3x3 matrix)");
- end if;
-
-
- Clr_New_Dbl (New_Dbl_2x2);
-
- if (New_Dbl_2x2 /= Expected_New_2x2) then
- Report.Failed ("Wrong result extended type (2x2 matrix)");
- end if;
-
-
- Report.Result;
-end CC51004;
diff --git a/gcc/testsuite/ada/acats/tests/cc/cc51006.a b/gcc/testsuite/ada/acats/tests/cc/cc51006.a
deleted file mode 100644
index b4dc4cdb4d4..00000000000
--- a/gcc/testsuite/ada/acats/tests/cc/cc51006.a
+++ /dev/null
@@ -1,224 +0,0 @@
--- CC51006.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that, in an instance, each implicit declaration of a primitive
--- subprogram of a formal (nontagged) derived type declares a view of
--- the corresponding primitive subprogram of the ancestor type, even if
--- the subprogram has been overridden for the actual type. Check that for
--- a formal derived type with no discriminant part, if the ancestor
--- subtype is an unconstrained scalar subtype then the actual may be
--- either constrained or unconstrained.
---
--- TEST DESCRIPTION:
--- The formal derived type has no discriminant part, but the ancestor
--- subtype is unconstrained, making the formal type unconstrained. Since
--- the ancestor subtype is a scalar subtype (not an access or composite
--- subtype), the actual may be either constrained or unconstrained.
---
--- Declare a root type of a class as an unconstrained scalar (use floating
--- point). Declare a primitive subprogram of the root type. Declare a
--- generic package which has a formal derived type with the scalar root
--- type as ancestor. Inside the generic, declare an operation which calls
--- the ancestor type's primitive subprogram. Derive both constrained and
--- unconstrained types from the root type and override the primitive
--- subprogram for each. Declare a constrained subtype of the unconstrained
--- derivative. Instantiate the generic package for the derived types and
--- the subtype and call the "generic" operation for each one. Confirm that
--- in all cases the root type's implementation of the primitive
--- subprogram is called.
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
---
---!
-
-package CC51006_0 is -- Weight class.
-
- type Weight_Type is digits 3; -- Root type of class (unconstrained).
-
- function Weight_To_String (Wt : Weight_Type) return String;
-
- -- ... Other operations.
-
-end CC51006_0;
-
-
- --==================================================================--
-
-
-package body CC51006_0 is
-
- -- The implementations of the operations below are purely artificial; the
- -- validity of their implementations in the context of the abstraction is
- -- irrelevant to the feature being tested.
-
- function Weight_To_String (Wt : Weight_Type) return String is
- begin
- if Wt > 0.0 then -- Always true for this test.
- return ("Root type's implementation called");
- else
- return ("Unexpected result ");
- end if;
- end Weight_To_String;
-
-end CC51006_0;
-
-
- --==================================================================--
-
-
-with CC51006_0; -- Weight class.
-generic -- Generic weight operations.
- type Weight is new CC51006_0.Weight_Type;
-package CC51006_1 is
-
- procedure Output_Weight (Wt : in Weight; TC_Return : out String);
-
- -- ... Other operations.
-
-end CC51006_1;
-
-
- --==================================================================--
-
-
-package body CC51006_1 is
-
-
- -- The implementation of this procedure is purely artificial, and contains
- -- an artificial parameter for testing purposes: the procedure returns the
- -- weight string to the caller.
-
- procedure Output_Weight (Wt : in Weight; TC_Return : out String) is
- begin
- TC_Return := Weight_To_String (Wt); -- Should always call root type's
- end Output_Weight; -- implementation.
-
-
-end CC51006_1;
-
-
- --==================================================================--
-
-
-with CC51006_0; -- Weight class.
-use CC51006_0;
-package CC51006_2 is -- Extensions to weight class.
-
- type Grams is new Weight_Type; -- Unconstrained
- -- derivative.
-
- function Weight_To_String (Wt : Grams) return String; -- Overrides root
- -- type's operation.
-
- subtype Milligrams is Grams -- Constrained
- range 0.0 .. 0.999; -- subtype (of der.).
-
- type Pounds is new Weight_Type -- Constrained
- range 0.0 .. 500.0; -- derivative.
-
- function Weight_To_String (Wt : Pounds) return String; -- Overrides root
- -- type's operation.
-
-end CC51006_2;
-
-
- --==================================================================--
-
-
-package body CC51006_2 is
-
- -- The implementations of the operations below are purely artificial; the
- -- validity of their implementations in the context of the abstraction is
- -- irrelevant to the feature being tested.
-
- function Weight_To_String (Wt : Grams) return String is
- begin
- return ("GRAMS: Should never be called ");
- end Weight_To_String;
-
-
- function Weight_To_String (Wt : Pounds) return String is
- begin
- return ("POUNDS: Should never be called ");
- end Weight_To_String;
-
-end CC51006_2;
-
-
- --==================================================================--
-
-
-with CC51006_1; -- Generic weight operations.
-with CC51006_2; -- Extensions to weight class.
-
-with Report;
-procedure CC51006 is
-
- package Metric_Wts_G is new CC51006_1 (CC51006_2.Grams); -- Unconstr.
- package Metric_Wts_MG is new CC51006_1 (CC51006_2.Milligrams); -- Constr.
- package US_Wts is new CC51006_1 (CC51006_2.Pounds); -- Constr.
-
- Gms : CC51006_2.Grams := 113.451;
- Mgm : CC51006_2.Milligrams := 0.549;
- Lbs : CC51006_2.Pounds := 24.52;
-
-
- subtype TC_Buffers is String (1 .. 33);
-
- TC_Expected : constant TC_Buffers := "Root type's implementation called";
- TC_Buffer : TC_Buffers;
-
-begin
- Report.Test ("CC51006", "Check that, in an instance, each implicit " &
- "declaration of a primitive subprogram of a formal " &
- "(nontagged) type declares a view of the corresponding " &
- "primitive subprogram of the ancestor type");
-
-
- Metric_Wts_G.Output_Weight (Gms, TC_Buffer);
-
- if TC_Buffer /= TC_Expected then
- Report.Failed ("Root operation not called for unconstrained derivative");
- end if;
-
-
- Metric_Wts_MG.Output_Weight (Mgm, TC_Buffer);
-
- if TC_Buffer /= TC_Expected then
- Report.Failed ("Root operation not called for constrained subtype");
- end if;
-
-
- US_Wts.Output_Weight (Lbs, TC_Buffer);
-
- if TC_Buffer /= TC_Expected then
- Report.Failed ("Root operation not called for constrained derivative");
- end if;
-
- Report.Result;
-end CC51006;
diff --git a/gcc/testsuite/ada/acats/tests/cc/cc51007.a b/gcc/testsuite/ada/acats/tests/cc/cc51007.a
deleted file mode 100644
index d8f78779dee..00000000000
--- a/gcc/testsuite/ada/acats/tests/cc/cc51007.a
+++ /dev/null
@@ -1,305 +0,0 @@
--- CC51007.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that a generic formal derived tagged type is a private extension.
--- Specifically, check that, for a generic formal derived type whose
--- ancestor type has abstract primitive subprograms, neither the formal
--- derived type nor its descendants need be abstract. Check that objects
--- and components of the formal derived type and its nonabstract
--- descendants may be declared and allocated, as may nonabstract
--- functions returning these types, and that aggregates of nonabstract
--- descendants of the formal derived type are legal. Check that calls to
--- the abstract primitive subprograms of the ancestor dispatch to the
--- bodies corresponding to the tag of the actual parameters.
---
--- TEST DESCRIPTION:
--- Although the ancestor type is abstract and has abstract primitive
--- subprograms, these subprograms, when inherited by a formal nonabstract
--- derived type, are not abstract, since the formal derived type is a
--- nonabstract private extension.
---
--- Thus, derivatives of the formal derived type need not be abstract,
--- and both the formal derived type and its derivatives are considered
--- nonabstract types.
---
--- This test verifies that the restrictions placed on abstract types do
--- not apply to the formal derived type or its derivatives. Specifically,
--- objects of, components of, allocators of, and nonabstract functions
--- returning the formal derived type or its derivatives are legal. In
--- addition, the test verifies that a call within the instance to a
--- primitive subprogram of the (abstract) ancestor type dispatches to
--- the body corresponding to the tag of the actual parameter.
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 23 Dec 94 SAIC Deleted illegal extension aggregate. Corrected
--- dispatching call. Editorial changes to commentary.
--- 05 Nov 95 SAIC ACVC 2.0.1 fixes: Moved instantiation of CC51007_3
--- to library level.
--- 11 Aug 96 SAIC ACVC 2.1: Added pragma Elaborate to context
--- clauses of CC51007_1 and CC51007_4.
---
---!
-
-package CC51007_0 is
-
- Max_Length : constant := 10;
- type Text is new String(1 .. Max_Length);
-
- type Alert is abstract tagged record -- Root type of class
- Message : Text := (others => '*'); -- (abstract).
- end record;
-
- procedure Handle (A: in out Alert) is abstract; -- Abstract dispatching
- -- operation.
-
-end CC51007_0;
-
--- No body for CC51007_0;
-
-
- --===================================================================--
-
-
-with CC51007_0;
-
-with Ada.Calendar;
-pragma Elaborate (Ada.Calendar);
-
-package CC51007_1 is
-
- type Low_Alert is new CC51007_0.Alert with record
- Time_Of_Arrival : Ada.Calendar.Time := Ada.Calendar.Time_Of (1901, 8, 1);
- end record;
-
- procedure Handle (A: in out Low_Alert); -- Overrides parent's
- -- implementation.
- Low : Low_Alert;
-
-end CC51007_1;
-
-
- --===================================================================--
-
-
-package body CC51007_1 is
-
- procedure Handle (A: in out Low_Alert) is -- Artificial for
- begin -- testing.
- A.Time_Of_Arrival := Ada.Calendar.Time_Of (1984, 1, 1);
- A.Message := "Low Alert!";
- end Handle;
-
-end CC51007_1;
-
-
- --===================================================================--
-
-
-with CC51007_1;
-package CC51007_2 is
-
- type Person is (OOD, CO, CinC);
-
- type Medium_Alert is new CC51007_1.Low_Alert with record
- Action_Officer : Person := OOD;
- end record;
-
- procedure Handle (A: in out Medium_Alert); -- Overrides parent's
- -- implementation.
- Med : Medium_Alert;
-
-end CC51007_2;
-
-
- --===================================================================--
-
-
-with Ada.Calendar;
-package body CC51007_2 is
-
- procedure Handle (A: in out Medium_Alert) is -- Artificial for
- begin -- testing.
- A.Action_Officer := CO;
- A.Time_Of_Arrival := Ada.Calendar.Time_Of (2001, 1, 1);
- A.Message := "Med Alert!";
- end Handle;
-
-end CC51007_2;
-
-
- --===================================================================--
-
-
-with CC51007_0;
-generic
- type Alert_Type is new CC51007_0.Alert with private;
- Initial_State : in Alert_Type;
-package CC51007_3 is
-
- function Clear_Message (A: Alert_Type) -- Function returning
- return Alert_Type; -- formal type.
-
-
- Max_Note : Natural := 10;
- type Note is new String (1 .. Max_Note);
-
- type Extended_Alert is new Alert_Type with record
- Addendum : Note := (others => '*');
- end record;
-
- -- In instance, inherits version of Handle from
- -- actual corresponding to formal type.
-
- function Annotate_Alert (A: in Alert_Type'Class) -- Function returning
- return Extended_Alert; -- derived type.
-
-
- Init_Ext_Alert : constant Extended_Alert := -- Object declaration.
- (Initial_State with Addendum => "----------"); -- Aggregate.
-
-
- type Alert_Type_Ptr is access constant Alert_Type;
- type Ext_Alert_Ptr is access Extended_Alert;
-
- Init_Alert_Ptr : Alert_Type_Ptr :=
- new Alert_Type'(Initial_State); -- Allocator.
-
- Init_Ext_Alert_Ptr : Ext_Alert_Ptr :=
- new Extended_Alert'(Init_Ext_Alert); -- Allocator.
-
-
- type Alert_Pair is record
- A : Alert_Type; -- Component.
- EA : Extended_Alert; -- Component.
- end record;
-
-end CC51007_3;
-
-
- --===================================================================--
-
-
-package body CC51007_3 is
-
- function Clear_Message (A: Alert_Type) return Alert_Type is
- Temp : Alert_Type := A; -- Object declaration.
- begin
- Temp.Message := (others => '-');
- return Temp;
- end Clear_Message;
-
- function Annotate_Alert (A: in Alert_Type'Class) return Extended_Alert is
- Temp : Alert_Type'Class := A;
- begin
- Handle (Temp); -- Dispatching call to
- -- operation of ancestor.
- return (Alert_Type(Temp) with Addendum => "No comment");
- end Annotate_Alert;
-
-end CC51007_3;
-
-
- --===================================================================--
-
-
-with CC51007_1;
-
-with CC51007_3;
-pragma Elaborate (CC51007_3);
-
-package CC51007_4 is new CC51007_3 (CC51007_1.Low_Alert, CC51007_1.Low);
-
-
- --===================================================================--
-
-
-with CC51007_1;
-with CC51007_2;
-with CC51007_3;
-with CC51007_4;
-
-with Ada.Calendar;
-with Report;
-procedure CC51007 is
-
- package Alert_Support renames CC51007_4;
-
- Ext : Alert_Support.Extended_Alert;
-
- TC_Result : Alert_Support.Extended_Alert;
-
- TC_Low_Expected : constant Alert_Support.Extended_Alert :=
- (Time_Of_Arrival => Ada.Calendar.Time_Of (1984, 1, 1),
- Message => "Low Alert!",
- Addendum => "No comment");
-
- TC_Med_Expected : constant Alert_Support.Extended_Alert :=
- (Time_Of_Arrival => Ada.Calendar.Time_Of (2001, 1, 1),
- Message => "Med Alert!",
- Addendum => "No comment");
-
- TC_Ext_Expected : constant Alert_Support.Extended_Alert := TC_Low_Expected;
-
-
- use type Alert_Support.Extended_Alert;
-
-begin
- Report.Test ("CC51007", "Check that, for a generic formal derived type " &
- "whose ancestor type has abstract primitive subprograms, " &
- "neither the formal derived type nor its descendants need " &
- "be abstract, and that objects of, components of, " &
- "allocators of, aggregates of, and nonabstract functions " &
- "returning these types are legal. Check that calls to the " &
- "abstract primitive subprograms of the ancestor dispatch " &
- "to the bodies corresponding to the tag of the actual " &
- "parameters");
-
-
- TC_Result := Alert_Support.Annotate_Alert (CC51007_1.Low); -- Dispatching
- -- call.
- if TC_Result /= TC_Low_Expected then
- Report.Failed ("Wrong results from dispatching call (Low_Alert)");
- end if;
-
-
- TC_Result := Alert_Support.Annotate_Alert (CC51007_2.Med); -- Dispatching
- -- call.
- if TC_Result /= TC_Med_Expected then
- Report.Failed ("Wrong results from dispatching call (Medium_Alert)");
- end if;
-
-
- TC_Result := Alert_Support.Annotate_Alert (Ext); -- Results in dispatching
- -- call.
- if TC_Result /= TC_Ext_Expected then
- Report.Failed ("Wrong results from dispatching call (Extended_Alert)");
- end if;
-
-
- Report.Result;
-end CC51007;
diff --git a/gcc/testsuite/ada/acats/tests/cc/cc51008.a b/gcc/testsuite/ada/acats/tests/cc/cc51008.a
deleted file mode 100644
index b95ae6cf04d..00000000000
--- a/gcc/testsuite/ada/acats/tests/cc/cc51008.a
+++ /dev/null
@@ -1,124 +0,0 @@
--- CC51008.A
---
--- Grant of Unlimited Rights
---
--- The Ada Conformity Assessment Authority (ACAA) holds unlimited
--- rights in the software and documentation contained herein. Unlimited
--- rights are the same as those granted by the U.S. Government for older
--- parts of the Ada Conformity Assessment Test Suite, and are defined
--- in DFAR 252.227-7013(a)(19). By making this public release, the ACAA
--- intends to confer upon all recipients unlimited rights equal to those
--- held by the ACAA. These rights include rights to use, duplicate,
--- release or disclose the released technical data and computer software
--- in whole or in part, in any manner and for any purpose whatsoever, and
--- to have or permit others to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE ACAA MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that operations are inherited for a formal derived type whose
--- ancestor is also a formal type as described in the corrigendum.
--- (Defect Report 8652/0038, as reflected in Technical Corrigendum 1,
--- RM95 12.5.1(21/1)).
---
--- CHANGE HISTORY:
--- 29 Jan 2001 PHL Initial version.
--- 30 Apr 2002 RLB Readied for release.
---
---!
-package CC51008_0 is
-
- type R0 is
- record
- C : Float;
- end record;
-
- procedure S (X : R0);
-
-end CC51008_0;
-
-with Report;
-use Report;
-package body CC51008_0 is
- procedure S (X : R0) is
- begin
- Comment ("CC51008_0.S called");
- end S;
-end CC51008_0;
-
-with CC51008_0;
-generic
- type F1 is new CC51008_0.R0;
- type F2 is new F1;
-package CC51008_1 is
- procedure G (O1 : F1; O2 : F2);
-end CC51008_1;
-
-package body CC51008_1 is
- procedure G (O1 : F1; O2 : F2) is
- begin
- S (O1);
- S (O2);
- end G;
-end CC51008_1;
-
-with CC51008_0;
-package CC51008_2 is
- type R2 is new CC51008_0.R0;
- procedure S (X : out R2);
-end CC51008_2;
-
-with Report;
-use Report;
-package body CC51008_2 is
- procedure S (X : out R2) is
- begin
- Failed ("CC51008_2.S called");
- end S;
-end CC51008_2;
-
-with CC51008_2;
-package CC51008_3 is
- type R3 is new CC51008_2.R2;
- procedure S (X : R3);
-end CC51008_3;
-
-with Report;
-use Report;
-package body CC51008_3 is
- procedure S (X : R3) is
- begin
- Failed ("CC51008_3.S called");
- end S;
-end CC51008_3;
-
-with CC51008_1;
-with CC51008_2;
-with CC51008_3;
-with Report;
-use Report;
-procedure CC51008 is
-
- package Inst is new CC51008_1 (CC51008_2.R2,
- CC51008_3.R3);
-
- X2 : constant CC51008_2.R2 := (C => 2.0);
- X3 : constant CC51008_3.R3 := (C => 3.0);
-
-begin
- Test ("CC51008",
- "Check that operations are inherited for a formal derived " &
- "type whose ancestor is also a formal type as described in " &
- "RM95 12.5.1(21/1)");
- Inst.G (X2, X3);
- Result;
-end CC51008;
-
diff --git a/gcc/testsuite/ada/acats/tests/cc/cc51a01.a b/gcc/testsuite/ada/acats/tests/cc/cc51a01.a
deleted file mode 100644
index 60c32be47f2..00000000000
--- a/gcc/testsuite/ada/acats/tests/cc/cc51a01.a
+++ /dev/null
@@ -1,193 +0,0 @@
--- CC51A01.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that, in an instance, each implicit declaration of a user-defined
--- subprogram of a formal derived record type declares a view of the
--- corresponding primitive subprogram of the ancestor, even if the
--- primitive subprogram has been overridden for the actual type.
---
--- TEST DESCRIPTION:
--- Declare a "fraction" type abstraction in a package (foundation code).
--- Declare a "fraction" I/O routine in a generic package with a formal
--- derived type whose ancestor type is the fraction type declared in
--- the first package. Within the I/O routine, call other operations of
--- ancestor type. Derive from the root fraction type in another package
--- and override one of the operations called in the generic I/O routine.
--- Derive from the derivative of the root fraction type. Instantiate
--- the generic package for each of the three types and call the I/O
--- routine.
---
--- TEST FILES:
--- The following files comprise this test:
---
--- FC51A00.A
--- CC51A01.A
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
---
---!
-
-with FC51A00; -- Fraction type abstraction.
-generic -- Fraction I/O support.
- type Fraction is new FC51A00.Fraction_Type; -- Formal derived type of a
-package CC51A01_0 is -- (private) record type.
-
- -- Simulate writing a fraction to standard output. In a real application,
- -- this subprogram might be a procedure which uses Text_IO routines. For
- -- the purposes of the test, the "output" is returned to the caller as a
- -- string.
- function Put (Item : in Fraction) return String;
-
- -- ... Other I/O operations for fractions.
-
-end CC51A01_0;
-
-
- --==================================================================--
-
-
-package body CC51A01_0 is
-
- function Put (Item : in Fraction) return String is
- Num : constant String := -- Fraction's primitive subprograms
- Integer'Image (Numerator (Item)); -- are inherited from its parent
- Den : constant String := -- (FC51A00.Fraction_Type) and NOT
- Integer'Image (Denominator (Item)); -- from the actual type.
- begin
- return (Num & '/' & Den);
- end Put;
-
-end CC51A01_0;
-
-
- --==================================================================--
-
-
-with FC51A00; -- Fraction type abstraction.
-package CC51A01_1 is
-
- -- Derive directly from the root type of the class and override one of the
- -- primitive subprograms.
-
- type Pos_Fraction is new FC51A00.Fraction_Type; -- Derived directly from
- -- root type of class.
- -- Inherits "/" from root type.
- -- Inherits "-" from root type.
- -- Inherits Numerator from root type.
- -- Inherits Denominator from root type.
-
- -- Return absolute value of numerator as integer.
- function Numerator (Frac : Pos_Fraction) -- Overrides parent's
- return Integer; -- operation.
-
-end CC51A01_1;
-
-
- --==================================================================--
-
-
-package body CC51A01_1 is
-
- -- This body should never be called.
- --
- -- The test sends the function Numerator a fraction with a negative
- -- numerator, and expects this negative numerator to be returned. This
- -- version of the function returns the absolute value of the numerator.
- -- Thus, a call to this version is detectable by examining the sign
- -- of the return value.
-
- function Numerator (Frac : Pos_Fraction) return Integer is
- Converted_Frac : FC51A00.Fraction_Type := FC51A00.Fraction_Type (Frac);
- Orig_Numerator : Integer := FC51A00.Numerator (Converted_Frac);
- begin
- return abs (Orig_Numerator);
- end Numerator;
-
-end CC51A01_1;
-
-
- --==================================================================--
-
-
-with FC51A00; -- Fraction type abstraction.
-with CC51A01_0; -- Fraction I/O support.
-with CC51A01_1; -- Positive fraction type abstraction.
-
-with Report;
-procedure CC51A01 is
-
- type Distance is new CC51A01_1.Pos_Fraction; -- Derived indirectly from
- -- root type of class.
- -- Inherits "/" indirectly from root type.
- -- Inherits "-" indirectly from root type.
- -- Inherits Numerator directly from parent type.
- -- Inherits Denominator indirectly from root type.
-
- use FC51A00, CC51A01_1; -- All primitive subprograms
- -- directly visible.
-
- package Fraction_IO is new CC51A01_0 (Fraction_Type);
- package Pos_Fraction_IO is new CC51A01_0 (Pos_Fraction);
- package Distance_IO is new CC51A01_0 (Distance);
-
- -- For each of the instances above, the subprogram "Put" should produce
- -- the same result. That is, the primitive subprograms called by Put
- -- should in all cases be those of the type Fraction_Type, which is the
- -- ancestor type for the formal derived type in the generic unit. In
- -- particular, for Pos_Fraction_IO and Distance_IO, the versions of
- -- Numerator called should NOT be those of the actual types, which override
- -- Fraction_Type's version.
-
- TC_Expected_Result : constant String := "-3/ 16";
-
- TC_Root_Type_Of_Class : Fraction_Type := -3/16;
- TC_Direct_Derivative : Pos_Fraction := -3/16;
- TC_Indirect_Derivative : Distance := -3/16;
-
-begin
- Report.Test ("CC51A01", "Check that, in an instance, each implicit " &
- "declaration of a user-defined subprogram of a formal " &
- "derived record type declares a view of the corresponding " &
- "primitive subprogram of the ancestor, even if the " &
- "primitive subprogram has been overridden for the actual " &
- "type");
-
- if (Fraction_IO.Put (TC_Root_Type_Of_Class) /= TC_Expected_Result) then
- Report.Failed ("Wrong result for root type");
- end if;
-
- if (Pos_Fraction_IO.Put (TC_Direct_Derivative) /= TC_Expected_Result) then
- Report.Failed ("Wrong result for direct derivative");
- end if;
-
- if (Distance_IO.Put (TC_Indirect_Derivative) /= TC_Expected_Result) then
- Report.Failed ("Wrong result for INdirect derivative");
- end if;
-
- Report.Result;
-end CC51A01;
diff --git a/gcc/testsuite/ada/acats/tests/cc/cc51b03.a b/gcc/testsuite/ada/acats/tests/cc/cc51b03.a
deleted file mode 100644
index 0cbeeb46f63..00000000000
--- a/gcc/testsuite/ada/acats/tests/cc/cc51b03.a
+++ /dev/null
@@ -1,258 +0,0 @@
--- CC51B03.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that the attribute S'Definite, where S is an indefinite formal
--- private or derived type, returns true if the actual corresponding to
--- S is definite, and returns false otherwise.
---
--- TEST DESCRIPTION:
--- A definite subtype is any subtype which is not indefinite. An
--- indefinite subtype is either:
--- a) An unconstrained array subtype.
--- b) A subtype with unknown discriminants (this includes class-wide
--- types).
--- c) A subtype with unconstrained discriminants without defaults.
---
--- The possible forms of indefinite formal subtype are as follows:
---
--- Formal derived types:
--- X - Ancestor is an unconstrained array type
--- * - Ancestor is a discriminated record type without defaults
--- X - Ancestor is a discriminated tagged type
--- * - Ancestor type has unknown discriminants
--- - Formal type has an unknown discriminant part
--- * - Formal type has a known discriminant part
---
--- Formal private types:
--- - Formal type has an unknown discriminant part
--- * - Formal type has a known discriminant part
---
--- The formal subtypes preceded by an 'X' above are not covered, because
--- other rules prevent a definite subtype from being passed as an actual.
--- The formal subtypes preceded by an '*' above are not covered, because
--- 'Definite is less likely to be used for these formals.
---
--- The following kinds of actuals are passed to various of the formal
--- types listed above:
---
--- - Undiscriminated type
--- - Type with defaulted discriminants
--- - Type with undefaulted discriminants
--- - Class-wide type
---
--- A typical usage of S'Definite might be algorithm selection in a
--- generic I/O package, e.g., the use of fixed-length or variable-length
--- records depending on whether the actual is definite or indefinite.
--- In such situations, S'Definite would appear in if conditions or other
--- contexts requiring a boolean expression. This test checks S'Definite
--- in such usage contexts but, for brevity, omits any surrounding
--- usage code.
---
--- TEST FILES:
--- The following files comprise this test:
---
--- FC51B00.A
--- -> CC51B03.A
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
---
---!
-
-with FC51B00; -- Indefinite subtype declarations.
-package CC51B03_0 is
-
- --
- -- Formal private type cases:
- --
-
- generic
- type Formal (<>) is private; -- Formal has unknown
- package PrivateFormalUnknownDiscriminants is -- discriminant part.
- function Is_Definite return Boolean;
- end PrivateFormalUnknownDiscriminants;
-
-
- --
- -- Formal derived type cases:
- --
-
- generic
- type Formal (<>) is new FC51B00.Vector -- Formal has an unknown disc.
- with private; -- part; ancestor is tagged.
- package TaggedAncestorUnknownDiscriminants is
- function Is_Definite return Boolean;
- end TaggedAncestorUnknownDiscriminants;
-
-
-end CC51B03_0;
-
-
- --==================================================================--
-
-
-package body CC51B03_0 is
-
- package body PrivateFormalUnknownDiscriminants is
- function Is_Definite return Boolean is
- begin
- if Formal'Definite then -- Attribute used in "if"
- -- ...Execute algorithm #1... -- condition inside subprogram.
- return True;
- else
- -- ...Execute algorithm #2...
- return False;
- end if;
- end Is_Definite;
- end PrivateFormalUnknownDiscriminants;
-
-
- package body TaggedAncestorUnknownDiscriminants is
- function Is_Definite return Boolean is
- begin
- return Formal'Definite; -- Attribute used in return
- end Is_Definite; -- statement inside subprogram.
- end TaggedAncestorUnknownDiscriminants;
-
-
-end CC51B03_0;
-
-
- --==================================================================--
-
-
-with FC51B00;
-package CC51B03_1 is
-
- subtype Spin_Type is Natural range 0 .. 3;
-
- type Extended_Vector (Spin : Spin_Type) is -- Tagged type with
- new FC51B00.Vector with null record; -- discriminant (indefinite).
-
-
-end CC51B03_1;
-
-
- --==================================================================--
-
-
-with FC51B00; -- Indefinite subtype declarations.
-with CC51B03_0; -- Generic package declarations.
-with CC51B03_1;
-
-with Report;
-procedure CC51B03 is
-
- --
- -- Instances for formal private type with unknown discriminants:
- --
-
- package PrivateFormal_UndiscriminatedTaggedActual is new
- CC51B03_0.PrivateFormalUnknownDiscriminants (FC51B00.Vector);
-
- package PrivateFormal_ClassWideActual is new
- CC51B03_0.PrivateFormalUnknownDiscriminants (FC51B00.Vector'Class);
-
- package PrivateFormal_DiscriminatedTaggedActual is new
- CC51B03_0.PrivateFormalUnknownDiscriminants (FC51B00.Square_Pair);
-
- package PrivateFormal_DiscriminatedUndefaultedRecordActual is new
- CC51B03_0.PrivateFormalUnknownDiscriminants (FC51B00.Square);
-
-
- subtype Length is Natural range 0 .. 20;
- type Message (Len : Length := 0) is record -- Record type with defaulted
- Text : String (1 .. Len); -- discriminant (definite).
- end record;
-
- package PrivateFormal_DiscriminatedDefaultedRecordActual is new
- CC51B03_0.PrivateFormalUnknownDiscriminants (Message);
-
-
- --
- -- Instances for formal derived tagged type with unknown discriminants:
- --
-
- package DerivedFormal_UndiscriminatedTaggedActual is new
- CC51B03_0.TaggedAncestorUnknownDiscriminants (FC51B00.Vector);
-
- package DerivedFormal_ClassWideActual is new
- CC51B03_0.TaggedAncestorUnknownDiscriminants (FC51B00.Vector'Class);
-
- package DerivedFormal_DiscriminatedTaggedActual is new
- CC51B03_0.TaggedAncestorUnknownDiscriminants (CC51B03_1.Extended_Vector);
-
-
-begin
- Report.Test ("CC51B03", "Check that S'Definite returns true if the " &
- "actual corresponding to S is definite, and false otherwise");
-
-
- if not PrivateFormal_UndiscriminatedTaggedActual.Is_Definite then
- Report.Failed ("Formal private/unknown discriminants: wrong " &
- "result for undiscriminated tagged actual");
- end if;
-
- if PrivateFormal_ClassWideActual.Is_Definite then
- Report.Failed ("Formal private/unknown discriminants: wrong " &
- "result for class-wide actual");
- end if;
-
- if PrivateFormal_DiscriminatedTaggedActual.Is_Definite then
- Report.Failed ("Formal private/unknown discriminants: wrong " &
- "result for discriminated tagged actual");
- end if;
-
- if PrivateFormal_DiscriminatedUndefaultedRecordActual.Is_Definite then
- Report.Failed ("Formal private/unknown discriminants: wrong result " &
- "for record actual with undefaulted discriminants");
- end if;
-
- if not PrivateFormal_DiscriminatedDefaultedRecordActual.Is_Definite then
- Report.Failed ("Formal private/unknown discriminants: wrong result " &
- "for record actual with defaulted discriminants");
- end if;
-
-
- if not DerivedFormal_UndiscriminatedTaggedActual.Is_Definite then
- Report.Failed ("Formal derived/unknown discriminants: wrong result " &
- "for undiscriminated tagged actual");
- end if;
-
- if DerivedFormal_ClassWideActual.Is_Definite then
- Report.Failed ("Formal derived/unknown discriminants: wrong result " &
- "for class-wide actual");
- end if;
-
- if DerivedFormal_DiscriminatedTaggedActual.Is_Definite then
- Report.Failed ("Formal derived/unknown discriminants: wrong result " &
- "for discriminated tagged actual");
- end if;
-
-
- Report.Result;
-end CC51B03;
diff --git a/gcc/testsuite/ada/acats/tests/cc/cc51d01.a b/gcc/testsuite/ada/acats/tests/cc/cc51d01.a
deleted file mode 100644
index 63c68c0d4fc..00000000000
--- a/gcc/testsuite/ada/acats/tests/cc/cc51d01.a
+++ /dev/null
@@ -1,262 +0,0 @@
--- CC51D01.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that, in an instance, each implicit declaration of a user-defined
--- subprogram of a formal private extension declares a view of the
--- corresponding primitive subprogram of the ancestor, and that if the
--- tag in a call is statically determined to be that of the formal type,
--- the body executed will be that corresponding to the actual type.
---
--- Check subprograms declared within a generic formal package. Check for
--- the case where the actual type passed to the formal private extension
--- is a specific tagged type. Check for several types in the same class.
---
---
--- TEST DESCRIPTION:
--- Declare a list abstraction in a generic package which manages lists of
--- elements of any nonlimited type (foundation code). Declare a package
--- which declares a tagged type and a type derived from it. Declare an
--- operation for the root tagged type and override it for the derived
--- type. Derive a type from this derived type, but do not override the
--- operation. Declare a generic subprogram which operates on lists of
--- elements of tagged types. Provide the generic subprogram with two
--- formal parameters: (1) a formal derived tagged type which represents a
--- list element type, and (2) a generic formal package with the list
--- abstraction package as template. Use the formal derived type as the
--- generic formal actual part for the formal package. Within the generic
--- subprogram, call the operation of the root tagged type. In the main
--- program, instantiate the generic list package and the generic
--- subprogram with the root tagged type and each derivative, then call
--- each instance with an object of the appropriate type.
---
--- TEST FILES:
--- The following files comprise this test:
---
--- FC51D00.A
--- -> CC51D01.A
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 04 Jan 95 SAIC Moved declaration of type Ranked_ID_Type from
--- main subprogram to package CC51D01_0. Removed
--- case passing class-wide actual to instance.
--- Updated test description and modified comments.
---
---!
-
-package CC51D01_0 is -- This package simulates support for a personnel
- -- database.
-
- type SSN_Type is new String (1 .. 9);
-
- type Blind_ID_Type is tagged record -- Root type of
- SSN : SSN_Type; -- class.
- -- ... Other components.
- end record;
-
- procedure Update_ID (Item : in out Blind_ID_Type); -- Parent operation.
-
- -- ... Other operations.
-
-
- type Name_Type is new String (1 .. 9);
-
- type Named_ID_Type is new Blind_ID_Type with record -- Direct derivative
- Name : Name_Type := "Doe "; -- of root type.
- -- ... Other components.
- end record;
-
- -- Inherits Update_ID from parent.
-
- procedure Update_ID (Item : in out Named_ID_Type); -- Overrides parent's
- -- implementation.
-
-
- type Ranked_ID_Type is new Named_ID_Type with record
- Level : Integer := 0; -- Indirect derivative
- -- ... Other components. -- of root type.
- end record;
-
- -- Inherits Update_ID from parent.
-
-end CC51D01_0;
-
-
- --==================================================================--
-
-
-package body CC51D01_0 is
-
- -- The implementations of Update_ID are purely artificial; the validity of
- -- their implementations in the context of the abstraction is irrelevant to
- -- the feature being tested.
-
- procedure Update_ID (Item : in out Blind_ID_Type) is
- begin
- Item.SSN := "111223333";
- end Update_ID;
-
-
- procedure Update_ID (Item : in out Named_ID_Type) is
- begin
- Item.SSN := "444556666";
- -- ... Other stuff.
- end Update_ID;
-
-end CC51D01_0;
-
-
- --==================================================================--
-
-
--- --
--- Formal package used here. --
--- --
-
-with FC51D00; -- Generic list abstraction.
-with CC51D01_0; -- Tagged type declarations.
-generic -- This procedure simulates a generic operation for types
- -- in the class rooted at Blind_ID_Type.
- type Elem_Type is new CC51D01_0.Blind_ID_Type with private;
- with package List_Mgr is new FC51D00 (Elem_Type);
-procedure CC51D01_1 (L : in out List_Mgr.List_Type; E : in Elem_Type);
-
-
- --==================================================================--
-
-
--- The implementation of CC51D01_1 is purely artificial; the validity
--- of its implementation in the context of the abstraction is irrelevant
--- to the feature being tested.
---
--- The expected behavior here is as follows: for each actual type corresponding
--- to Elem_Type, the call to Update_ID should invoke the actual type's
--- implementation, which updates the object's SSN field. Write_Element then
--- adds the object to the list.
-
-procedure CC51D01_1 (L : in out List_Mgr.List_Type; E : in Elem_Type) is
- Element : Elem_Type := E; -- Can't update IN parameter.
-begin
- Update_ID (Element); -- Executes actual type's version.
- List_Mgr.Write_Element (1, L, Element); -- Executes actual type's version.
-end CC51D01_1;
-
-
- --==================================================================--
-
-
-with FC51D00; -- Generic list abstraction.
-with CC51D01_0; -- Tagged type declarations.
-with CC51D01_1; -- Generic operation.
-
-with Report;
-procedure CC51D01 is
-
- use CC51D01_0; -- All types & ops
- -- directly visible.
-
- -- Begin test code declarations: -----------------------
-
- TC_Expected_1 : Blind_ID_Type := (SSN => "111223333");
- TC_Expected_2 : Named_ID_Type := ("444556666", "Doe ");
- TC_Expected_3 : Ranked_ID_Type := ("444556666", "Doe ", 0);
-
- TC_Initial_1 : Blind_ID_Type := (SSN => "777889999");
- TC_Initial_2 : Named_ID_Type := ("777889999", "Doe ");
- TC_Initial_3 : Ranked_ID_Type := ("777889999", "Doe ", 0);
-
- -- End test code declarations. -------------------------
-
-
- -- Begin instantiations and list declarations: ---------
-
- -- At this point in an application, the generic list package would be
- -- instantiated for one of the visible tagged types. Next, the generic
- -- subprogram would be instantiated for the same tagged type and the
- -- preceding list package instance.
- --
- -- In order to cover all the important cases, this test instantiates several
- -- packages and subprograms (probably more than would typically appear
- -- in user code).
-
- -- Support for lists of blind IDs:
-
- package Blind_Lists is new FC51D00 (Blind_ID_Type);
- procedure Update_and_Write is new CC51D01_1 (Blind_ID_Type, Blind_Lists);
- Blind_List : Blind_Lists.List_Type;
-
-
- -- Support for lists of named IDs:
-
- package Named_Lists is new FC51D00 (Named_ID_Type);
- procedure Update_and_Write is new -- Overloads subprog
- CC51D01_1 (Elem_Type => Named_ID_Type, -- for Blind_ID_Type.
- List_Mgr => Named_Lists);
- Named_List : Named_Lists.List_Type;
-
-
- -- Support for lists of ranked IDs:
-
- package Ranked_Lists is new FC51D00 (Ranked_ID_Type);
- procedure Update_and_Write is new -- Overloads.
- CC51D01_1 (Elem_Type => Ranked_ID_Type,
- List_Mgr => Ranked_Lists);
- Ranked_List : Ranked_Lists.List_Type;
-
- -- End instantiations and list declarations. -----------
-
-
-begin
- Report.Test ("CC51D01", "Formal private extension, specific tagged " &
- "type actual: body of primitive subprogram executed is " &
- "that of actual type. Check for subprograms declared in " &
- "a formal package");
-
-
- Update_and_Write (Blind_List, TC_Initial_1);
-
- if (Blind_Lists.View_Element (1, Blind_List) /= TC_Expected_1) then
- Report.Failed ("Wrong result for root tagged type");
- end if;
-
-
- Update_and_Write (Named_List, TC_Initial_2);
-
- if (Named_Lists.View_Element (1, Named_List) /= TC_Expected_2) then
- Report.Failed ("Wrong result for type derived directly from root");
- end if;
-
-
- Update_and_Write (Ranked_List, TC_Initial_3);
-
- if (Ranked_Lists.View_Element (1, Ranked_List) /= TC_Expected_3) then
- Report.Failed ("Wrong result for type derived indirectly from root");
- end if;
-
-
- Report.Result;
-end CC51D01;
diff --git a/gcc/testsuite/ada/acats/tests/cc/cc51d02.a b/gcc/testsuite/ada/acats/tests/cc/cc51d02.a
deleted file mode 100644
index 52055639179..00000000000
--- a/gcc/testsuite/ada/acats/tests/cc/cc51d02.a
+++ /dev/null
@@ -1,244 +0,0 @@
--- CC51D02.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that, in an instance, each implicit declaration of a user-defined
--- subprogram of a formal private extension declares a view of the
--- corresponding primitive subprogram of the ancestor, and that if the
--- tag in a call is statically determined to be that of the formal type,
--- the body executed will be that corresponding to the actual type.
---
--- Check subprograms declared within a generic formal package. Check for
--- the case where the actual type passed to the formal private extension
--- is a class-wide type. Check for several types in the same class.
---
---
--- TEST DESCRIPTION:
--- Declare a list abstraction in a generic package which manages lists of
--- elements of any nonlimited type (foundation code). Declare a package
--- which declares a tagged type and a derivative. Declare an operation
--- for the root tagged type and override it for the derivative. Declare
--- a generic subprogram which operates on lists of elements of tagged
--- types. Provide the generic subprogram with two formal parameters: (1)
--- a formal derived tagged type which represents a list element type, and
--- (2) a generic formal package with the list abstraction package as
--- template. Use the formal derived type as the generic formal actual
--- part for the formal package. Within the generic subprogram, call the
--- operation of the root tagged type. In the main program, instantiate
--- the generic list package and the generic subprogram with the class-wide
--- type for the root tagged type.
---
--- TEST FILES:
--- The following files comprise this test:
---
--- FC51D00.A
--- -> CC51D02.A
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 05 Jan 95 SAIC Changed types of TC_Expected_1 and TC_Expected_2
--- from specific to class-wide. Eliminated (illegal)
--- assignment step prior to comparison of
--- TC_Expected_X with item on stack.
---
---!
-
-package CC51D02_0 is -- This package simulates support for a personnel
- -- database.
-
- type SSN_Type is new String (1 .. 9);
-
- type Blind_ID_Type is tagged record -- Root type of
- SSN : SSN_Type; -- class.
- -- ... Other components.
- end record;
-
- procedure Update_ID (Item : in out Blind_ID_Type); -- Parent operation.
-
- -- ... Other operations.
-
-
- type Name_Type is new String (1 .. 9);
-
- type Named_ID_Type is new Blind_ID_Type with record -- Direct derivative
- Name : Name_Type := "Doe "; -- of root type.
- -- ... Other components.
- end record;
-
- -- Inherits Update_ID from parent.
-
- procedure Update_ID (Item : in out Named_ID_Type); -- Overrides parent's
- -- implementation.
-
-end CC51D02_0;
-
-
- --==================================================================--
-
-
-package body CC51D02_0 is
-
- -- The implementations of Update_ID are purely artificial; the validity of
- -- their implementations in the context of the abstraction is irrelevant to
- -- the feature being tested.
-
- procedure Update_ID (Item : in out Blind_ID_Type) is
- begin
- Item.SSN := "111223333";
- end Update_ID;
-
-
- procedure Update_ID (Item : in out Named_ID_Type) is
- begin
- Item.SSN := "444556666";
- -- ... Other stuff.
- end Update_ID;
-
-end CC51D02_0;
-
-
- --==================================================================--
-
-
--- --
--- Formal package used here. --
--- --
-
-with FC51D00; -- Generic list abstraction.
-with CC51D02_0; -- Tagged type declarations.
-generic -- This procedure simulates a generic operation for types
- -- in the class rooted at Blind_ID_Type.
- type Elem_Type (<>) is new CC51D02_0.Blind_ID_Type with private;
- with package List_Mgr is new FC51D00 (Elem_Type);
-procedure CC51D02_1 (L : in out List_Mgr.List_Type; E : in Elem_Type);
-
-
- --==================================================================--
-
-
--- The implementation of CC51D02_1 is purely artificial; the validity
--- of its implementation in the context of the abstraction is irrelevant
--- to the feature being tested.
---
--- The expected behavior here is as follows: for each actual type corresponding
--- to Elem_Type, the call to Update_ID should invoke the actual type's
--- implementation (based on the tag of the actual), which updates the object's
--- SSN field. Write_Element then adds the object to the list.
-
-procedure CC51D02_1 (L : in out List_Mgr.List_Type; E : in Elem_Type) is
- Element : Elem_Type := E; -- Can't update IN parameter.
- -- Initialization of unconstrained variable.
-begin
- Update_ID (Element); -- Executes actual type's version
- -- (for this test, this will be a
- -- dispatching call).
- List_Mgr.Write_Element (1, L, Element); -- Executes actual type's version
- -- (for this test, this will be a
- -- class-wide operation).
-end CC51D02_1;
-
-
- --==================================================================--
-
-
-with FC51D00; -- Generic list abstraction.
-with CC51D02_0; -- Tagged type declarations.
-with CC51D02_1; -- Generic operation.
-
-with Report;
-procedure CC51D02 is
-
- use CC51D02_0; -- All types & ops
- -- directly visible.
-
- -- Begin test code declarations: -----------------------
-
- TC_Expected_1 : Blind_ID_Type'Class :=
- Blind_ID_Type'(SSN => "111223333");
- TC_Expected_2 : Blind_ID_Type'Class :=
- Named_ID_Type'("444556666", "Doe ");
-
-
- TC_Initial_1 : Blind_ID_Type := (SSN => "777889999");
- TC_Initial_2 : Named_ID_Type := ("777889999", "Doe ");
- TC_Initial_3 : Blind_ID_Type'Class := TC_Initial_2;
-
- -- End test code declarations. -------------------------
-
-
- package ID_Class_Lists is new FC51D00 (Blind_ID_Type'Class);
-
- procedure Update_and_Write is new CC51D02_1 (Blind_ID_Type'Class,
- ID_Class_Lists);
-
- Blind_List : ID_Class_Lists.List_Type;
- Named_List : ID_Class_Lists.List_Type;
- Maimed_List : ID_Class_Lists.List_Type;
-
-
-begin
- Report.Test ("CC51D02", "Formal private extension, class-wide actual: " &
- "body of primitive subprogram executed is that of actual " &
- "type. Check for subprograms declared in formal package");
-
-
- Update_and_Write (Blind_List, TC_Initial_1); -- Test root type actual.
-
- if (ID_Class_Lists.View_Element (1, Blind_List) not in Blind_ID_Type) then
- Report.Failed ("Result for root type actual is not in proper class");
- elsif (ID_Class_Lists.View_Element (1, Blind_List) /= TC_Expected_1) then
- Report.Failed ("Wrong result for root type actual");
- end if;
-
-
- Update_and_Write (Named_List, TC_Initial_2); -- Test derived type actual.
-
- if (ID_Class_Lists.View_Element (1, Named_List) not in Named_ID_Type) then
- Report.Failed ("Result for derived type actual is not in proper class");
- elsif (ID_Class_Lists.View_Element (1, Named_List)/= TC_Expected_2) then
- Report.Failed ("Wrong result for derived type actual");
- end if;
-
-
- -- In the subtest below, an object of a class-wide type (TC_Initial_3) is
- -- passed to Update_and_Write. It has been initialized with an object of
- -- type Named_ID_Type, so the result should be identical to
- -- that of the Named_ID_Type subtest (namely TC_Expected_2). Note that
- -- a new list of Named IDs is used (Maimed_List). This is to assure test
- -- validity, since Named_List has already been updated by a previous
- -- subtest.
-
- Update_and_Write (Maimed_List, TC_Initial_3); -- Test class-wide actual.
-
- if (ID_Class_Lists.View_Element (1, Maimed_List) not in Named_ID_Type) then
- Report.Failed ("Result for class-wide actual is not in proper class");
- elsif (ID_Class_Lists.View_Element (1, Maimed_List) /= TC_Expected_2) then
- Report.Failed ("Wrong result for class-wide actual");
- end if;
-
-
- Report.Result;
-end CC51D02;
diff --git a/gcc/testsuite/ada/acats/tests/cc/cc54001.a b/gcc/testsuite/ada/acats/tests/cc/cc54001.a
deleted file mode 100644
index eb297d0ecdc..00000000000
--- a/gcc/testsuite/ada/acats/tests/cc/cc54001.a
+++ /dev/null
@@ -1,184 +0,0 @@
--- CC54001.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that a general access-to-constant type may be passed as an
--- actual to a generic formal access-to-constant type.
---
--- TEST DESCRIPTION:
--- The generic implements a stack of access objects as an array. The
--- designated type of the formal access type is itself a formal private
--- type declared in the same generic formal part.
---
--- The generic is instantiated with an unconstrained subtype of String,
--- which results in a stack which can accommodate strings of varying
--- lengths (ragged array). Furthermore, the access objects to be pushed
--- onto the stack are created both statically and dynamically, utilizing
--- allocators and the 'Access attribute.
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 10 Apr 96 SAIC ACVC 2.1: Added pragma Elaborate to context clause
--- preceding CC54001_1.
---
---!
-
-generic
- Size : in Positive;
- type Element_Type (<>) is private;
- type Element_Ptr is access constant Element_Type;
-package CC54001_0 is -- Generic stack of pointers.
-
- type Stack_Type is private;
-
- procedure Push (Stack : in out Stack_Type;
- Elem_Ptr : in Element_Ptr);
-
- procedure Pop (Stack : in out Stack_Type;
- Elem_Ptr : out Element_Ptr);
-
- -- ... Other operations.
-
-private
-
- subtype Index is Positive range 1 .. (Size + 1);
- type Stack_Type is array (Index) of Element_Ptr; -- Last element unused.
-
- Top : Index := 1;
-
-end CC54001_0;
-
-
- --===================================================================--
-
-
-package body CC54001_0 is
-
- procedure Push (Stack : in out Stack_Type;
- Elem_Ptr : in Element_Ptr) is
- begin
- Stack(Top) := Elem_Ptr;
- Top := Top + 1; -- Artificial: no Constraint_Error protection.
- end Push;
-
-
- procedure Pop (Stack : in out Stack_Type;
- Elem_Ptr : out Element_Ptr) is
- begin
- Top := Top - 1; -- Artificial: no Constraint_Error protection.
- Elem_Ptr := Stack(Top);
- end Pop;
-
-end CC54001_0;
-
-
- --===================================================================--
-
-
-with CC54001_0; -- Generic stack of pointers.
-pragma Elaborate (CC54001_0);
-
-package CC54001_1 is
-
- subtype Message is String;
- type Message_Ptr is access constant Message;
-
- Message_Count : constant := 4;
-
- Message_0 : aliased constant Message := "Hello";
- Message_1 : aliased constant Message := "Doctor";
- Message_2 : aliased constant Message := "Name";
- Message_3 : aliased constant Message := "Continue";
-
-
- package Stack_of_Messages is new CC54001_0
- (Element_Type => Message,
- Element_Ptr => Message_Ptr,
- Size => Message_Count);
-
- Message_Stack : Stack_Of_Messages.Stack_Type;
-
-
- procedure Create_Message_Stack;
-
-end CC54001_1;
-
-
- --===================================================================--
-
-
-package body CC54001_1 is
-
- procedure Create_Message_Stack is
- -- Push access objects onto stack. Note that some are statically
- -- allocated, and some are dynamically allocated (using an aliased
- -- object to initialize).
- begin
- Stack_Of_Messages.Push (Message_Stack, Message_0'Access); -- Static.
- Stack_Of_Messages.Push (Message_Stack,
- new Message'(Message_1)); -- Dynamic.
- Stack_Of_Messages.Push (Message_Stack, Message_2'Access); -- Static.
- Stack_Of_Messages.Push (Message_Stack, -- Dynamic.
- new Message'(Message_3));
- end Create_Message_Stack;
-
-end CC54001_1;
-
-
- --===================================================================--
-
-
-with CC54001_1;
-
-with Report;
-procedure CC54001 is
-
- package Messages renames CC54001_1.Stack_Of_Messages;
-
- Msg0, Msg1, Msg2, Msg3 : CC54001_1.Message_Ptr;
-
-begin
- Report.Test ("CC54001", "Check that a general access-to-constant type " &
- "may be passed as an actual to a generic formal " &
- "access-to-constant type");
-
- CC54001_1.Create_Message_Stack;
-
- Messages.Pop (CC54001_1.Message_Stack, Msg3); -- Pop items off stack in the
- Messages.Pop (CC54001_1.Message_Stack, Msg2); -- reverse order that they
- Messages.Pop (CC54001_1.Message_Stack, Msg1); -- were pushed.
- Messages.Pop (CC54001_1.Message_Stack, Msg0);
-
- if Msg0.all /= CC54001_1.Message_0 or else
- Msg1.all /= CC54001_1.Message_1 or else
- Msg2.all /= CC54001_1.Message_2 or else
- Msg3.all /= CC54001_1.Message_3
- then
- Report.Failed ("Items popped off of stack do not match those pushed");
- end if;
-
- Report.Result;
-end CC54001;
diff --git a/gcc/testsuite/ada/acats/tests/cc/cc54002.a b/gcc/testsuite/ada/acats/tests/cc/cc54002.a
deleted file mode 100644
index 623f25d6c86..00000000000
--- a/gcc/testsuite/ada/acats/tests/cc/cc54002.a
+++ /dev/null
@@ -1,223 +0,0 @@
--- CC54002.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that a general access-to-variable type may be passed as an
--- actual to a generic formal general access-to-variable type. Check that
--- designated objects may be read and updated through the access value.
---
--- TEST DESCRIPTION:
--- The generic implements a List of access objects as an array, which
--- is itself a component of a record. The designated type of the formal
--- access type is a formal private type declared in the same generic
--- formal part.
---
--- The access objects to be placed in the List are created both
--- statically and dynamically, utilizing allocators and the 'Access
--- attribute.
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 10 Apr 96 SAIC ACVC 2.1: Added pragma Elaborate to context clause
--- preceding CC54002_1.
---
---!
-
-generic
- Size : in Positive;
- type Element_Type (<>) is private;
- type Element_Ptr is access all Element_Type;
-package CC54002_0 is -- Generic list of pointers.
-
- subtype Index is Positive range 1 .. (Size + 1);
-
- type List_Array is array (Index) of Element_Ptr;
-
- type List_Type is record
- Elements : List_Array;
- Next : Index := 1; -- Next available "slot" in list.
- end record;
-
-
- procedure Put (List : in out List_Type;
- Elem_Ptr : in Element_Ptr;
- Location : in Index);
-
- procedure Get (List : in out List_Type;
- Elem_Ptr : out Element_Ptr;
- Location : in Index);
-
- -- ... Other operations.
-
-end CC54002_0;
-
-
- --===================================================================--
-
-
-package body CC54002_0 is
-
- procedure Put (List : in out List_Type;
- Elem_Ptr : in Element_Ptr;
- Location : in Index) is
- begin
- List.Elements(Location) := Elem_Ptr;
- end Put;
-
-
- procedure Get (List : in out List_Type;
- Elem_Ptr : out Element_Ptr;
- Location : in Index) is
- begin -- Artificial: no provision for getting "empty" element.
- Elem_Ptr := List.Elements(Location);
- end Get;
-
-end CC54002_0;
-
-
- --===================================================================--
-
-
-with CC54002_0; -- Generic List of pointers.
-pragma Elaborate (CC54002_0);
-
-package CC54002_1 is
-
- subtype Lengths is Natural range 0 .. 50;
-
- type Subscriber (NLen, ALen: Lengths := 50) is record
- Name : String(1 .. NLen);
- Address : String(1 .. ALen);
- -- ... Other components.
- end record;
-
- type Subscriber_Ptr is access all Subscriber; -- General access-to-
- -- variable type.
-
- package District_Subscription_Lists is new CC54002_0
- (Element_Type => Subscriber,
- Element_Ptr => Subscriber_Ptr,
- Size => 100);
-
- District_01_Subscribers : District_Subscription_Lists.List_Type;
-
-
- New_Subscriber_01 : aliased CC54002_1.Subscriber :=
- (12, 23, "Brown, Silas", "King's Pyland, Dartmoor");
-
- New_Subscriber_02 : aliased CC54002_1.Subscriber :=
- (16, 23, "Hatherly, Victor", "16A Victoria St. London");
-
-end CC54002_1;
-
--- No body for CC54002_1.
-
-
- --===================================================================--
-
-
-with CC54002_1;
-
-with Report;
-procedure CC54002 is
-
- Mod_Subscriber_01 : constant CC54002_1.Subscriber :=
- (12, 23, "Brown, Silas", "Mapleton, Dartmoor ");
-
- TC_Actual_01, TC_Actual_02 : CC54002_1.Subscriber_Ptr;
-
-
- use type CC54002_1.Subscriber; -- "/=" directly visible.
-
-begin
- Report.Test ("CC54002", "Check that a general access-to-variable type " &
- "may be passed as an actual to a generic formal " &
- "access-to-variable type");
-
-
- -- Add elements to the list:
-
- CC54002_1.District_Subscription_Lists.Put -- Element created statically.
- (List => CC54002_1.District_01_Subscribers,
- Elem_Ptr => CC54002_1.New_Subscriber_01'Access,
- Location => 1);
-
- CC54002_1.District_Subscription_Lists.Put -- Element created dynamically.
- (List => CC54002_1.District_01_Subscribers,
- Elem_Ptr => new CC54002_1.Subscriber'(CC54002_1.New_Subscriber_02),
- Location => 2);
-
-
- -- Manipulation of the objects on the list is performed below directly
- -- through the access objects. Although such manipulation is artificial
- -- from the perspective of this usage model, it is not artificial in
- -- general and is necessary in order to test the objective.
-
-
- -- Modify the first list element through the access object:
-
- CC54002_1.District_01_Subscribers.Elements(1).Address := -- Update
- "Mapleton, Dartmoor "; -- Implicit dereference. -- through the
- -- access
- -- object.
- -- Retrieve elements of the list:
-
- CC54002_1.District_Subscription_Lists.Get
- (CC54002_1.District_01_Subscribers,
- TC_Actual_01,
- 1);
-
- CC54002_1.District_Subscription_Lists.Get
- (CC54002_1.District_01_Subscribers,
- TC_Actual_02,
- 2);
-
- -- Verify list contents in two ways: 1st verify the directly-dereferenced
- -- access objects against the dereferenced access objects returned by Get;
- -- 2nd verify them against objects the expected values:
-
- -- Read
- -- through the
- -- access
- -- objects.
-
- if CC54002_1.District_01_Subscribers.Elements(1).all /= TC_Actual_01.all
- or else
- CC54002_1.District_01_Subscribers.Elements(2).all /= TC_Actual_02.all
- then
- Report.Failed ("Wrong results returned by Get");
-
- elsif CC54002_1.District_01_Subscribers.Elements(1).all /=
- Mod_Subscriber_01
- or
- CC54002_1.District_01_Subscribers.Elements(2).all /=
- CC54002_1.New_Subscriber_02
- then
- Report.Failed ("List elements do not have expected values");
- end if;
-
- Report.Result;
-end CC54002;
diff --git a/gcc/testsuite/ada/acats/tests/cc/cc54003.a b/gcc/testsuite/ada/acats/tests/cc/cc54003.a
deleted file mode 100644
index d8aaeaf9c81..00000000000
--- a/gcc/testsuite/ada/acats/tests/cc/cc54003.a
+++ /dev/null
@@ -1,234 +0,0 @@
--- CC54003.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that a general access-to-subprogram type may be passed as an
--- actual to a generic formal access-to-subprogram type. Check that
--- designated subprograms may be called by dereferencing the access
--- values.
---
--- TEST DESCRIPTION:
--- The generic implements a stack of access-to-subprogram objects as an
--- array. The profile of the access-to-subprogram formal corresponds to
--- a function which accepts a parameter of some type and returns an
--- object of the same type.
---
--- For this test, the functions for which access values will be pushed
--- onto the stack accept a parameter of type access-to-string, lengthen
--- the pointed-to string, then return an access object pointing to this
--- lengthened string.
---
--- The instance declares a function Execute_Stack which executes each
--- subprogram on the stack in sequence. This function accepts some initial
--- access-to-string, then returns an access object pointing to the
--- lengthened string resulting from the execution of the stacked
--- subprograms. Access-to-string objects are used rather than strings
--- themselves because the initial string "grows" during each iteration.
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 10 Apr 96 SAIC ACVC 2.1: Added pragma Elaborate to context clause
--- preceding CC54003_2.
---
---!
-
-generic
-
- Size : in Positive;
-
- type Item_Type (<>) is private;
- type Item_Ptr is access Item_Type;
-
- type Function_Ptr is access function (Item : Item_Ptr)
- return Item_Ptr;
-
-package CC54003_0 is -- Generic stack of pointers.
-
- type Stack_Type is private;
-
- procedure Push (Stack : in out Stack_Type;
- Func_Ptr : in Function_Ptr);
-
- function Execute_Stack (Stack : Stack_Type;
- Initial_Input : Item_Ptr) return Item_Ptr;
-
- -- ... Other operations.
-
-private
-
- subtype Index is Positive range 1 .. (Size + 1);
- type Stack_Type is array (Index) of Function_Ptr; -- Last slot unused.
-
- Top : Index := 1; -- Top refers to the next available slot.
-
-end CC54003_0;
-
-
- --===================================================================--
-
-
-package body CC54003_0 is
-
- procedure Push (Stack : in out Stack_Type;
- Func_Ptr : in Function_Ptr) is
- begin
- Stack(Top) := Func_Ptr;
- Top := Top + 1; -- Artificial: no Constraint_Error protection.
- end Push;
-
-
- -- Call each subprogram on the stack in sequence. For the first call, pass
- -- Initial_Input. For succeeding calls, pass the result of the previous
- -- call.
-
- function Execute_Stack (Stack : Stack_Type;
- Initial_Input : Item_Ptr) return Item_Ptr is
- Result : Item_Ptr := Initial_Input;
- begin
- for I in reverse Index'First .. (Top - 1) loop -- Artificial: no C_E
- Result := Stack(I)(Result); -- protection.
- end loop;
- return Result;
- end Execute_Stack;
-
-end CC54003_0;
-
-
- --===================================================================--
-
-
-package CC54003_1 is
-
- subtype Message is String;
- type Message_Ptr is access Message;
-
- function Add_Prefix (Msg_Ptr : Message_Ptr) return Message_Ptr;
- function Add_Suffix (Msg_Ptr : Message_Ptr) return Message_Ptr;
-
- -- ...Other operations.
-
-end CC54003_1;
-
-
- --===================================================================--
-
-
-package body CC54003_1 is
-
- function Add_Prefix (Msg_Ptr : Message_Ptr) return Message_Ptr is
- Sender : constant String := "Dummy: "; -- Artificial; in a real
- -- application Sender might
- New_Msg : Message := Sender & Msg_Ptr.all; -- be a call to a function.
- begin
- return new Message'(New_Msg);
- end Add_Prefix;
-
-
- function Add_Suffix (Msg_Ptr : Message_Ptr) return Message_Ptr is
- Time : constant String := " (12:03pm)"; -- Artificial; in a real
- -- application Time might be a
- New_Msg : Message := Msg_Ptr.all & Time; -- be a call to a function.
- begin
- return new Message'(New_Msg);
- end Add_Suffix;
-
-end CC54003_1;
-
-
- --===================================================================--
-
-
-with CC54003_0; -- Generic stack of pointers.
-pragma Elaborate (CC54003_0);
-
-with CC54003_1; -- Message abstraction.
-
-package CC54003_2 is
-
- type Operation_Ptr is access function (Msg_Ptr : CC54003_1.Message_Ptr)
- return CC54003_1.Message_Ptr;
-
- Maximum_Ops : constant := 4; -- Arbitrary.
-
- package Stack_of_Ops is new CC54003_0
- (Item_Type => CC54003_1.Message,
- Item_Ptr => CC54003_1.Message_Ptr,
- Function_Ptr => Operation_Ptr,
- Size => Maximum_Ops);
-
- Operation_Stack : Stack_Of_Ops.Stack_Type;
-
-
- procedure Create_Operation_Stack;
-
-end CC54003_2;
-
- --===================================================================--
-
-
-package body CC54003_2 is
-
- procedure Create_Operation_Stack is
- begin
- Stack_Of_Ops.Push (Operation_Stack, CC54003_1.Add_Prefix'Access);
- Stack_Of_Ops.Push (Operation_Stack, CC54003_1.Add_Suffix'Access);
- end Create_Operation_Stack;
-
-end CC54003_2;
-
-
- --===================================================================--
-
-
-with CC54003_1; -- Message abstraction.
-with CC54003_2; -- Message-operation stack.
-
-with Report;
-procedure CC54003 is
-
- package Msg_Ops renames CC54003_2.Stack_Of_Ops;
-
- Msg : CC54003_1.Message_Ptr := new CC54003_1.Message'("Hello there");
- Expected : CC54003_1.Message := "Dummy: Hello there (12:03pm)";
-
-begin
- Report.Test ("CC54003", "Check that a general access-to-subprogram type " &
- "may be passed as an actual to a generic formal " &
- "access-to-subprogram type");
-
- CC54003_2.Create_Operation_Stack;
-
- declare
- Actual : CC54003_1.Message_Ptr :=
- Msg_Ops.Execute_Stack (CC54003_2.Operation_Stack, Msg);
- begin
- if Actual.all /= Expected then
- Report.Failed ("Wrong result from dereferenced subprogram execution");
- end if;
- end;
-
- Report.Result;
-end CC54003;
diff --git a/gcc/testsuite/ada/acats/tests/cc/cc54004.a b/gcc/testsuite/ada/acats/tests/cc/cc54004.a
deleted file mode 100644
index 0023b3a7461..00000000000
--- a/gcc/testsuite/ada/acats/tests/cc/cc54004.a
+++ /dev/null
@@ -1,295 +0,0 @@
--- CC54004.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that the designated type of a generic formal pool-specific
--- access type may be class-wide. Check that calls to primitive
--- subprograms in the instance dispatch to the appropriate bodies when
--- the controlling operand is a dereference of an object of the access-
--- to-class-wide type.
---
--- TEST DESCRIPTION:
--- A hierarchy of types is declared in two packages. The root type of
--- the class is declared as abstract in a separate package. It possesses
--- an abstract primitive subprogram Handle. A concrete type extends the
--- root type in a second package with a component of an enumeration type.
--- A second type extends this extension in the same package. Both
--- derivatives override the root type's primitive subprogram with a
--- non-abstract subprogram.
---
--- The generic implements a heterogeneous stack of access-to-class-wide
--- objects in the root type's class. A subprogram declared in the
--- generic calls Handle using dereferences of each of the class-wide
--- objects on the stack as operand. Each call to Handle should dispatch
--- to the appropriate body based on the tag of the operand. The
--- overriding versions of Handle each set the component of the type to
--- a different value. The value of the component is checked to verify
--- that the calls dispatched correctly.
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 10 Apr 96 SAIC ACVC 2.1: Added pragma Elaborate to context clause
--- preceding CC54004_3.
---
---!
-
-package CC54004_0 is
-
- -- The types and operations defined here are artificial. The component
- -- TC_Code is the only component required for testing purposes.
-
- type TC_Code_Type is (None, Low, Medium);
-
- type Alert is abstract tagged record -- Abstract type.
- TC_Code : TC_Code_Type; -- Testing flag.
- end record;
-
- procedure Handle (A : in out Alert); -- Non-abstract primitive
- -- subprogram.
- -- ...Other operations.
-
- type Alert_Ptr is access Alert'Class; -- Access-to-class-wide
- -- type.
-end CC54004_0;
-
-
- --===================================================================--
-
-
-package body CC54004_0 is
-
- procedure Handle (A : in out Alert) is
- begin
- A.TC_Code := None;
- end Handle;
-
-end CC54004_0;
-
-
- --===================================================================--
-
-
-with CC54004_0;
-use CC54004_0;
-package CC54004_1 is
-
- type Low_Alert is new CC54004_0.Alert with record
- C1 : String (1 .. 5) := "Dummy";
- -- ...Other components.
- end record;
-
- procedure Handle (A : in out Low_Alert); -- Overrides parent's
- -- operations.
- --...Other operations.
-
-
- type Medium_Alert is new Low_Alert with record
- C : Integer := 6;
- -- ...Other components.
- end record;
-
- procedure Handle (A : in out Medium_Alert); -- Overrides parent's
- -- operations.
- --...Other operations.
-
-end CC54004_1;
-
-
- --===================================================================--
-
-package body CC54004_1 is
-
- procedure Handle (A : in out Low_Alert) is
- begin
- A.TC_Code := Low;
- end Handle;
-
- procedure Handle (A : in out Medium_Alert) is
- begin
- A.TC_Code := Medium;
- end Handle;
-
-end CC54004_1;
-
-
- --===================================================================--
-
-
-with CC54004_0;
-generic
- type Element_Type is abstract new CC54004_0.Alert with private;
- type Element_Ptr is access Element_Type'Class;
-package CC54004_2 is
-
- type Stack_Type is private;
-
- procedure Push (Stack : in out Stack_Type;
- Elem_Ptr : in Element_Ptr);
-
- procedure Pop (Stack : in out Stack_Type;
- Elem_Ptr : out Element_Ptr);
-
- procedure Process_Stack (Stack : in out Stack_Type);
-
- -- ... Other operations.
-
-private
-
- subtype Index is Positive range 1 .. 5;
- type Stack_Type is array (Index) of Element_Ptr;
-
- Top : Index := 1;
-
-end CC54004_2;
-
-
- --===================================================================--
-
-
-package body CC54004_2 is
-
- procedure Push (Stack : in out Stack_Type;
- Elem_Ptr : in Element_Ptr) is
- begin
- Stack(Top) := Elem_Ptr;
- Top := Top + 1; -- Artificial: no Constraint_Error protection.
- end Push;
-
-
- procedure Pop (Stack : in out Stack_Type;
- Elem_Ptr : out Element_Ptr)is
- begin
- Top := Top - 1; -- Artificial: no Constraint_Error protection.
- Elem_Ptr := Stack(Top);
- end Pop;
-
-
- -- Call Handle for each element on the stack. Since the dereferenced access
- -- object is of a class-wide type, all calls to Handle are dispatching. The
- -- version of Handle called will be that declared for the type
- -- corresponding to the tag of the operand.
-
- procedure Process_Stack (Stack : in out Stack_Type) is
- begin -- Artificial: no Constraint_Error protection.
- for I in reverse Index'First .. (Top - 1) loop
- Handle (Stack(I).all); -- Call dispatches based on
- end loop; -- tag of operand.
- end Process_Stack;
-
-end CC54004_2;
-
-
- --===================================================================--
-
-
-with CC54004_0;
-with CC54004_1;
-with CC54004_2;
-pragma Elaborate (CC54004_2);
-
-package CC54004_3 is
-
- package Alert_Stacks is new CC54004_2 (Element_Type => CC54004_0.Alert,
- Element_Ptr => CC54004_0.Alert_Ptr);
-
- -- All overriding versions of Handle visible at the point of instantiation.
-
- Alert_List : Alert_Stacks.Stack_Type;
-
- procedure TC_Create_Alert_Stack;
-
-end CC54004_3;
-
-
- --===================================================================--
-
-
-package body CC54004_3 is
-
- procedure TC_Create_Alert_Stack is
- begin
- Alert_Stacks.Push (Alert_List, new CC54004_1.Low_Alert);
- Alert_Stacks.Push (Alert_List, new CC54004_1.Medium_Alert);
- end TC_Create_Alert_Stack;
-
-end CC54004_3;
-
-
- --===================================================================--
-
-
-with CC54004_0;
-with CC54004_1;
-with CC54004_3;
-
-with Report;
-procedure CC54004 is
- TC_Low_Ptr, TC_Med_Ptr : CC54004_0.Alert_Ptr;
- TC_Low_Actual : CC54004_1.Low_Alert;
- TC_Med_Actual : CC54004_1.Medium_Alert;
-
- use type CC54004_0.TC_Code_Type;
-begin
- Report.Test ("CC54004", "Check that the designated type of a generic " &
- "formal pool-specific access type may be class-wide");
-
-
- -- Create stack of elements:
-
- CC54004_3.TC_Create_Alert_Stack;
-
-
- -- Commence dispatching operations on stack elements:
-
- CC54004_3.Alert_Stacks.Process_Stack (CC54004_3.Alert_List);
-
-
- -- Pop "handled" alerts off stack:
-
- CC54004_3.Alert_Stacks.Pop (CC54004_3.Alert_List, TC_Med_Ptr);
- CC54004_3.Alert_Stacks.Pop (CC54004_3.Alert_List, TC_Low_Ptr);
-
-
- -- Verify results:
-
- if TC_Low_Ptr.all not in CC54004_1.Low_Alert or else
- TC_Med_Ptr.all not in CC54004_1.Medium_Alert
- then
- Report.Failed ("Class-wide objects do not have expected tags");
-
- -- The explicit dereference of the "Pop"ed pointers results in views of
- -- the designated objects, the nominal subtypes of which are class-wide.
- -- In order to be able to reference the component TC_Code, these views
- -- must be converted to a specific type possessing that component.
-
- elsif CC54004_1.Low_Alert(TC_Low_Ptr.all).TC_Code /= CC54004_0.Low or
- CC54004_1.Medium_Alert(TC_Med_Ptr.all).TC_Code /= CC54004_0.Medium
- then
- Report.Failed ("Calls did not dispatch to expected operations");
- end if;
-
- Report.Result;
-end CC54004;
diff --git a/gcc/testsuite/ada/acats/tests/cc/cc70001.a b/gcc/testsuite/ada/acats/tests/cc/cc70001.a
deleted file mode 100644
index 65681b072e1..00000000000
--- a/gcc/testsuite/ada/acats/tests/cc/cc70001.a
+++ /dev/null
@@ -1,309 +0,0 @@
--- CC70001.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that the template for a generic formal package may be a child
--- package, and that a child instance which is an instance of the
--- template may be passed as an actual to the formal package. Check that
--- the visible part of the generic formal package includes the first list
--- of basic declarative items of the package specification.
---
--- TEST DESCRIPTION:
--- Declare a list abstraction in a generic package which manages lists of
--- elements of any nonlimited type. Declare a generic child package of
--- this package which defines additional list operations. Declare a
--- generic subprogram which operates on lists of elements of discrete
--- types. Provide the generic subprogram with three formal parameters:
--- (1) a formal discrete type which represents a list element type, (2)
--- a generic formal package with the parent list generic as template, and
--- (3) a generic formal package with the child list generic as template.
--- Use the formal discrete type as the generic formal actual part for the
--- parent formal package. In the main program, declare an instance of
--- parent, then declare an instance of the child which is itself a child
--- the parent's instance. Pass these instances as actuals to the generic
--- subprogram instance.
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 05 Nov 95 SAIC ACVC 2.0.1 fixes: Corrected syntax of formal
--- package declaration.
--- 27 Feb 97 PWB.CTA Added an elaboration pragma.
---!
-
-generic
- type Element_Type is private; -- List elems may be of any nonlimited type.
-package CC70001_0 is -- List abstraction.
-
- type List_Type is limited private;
-
-
- -- Return true if current element is last in the list.
- function End_Of_List (L : List_Type) return Boolean;
-
- -- Set "current" pointer to first list element.
- procedure Reset (L : in out List_Type);
-
-private
-
- type Node_Type;
- type Node_Pointer is access Node_Type;
-
- type Node_Type is record
- Item : Element_Type;
- Next : Node_Pointer;
- end record;
-
- type List_Type is record
- First : Node_Pointer;
- Current : Node_Pointer;
- Last : Node_Pointer;
- end record;
-
-end CC70001_0;
-
-
- --==================================================================--
-
-
-package body CC70001_0 is
-
- function End_Of_List (L : List_Type) return Boolean is
- begin
- return (L.Current = null);
- end End_Of_List;
-
-
- procedure Reset (L : in out List_Type) is
- begin
- L.Current := L.First; -- Set "current" pointer to first
- end Reset; -- list element.
-
-end CC70001_0;
-
-
- --==================================================================--
-
-
--- Child must be generic since parent is generic. A formal parameter for
--- "element type" can not be provided here, because then the type of list
--- element assumed by these new operations would be different from that
--- defined by the list type declared in the parent.
-
-generic
-package CC70001_0.CC70001_1 is -- Additional list operations.
-
- -- Read from current element and advance "current" pointer.
- procedure Read_Element (L : in out List_Type; E : out Element_Type);
-
- -- Write to current element and advance "current" pointer.
- procedure Write_Element (L : in out List_Type; E : in Element_Type);
-
- -- Add element to end of list.
- procedure Add_Element (L : in out List_Type; E : in Element_Type);
-
-end CC70001_0.CC70001_1;
-
-
- --==================================================================--
-
-
-package body CC70001_0.CC70001_1 is
-
- procedure Read_Element (L : in out List_Type; E : out Element_Type) is
- begin
- -- ... Error-checking code omitted for brevity.
- E := L.Current.Item; -- Retrieve current element.
- L.Current := L.Current.Next; -- Advance "current" pointer.
- end Read_Element;
-
-
- procedure Write_Element (L : in out List_Type; E : in Element_Type) is
- begin
- -- ... Error-checking code omitted for brevity.
- L.Current.Item := E; -- Write to current element.
- L.Current := L.Current.Next; -- Advance "current" pointer.
- end Write_Element;
-
-
- procedure Add_Element (L : in out List_Type; E : in Element_Type) is
- New_Node : Node_Pointer := new Node_Type'(E, null);
- begin
- if L.First = null then -- No elements in list, so add new
- L.First := New_Node; -- element at beginning of list.
- else
- L.Last.Next := New_Node; -- Add new element at end of list.
- end if;
- L.Last := New_Node; -- Set last-in-list pointer.
- end Add_Element;
-
-end CC70001_0.CC70001_1;
-
-
- --==================================================================--
-
-
-with CC70001_0.CC70001_1; -- Generic list abstraction + additional operations.
-generic
-
- -- Import the list abstraction defined in CC70001_0, as well as the
- -- additional operations defined in CC70001_0.CC70001_1. Declare a formal
- -- discrete type. Restrict this generic procedure to operate only on lists
- -- of discrete elements by passing the formal discrete type as an actual
- -- parameter to the formal (parent) package.
-
- type Elem_Type is (<>); -- Discrete types only.
- with package List_Mgr is new CC70001_0 (Elem_Type);
- with package List_Ops is new List_Mgr.CC70001_1 (<>);
-
-procedure CC70001_2 (L : in out List_Mgr.List_Type);
-
-
- --==================================================================--
-
-
-procedure CC70001_2 (L : in out List_Mgr.List_Type) is
-begin
- List_Mgr.Reset (L);
- while not List_Mgr.End_Of_List (L) loop
- List_Ops.Write_Element (L, Elem_Type'First);
- end loop;
-end CC70001_2;
-
-
- --==================================================================--
-
-
-package CC70001_3 is
-
- type Points is range 0 .. 10;
-
- -- ... Various other types used by the application.
-
-end CC70001_3;
-
-
--- No body for CC70001_3;
-
-
- --==================================================================--
-
-
--- Declare instances of the generic list packages for the discrete type.
--- In order to establish that the type passed as an actual to the parent
--- generic (CC70001_0) is the one utilized by the child generic (CC70001_1),
--- the instance of the child must itself be declared as a child of the
--- instance of the parent. Since only library units may have or be children,
--- both instances must be library units.
-
-with CC70001_0; -- Generic list abstraction.
-with CC70001_3; -- Package containing discrete type declaration.
-pragma Elaborate (CC70001_0);
-package CC70001_4 is new CC70001_0 (CC70001_3.Points);
-
-with CC70001_0.CC70001_1; -- Generic extension to list abstraction.
-with CC70001_4;
-package CC70001_4.CC70001_5 is new CC70001_4.CC70001_1;
-
-
- --==================================================================--
-
-
-with CC70001_2; -- Generic "zeroing" op for lists of discrete types.
-with CC70001_3; -- Types for application.
-with CC70001_4.CC70001_5; -- Discrete list abstraction + additional ops.
-
-with Report;
-procedure CC70001 is
-
- package Lists_Of_Scores renames CC70001_4;
- package Score_Ops renames CC70001_4.CC70001_5;
-
- Scores : Lists_Of_Scores.List_Type; -- List of points.
-
- procedure Reset_All_Scores is new CC70001_2 -- Operation on lists of
- (Elem_Type => CC70001_3.Points, -- points.
- List_Mgr => Lists_Of_Scores,
- List_Ops => Score_Ops);
-
-
- -- Begin test code declarations: -----------------------
-
- type TC_Score_Array is array (1 .. 3) of CC70001_3.Points;
-
- TC_Initial_Values : constant TC_Score_Array := (2, 4, 6);
- TC_Final_Values : constant TC_Score_Array := (0, 0, 0);
-
- TC_Correct_Initial_Values : Boolean := False;
- TC_Correct_Final_Values : Boolean := False;
-
-
- procedure TC_Initialize_List (L : in out Lists_of_Scores.List_Type) is
- begin -- Initial list contains 3 scores
- for I in TC_Score_Array'Range loop -- with the values 2, 4, and 6.
- Score_Ops.Add_Element (L, TC_Initial_Values(I));
- end loop;
- end TC_Initialize_List;
-
-
- procedure TC_Verify_List (L : in out Lists_of_Scores.List_Type;
- Expected : in TC_Score_Array;
- OK : out Boolean) is
- Actual : TC_Score_Array;
- begin -- Verify that all scores have been
- Lists_of_Scores.Reset (L); -- set to zero.
- for I in TC_Score_Array'Range loop
- Score_Ops.Read_Element (L, Actual(I));
- end loop;
- OK := (Actual = Expected);
- end TC_Verify_List;
-
- -- End test code declarations. -------------------------
-
-
-begin
- Report.Test ("CC70001", "Check that the template for a generic formal " &
- "package may be a child package, and that a child instance " &
- "which is an instance of the template may be passed as an " &
- "actual to the formal package. Check that the visible part " &
- "of the generic formal package includes the first list of " &
- "basic declarative items of the package specification");
-
- TC_Initialize_List (Scores);
- TC_Verify_List (Scores, TC_Initial_Values, TC_Correct_Initial_Values);
-
- if not TC_Correct_Initial_Values then
- Report.Failed ("List contains incorrect initial values");
- end if;
-
- Reset_All_Scores (Scores);
- TC_Verify_List (Scores, TC_Final_Values, TC_Correct_Final_Values);
-
- if not TC_Correct_Final_Values then
- Report.Failed ("List contains incorrect final values");
- end if;
-
- Report.Result;
-end CC70001;
diff --git a/gcc/testsuite/ada/acats/tests/cc/cc70002.a b/gcc/testsuite/ada/acats/tests/cc/cc70002.a
deleted file mode 100644
index 3e4d9c40b30..00000000000
--- a/gcc/testsuite/ada/acats/tests/cc/cc70002.a
+++ /dev/null
@@ -1,241 +0,0 @@
--- CC70002.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that a formal package actual part may specify actual parameters
--- for a generic formal package. Check that these actual parameters may
--- be formal types, formal objects, and formal subprograms. Check that
--- the visible part of the generic formal package includes the first list
--- of basic declarative items of the package specification, and that if
--- the formal package actual part is (<>), it also includes the generic
--- formal part of the template for the formal package.
---
--- TEST DESCRIPTION:
--- Declare a generic package which defines a "signature" for mathematical
--- groups. Declare a second generic package which defines a
--- two-dimensional matrix abstraction. Declare a third generic package
--- which provides mathematical group operations for two-dimensional
--- matrices. Provide this third generic with two formal parameters: (1)
--- a generic formal package with the second generic as template and a
--- (<>) actual part, and (2) a generic formal package with the first
--- generic as template and an actual part that takes a formal type,
--- object, and subprogram from the first formal package as actuals.
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
---
---!
-
-generic -- Mathematical group signature.
-
- type Group_Type is private;
-
- Identity : in Group_Type;
-
- with function Operation (Left, Right : Group_Type) return Group_Type;
--- with function Inverse... (omitted for brevity).
-
-package CC70002_0 is
-
- function Power (Left : Group_Type; Right : Integer) return Group_Type;
-
- -- ... Other group operations.
-
-end CC70002_0;
-
-
- --==================================================================--
-
-
-package body CC70002_0 is
-
- -- The implementation of Power is purely artificial; the validity of its
- -- implementation in the context of the abstraction is irrelevant to the
- -- feature being tested.
-
- function Power (Left : Group_Type; Right : Integer) return Group_Type is
- Result : Group_Type := Identity;
- begin
- Result := Operation (Result, Left); -- All this really does is add
- return Result; -- one to each matrix element.
- end Power;
-
-end CC70002_0;
-
-
- --==================================================================--
-
-
-generic -- 2D matrix abstraction.
- type Element_Type is range <>;
-
- type Abscissa is range <>;
- type Ordinate is range <>;
-
- type Matrix_2D is array (Abscissa, Ordinate) of Element_Type;
-package CC70002_1 is
-
- Add_Ident : constant Matrix_2D := (Abscissa => (others => 1));
- -- Artificial for
- -- testing purposes.
- -- ... Other identity matrices.
-
-
- function "+" (A, B : Matrix_2D) return Matrix_2D;
-
- -- ... Other operations.
-
-end CC70002_1;
-
-
- --==================================================================--
-
-
-package body CC70002_1 is
-
- function "+" (A, B : Matrix_2D) return Matrix_2D is
- C : Matrix_2D;
- begin
- for I in Abscissa loop
- for J in Ordinate loop
- C(I,J) := A(I,J) + B(I,J);
- end loop;
- end loop;
- return C;
- end "+";
-
-end CC70002_1;
-
-
- --==================================================================--
-
-
-with CC70002_0; -- Mathematical group signature.
-with CC70002_1; -- 2D matrix abstraction.
-
-generic -- Mathematical 2D matrix addition group.
-
- with package Matrix_Ops is new CC70002_1 (<>);
-
- -- Although the restriction of the formal package below to signatures
- -- describing addition groups, and then only for 2D matrices, is rather
- -- artificial in the context of this "application," the passing of types,
- -- objects, and subprograms as actuals to a formal package is not.
-
- with package Math_Sig is new CC70002_0
- (Group_Type => Matrix_Ops.Matrix_2D,
- Identity => Matrix_Ops.Add_Ident,
- Operation => Matrix_Ops."+");
-
-package CC70002_2 is
-
- -- Add two matrices that are to be multiplied by coefficients:
- -- [ ] = CA*[ ] + CB*[ ].
-
- function Add_Matrices_With_Coefficients (A : Matrix_Ops.Matrix_2D;
- CA : Integer;
- B : Matrix_Ops.Matrix_2D;
- CB : Integer)
- return Matrix_Ops.Matrix_2D;
-
- -- ...Other operations.
-
-end CC70002_2;
-
-
- --==================================================================--
-
-
-package body CC70002_2 is
-
- function Add_Matrices_With_Coefficients (A : Matrix_Ops.Matrix_2D;
- CA : Integer;
- B : Matrix_Ops.Matrix_2D;
- CB : Integer)
- return Matrix_Ops.Matrix_2D is
- Left, Right : Matrix_Ops.Matrix_2D;
- begin
- Left := Math_Sig.Power (A, CA); -- Multiply 1st array by its coeff.
- Right := Math_Sig.Power (B, CB); -- Multiply 2nd array by its coeff.
- return (Matrix_Ops."+" (Left, Right));-- Add these two arrays.
- end Add_Matrices_With_Coefficients;
-
-end CC70002_2;
-
-
- --==================================================================--
-
-
-with CC70002_0; -- Mathematical group signature.
-with CC70002_1; -- 2D matrix abstraction.
-with CC70002_2; -- Mathematical 2D matrix addition group.
-
-with Report;
-procedure CC70002 is
-
- subtype Cell_Type is Positive range 1 .. 3;
- subtype Category_Type is Positive range 1 .. 2;
-
- type Data_Points is new Natural range 0 .. 100;
-
- type Table_Type is array (Cell_Type, Category_Type) of Data_Points;
-
- package Data_Table_Support is new CC70002_1 (Data_Points,
- Cell_Type,
- Category_Type,
- Table_Type);
-
- package Data_Table_Addition_Group is new CC70002_0
- (Group_Type => Table_Type,
- Identity => Data_Table_Support.Add_Ident,
- Operation => Data_Table_Support."+");
-
- package Table_Add_Ops is new CC70002_2
- (Data_Table_Support, Data_Table_Addition_Group);
-
-
- Scores_Table : Table_Type := ( ( 12, 0),
- ( 21, 33),
- ( 49, 9) );
- Expected : Table_Type := ( ( 26, 2),
- ( 44, 68),
- ( 100, 20) );
-
-begin
- Report.Test ("CC70002", "Check that a generic formal package actual " &
- "part may specify formal objects, formal subprograms, " &
- "and formal types");
-
- Scores_Table := Table_Add_Ops.Add_Matrices_With_Coefficients
- (Scores_Table, 2,
- Scores_Table, 1);
-
- if (Scores_Table /= Expected) then
- Report.Failed ("Incorrect result for multi-dimensional array");
- end if;
-
- Report.Result;
-end CC70002;
diff --git a/gcc/testsuite/ada/acats/tests/cc/cc70003.a b/gcc/testsuite/ada/acats/tests/cc/cc70003.a
deleted file mode 100644
index d2309fc3695..00000000000
--- a/gcc/testsuite/ada/acats/tests/cc/cc70003.a
+++ /dev/null
@@ -1,212 +0,0 @@
--- CC70003.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that the actual passed to a formal package may be a formal
--- access-to-subprogram type. Check that the visible part of the generic
--- formal package includes the first list of basic declarative items of
--- the package specification.
---
--- TEST DESCRIPTION:
--- Declare a list abstraction in a generic package which manages lists of
--- elements of any nonlimited type (foundation code). Declare a generic
--- package which supports the execution of lists of operations. Provide
--- the generic package with two formal parameters: (1) a formal access-
--- to-function type, and (2) a generic formal package with the list
--- abstraction package as template. Within a procedure declared in the
--- list-execution package, utilize information about the profile of
--- the functions in the list. Declare a package which declares functions
--- matching the profile of the formal access-to-subprogram type. In the
--- main program, create a list of pointers to the functions declared in
--- the package, instantiate the list abstraction and list-execution
--- packages, and use the list-execution procedure to call each of the
--- functions in the list in sequence.
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
---
---!
-
-generic
- type Element_Type is private;
-package CC70003_0 is -- This package simulates a generic list abstraction.
-
- -- The definition of List_Type below is purely artificial; its validity
- -- in the context of the abstraction is irrelevant to the feature being
- -- tested.
-
- type Element_Ptr is access Element_Type;
-
- subtype List_Size is Natural range 1 .. 2;
- type List_Type is array (List_Size) of Element_Ptr;
-
- function View_Element (I : List_Size; L : List_Type) return Element_Type;
-
- procedure Write_Element (I : in List_Size;
- L : in out List_Type;
- E : in Element_Type);
-
- -- ... Other list operations for Element_Type.
-
-end CC70003_0;
-
-
- --==================================================================--
-
-
-package body CC70003_0 is
-
- -- The implementations of the operations below are purely artificial; the
- -- validity of their implementations in the context of the abstraction is
- -- irrelevant to the feature being tested.
-
- function View_Element (I : List_Size; L : List_Type) return Element_Type is
- begin
- return L(I).all;
- end View_Element;
-
-
- procedure Write_Element (I : in List_Size;
- L : in out List_Type;
- E : in Element_Type) is
- begin
- L(I) := new Element_Type'(E);
- end Write_Element;
-
-end CC70003_0;
-
-
- --==================================================================--
-
-
-with CC70003_0; -- Generic list abstraction.
-generic
- type Elem_Type is access function (F : Float) return Float;
- with package List_Mgr is new CC70003_0 (Elem_Type);
-package CC70003_1 is -- This package simulates support for executing lists
- -- of operations.
-
- procedure Execute_List (L : List_Mgr.List_Type; F : in out Float);
-
- -- ... Other operations.
-
-end CC70003_1;
-
-
- --==================================================================--
-
-
-package body CC70003_1 is
-
- procedure Execute_List (L : List_Mgr.List_Type; F : in out Float) is
- begin
- for I in L'Range loop
- F := List_Mgr.View_Element(I, L)(F); -- Execute next operation in
- end loop; -- list with current value of
- end Execute_List; -- F as operand.
-
-
-end CC70003_1;
-
-
- --==================================================================--
-
-
-package CC70003_2 is
-
- function Sine (F : Float) return Float;
- function Exp (F : Float) return Float;
-
- -- ... Other math functions.
-
-end CC70003_2;
-
-
- --==================================================================--
-
-
-package body CC70003_2 is
-
- -- The implementations of the functions below are purely artificial; the
- -- validity of their implementations in the context of the abstraction is
- -- irrelevant to the feature being tested.
-
- function Sine (F : Float) return Float is
- begin
- return (-0.15);
- end Sine;
-
- function Exp (F : Float) return Float is
- begin
- if (F = 0.0) then
- return (-0.69);
- else
- return (2.0); -- This branch should be taken.
- end if;
- end Exp;
-
-end CC70003_2;
-
-
- --==================================================================--
-
-
-with CC70003_0; -- Generic list abstraction.
-with CC70003_1; -- Generic operation-list abstraction.
-with CC70003_2; -- Math library.
-
-with Report;
-procedure CC70003 is
-
- type Math_Op is access function (F : Float) return Float;
-
- package Math_Op_Lists is new CC70003_0 (Math_Op);
- package Math_Op_List_Support is new CC70003_1 (Math_Op, Math_Op_Lists);
-
- Sin_Ptr : Math_Op := CC70003_2.Sine'Access;
- Exp_Ptr : Math_Op := CC70003_2.Exp'Access;
-
- Op_List : Math_Op_Lists.List_Type;
-
- Operand : Float := 0.0;
- Expected : Float := 2.0;
-
-
-begin
- Report.Test ("CC70003", "Check that the actual passed to a formal " &
- "package may be a formal access-to-subprogram type");
-
- Math_Op_Lists.Write_Element (1, Op_List, Sin_Ptr);
- Math_Op_Lists.Write_Element (2, Op_List, Exp_Ptr);
-
- Math_Op_List_Support.Execute_List (Op_List, Operand);
-
- if (Operand /= Expected) then
- Report.Failed ("Incorrect results from indirect function calls");
- end if;
-
- Report.Result;
-end CC70003;
diff --git a/gcc/testsuite/ada/acats/tests/cc/cc70a01.a b/gcc/testsuite/ada/acats/tests/cc/cc70a01.a
deleted file mode 100644
index ac92f437a44..00000000000
--- a/gcc/testsuite/ada/acats/tests/cc/cc70a01.a
+++ /dev/null
@@ -1,208 +0,0 @@
--- CC70A01.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that the visible part of a generic formal package includes the
--- first list of basic declarative items of the package specification.
--- Check for a generic package which declares a formal package with (<>)
--- as its actual part.
---
--- TEST DESCRIPTION:
--- The "first list of basic declarative items" of a package specification
--- is the visible part of the package. Thus, the declarations in the
--- visible part of the actual instance corresponding to a formal
--- package are available in the generic which declares the formal package.
---
--- Declare a generic package which simulates a complex integer abstraction
--- (foundation code).
---
--- Declare a second, library-level generic package which utilizes the
--- first generic package as a generic formal package (with a (<>)
--- actual_part). In the second generic package, declare objects, types,
--- and operations in terms of the objects, types, and operations declared
--- in the first generic package.
---
--- In the main program, instantiate the first generic package, then
--- instantiate the second generic package and pass the first instance
--- to it as a generic actual parameter. Check that the operations in
--- the second instance perform as expected.
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
---
---!
-
-with FC70A00; -- Generic complex integer operations.
-
-generic -- Generic complex matrix operations.
- with package Complex_Package is new FC70A00 (<>);
-package CC70A01_0 is
-
- type Complex_Matrix_Type is -- 1st index is matrix
- array (Positive range <>, Positive range <>) -- row, 2nd is column.
- of Complex_Package.Complex_Type;
- Dimension_Mismatch : exception;
-
-
- function Identity_Matrix (Size : Positive) -- Create identity matrix
- return Complex_Matrix_Type; -- of specified size.
-
- function "*" (Left : Complex_Matrix_Type; -- Multiply two complex
- Right : Complex_Matrix_Type) -- matrices.
- return Complex_Matrix_Type;
-
-end CC70A01_0;
-
-
- --==================================================================--
-
-
-package body CC70A01_0 is -- Generic complex matrix operations.
-
- use Complex_Package;
-
- --==============================================--
-
- function Inner_Product (Left, Right : Complex_Matrix_Type;
- Row, Column : Positive) -- Compute inner product
- return Complex_Package.Complex_Type is -- for matrix-multiply.
-
- Result : Complex_Type := Zero;
- subtype Vector_Size is Positive range Left'Range(2);
-
- begin -- Inner_Product.
- for I in Vector_Size loop
- Result := Result + -- Complex_Package."+".
- (Left(Row, I) * Right(I, Column)); -- Complex_Package."*".
- end loop;
- return (Result);
- end Inner_Product;
-
- --==============================================--
-
- function Identity_Matrix (Size : Positive) return Complex_Matrix_Type is
- Result : Complex_Matrix_Type (1 .. Size, 1 .. Size) :=
- (others => (others => Zero)); -- Zeroes everywhere...
- begin
- for I in 1 .. Size loop
- Result (I, I) := One; -- Ones on the diagonal.
- end loop;
- return (Result);
- end Identity_Matrix;
-
- --==============================================--
-
- function "*" (Left : Complex_Matrix_Type; Right : Complex_Matrix_Type)
- return Complex_Matrix_Type is
-
- subtype Rows is Positive range Left'Range(1);
- subtype Columns is Positive range Right'Range(2);
-
- Result : Complex_Matrix_Type(Rows, Columns);
- begin
- if Left'Length(2) /= Right'Length(1) then -- # columns of Left must
- -- match # rows of Right.
- raise Dimension_Mismatch;
- else
- for I in Rows loop
- for J in Columns loop
- Result(I, J) := Inner_Product (Left, Right, I, J);
- end loop;
- end loop;
- return (Result);
- end if;
- end "*";
-
-end CC70A01_0;
-
-
- --==================================================================--
-
-
-with Report;
-
-with FC70A00; -- Generic complex integer operations.
-with CC70A01_0; -- Generic complex matrix operations.
-
-procedure CC70A01 is
-
- type My_Integer is range -100 .. 100;
-
- package My_Complex_Package is new FC70A00 (My_Integer);
- package My_Matrix_Package is new CC70A01_0 (My_Complex_Package);
-
- use My_Complex_Package, -- All user-defined
- My_Matrix_Package; -- operators directly
- -- visible.
-
- subtype Matrix_2x2 is Complex_Matrix_Type (1 .. 2, 1 .. 2);
- subtype Matrix_2x3 is Complex_Matrix_Type (1 .. 2, 1 .. 3);
-
- function C (Real, Imag : My_Integer) return Complex_Type renames Complex;
-
-begin -- Main program.
-
- Report.Test ("CC70A01", "Check that the visible part of a generic " &
- "formal package includes the first list of basic " &
- "declarative items of the package specification. Check " &
- "for a generic package where formal package has (<>) " &
- "actual part");
-
- declare
- Identity_2x2 : Matrix_2x2 := Identity_Matrix (Size => 2);
- Operand_2x3 : Matrix_2x3 := ( ( C(1, 2), C(3, 6), C(5, 1) ),
- ( C(0, 3), C(7, 9), C(3, 4) ) );
- Result_2x3 : Matrix_2x3 := ( others => ( others => Zero ) );
- begin
-
- begin -- Block #1.
- Result_2x3 := Identity_2x2 * Operand_2x3; -- Should return
- -- Operand_2x3.
- if (Result_2x3 /= Operand_2x3) then
- Report.Failed ("Incorrect results from matrix multiplication");
- end if;
- exception
- when others =>
- Report.Failed ("Unexpected exception raised - Block #1");
- end; -- Block #1.
-
-
- begin -- Block #2.
- Result_2x3 := Operand_2x3 * Identity_2x2; -- Can't multiply 2x3
- -- by 2x2.
- Report.Failed ("Exception Dimension_Mismatch not raised");
- exception
- when Dimension_Mismatch =>
- null;
- when others =>
- Report.Failed ("Unexpected exception raised - Block #2");
- end; -- Block #2.
-
- end;
-
- Report.Result;
-
-end CC70A01;
diff --git a/gcc/testsuite/ada/acats/tests/cc/cc70a02.a b/gcc/testsuite/ada/acats/tests/cc/cc70a02.a
deleted file mode 100644
index 3601ce443e1..00000000000
--- a/gcc/testsuite/ada/acats/tests/cc/cc70a02.a
+++ /dev/null
@@ -1,193 +0,0 @@
--- CC70A02.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that the visible part of a generic formal package includes the
--- first list of basic declarative items of the package specification.
--- Check for a generic subprogram which declares a formal package with
--- (<>) as its actual part.
---
--- TEST DESCRIPTION:
--- The "first list of basic declarative items" of a package specification
--- is the visible part of the package. Thus, the declarations in the
--- visible part of the actual instance corresponding to a formal
--- package are available in the generic which declares the formal package.
---
--- Declare a generic package which simulates a complex integer abstraction
--- (foundation code).
---
--- Declare a second generic package which defines a "signature" for
--- mathematical groups. Declare a generic function within a package
--- which utilizes the second generic package as a generic formal package
--- (with a (<>) actual_part).
---
--- In the main program, instantiate the first generic package, then
--- instantiate the second generic package with objects, types, and
--- operations declared in the first instance.
---
--- Instantiate the generic function and pass the second instance
--- to it as a generic actual parameter. Check that the instance of the
--- generic function performs as expected.
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
---
---!
-
-generic -- Mathematical group signature.
-
- type Group_Type is private;
-
- Identity : in Group_Type;
-
- with function Operation (Left, Right : Group_Type) return Group_Type;
- with function Inverse (Right : Group_Type) return Group_Type;
-
-package CC70A02_0 is end;
-
--- No body for CC70A02_0.
-
-
- --==================================================================--
-
-
-with CC70A02_0; -- Mathematical group signature.
-
-package CC70A02_1 is -- Mathematical group operations.
-
- -- --
- -- Generic formal package used here --
- -- --
-
- generic -- Powers for mathematical groups.
- with package Group is new CC70A02_0 (<>);
- function Power (Left : Group.Group_Type; Right : Integer)
- return Group.Group_Type;
-
-
-end CC70A02_1;
-
-
- --==================================================================--
-
-
-package body CC70A02_1 is -- Mathematical group operations.
-
-
-
- function Power (Left : Group.Group_Type; Right : Integer)
- return Group.Group_Type is
- Result : Group.Group_Type := Group.Identity;
- begin
- for I in 1 .. abs(Right) loop -- Repeat group operations
- Result := Group.Operation (Result, Left); -- the specified number of
- end loop; -- times.
-
- if Right < 0 then -- If specified power is
- return Group.Inverse (Result); -- negative, return the
- else -- inverse of the result.
- return Result; -- If it is zero, return
- end if; -- the identity.
- end Power;
-
-
-end CC70A02_1;
-
-
- --==================================================================--
-
-
-with Report;
-
-with FC70A00; -- Complex integer abstraction.
-with CC70A02_0; -- Mathematical group signature.
-with CC70A02_1; -- Mathematical group operations.
-
-procedure CC70A02 is
-
- -- Declare an instance of complex integers:
-
- type My_Integer is range -100 .. 100;
- package Complex_Integers is new FC70A00 (My_Integer);
-
-
- -- Define an addition group for complex integers:
-
- package Complex_Addition_Group is new CC70A02_0
- (Group_Type => Complex_Integers.Complex_Type, -- For complex integers...
- Identity => Complex_Integers.Zero, -- Additive identity.
- Operation => Complex_Integers."+", -- Additive operation.
- Inverse => Complex_Integers."-"); -- Additive inverse.
-
- function Complex_Multiplication is new -- Multiplication of a
- CC70A02_1.Power(Complex_Addition_Group); -- complex integer by a
- -- constant.
-
-
- -- Define a multiplication group for complex integers:
-
- package Complex_Multiplication_Group is new CC70A02_0
- (Group_Type => Complex_Integers.Complex_Type, -- For complex integers...
- Identity => Complex_Integers.One, -- Multiplicative identity.
- Operation => Complex_Integers."*", -- Multiplicative oper.
- Inverse => Complex_Integers.Reciprocal); -- Multiplicative inverse.
-
- function Complex_Exponentiation is new -- Exponentiation of a
- CC70A02_1.Power(Complex_Multiplication_Group); -- complex integer by a
- -- constant.
-
- use Complex_Integers;
-
-
-begin -- Main program.
-
- Report.Test ("CC70A02", "Check that the visible part of a generic " &
- "formal package includes the first list of basic " &
- "declarative items of the package specification. Check " &
- "for a generic subprogram where formal package has (<>) " &
- "actual part");
-
- declare
- Mult_Operand : constant Complex_Type := Complex ( -4, 9);
- Exp_Operand : constant Complex_Type := Complex ( 0, -7);
-
- Expected_Mult_Result : constant Complex_Type := Complex ( 28, -63);
- Expected_Exp_Result : constant Complex_Type := Complex (-49, 0);
- begin
-
- if Complex_Multiplication (Mult_Operand, -7) /= Expected_Mult_Result then
- Report.Failed ("Incorrect results from complex multiplication");
- end if;
-
- if Complex_Exponentiation (Exp_Operand, 2) /= Expected_Exp_Result then
- Report.Failed ("Incorrect results from complex exponentiation");
- end if;
-
- end;
-
- Report.Result;
-
-end CC70A02;
diff --git a/gcc/testsuite/ada/acats/tests/cc/cc70b01.a b/gcc/testsuite/ada/acats/tests/cc/cc70b01.a
deleted file mode 100644
index 6c514e17b06..00000000000
--- a/gcc/testsuite/ada/acats/tests/cc/cc70b01.a
+++ /dev/null
@@ -1,170 +0,0 @@
--- CC70B01.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that a formal package actual part may specify actual parameters
--- for a generic formal package. Check that a use clause in the generic
--- formal part provides direct visibility of declarations within the
--- generic formal package. Check that the scope of such a use clause
--- extends to the generic subprogram body. Check that the visible part of
--- the generic formal package includes the first list of basic
--- declarative items of the package specification.
---
--- Check the case where the formal package is declared in a generic
--- subprogram.
---
--- TEST DESCRIPTION:
--- Declare a list abstraction in a generic package which manages lists of
--- elements of any nonlimited type (foundation code). Declare a generic
--- subprogram which operates on lists of elements of discrete types.
--- Provide the generic subprogram with two formal parameters: (1) a
--- formal discrete type which represents a list element type, and (2) a
--- generic formal package with the list abstraction package as template.
--- Use the formal discrete type as the generic formal actual part for the
--- formal package. Include a use clause for the formal package in the
--- generic subprogram formal part.
---
--- TEST FILES:
--- The following files comprise this test:
---
--- FC70B00.A
--- CC70B01.A
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
---
---!
-
--- Declare a generic subprogram which performs an operation on lists of
--- discrete objects.
-
-with FC70B00; -- Generic list abstraction.
-generic
-
- -- Import the list abstraction defined in FC70B00. To ensure that only
- -- list abstraction instances defining lists of *discrete* elements will be
- -- accepted as actuals to this generic, declare a formal discrete type and
- -- pass it as an actual parameter to the formal package.
- --
- -- Only instances declared for the same discrete type as that used to
- -- instantiate this generic subprogram will be accepted.
-
- type Elem_Type is (<>); -- Discrete types only.
- with package List_Mgr is new FC70B00 (Elem_Type);
-
- use List_Mgr; -- Use clause for formal package.
-
-procedure CC70B01_0 (L : in out List_Type); -- List_Mgr.List_Type directly
- -- visible.
-
-
- --==================================================================--
-
-
-procedure CC70B01_0 (L : in out List_Type) is -- Declarations in List_Mgr
-begin -- still directly visible.
- Reset (L);
- while not End_Of_List (L) loop
- Write_Element (L, Elem_Type'First); -- This statement assumes
- end loop; -- Elem_Type is discrete.
-end CC70B01_0;
-
-
- --==================================================================--
-
-
-with FC70B00; -- Generic list abstraction.
-with CC70B01_0; -- Generic "zeroing" operation for lists of discrete types.
-
-with Report;
-procedure CC70B01 is
-
- type Points is range 0 .. 10; -- Discrete type.
- package Lists_of_Scores is new FC70B00 (Points); -- List-of-points
- -- abstraction.
- Scores : Lists_of_Scores.List_Type; -- List of points.
-
- procedure Reset_All_Scores is new -- Operation on lists of
- CC70B01_0 (Points, Lists_of_Scores); -- points.
-
-
- -- Begin test code declarations: -----------------------
-
- type TC_Score_Array is array (1 .. 3) of Points;
-
- TC_Initial_Values : constant TC_Score_Array := (2, 4, 6);
- TC_Final_Values : constant TC_Score_Array := (0, 0, 0);
-
- TC_Correct_Initial_Values : Boolean := False;
- TC_Correct_Final_Values : Boolean := False;
-
-
- procedure TC_Initialize_List (L : in out Lists_of_Scores.List_Type) is
- begin -- Initial list contains 3 scores
- for I in TC_Score_Array'Range loop -- with the values 2, 4, and 6.
- Lists_of_Scores.Add_Element (L, TC_Initial_Values(I));
- end loop;
- end TC_Initialize_List;
-
-
- procedure TC_Verify_List (L : in out Lists_of_Scores.List_Type;
- Expected : in TC_Score_Array;
- OK : out Boolean) is
- Actual : TC_Score_Array;
- begin -- Verify that all scores have been
- Lists_of_Scores.Reset (L); -- set to zero.
- for I in TC_Score_Array'Range loop
- Lists_of_Scores.Read_Element (L, Actual(I));
- end loop;
- OK := (Actual = Expected);
- end TC_Verify_List;
-
- -- End test code declarations. -------------------------
-
-
-begin
- Report.Test ("CC70B01", "Check that a library-level generic subprogram " &
- "may have a formal package as a formal parameter, and that " &
- "the generic formal actual part may specify explicit actual " &
- "parameters. Check that a use clause is legal in the " &
- "generic formal part");
-
- TC_Initialize_List (Scores);
- TC_Verify_List (Scores, TC_Initial_Values, TC_Correct_Initial_Values);
-
- if not TC_Correct_Initial_Values then
- Report.Failed ("List contains incorrect initial values");
- end if;
-
- Reset_All_Scores (Scores);
- TC_Verify_List (Scores, TC_Final_Values, TC_Correct_Final_Values);
-
- if not TC_Correct_Final_Values then
- Report.Failed ("List contains incorrect final values");
- end if;
-
- Report.Result;
-end CC70B01;
diff --git a/gcc/testsuite/ada/acats/tests/cc/cc70b02.a b/gcc/testsuite/ada/acats/tests/cc/cc70b02.a
deleted file mode 100644
index d27eea843f4..00000000000
--- a/gcc/testsuite/ada/acats/tests/cc/cc70b02.a
+++ /dev/null
@@ -1,222 +0,0 @@
--- CC70B02.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that a formal package actual part may specify actual parameters
--- for a generic formal package. Check that such an actual parameter may
--- be a formal parameter of a previously declared formal package
--- (with a (<>) actual part). Check that a use clause in the generic
--- formal part provides direct visibility of declarations within the
--- generic formal package, including formal parameters (if the formal
--- package has a (<>) actual part). Check that the scope of such a use
--- clause extends to the generic subprogram body. Check that the visible
--- part of the generic formal package includes the first list of basic
--- declarative items of the package specification.
---
--- Check the case where the formal package is declared in a generic
--- package.
---
--- TEST DESCRIPTION:
--- Declare a list abstraction in a generic package which manages lists of
--- elements of any nonlimited type (foundation code). Declare a second
--- generic package which declares operations on discrete types. Declare
--- a third generic package which combines the abstractions of the first
--- two generics and declares operations on lists of elements of discrete
--- types. Provide the third generic package with two formal parameters:
--- (1) a generic formal package with the discrete operation package as
--- template, and (2) a generic formal package with the list abstraction
--- package as template. Use the formal discrete type of the discrete
--- operations generic as the generic formal actual part for the second
--- formal package. Include a use clause for the first formal package in
--- the third generic package formal part.
---
--- TEST FILES:
--- The following files comprise this test:
---
--- FC70B00.A
--- CC70B02.A
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
---
---!
-
-generic
- type Discrete_Type is (<>); -- Discrete types only.
-package CC70B02_0 is -- Discrete type operations.
-
- procedure Double (Object : in out Discrete_Type);
-
- -- ... Other operations on discrete objects.
-
-end CC70B02_0;
-
-
- --==================================================================--
-
-
-package body CC70B02_0 is
-
- procedure Double (Object : in out Discrete_Type) is
- Doubled_Position : Integer := Discrete_Type'Pos (Object) * 2;
- begin
- -- ... Error-checking code omitted for brevity.
- Object := Discrete_Type'Val (Doubled_Position);
- end Double;
-
-end CC70B02_0;
-
-
- --==================================================================--
-
-
-with CC70B02_0; -- Discrete type operations.
-with FC70B00; -- List abstraction.
-generic
-
- -- Import both the discrete-operation and list abstractions. To ensure that
- -- only list abstraction instances defining lists of *discrete* elements
- -- will be accepted as actuals to this generic, pass the formal discrete
- -- type from the discrete-operation abstraction as an actual parameter to
- -- the list-abstraction formal package.
- --
- -- Only list instances declared for the same discrete type as that used
- -- to instantiate the discrete-operation package will be accepted.
-
- with package Discrete_Ops is new CC70B02_0 (<>);
-
- use Discrete_Ops; -- Discrete_Ops directly visible.
-
- with package List_Mgr is new FC70B00 (Discrete_Type); -- Discrete_Type is
- -- formal parameter
- -- of template for
- -- Discrete_Ops.
-package CC70B02_1 is -- Discrete list operations.
-
- procedure Double_List (L : in out List_Mgr.List_Type);
-
- -- ... Other operations on lists of discrete objects.
-
-end CC70B02_1;
-
-
- --==================================================================--
-
-
-package body CC70B02_1 is
-
- procedure Double_List (L : in out List_Mgr.List_Type) is
- Element : Discrete_Type; -- Formal part of Discrete_Ops template
- begin -- is directly visible here.
- List_Mgr.Reset (L);
- while not List_Mgr.End_Of_List (L) loop
- List_Mgr.View_Element (L, Element);
- Double (Element);
- List_Mgr.Write_Element (L, Element);
- end loop;
- end Double_List;
-
-end CC70B02_1;
-
-
- --==================================================================--
-
-
-with FC70B00; -- Generic list abstraction.
-with CC70B02_0; -- Generic discrete type operations.
-with CC70B02_1; -- Generic discrete list operations.
-
-with Report;
-procedure CC70B02 is
-
- type Points is range 0 .. 100; -- Discrete type.
-
- package Points_Ops is new CC70B02_0 (Points); -- Points-type operations.
- package Lists_of_Points is new FC70B00 (Points); -- Points lists.
- package Points_List_Ops is new -- Points-list operations.
- CC70B02_1 (Points_Ops, Lists_Of_Points);
-
- Scores : Lists_of_Points.List_Type; -- List of points.
-
-
- -- Begin test code declarations: -----------------------
-
- type TC_Score_Array is array (1 .. 3) of Points;
-
- TC_Initial_Values : constant TC_Score_Array := (23, 15, 0);
- TC_Final_Values : constant TC_Score_Array := (46, 30, 0);
-
- TC_Correct_Initial_Values : Boolean := False;
- TC_Correct_Final_Values : Boolean := False;
-
-
- procedure TC_Initialize_List (L : in out Lists_Of_Points.List_Type) is
- begin -- Initial list contains 3 scores
- for I in TC_Score_Array'Range loop -- with the values 23, 15, and 0.
- Lists_Of_Points.Add_Element (L, TC_Initial_Values(I));
- end loop;
- end TC_Initialize_List;
-
-
- procedure TC_Verify_List (L : in out Lists_Of_Points.List_Type;
- Expected : in TC_Score_Array;
- OK : out Boolean) is
- Actual : TC_Score_Array;
- begin -- Verify that all scores have been
- Lists_Of_Points.Reset (L); -- set to zero.
- for I in TC_Score_Array'Range loop
- Lists_Of_Points.Read_Element (L, Actual(I));
- end loop;
- OK := (Actual = Expected);
- end TC_Verify_List;
-
- -- End test code declarations. -------------------------
-
-
-begin
- Report.Test ("CC70B02", "Check that a library-level generic package " &
- "may have a formal package as a formal parameter, and that " &
- "the generic formal actual part may specify explicit actual " &
- "parameters (including a formal parameter of a previously " &
- "declared formal package). Check that a use clause is legal " &
- "in the generic formal part");
-
- TC_Initialize_List (Scores);
- TC_Verify_List (Scores, TC_Initial_Values, TC_Correct_Initial_Values);
-
- if not TC_Correct_Initial_Values then
- Report.Failed ("List contains incorrect initial values");
- end if;
-
- Points_List_Ops.Double_List (Scores);
- TC_Verify_List (Scores, TC_Final_Values, TC_Correct_Final_Values);
-
- if not TC_Correct_Final_Values then
- Report.Failed ("List contains incorrect final values");
- end if;
-
- Report.Result;
-end CC70B02;
diff --git a/gcc/testsuite/ada/acats/tests/cc/cc70c01.a b/gcc/testsuite/ada/acats/tests/cc/cc70c01.a
deleted file mode 100644
index f22ad01e76c..00000000000
--- a/gcc/testsuite/ada/acats/tests/cc/cc70c01.a
+++ /dev/null
@@ -1,187 +0,0 @@
--- CC70C01.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that a generic formal package is an instance. Specifically,
--- check that a generic formal package may be passed as an actual
--- parameter in an instantiation of a generic package. Check that the
--- visible part of the generic formal package includes the first list of
--- basic declarative items of the package specification.
---
--- TEST DESCRIPTION:
--- A generic formal package is a package, and is an instance.
---
--- Declare a list type in a generic package for lists of elements of any
--- nonlimited type (foundation code). Declare a second generic package
--- which declares operations for the list type, and parameterize it with
--- a generic formal package with the list-type package as template
--- (foundation code). Declare a third generic package which declares
--- additional operations for the list type, and parameterize it just like
--- the second generic package. Declare an instance of the second generic
--- in the spec of the third generic, passing the formal package as the
--- actual.
---
--- TEST FILES:
--- The following files comprise this test:
---
--- FC70C00.A
--- CC70C01.A
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
---
---!
-
-with FC70C00_0; -- List abstraction.
-with FC70C00_1; -- Basic list operations.
-generic
- with package Lists is new FC70C00_0 (<>);
-package CC70C01_0 is -- Additional list operations.
-
- -- Instantiate a generic package (FC70C00_1) with a generic formal package
- -- (Lists). This ensures that the package passed as an actual corresponding
- -- to Lists is the same one passed as an actual to FC70C00_1. Thus, all list
- -- operations from both FC70C00_1 and this package operate on lists of the
- -- same element type.
-
- package Basic_List_Ops is new FC70C00_1 (Lists);
-
-
- End_of_List_Reached : exception;
-
-
- -- Read from current element and advance "current" pointer.
- procedure Read_Element (L : in out Lists.List_Type;
- E : out Lists.Element_Type);
-
- -- Add element to end of list.
- procedure Add_Element (L : in out Lists.List_Type;
- E : in Lists.Element_Type);
-
-end CC70C01_0;
-
-
- --==================================================================--
-
-
-package body CC70C01_0 is
-
- procedure Read_Element (L : in out Lists.List_Type;
- E : out Lists.Element_Type) is
- begin
- if Basic_List_Ops.End_Of_List (L) then -- Use of op from the previous
- raise End_Of_List_Reached; -- generic package.
- else
- E := L.Current.Item; -- Retrieve current element.
- L.Current := L.Current.Next; -- Advance "current" pointer.
- end if;
- end Read_Element;
-
-
- procedure Add_Element (L : in out Lists.List_Type;
- E : in Lists.Element_Type) is
- New_Node : Lists.Node_Pointer := new Lists.Node_Type'(E, null);
- use type Lists.Node_Pointer;
- begin
- if L.First = null then -- No elements in list, so add new
- L.First := New_Node; -- element at beginning of list.
- else
- L.Last.Next := New_Node; -- Add new element at end of list.
- end if;
- L.Last := New_Node; -- Set last-in-list pointer.
- end Add_Element;
-
-
-end CC70C01_0;
-
-
- --==================================================================--
-
-
-with FC70C00_0; -- Generic list abstraction.
-with CC70C01_0; -- Additional generic list operations.
-
-with Report;
-procedure CC70C01 is
-
- type Points is range 0 .. 100; -- Discrete type.
-
- package Lists_of_Points is new FC70C00_0 (Points); -- Points lists.
-
- package Points_List_Ops is new -- Points-list ops.
- CC70C01_0 (Lists_Of_Points);
-
- Scores : Lists_of_Points.List_Type; -- List of points.
-
-
- -- Begin test code declarations: -----------------------
-
- type TC_Score_Array is array (1 .. 3) of Points;
-
- TC_List_Values : constant TC_Score_Array := (23, 15, 0);
-
- TC_Correct_List_Values : Boolean := False;
-
-
- procedure TC_Initialize_List (L : in out Lists_Of_Points.List_Type) is
- begin -- Initial list contains 3 scores
- for I in TC_Score_Array'Range loop -- with the values 23, 15, and 0.
- Points_List_Ops.Add_Element (L, TC_List_Values(I));
- end loop;
- end TC_Initialize_List;
-
-
- procedure TC_Verify_List (L : in out Lists_Of_Points.List_Type;
- Expected : in TC_Score_Array;
- OK : out Boolean) is
- Actual : TC_Score_Array;
- begin
- Points_List_Ops.Basic_List_Ops.Reset (L);
- for I in TC_Score_Array'Range loop
- Points_List_Ops.Read_Element (L, Actual(I));
- end loop;
- OK := (Actual = Expected);
- end TC_Verify_List;
-
- -- End test code declarations. -------------------------
-
-
-begin
-
- Report.Test ("CC70C01", "Check that a generic formal package may be " &
- "passed as an actual in an instantiation of a generic " &
- "package");
-
- TC_Initialize_List (Scores);
- TC_Verify_List (Scores, TC_List_Values, TC_Correct_List_Values);
-
- if not TC_Correct_List_Values then
- Report.Failed ("List contains incorrect values");
- end if;
-
- Report.Result;
-
-end CC70C01;
diff --git a/gcc/testsuite/ada/acats/tests/cc/cc70c02.a b/gcc/testsuite/ada/acats/tests/cc/cc70c02.a
deleted file mode 100644
index f479193b534..00000000000
--- a/gcc/testsuite/ada/acats/tests/cc/cc70c02.a
+++ /dev/null
@@ -1,192 +0,0 @@
--- CC70C02.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that a generic formal package is an instance. Specifically,
--- check that a generic formal package may be passed as an actual
--- parameter to another generic formal package. Check that the
--- visible part of the generic formal package includes the first list of
--- basic declarative items of the package specification.
---
--- TEST DESCRIPTION:
--- A generic formal package is a package, and is an instance.
---
--- Declare a list type in a generic package for lists of elements of any
--- nonlimited type (foundation code). Declare a second generic package
--- which declares operations for the list type, and parameterize it with
--- a generic formal package with the list-type package as template
--- (foundation code). Declare a third generic package which declares
--- additional operations for the list type, and parameterize it with two
--- generic formal packages, one with the list-type package as template,
--- the other with the second generic package as template. Use the first
--- formal package as the generic formal actual part for the second formal
--- package.
---
--- TEST FILES:
--- The following files comprise this test:
---
--- FC70C00.A
--- CC70C02.A
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
---
---!
-
-with FC70C00_0; -- List abstraction.
-with FC70C00_1; -- Basic list operations.
-generic
-
- -- Import both the list-type abstraction defined in FC70C00_0 and the basic
- -- list operations defined in FC70C00_1. To ensure that only basic operation
- -- instances for lists of the same element type as that used to instantiate
- -- the list type are accepted as actuals to this generic, pass the list-type
- -- formal package as an actual parameter to the list-operation formal
- -- package.
-
- with package Lists is new FC70C00_0 (<>);
- with package Basic_List_Ops is new FC70C00_1 (Lists);
-package CC70C02_0 is -- Additional list operations.
-
- End_of_List_Reached : exception;
-
-
- -- Read from current element and advance "current" pointer.
- procedure Read_Element (L : in out Lists.List_Type;
- E : out Lists.Element_Type);
-
- -- Add element to end of list.
- procedure Add_Element (L : in out Lists.List_Type;
- E : in Lists.Element_Type);
-
-end CC70C02_0;
-
-
- --==================================================================--
-
-
-package body CC70C02_0 is
-
- procedure Read_Element (L : in out Lists.List_Type;
- E : out Lists.Element_Type) is
- begin
- if Basic_List_Ops.End_Of_List (L) then -- Use of op from the previous
- raise End_Of_List_Reached; -- generic package.
- else
- E := L.Current.Item; -- Retrieve current element.
- L.Current := L.Current.Next; -- Advance "current" pointer.
- end if;
- end Read_Element;
-
-
- procedure Add_Element (L : in out Lists.List_Type;
- E : in Lists.Element_Type) is
- New_Node : Lists.Node_Pointer := new Lists.Node_Type'(E, null);
- use type Lists.Node_Pointer;
- begin
- if L.First = null then -- No elements in list, so add new
- L.First := New_Node; -- element at beginning of list.
- else
- L.Last.Next := New_Node; -- Add new element at end of list.
- end if;
- L.Last := New_Node; -- Set last-in-list pointer.
- end Add_Element;
-
-
-end CC70C02_0;
-
-
- --==================================================================--
-
-
-with FC70C00_0; -- Generic list type abstraction.
-with FC70C00_1; -- Generic list operations.
-with CC70C02_0; -- Additional generic list operations.
-
-with Report;
-procedure CC70C02 is
-
- type Points is range 0 .. 100; -- Discrete type.
-
- package Lists_of_Points is new FC70C00_0 (Points); -- Points lists.
-
- package Basic_Point_Ops is new -- Basic points-list ops.
- FC70C00_1 (Lists_Of_Points);
-
- package Points_List_Ops is new -- More points-list ops.
- CC70C02_0 (Lists => Lists_Of_Points,
- Basic_List_Ops => Basic_Point_Ops);
-
- Scores : Lists_of_Points.List_Type; -- List of points.
-
-
- -- Begin test code declarations: -----------------------
-
- type TC_Score_Array is array (1 .. 3) of Points;
-
- TC_List_Values : constant TC_Score_Array := (23, 15, 0);
-
- TC_Correct_List_Values : Boolean := False;
-
-
- procedure TC_Initialize_List (L : in out Lists_Of_Points.List_Type) is
- begin -- Initial list contains 3 scores
- for I in TC_Score_Array'Range loop -- with the values 23, 15, and 0.
- Points_List_Ops.Add_Element (L, TC_List_Values(I));
- end loop;
- end TC_Initialize_List;
-
-
- procedure TC_Verify_List (L : in out Lists_Of_Points.List_Type;
- Expected : in TC_Score_Array;
- OK : out Boolean) is
- Actual : TC_Score_Array;
- begin
- Basic_Point_Ops.Reset (L);
- for I in TC_Score_Array'Range loop
- Points_List_Ops.Read_Element (L, Actual(I));
- end loop;
- OK := (Actual = Expected);
- end TC_Verify_List;
-
- -- End test code declarations. -------------------------
-
-
-begin
-
- Report.Test ("CC70C02", "Check that a generic formal package may be " &
- "passed as an actual to another formal package");
-
- TC_Initialize_List (Scores);
- TC_Verify_List (Scores, TC_List_Values, TC_Correct_List_Values);
-
- if not TC_Correct_List_Values then
- Report.Failed ("List contains incorrect values");
- end if;
-
- Report.Result;
-
-end CC70C02;
diff --git a/gcc/testsuite/ada/acats/tests/cd/cd10001.a b/gcc/testsuite/ada/acats/tests/cd/cd10001.a
deleted file mode 100644
index 6b44067c904..00000000000
--- a/gcc/testsuite/ada/acats/tests/cd/cd10001.a
+++ /dev/null
@@ -1,300 +0,0 @@
--- CD10001.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that representation items may contain nonstatic expressions
--- in the case that each expression in the representation item is a
--- name that statically denotes a constant declared before the entity.
---
---
--- TEST DESCRIPTION:
--- For each of the specific items in the objective, this test checks
--- an example of each of the categories of representation specification
--- that are applicable to that objective, to wit:
--- address clause ....................... Expressions need not be static
--- alignment clause ..................... Expressions must be static
--- bit order clause ..................... Not tested
--- component size clause ................ Expressions must be static
--- enumeration representation clause .... Expressions must be static
--- external tag clause .................. Expressions must be static
--- Import, Export and Convention pragmas Not tested
--- input clause ......................... Not tested
--- output clause ........................ Not tested
--- Pack pragma .......................... Not tested
--- read clause .......................... Not tested
--- record representation clause ......... Expressions must be static
--- size clause .......................... Expressions must be static
--- small clause ......................... Expressions must be static
--- storage pool clause .................. Not tested
--- storage size clause .................. Expressions must be static
--- write clause ......................... Not tested
---
--- APPLICABILITY CRITERIA:
--- All implementations must attempt to compile this test.
---
--- For implementations validating against Systems Programming Annex (C):
--- this test must execute.
---
--- For implementations not validating against Annex C:
--- if this test compiles without error messages at compilation,
--- it must bind and execute.
---
--- PASS/FAIL CRITERIA:
--- For implementations validating against Systems Programming Annex (C):
--- this test must execute, report PASSED, and complete normally,
--- otherwise the test FAILS
---
--- For implementations not validating against Annex C:
--- PASSING behavior is:
--- this test executes, reports PASSED, and completes normally
--- or
--- this test executes and reports NOT_APPLICABLE
--- or
--- this test produces at least one error message at compilation, and
--- the error message is associated with one of the items marked:
--- -- N/A => ERROR.
---
--- All other behaviors are FAILING.
---
-
--- CHANGE HISTORY:
--- 11 JUL 95 SAIC Initial version
--- 10 MAR 97 PWB.CTA Made Nonstatic_Entity nonstatic; changed
--- Tenths'Small from 1.0/32.0 to 1.0/10.0,
--- as expected by the later check; improved
--- internal documentation.
--- 16 FEB 98 EDS Modified test documentation.
--- 24 NOV 98 RLB Changed Tenths'Small to 1.0/32.0, as this is
--- necessary so that all implementations can
--- process this test. (3.5.9(21) means non-binary
--- smalls are optional.)
--- 11 MAR 99 RLB Merged versions. Most EDS changes removed (as
--- they made the test less applicable than the ACAA
--- version).
---!
-
------------------------------------------------------------------ CD10001_0
-
-with System;
-with System.Storage_Elements;
-with Impdef;
-with SPPRT13;
-package CD10001_0 is
-
- -- a few types and objects to work with.
-
- type Int is range -2048 .. 2047;
- My_Int : Int := 1024;
-
- type Enumeration is (First, Second, Third, Fourth, Fifth);
-
- -- a few names that statically denote constants:
-
- Nonstatic_Entity : constant System.Address := -- Non-static
- System.Storage_Elements."+"
- ( SPPRT13.Variable_Address,
- System.Storage_Elements.Storage_Offset'(0) );
-
- Tag_String : constant String := Impdef.External_Tag_Value; -- Static
- -- Check to ensure that Tag_String is static
- Tag_String_Length : constant := Tag_String'Length;
-
- A_Reasonable_Size_Value : constant := System.Storage_Unit; -- Static
-
- Zero : constant := 0; -- Static
- One : constant := 1; -- Static
- Two : constant := 2; -- Static
- Three : constant := 3; -- Static
- Four : constant := 4; -- Static
- Five : constant := 5; -- Static
-
- K : constant Int := My_Int; -- Non-Static
-
--- Check that representation items containing nonstatic expressions are
--- supported in the case that the representation item is a name that
--- statically denotes a constant declared before the entity.
---
--- address clause
--- Expression must be static - RM 13.3(12)
-
- Object_Address : Enumeration;
- for Object_Address'Address use Nonstatic_Entity; -- N/A => ERROR.
-
--- alignment clause
--- Expression must be static - RM 13.3(25)
-
- Object_Alignment : Enumeration;
- for Object_Alignment'Alignment use One; -- N/A => ERROR.
-
--- bit order clause
--- no interesting test can be specified
-
--- component size clause
--- Expression must be static - RM 13.3(69)
-
- type Array_With_Components is array(1..10) of Enumeration;
- for Array_With_Components'Component_Size
- use A_Reasonable_Size_Value; -- N/A => ERROR.
-
--- enumeration representation clause
--- Expressions must be static - RM 13.4(6)
-
- type Enumeration_1 is (First, Second, Third);
- for Enumeration_1 use (First => One, Second => Two, Third => Three);
-
--- external tag clause
--- Expression must be static - RM 13.3(75)
-
- type Some_Tagged_Type is tagged null record;
- for Some_Tagged_Type'External_Tag use Tag_String; -- N/A => ERROR.
-
--- Import, Export and Convention pragmas
--- no interesting test can be specified
-
--- input clause
--- no interesting test can be specified
-
--- output clause
--- no interesting test can be specified
-
--- Pack pragma
--- no interesting test can be specified
-
--- read clause
--- no interesting test can be specified
-
--- record representation clause
--- Expressions must be static - RM 13.3(10)
-
- type Record_To_Layout is record
- Bit_0 : Boolean;
- Bit_1 : Boolean;
- end record;
- for Record_To_Layout use record -- N/A => ERROR.
- Bit_0 at Zero range Zero..Zero; -- N/A => ERROR.
- Bit_1 at Zero range Four..Four; -- N/A => ERROR.
- end record; -- N/A => ERROR.
-
--- size clause
--- Expression must be static - RM 13.3(41)
-
- Object_Size : Enumeration;
- for Object_Size'Size use A_Reasonable_Size_Value; -- N/A => ERROR.
-
--- small clause
--- Expression must be static - RM 3.5.10(2)
-
- type Tenths is delta 0.1 range 0.0..10.0;
- for Tenths'Small use 1.0 / (Two ** Five); -- N/A => ERROR.
-
--- storage pool clause
--- Not tested
-
--- storage size clause
--- Expression may be non-static - RM 13.11(15)
- type Reference is access Record_To_Layout;
- for Reference'Storage_Size use Four * K; -- N/A => ERROR.
-
-
--- write clause
--- no interesting test can be specified
-
- procedure TC_Check_Values;
-
-end CD10001_0;
-
--- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
-
-with TCTouch;
-package body CD10001_0 is
-
- use type System.Address;
-
- procedure Assert( Truth : Boolean; Message: String ) is
- begin
- if not Truth then
- TCTouch.Implementation_Check( Message );
- end if;
- end Assert;
-
- procedure TC_Check_Values is
- Record_Object : Record_To_Layout;
- begin
-
- Assert(Object_Address'Address = Nonstatic_Entity,
- "Object not at specified address");
-
- Assert(Object_Alignment'Alignment >= One,
- "Object not at specified alignment");
-
- Assert(Array_With_Components'Component_Size = A_Reasonable_Size_Value,
- "Array Components not specified size");
-
--- I don't see how to reliably check this one:
---
--- type Enumeration_1 is (First, Second, Third);
--- for Enumeration_1 use (First => One, Second => Two, Third => Three);
-
- Assert(Some_Tagged_Type'External_Tag = Tag_String,
- "External_Tag not specified value");
- Assert(Record_Object.Bit_0'First_Bit = Zero,
- "Record object First_Bit not zero");
-
- Assert(Record_Object.Bit_1'Last_Bit = Four,
- "Record object Last_Bit not four");
-
- Assert(Object_Size'Size = A_Reasonable_Size_Value,
- "Object size not specified value");
-
- Assert(Tenths'Small = 1.0 / Two ** Five,
- "Tenths small not specified value");
-
- Assert(Reference'Storage_Size = 4096, -- Four * K,
- "Reference storage size not specified value");
-
- end TC_Check_Values;
-
-end CD10001_0;
-
-------------------------------------------------------------------- CD10001
-
-with Report;
-with CD10001_0;
-
-procedure CD10001 is
-
-begin -- Main test procedure.
-
- Report.Test ("CD10001", "Check that representation items containing " &
- "nonstatic expressions are supported in the " &
- "case that the representation item is a name " &
- "that statically denotes a constant declared " &
- "before the entity" );
-
- CD10001_0.TC_Check_Values;
-
- Report.Result;
-
-end CD10001;
diff --git a/gcc/testsuite/ada/acats/tests/cd/cd10002.a b/gcc/testsuite/ada/acats/tests/cd/cd10002.a
deleted file mode 100644
index fc56d4299df..00000000000
--- a/gcc/testsuite/ada/acats/tests/cd/cd10002.a
+++ /dev/null
@@ -1,1198 +0,0 @@
--- CD10002.A
---
--- Grant of Unlimited Rights
---
--- The Ada Conformity Assessment Authority (ACAA) holds unlimited
--- rights in the software and documentation contained herein. Unlimited
--- rights are the same as those granted by the U.S. Government for older
--- parts of the Ada Conformity Assessment Test Suite, and are defined
--- in DFAR 252.227-7013(a)(19). By making this public release, the ACAA
--- intends to confer upon all recipients unlimited rights equal to those
--- held by the ACAA. These rights include rights to use, duplicate,
--- release or disclose the released technical data and computer software
--- in whole or in part, in any manner and for any purpose whatsoever, and
--- to have or permit others to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that operational items are allowed in some contexts where
--- representation items are not:
---
--- 1 - Check that the name of an incompletely defined type can be used
--- when specifying an operational item. (RM95/TC1 7.3(5)).
---
--- 2 - Check that operational items can be specified for a descendant of
--- a generic formal untagged type. (RM95/TC1 13.1(10)).
---
--- 3 - Check that operational items can be specified for a derived
--- untagged type even if the parent type is a by-reference type or
--- has user-defined primitive subprograms. (RM95/TC1 13.1(11/1)).
---
--- (Defect Report 8652/0009, as reflected in Technical Corrigendum 1).
---
--- CHANGE HISTORY:
--- 19 JAN 2001 PHL Initial version.
--- 3 DEC 2001 RLB Reformatted for ACATS.
--- 3 OCT 2002 RLB Corrected incorrect type derivations.
---
---!
-with Ada.Streams;
-use Ada.Streams;
-package CD10002_0 is
-
- type Kinds is (Read, Write, Input, Output);
- type Counts is array (Kinds) of Natural;
-
- generic
- type T is private;
- package Nonlimited_Stream_Ops is
-
- procedure Write (Stream : access Root_Stream_Type'Class; Item : T);
- function Input (Stream : access Root_Stream_Type'Class) return T;
- procedure Read (Stream : access Root_Stream_Type'Class; Item : out T);
- procedure Output (Stream : access Root_Stream_Type'Class; Item : T);
-
- function Get_Counts return Counts;
-
- end Nonlimited_Stream_Ops;
-
- generic
- type T (<>) is limited private; -- Should be self-initializing.
- C : in out T;
- package Limited_Stream_Ops is
-
- procedure Write (Stream : access Root_Stream_Type'Class; Item : T);
- function Input (Stream : access Root_Stream_Type'Class) return T;
- procedure Read (Stream : access Root_Stream_Type'Class; Item : out T);
- procedure Output (Stream : access Root_Stream_Type'Class; Item : T);
-
- function Get_Counts return Counts;
-
- end Limited_Stream_Ops;
-
-end CD10002_0;
-
-
-package body CD10002_0 is
-
- package body Nonlimited_Stream_Ops is
- Cnts : Counts := (others => 0);
- X : T; -- Initialized by Write/Output.
-
- procedure Write (Stream : access Root_Stream_Type'Class; Item : T) is
- begin
- X := Item;
- Cnts (Write) := Cnts (Write) + 1;
- end Write;
-
- function Input (Stream : access Root_Stream_Type'Class) return T is
- begin
- Cnts (Input) := Cnts (Input) + 1;
- return X;
- end Input;
-
- procedure Read (Stream : access Root_Stream_Type'Class; Item : out T) is
- begin
- Cnts (Read) := Cnts (Read) + 1;
- Item := X;
- end Read;
-
- procedure Output (Stream : access Root_Stream_Type'Class; Item : T) is
- begin
- X := Item;
- Cnts (Output) := Cnts (Output) + 1;
- end Output;
-
- function Get_Counts return Counts is
- begin
- return Cnts;
- end Get_Counts;
-
- end Nonlimited_Stream_Ops;
-
- package body Limited_Stream_Ops is
- Cnts : Counts := (others => 0);
-
- procedure Write (Stream : access Root_Stream_Type'Class; Item : T) is
- begin
- Cnts (Write) := Cnts (Write) + 1;
- end Write;
-
- function Input (Stream : access Root_Stream_Type'Class) return T is
- begin
- Cnts (Input) := Cnts (Input) + 1;
- return C;
- end Input;
-
- procedure Read (Stream : access Root_Stream_Type'Class; Item : out T) is
- begin
- Cnts (Read) := Cnts (Read) + 1;
- end Read;
-
- procedure Output (Stream : access Root_Stream_Type'Class; Item : T) is
- begin
- Cnts (Output) := Cnts (Output) + 1;
- end Output;
-
- function Get_Counts return Counts is
- begin
- return Cnts;
- end Get_Counts;
-
- end Limited_Stream_Ops;
-
-end CD10002_0;
-
-
-with Ada.Streams;
-use Ada.Streams;
-package CD10002_1 is
-
- type Dummy_Stream is new Root_Stream_Type with null record;
- procedure Read (Stream : in out Dummy_Stream;
- Item : out Stream_Element_Array;
- Last : out Stream_Element_Offset);
- procedure Write (Stream : in out Dummy_Stream;
- Item : Stream_Element_Array);
-
-end CD10002_1;
-
-
-with Report;
-use Report;
-package body CD10002_1 is
-
- procedure Read (Stream : in out Dummy_Stream;
- Item : out Stream_Element_Array;
- Last : out Stream_Element_Offset) is
- begin
- Failed ("Unexpected call to the Read operation of Dummy_Stream");
- end Read;
-
- procedure Write (Stream : in out Dummy_Stream;
- Item : Stream_Element_Array) is
- begin
- Failed ("Unexpected call to the Write operation of Dummy_Stream");
- end Write;
-
-end CD10002_1;
-
-
-with Ada.Streams;
-use Ada.Streams;
-with CD10002_0;
-package CD10002_Deriv is
-
- -- Parent has user-defined subprograms.
-
- type T1 is new Boolean;
- function Is_Odd (X : Integer) return T1;
-
- type T2 is
- record
- F : Float;
- end record;
- procedure Print (X : T2);
-
- type T3 is array (Boolean) of Duration;
- function "+" (L, R : T3) return T3;
-
- -- Parent is by-reference. No need to check the case where the parent
- -- is tagged, because the defect report only deals with untagged types.
-
- task type T4 is
- end T4;
-
- protected type T5 is
- end T5;
-
- type T6 (D : access Integer := new Integer'(2)) is limited null record;
-
- type T7 is array (Character) of T6;
-
- package P is
- type T8 is limited private;
- private
- type T8 is new T5;
- end P;
-
- type Nt1 is new T1;
- type Nt2 is new T2;
- type Nt3 is new T3;
- type Nt4 is new T4;
- type Nt5 is new T5;
- type Nt6 is new T6;
- type Nt7 is new T7;
- type Nt8 is new P.T8;
-
- procedure Write (Stream : access Root_Stream_Type'Class; Item : Nt1'Base);
- function Input (Stream : access Root_Stream_Type'Class) return Nt1'Base;
- procedure Read (Stream : access Root_Stream_Type'Class;
- Item : out Nt1'Base);
- procedure Output (Stream : access Root_Stream_Type'Class; Item : Nt1'Base);
-
- procedure Write (Stream : access Root_Stream_Type'Class; Item : Nt2);
- function Input (Stream : access Root_Stream_Type'Class) return Nt2;
- procedure Read (Stream : access Root_Stream_Type'Class; Item : out Nt2);
- procedure Output (Stream : access Root_Stream_Type'Class; Item : Nt2);
-
- procedure Write (Stream : access Root_Stream_Type'Class; Item : Nt3);
- function Input (Stream : access Root_Stream_Type'Class) return Nt3;
- procedure Read (Stream : access Root_Stream_Type'Class; Item : out Nt3);
- procedure Output (Stream : access Root_Stream_Type'Class; Item : Nt3);
-
- procedure Write (Stream : access Root_Stream_Type'Class; Item : Nt4);
- function Input (Stream : access Root_Stream_Type'Class) return Nt4;
- procedure Read (Stream : access Root_Stream_Type'Class; Item : out Nt4);
- procedure Output (Stream : access Root_Stream_Type'Class; Item : Nt4);
-
- procedure Write (Stream : access Root_Stream_Type'Class; Item : Nt5);
- function Input (Stream : access Root_Stream_Type'Class) return Nt5;
- procedure Read (Stream : access Root_Stream_Type'Class; Item : out Nt5);
- procedure Output (Stream : access Root_Stream_Type'Class; Item : Nt5);
-
- procedure Write (Stream : access Root_Stream_Type'Class; Item : Nt6);
- function Input (Stream : access Root_Stream_Type'Class) return Nt6;
- procedure Read (Stream : access Root_Stream_Type'Class; Item : out Nt6);
- procedure Output (Stream : access Root_Stream_Type'Class; Item : Nt6);
-
- procedure Write (Stream : access Root_Stream_Type'Class; Item : Nt7);
- function Input (Stream : access Root_Stream_Type'Class) return Nt7;
- procedure Read (Stream : access Root_Stream_Type'Class; Item : out Nt7);
- procedure Output (Stream : access Root_Stream_Type'Class; Item : Nt7);
-
- procedure Write (Stream : access Root_Stream_Type'Class; Item : Nt8);
- function Input (Stream : access Root_Stream_Type'Class) return Nt8;
- procedure Read (Stream : access Root_Stream_Type'Class; Item : out Nt8);
- procedure Output (Stream : access Root_Stream_Type'Class; Item : Nt8);
-
- for Nt1'Write use Write;
- for Nt1'Read use Read;
- for Nt1'Output use Output;
- for Nt1'Input use Input;
-
- for Nt2'Write use Write;
- for Nt2'Read use Read;
- for Nt2'Output use Output;
- for Nt2'Input use Input;
-
- for Nt3'Write use Write;
- for Nt3'Read use Read;
- for Nt3'Output use Output;
- for Nt3'Input use Input;
-
- for Nt4'Write use Write;
- for Nt4'Read use Read;
- for Nt4'Output use Output;
- for Nt4'Input use Input;
-
- for Nt5'Write use Write;
- for Nt5'Read use Read;
- for Nt5'Output use Output;
- for Nt5'Input use Input;
-
- for Nt6'Write use Write;
- for Nt6'Read use Read;
- for Nt6'Output use Output;
- for Nt6'Input use Input;
-
- for Nt7'Write use Write;
- for Nt7'Read use Read;
- for Nt7'Output use Output;
- for Nt7'Input use Input;
-
- for Nt8'Write use Write;
- for Nt8'Read use Read;
- for Nt8'Output use Output;
- for Nt8'Input use Input;
-
- -- All these variables are self-initializing.
- C4 : Nt4;
- C5 : Nt5;
- C6 : Nt6;
- C7 : Nt7;
- C8 : Nt8;
-
- package Nt1_Ops is new CD10002_0.Nonlimited_Stream_Ops (Nt1'Base);
- package Nt2_Ops is new CD10002_0.Nonlimited_Stream_Ops (Nt2);
- package Nt3_Ops is new CD10002_0.Nonlimited_Stream_Ops (Nt3);
- package Nt4_Ops is new CD10002_0.Limited_Stream_Ops (Nt4, C4);
- package Nt5_Ops is new CD10002_0.Limited_Stream_Ops (Nt5, C5);
- package Nt6_Ops is new CD10002_0.Limited_Stream_Ops (Nt6, C6);
- package Nt7_Ops is new CD10002_0.Limited_Stream_Ops (Nt7, C7);
- package Nt8_Ops is new CD10002_0.Limited_Stream_Ops (Nt8, C8);
-
-end CD10002_Deriv;
-
-
-package body CD10002_Deriv is
-
- function Is_Odd (X : Integer) return T1 is
- begin
- return True;
- end Is_Odd;
- procedure Print (X : T2) is
- begin
- null;
- end Print;
- function "+" (L, R : T3) return T3 is
- begin
- return (False => L (False) + R (True), True => L (True) + R (False));
- end "+";
- task body T4 is
- begin
- null;
- end T4;
- protected body T5 is
- end T5;
-
- procedure Write (Stream : access Root_Stream_Type'Class; Item : Nt1'Base)
- renames Nt1_Ops.Write;
- function Input (Stream : access Root_Stream_Type'Class) return Nt1'Base
- renames Nt1_Ops.Input;
- procedure Read (Stream : access Root_Stream_Type'Class; Item : out Nt1'Base)
- renames Nt1_Ops.Read;
- procedure Output (Stream : access Root_Stream_Type'Class; Item : Nt1'Base)
- renames Nt1_Ops.Output;
-
- procedure Write (Stream : access Root_Stream_Type'Class; Item : Nt2)
- renames Nt2_Ops.Write;
- function Input (Stream : access Root_Stream_Type'Class) return Nt2
- renames Nt2_Ops.Input;
- procedure Read (Stream : access Root_Stream_Type'Class; Item : out Nt2)
- renames Nt2_Ops.Read;
- procedure Output (Stream : access Root_Stream_Type'Class; Item : Nt2)
- renames Nt2_Ops.Output;
-
- procedure Write (Stream : access Root_Stream_Type'Class; Item : Nt3)
- renames Nt3_Ops.Write;
- function Input (Stream : access Root_Stream_Type'Class) return Nt3
- renames Nt3_Ops.Input;
- procedure Read (Stream : access Root_Stream_Type'Class; Item : out Nt3)
- renames Nt3_Ops.Read;
- procedure Output (Stream : access Root_Stream_Type'Class; Item : Nt3)
- renames Nt3_Ops.Output;
-
- procedure Write (Stream : access Root_Stream_Type'Class; Item : Nt4)
- renames Nt4_Ops.Write;
- function Input (Stream : access Root_Stream_Type'Class) return Nt4
- renames Nt4_Ops.Input;
- procedure Read (Stream : access Root_Stream_Type'Class; Item : out Nt4)
- renames Nt4_Ops.Read;
- procedure Output (Stream : access Root_Stream_Type'Class; Item : Nt4)
- renames Nt4_Ops.Output;
-
- procedure Write (Stream : access Root_Stream_Type'Class; Item : Nt5)
- renames Nt5_Ops.Write;
- function Input (Stream : access Root_Stream_Type'Class) return Nt5
- renames Nt5_Ops.Input;
- procedure Read (Stream : access Root_Stream_Type'Class; Item : out Nt5)
- renames Nt5_Ops.Read;
- procedure Output (Stream : access Root_Stream_Type'Class; Item : Nt5)
- renames Nt5_Ops.Output;
-
- procedure Write (Stream : access Root_Stream_Type'Class; Item : Nt6)
- renames Nt6_Ops.Write;
- function Input (Stream : access Root_Stream_Type'Class) return Nt6
- renames Nt6_Ops.Input;
- procedure Read (Stream : access Root_Stream_Type'Class; Item : out Nt6)
- renames Nt6_Ops.Read;
- procedure Output (Stream : access Root_Stream_Type'Class; Item : Nt6)
- renames Nt6_Ops.Output;
-
- procedure Write (Stream : access Root_Stream_Type'Class; Item : Nt7)
- renames Nt7_Ops.Write;
- function Input (Stream : access Root_Stream_Type'Class) return Nt7
- renames Nt7_Ops.Input;
- procedure Read (Stream : access Root_Stream_Type'Class; Item : out Nt7)
- renames Nt7_Ops.Read;
- procedure Output (Stream : access Root_Stream_Type'Class; Item : Nt7)
- renames Nt7_Ops.Output;
-
- procedure Write (Stream : access Root_Stream_Type'Class; Item : Nt8)
- renames Nt8_Ops.Write;
- function Input (Stream : access Root_Stream_Type'Class) return Nt8
- renames Nt8_Ops.Input;
- procedure Read (Stream : access Root_Stream_Type'Class; Item : out Nt8)
- renames Nt8_Ops.Read;
- procedure Output (Stream : access Root_Stream_Type'Class; Item : Nt8)
- renames Nt8_Ops.Output;
-
-end CD10002_Deriv;
-
-
-with Ada.Streams;
-use Ada.Streams;
-with CD10002_0;
-generic
- type T1 is (<>);
- type T2 is range <>;
- type T3 is mod <>;
- type T4 is digits <>;
- type T5 is delta <>;
- type T6 is delta <> digits <>;
- type T7 is access T3;
- type T8 is new Boolean;
- type T9 is private;
- type T10 (<>) is limited private; -- Should be self-initializing.
- C10 : in out T10;
- type T11 is array (T1) of T2;
-package CD10002_Gen is
-
- -- Direct descendants.
- type Nt1 is new T1;
- type Nt2 is new T2;
- type Nt3 is new T3;
- type Nt4 is new T4;
- type Nt5 is new T5;
- type Nt6 is new T6;
- type Nt7 is new T7;
- type Nt8 is new T8;
- type Nt9 is new T9;
- type Nt10 is new T10;
- type Nt11 is new T11;
-
- -- Indirect descendants (only pick two, a limited one and a non-limited
- -- one).
- type Nt12 is new Nt10;
- type Nt13 is new Nt11;
-
- procedure Write (Stream : access Root_Stream_Type'Class; Item : Nt1'Base);
- function Input (Stream : access Root_Stream_Type'Class) return Nt1'Base;
- procedure Read (Stream : access Root_Stream_Type'Class;
- Item : out Nt1'Base);
- procedure Output (Stream : access Root_Stream_Type'Class; Item : Nt1'Base);
-
- procedure Write (Stream : access Root_Stream_Type'Class; Item : Nt2'Base);
- function Input (Stream : access Root_Stream_Type'Class) return Nt2'Base;
- procedure Read (Stream : access Root_Stream_Type'Class;
- Item : out Nt2'Base);
- procedure Output (Stream : access Root_Stream_Type'Class; Item : Nt2'Base);
-
- procedure Write (Stream : access Root_Stream_Type'Class; Item : Nt3'Base);
- function Input (Stream : access Root_Stream_Type'Class) return Nt3'Base;
- procedure Read (Stream : access Root_Stream_Type'Class;
- Item : out Nt3'Base);
- procedure Output (Stream : access Root_Stream_Type'Class; Item : Nt3'Base);
-
- procedure Write (Stream : access Root_Stream_Type'Class; Item : Nt4'Base);
- function Input (Stream : access Root_Stream_Type'Class) return Nt4'Base;
- procedure Read (Stream : access Root_Stream_Type'Class;
- Item : out Nt4'Base);
- procedure Output (Stream : access Root_Stream_Type'Class; Item : Nt4'Base);
-
- procedure Write (Stream : access Root_Stream_Type'Class; Item : Nt5'Base);
- function Input (Stream : access Root_Stream_Type'Class) return Nt5'Base;
- procedure Read (Stream : access Root_Stream_Type'Class;
- Item : out Nt5'Base);
- procedure Output (Stream : access Root_Stream_Type'Class; Item : Nt5'Base);
-
- procedure Write (Stream : access Root_Stream_Type'Class; Item : Nt6'Base);
- function Input (Stream : access Root_Stream_Type'Class) return Nt6'Base;
- procedure Read (Stream : access Root_Stream_Type'Class;
- Item : out Nt6'Base);
- procedure Output (Stream : access Root_Stream_Type'Class; Item : Nt6'Base);
-
- procedure Write (Stream : access Root_Stream_Type'Class; Item : Nt7);
- function Input (Stream : access Root_Stream_Type'Class) return Nt7;
- procedure Read (Stream : access Root_Stream_Type'Class; Item : out Nt7);
- procedure Output (Stream : access Root_Stream_Type'Class; Item : Nt7);
-
- procedure Write (Stream : access Root_Stream_Type'Class; Item : Nt8'Base);
- function Input (Stream : access Root_Stream_Type'Class) return Nt8'Base;
- procedure Read (Stream : access Root_Stream_Type'Class;
- Item : out Nt8'Base);
- procedure Output (Stream : access Root_Stream_Type'Class; Item : Nt8'Base);
-
- procedure Write (Stream : access Root_Stream_Type'Class; Item : Nt9);
- function Input (Stream : access Root_Stream_Type'Class) return Nt9;
- procedure Read (Stream : access Root_Stream_Type'Class; Item : out Nt9);
- procedure Output (Stream : access Root_Stream_Type'Class; Item : Nt9);
-
- procedure Write (Stream : access Root_Stream_Type'Class; Item : Nt10);
- function Input (Stream : access Root_Stream_Type'Class) return Nt10;
- procedure Read (Stream : access Root_Stream_Type'Class; Item : out Nt10);
- procedure Output (Stream : access Root_Stream_Type'Class; Item : Nt10);
-
- procedure Write (Stream : access Root_Stream_Type'Class; Item : Nt11);
- function Input (Stream : access Root_Stream_Type'Class) return Nt11;
- procedure Read (Stream : access Root_Stream_Type'Class; Item : out Nt11);
- procedure Output (Stream : access Root_Stream_Type'Class; Item : Nt11);
-
- procedure Write (Stream : access Root_Stream_Type'Class; Item : Nt12);
- function Input (Stream : access Root_Stream_Type'Class) return Nt12;
- procedure Read (Stream : access Root_Stream_Type'Class; Item : out Nt12);
- procedure Output (Stream : access Root_Stream_Type'Class; Item : Nt12);
-
- procedure Write (Stream : access Root_Stream_Type'Class; Item : Nt13);
- function Input (Stream : access Root_Stream_Type'Class) return Nt13;
- procedure Read (Stream : access Root_Stream_Type'Class; Item : out Nt13);
- procedure Output (Stream : access Root_Stream_Type'Class; Item : Nt13);
-
- for Nt1'Write use Write;
- for Nt1'Read use Read;
- for Nt1'Output use Output;
- for Nt1'Input use Input;
-
- for Nt2'Write use Write;
- for Nt2'Read use Read;
- for Nt2'Output use Output;
- for Nt2'Input use Input;
-
- for Nt3'Write use Write;
- for Nt3'Read use Read;
- for Nt3'Output use Output;
- for Nt3'Input use Input;
-
- for Nt4'Write use Write;
- for Nt4'Read use Read;
- for Nt4'Output use Output;
- for Nt4'Input use Input;
-
- for Nt5'Write use Write;
- for Nt5'Read use Read;
- for Nt5'Output use Output;
- for Nt5'Input use Input;
-
- for Nt6'Write use Write;
- for Nt6'Read use Read;
- for Nt6'Output use Output;
- for Nt6'Input use Input;
-
- for Nt7'Write use Write;
- for Nt7'Read use Read;
- for Nt7'Output use Output;
- for Nt7'Input use Input;
-
- for Nt8'Write use Write;
- for Nt8'Read use Read;
- for Nt8'Output use Output;
- for Nt8'Input use Input;
-
- for Nt9'Write use Write;
- for Nt9'Read use Read;
- for Nt9'Output use Output;
- for Nt9'Input use Input;
-
- for Nt10'Write use Write;
- for Nt10'Read use Read;
- for Nt10'Output use Output;
- for Nt10'Input use Input;
-
- for Nt11'Write use Write;
- for Nt11'Read use Read;
- for Nt11'Output use Output;
- for Nt11'Input use Input;
-
- for Nt12'Write use Write;
- for Nt12'Read use Read;
- for Nt12'Output use Output;
- for Nt12'Input use Input;
-
- for Nt13'Write use Write;
- for Nt13'Read use Read;
- for Nt13'Output use Output;
- for Nt13'Input use Input;
-
- type Null_Record is null record;
-
- package Nt1_Ops is new CD10002_0.Nonlimited_Stream_Ops (Nt1'Base);
- package Nt2_Ops is new CD10002_0.Nonlimited_Stream_Ops (Nt2'Base);
- package Nt3_Ops is new CD10002_0.Nonlimited_Stream_Ops (Nt3'Base);
- package Nt4_Ops is new CD10002_0.Nonlimited_Stream_Ops (Nt4'Base);
- package Nt5_Ops is new CD10002_0.Nonlimited_Stream_Ops (Nt5'Base);
- package Nt6_Ops is new CD10002_0.Nonlimited_Stream_Ops (Nt6'Base);
- package Nt7_Ops is new CD10002_0.Nonlimited_Stream_Ops (Nt7);
- package Nt8_Ops is new CD10002_0.Nonlimited_Stream_Ops (Nt8'Base);
- package Nt9_Ops is new CD10002_0.Nonlimited_Stream_Ops (Nt9);
- package Nt11_Ops is new CD10002_0.Nonlimited_Stream_Ops (Nt11);
- package Nt13_Ops is new CD10002_0.Nonlimited_Stream_Ops (Nt13);
-
- function Get_Nt10_Counts return CD10002_0.Counts;
- function Get_Nt12_Counts return CD10002_0.Counts;
-
-end CD10002_Gen;
-
-
-package body CD10002_Gen is
-
- use CD10002_0;
-
- Nt10_Cnts : Counts := (others => 0);
- Nt12_Cnts : Counts := (others => 0);
-
- procedure Write (Stream : access Root_Stream_Type'Class; Item : Nt1'Base)
- renames Nt1_Ops.Write;
- function Input (Stream : access Root_Stream_Type'Class) return Nt1'Base
- renames Nt1_Ops.Input;
- procedure Read (Stream : access Root_Stream_Type'Class; Item : out Nt1'Base)
- renames Nt1_Ops.Read;
- procedure Output (Stream : access Root_Stream_Type'Class; Item : Nt1'Base)
- renames Nt1_Ops.Output;
-
- procedure Write (Stream : access Root_Stream_Type'Class; Item : Nt2'Base)
- renames Nt2_Ops.Write;
- function Input (Stream : access Root_Stream_Type'Class) return Nt2'Base
- renames Nt2_Ops.Input;
- procedure Read (Stream : access Root_Stream_Type'Class; Item : out Nt2'Base)
- renames Nt2_Ops.Read;
- procedure Output (Stream : access Root_Stream_Type'Class; Item : Nt2'Base)
- renames Nt2_Ops.Output;
-
- procedure Write (Stream : access Root_Stream_Type'Class; Item : Nt3'Base)
- renames Nt3_Ops.Write;
- function Input (Stream : access Root_Stream_Type'Class) return Nt3'Base
- renames Nt3_Ops.Input;
- procedure Read (Stream : access Root_Stream_Type'Class; Item : out Nt3'Base)
- renames Nt3_Ops.Read;
- procedure Output (Stream : access Root_Stream_Type'Class; Item : Nt3'Base)
- renames Nt3_Ops.Output;
-
- procedure Write (Stream : access Root_Stream_Type'Class; Item : Nt4'Base)
- renames Nt4_Ops.Write;
- function Input (Stream : access Root_Stream_Type'Class) return Nt4'Base
- renames Nt4_Ops.Input;
- procedure Read (Stream : access Root_Stream_Type'Class; Item : out Nt4'Base)
- renames Nt4_Ops.Read;
- procedure Output (Stream : access Root_Stream_Type'Class; Item : Nt4'Base)
- renames Nt4_Ops.Output;
-
- procedure Write (Stream : access Root_Stream_Type'Class; Item : Nt5'Base)
- renames Nt5_Ops.Write;
- function Input (Stream : access Root_Stream_Type'Class) return Nt5'Base
- renames Nt5_Ops.Input;
- procedure Read (Stream : access Root_Stream_Type'Class; Item : out Nt5'Base)
- renames Nt5_Ops.Read;
- procedure Output (Stream : access Root_Stream_Type'Class; Item : Nt5'Base)
- renames Nt5_Ops.Output;
-
- procedure Write (Stream : access Root_Stream_Type'Class; Item : Nt6'Base)
- renames Nt6_Ops.Write;
- function Input (Stream : access Root_Stream_Type'Class) return Nt6'Base
- renames Nt6_Ops.Input;
- procedure Read (Stream : access Root_Stream_Type'Class; Item : out Nt6'Base)
- renames Nt6_Ops.Read;
- procedure Output (Stream : access Root_Stream_Type'Class; Item : Nt6'Base)
- renames Nt6_Ops.Output;
-
- procedure Write (Stream : access Root_Stream_Type'Class; Item : Nt7)
- renames Nt7_Ops.Write;
- function Input (Stream : access Root_Stream_Type'Class) return Nt7
- renames Nt7_Ops.Input;
- procedure Read (Stream : access Root_Stream_Type'Class; Item : out Nt7)
- renames Nt7_Ops.Read;
- procedure Output (Stream : access Root_Stream_Type'Class; Item : Nt7)
- renames Nt7_Ops.Output;
-
- procedure Write (Stream : access Root_Stream_Type'Class; Item : Nt8'Base)
- renames Nt8_Ops.Write;
- function Input (Stream : access Root_Stream_Type'Class) return Nt8'Base
- renames Nt8_Ops.Input;
- procedure Read (Stream : access Root_Stream_Type'Class; Item : out Nt8'Base)
- renames Nt8_Ops.Read;
- procedure Output (Stream : access Root_Stream_Type'Class; Item : Nt8'Base)
- renames Nt8_Ops.Output;
-
- procedure Write (Stream : access Root_Stream_Type'Class; Item : Nt9)
- renames Nt9_Ops.Write;
- function Input (Stream : access Root_Stream_Type'Class) return Nt9
- renames Nt9_Ops.Input;
- procedure Read (Stream : access Root_Stream_Type'Class; Item : out Nt9)
- renames Nt9_Ops.Read;
- procedure Output (Stream : access Root_Stream_Type'Class; Item : Nt9)
- renames Nt9_Ops.Output;
-
- procedure Write (Stream : access Root_Stream_Type'Class; Item : Nt10) is
- begin
- Nt10_Cnts (Write) := Nt10_Cnts (Write) + 1;
- end Write;
- function Input (Stream : access Root_Stream_Type'Class) return Nt10 is
- begin
- Nt10_Cnts (Input) := Nt10_Cnts (Input) + 1;
- return Nt10 (C10);
- end Input;
- procedure Read (Stream : access Root_Stream_Type'Class; Item : out Nt10) is
- begin
- Nt10_Cnts (Read) := Nt10_Cnts (Read) + 1;
- end Read;
- procedure Output (Stream : access Root_Stream_Type'Class; Item : Nt10) is
- begin
- Nt10_Cnts (Output) := Nt10_Cnts (Output) + 1;
- end Output;
- function Get_Nt10_Counts return CD10002_0.Counts is
- begin
- return Nt10_Cnts;
- end Get_Nt10_Counts;
-
- procedure Write (Stream : access Root_Stream_Type'Class; Item : Nt11)
- renames Nt11_Ops.Write;
- function Input (Stream : access Root_Stream_Type'Class) return Nt11
- renames Nt11_Ops.Input;
- procedure Read (Stream : access Root_Stream_Type'Class; Item : out Nt11)
- renames Nt11_Ops.Read;
- procedure Output (Stream : access Root_Stream_Type'Class; Item : Nt11)
- renames Nt11_Ops.Output;
-
- procedure Write (Stream : access Root_Stream_Type'Class; Item : Nt12) is
- begin
- Nt12_Cnts (Write) := Nt12_Cnts (Write) + 1;
- end Write;
- function Input (Stream : access Root_Stream_Type'Class) return Nt12 is
- begin
- Nt12_Cnts (Input) := Nt12_Cnts (Input) + 1;
- return Nt12 (C10);
- end Input;
- procedure Read (Stream : access Root_Stream_Type'Class; Item : out Nt12) is
- begin
- Nt12_Cnts (Read) := Nt12_Cnts (Read) + 1;
- end Read;
- procedure Output (Stream : access Root_Stream_Type'Class; Item : Nt12) is
- begin
- Nt12_Cnts (Output) := Nt12_Cnts (Output) + 1;
- end Output;
- function Get_Nt12_Counts return CD10002_0.Counts is
- begin
- return Nt12_Cnts;
- end Get_Nt12_Counts;
-
- procedure Write (Stream : access Root_Stream_Type'Class; Item : Nt13)
- renames Nt13_Ops.Write;
- function Input (Stream : access Root_Stream_Type'Class) return Nt13
- renames Nt13_Ops.Input;
- procedure Read (Stream : access Root_Stream_Type'Class; Item : out Nt13)
- renames Nt13_Ops.Read;
- procedure Output (Stream : access Root_Stream_Type'Class; Item : Nt13)
- renames Nt13_Ops.Output;
-
-end CD10002_Gen;
-
-
-with Ada.Streams;
-use Ada.Streams;
-with CD10002_0;
-package CD10002_Priv is
-
- External_Tag_1 : constant String := "Isaac Newton";
- External_Tag_2 : constant String := "Albert Einstein";
-
- type T1 is tagged private;
- type T2 is tagged
- record
- C : T1;
- end record;
-
- procedure Write (Stream : access Root_Stream_Type'Class; Item : T1);
- function Input (Stream : access Root_Stream_Type'Class) return T1;
- procedure Read (Stream : access Root_Stream_Type'Class; Item : out T1);
- procedure Output (Stream : access Root_Stream_Type'Class; Item : T1);
-
- procedure Write (Stream : access Root_Stream_Type'Class; Item : T2);
- function Input (Stream : access Root_Stream_Type'Class) return T2;
- procedure Read (Stream : access Root_Stream_Type'Class; Item : out T2);
- procedure Output (Stream : access Root_Stream_Type'Class; Item : T2);
-
- for T1'Write use Write;
- for T1'Input use Input;
-
- for T2'Read use Read;
- for T2'Output use Output;
- for T2'External_Tag use External_Tag_2;
-
- function Get_T1_Counts return CD10002_0.Counts;
- function Get_T2_Counts return CD10002_0.Counts;
-
-private
-
- for T1'Read use Read;
- for T1'Output use Output;
- for T1'External_Tag use External_Tag_1;
-
- for T2'Write use Write;
- for T2'Input use Input;
-
- type T1 is tagged null record;
-
- package T1_Ops is new CD10002_0.Nonlimited_Stream_Ops (T1);
- package T2_Ops is new CD10002_0.Nonlimited_Stream_Ops (T2);
-
-end CD10002_Priv;
-
-
-package body CD10002_Priv is
- procedure Write (Stream : access Root_Stream_Type'Class; Item : T1)
- renames T1_Ops.Write;
- function Input (Stream : access Root_Stream_Type'Class) return T1
- renames T1_Ops.Input;
- procedure Read (Stream : access Root_Stream_Type'Class; Item : out T1)
- renames T1_Ops.Read;
- procedure Output (Stream : access Root_Stream_Type'Class; Item : T1)
- renames T1_Ops.Output;
-
- procedure Write (Stream : access Root_Stream_Type'Class; Item : T2)
- renames T2_Ops.Write;
- function Input (Stream : access Root_Stream_Type'Class) return T2
- renames T2_Ops.Input;
- procedure Read (Stream : access Root_Stream_Type'Class; Item : out T2)
- renames T2_Ops.Read;
- procedure Output (Stream : access Root_Stream_Type'Class; Item : T2)
- renames T2_Ops.Output;
-
- function Get_T1_Counts return CD10002_0.Counts renames T1_Ops.Get_Counts;
- function Get_T2_Counts return CD10002_0.Counts renames T2_Ops.Get_Counts;
-end CD10002_Priv;
-
-
-with Ada.Streams;
-use Ada.Streams;
-with Report;
-use Report;
-with System;
-with CD10002_0;
-with CD10002_1;
-with CD10002_Deriv;
-with CD10002_Gen;
-with CD10002_Priv;
-procedure CD10002 is
-
- package Deriv renames CD10002_Deriv;
- generic package Gen renames CD10002_Gen;
- package Priv renames CD10002_Priv;
-
- type Stream_Ops is (Read, Write, Input, Output);
- type Counts is array (Stream_Ops) of Natural;
-
- S : aliased CD10002_1.Dummy_Stream;
-
-begin
- Test ("CD10002",
- "Check that operational items are allowed in some contexts " &
- "where representation items are not");
-
- Test_Priv:
- declare
- X1 : Priv.T1;
- X2 : Priv.T2;
- use CD10002_0;
- begin
- Comment
- ("Check that the name of an incompletely defined type can be " &
- "used when specifying an operational item");
-
- -- Partial view of a private type.
- Priv.T1'Write (S'Access, X1);
- Priv.T1'Read (S'Access, X1);
- Priv.T1'Output (S'Access, X1);
- X1 := Priv.T1'Input (S'Access);
-
- if Priv.Get_T1_Counts /= (1, 1, 1, 1) then
- Failed ("Incorrect calls to the stream attributes for Priv.T1");
- elsif Priv.T1'External_Tag /= Priv.External_Tag_1 then
- Failed ("Incorrect external tag for Priv.T1");
- end if;
-
- -- Incompletely defined but not private.
- Priv.T2'Write (S'Access, X2);
- Priv.T2'Read (S'Access, X2);
- Priv.T2'Output (S'Access, X2);
- X2 := Priv.T2'Input (S'Access);
-
- if Priv.Get_T2_Counts /= (1, 1, 1, 1) then
- Failed ("Incorrect calls to the stream attributes for Priv.T2");
- elsif Priv.T2'External_Tag /= Priv.External_Tag_2 then
- Failed ("Incorrect external tag for Priv.T2");
- end if;
-
- end Test_Priv;
-
- Test_Gen:
- declare
-
- type Modular is mod System.Max_Binary_Modulus;
- type Decimal is delta 1.0 digits 1;
- type Access_Modular is access Modular;
- type R9 is null record;
- type R10 (D : access Integer) is limited null record;
- type Arr is array (Character) of Integer;
-
- C10 : R10 (new Integer'(19));
-
- package Inst is new Gen (T1 => Character,
- T2 => Integer,
- T3 => Modular,
- T4 => Float,
- T5 => Duration,
- T6 => Decimal,
- T7 => Access_Modular,
- T8 => Boolean,
- T9 => R9,
- T10 => R10,
- C10 => C10,
- T11 => Arr);
-
- X1 : Inst.Nt1 := 'a';
- X2 : Inst.Nt2 := 0;
- X3 : Inst.Nt3 := 0;
- X4 : Inst.Nt4 := 0.0;
- X5 : Inst.Nt5 := 0.0;
- X6 : Inst.Nt6 := 0.0;
- X7 : Inst.Nt7 := null;
- X8 : Inst.Nt8 := Inst.False;
- X9 : Inst.Nt9 := (null record);
- X10 : Inst.Nt10 (D => new Integer'(5));
- Y10 : Integer;
- X11 : Inst.Nt11 := (others => 0);
- X12 : Inst.Nt12 (D => new Integer'(7));
- Y12 : Integer;
- X13 : Inst.Nt13 := (others => 0);
- use CD10002_0;
- begin
- Comment ("Check that operational items can be specified for a " &
- "descendant of a generic formal untagged type");
-
- Inst.Nt1'Write (S'Access, X1);
- Inst.Nt1'Read (S'Access, X1);
- Inst.Nt1'Output (S'Access, X1);
- X1 := Inst.Nt1'Input (S'Access);
-
- if Inst.Nt1_Ops.Get_Counts /= (1, 1, 1, 1) then
- Failed
- ("Incorrect calls to the stream attributes for Inst.Nt1");
- end if;
-
- Inst.Nt2'Write (S'Access, X2);
- Inst.Nt2'Read (S'Access, X2);
- Inst.Nt2'Output (S'Access, X2);
- X2 := Inst.Nt2'Input (S'Access);
-
- if Inst.Nt2_Ops.Get_Counts /= (1, 1, 1, 1) then
- Failed
- ("Incorrect calls to the stream attributes for Inst.Nt2");
- end if;
-
- Inst.Nt3'Write (S'Access, X3);
- Inst.Nt3'Read (S'Access, X3);
- Inst.Nt3'Output (S'Access, X3);
- X3 := Inst.Nt3'Input (S'Access);
-
- if Inst.Nt3_Ops.Get_Counts /= (1, 1, 1, 1) then
- Failed
- ("Incorrect calls to the stream attributes for Inst.Nt3");
- end if;
-
- Inst.Nt4'Write (S'Access, X4);
- Inst.Nt4'Read (S'Access, X4);
- Inst.Nt4'Output (S'Access, X4);
- X4 := Inst.Nt4'Input (S'Access);
-
- if Inst.Nt4_Ops.Get_Counts /= (1, 1, 1, 1) then
- Failed
- ("Incorrect calls to the stream attributes for Inst.Nt4");
- end if;
-
- Inst.Nt5'Write (S'Access, X5);
- Inst.Nt5'Read (S'Access, X5);
- Inst.Nt5'Output (S'Access, X5);
- X5 := Inst.Nt5'Input (S'Access);
-
- if Inst.Nt5_Ops.Get_Counts /= (1, 1, 1, 1) then
- Failed
- ("Incorrect calls to the stream attributes for Inst.Nt5");
- end if;
-
- Inst.Nt6'Write (S'Access, X6);
- Inst.Nt6'Read (S'Access, X6);
- Inst.Nt6'Output (S'Access, X6);
- X6 := Inst.Nt6'Input (S'Access);
-
- if Inst.Nt6_Ops.Get_Counts /= (1, 1, 1, 1) then
- Failed
- ("Incorrect calls to the stream attributes for Inst.Nt6");
- end if;
-
- Inst.Nt7'Write (S'Access, X7);
- Inst.Nt7'Read (S'Access, X7);
- Inst.Nt7'Output (S'Access, X7);
- X7 := Inst.Nt7'Input (S'Access);
-
- if Inst.Nt7_Ops.Get_Counts /= (1, 1, 1, 1) then
- Failed
- ("Incorrect calls to the stream attributes for Inst.Nt7");
- end if;
-
- Inst.Nt8'Write (S'Access, X8);
- Inst.Nt8'Read (S'Access, X8);
- Inst.Nt8'Output (S'Access, X8);
- X8 := Inst.Nt8'Input (S'Access);
-
- if Inst.Nt8_Ops.Get_Counts /= (1, 1, 1, 1) then
- Failed
- ("Incorrect calls to the stream attributes for Inst.Nt8");
- end if;
-
- Inst.Nt9'Write (S'Access, X9);
- Inst.Nt9'Read (S'Access, X9);
- Inst.Nt9'Output (S'Access, X9);
- X9 := Inst.Nt9'Input (S'Access);
-
- if Inst.Nt9_Ops.Get_Counts /= (1, 1, 1, 1) then
- Failed
- ("Incorrect calls to the stream attributes for Inst.Nt9");
- end if;
-
- Inst.Nt10'Write (S'Access, X10);
- Inst.Nt10'Read (S'Access, X10);
- Inst.Nt10'Output (S'Access, X10);
- Y10 := Inst.Nt10'Input (S'Access).D.all;
-
- if Inst.Get_Nt10_Counts /= (1, 1, 1, 1) then
- Failed
- ("Incorrect calls to the stream attributes for Inst.Nt10");
- end if;
-
- Inst.Nt11'Write (S'Access, X11);
- Inst.Nt11'Read (S'Access, X11);
- Inst.Nt11'Output (S'Access, X11);
- X11 := Inst.Nt11'Input (S'Access);
-
- if Inst.Nt11_Ops.Get_Counts /= (1, 1, 1, 1) then
- Failed
- ("Incorrect calls to the stream attributes for Inst.Nt11");
- end if;
-
- Inst.Nt12'Write (S'Access, X12);
- Inst.Nt12'Read (S'Access, X12);
- Inst.Nt12'Output (S'Access, X12);
- Y12 := Inst.Nt12'Input (S'Access).D.all;
-
- if Inst.Get_Nt12_Counts /= (1, 1, 1, 1) then
- Failed
- ("Incorrect calls to the stream attributes for Inst.Nt12");
- end if;
-
- Inst.Nt13'Write (S'Access, X13);
- Inst.Nt13'Read (S'Access, X13);
- Inst.Nt13'Output (S'Access, X13);
- X13 := Inst.Nt13'Input (S'Access);
-
- if Inst.Nt13_Ops.Get_Counts /= (1, 1, 1, 1) then
- Failed
- ("Incorrect calls to the stream attributes for Inst.Nt13");
- end if;
- end Test_Gen;
-
- Test_Deriv:
- declare
- X1 : Deriv.Nt1 := Deriv.False;
- X2 : Deriv.Nt2 := (others => 0.0);
- X3 : Deriv.Nt3 := (others => 0.0);
- X4 : Deriv.Nt4;
- Y4 : Boolean;
- X5 : Deriv.Nt5;
- Y5 : System.Address;
- X6 : Deriv.Nt6;
- Y6 : Integer;
- X7 : Deriv.Nt7;
- Y7 : Integer;
- X8 : Deriv.Nt8;
- Y8 : Integer;
- use CD10002_0;
- begin
- Comment ("Check that operational items can be specified for a " &
- "derived untagged type even if the parent type is a " &
- "by-reference type, or has user-defined primitive " &
- "subprograms");
-
- Deriv.Nt1'Write (S'Access, X1);
- Deriv.Nt1'Read (S'Access, X1);
- Deriv.Nt1'Output (S'Access, X1);
- X1 := Deriv.Nt1'Input (S'Access);
-
- if Deriv.Nt1_Ops.Get_Counts /= (1, 1, 1, 1) then
- Failed
- ("Incorrect calls to the stream attributes for Deriv.Nt1");
- end if;
-
- Deriv.Nt2'Write (S'Access, X2);
- Deriv.Nt2'Read (S'Access, X2);
- Deriv.Nt2'Output (S'Access, X2);
- X2 := Deriv.Nt2'Input (S'Access);
-
- if Deriv.Nt2_Ops.Get_Counts /= (1, 1, 1, 1) then
- Failed
- ("Incorrect calls to the stream attributes for Deriv.Nt2");
- end if;
-
- Deriv.Nt3'Write (S'Access, X3);
- Deriv.Nt3'Read (S'Access, X3);
- Deriv.Nt3'Output (S'Access, X3);
- X3 := Deriv.Nt3'Input (S'Access);
-
- if Deriv.Nt3_Ops.Get_Counts /= (1, 1, 1, 1) then
- Failed
- ("Incorrect calls to the stream attributes for Deriv.Nt3");
- end if;
-
- Deriv.Nt4'Write (S'Access, X4);
- Deriv.Nt4'Read (S'Access, X4);
- Deriv.Nt4'Output (S'Access, X4);
- Y4 := Deriv.Nt4'Input (S'Access)'Terminated;
-
- if Deriv.Nt4_Ops.Get_Counts /= (1, 1, 1, 1) then
- Failed
- ("Incorrect calls to the stream attributes for Deriv.Nt4");
- end if;
-
- Deriv.Nt5'Write (S'Access, X5);
- Deriv.Nt5'Read (S'Access, X5);
- Deriv.Nt5'Output (S'Access, X5);
- Y5 := Deriv.Nt5'Input (S'Access)'Address;
-
- if Deriv.Nt5_Ops.Get_Counts /= (1, 1, 1, 1) then
- Failed
- ("Incorrect calls to the stream attributes for Deriv.Nt5");
- end if;
-
- Deriv.Nt6'Write (S'Access, X6);
- Deriv.Nt6'Read (S'Access, X6);
- Deriv.Nt6'Output (S'Access, X6);
- Y6 := Deriv.Nt6'Input (S'Access).D.all;
-
- if Deriv.Nt6_Ops.Get_Counts /= (1, 1, 1, 1) then
- Failed
- ("Incorrect calls to the stream attributes for Deriv.Nt6");
- end if;
-
- Deriv.Nt7'Write (S'Access, X7);
- Deriv.Nt7'Read (S'Access, X7);
- Deriv.Nt7'Output (S'Access, X7);
- Y7 := Deriv.Nt7'Input (S'Access) ('a').D.all;
-
- if Deriv.Nt7_Ops.Get_Counts /= (1, 1, 1, 1) then
- Failed
- ("Incorrect calls to the stream attributes for Deriv.Nt7");
- end if;
-
- Deriv.Nt8'Write (S'Access, X8);
- Deriv.Nt8'Read (S'Access, X8);
- Deriv.Nt8'Output (S'Access, X8);
- Y8 := Deriv.Nt8'Input (S'Access)'Size;
-
- if Deriv.Nt8_Ops.Get_Counts /= (1, 1, 1, 1) then
- Failed
- ("Incorrect calls to the stream attributes for Deriv.Nt8");
- end if;
- end Test_Deriv;
-
- Result;
-end CD10002;
-
-
diff --git a/gcc/testsuite/ada/acats/tests/cd/cd20001.a b/gcc/testsuite/ada/acats/tests/cd/cd20001.a
deleted file mode 100644
index 21f9738733b..00000000000
--- a/gcc/testsuite/ada/acats/tests/cd/cd20001.a
+++ /dev/null
@@ -1,275 +0,0 @@
--- CD20001.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that for packed records the components are packed as tightly
--- as possible subject to the Size of the component subtypes.
--- Specifically check that Boolean objects are packed one to a bit.
---
--- Check that the Component_Size for a packed array type is less than
--- or equal to the smallest of those factors of the word size that are
--- greater than or equal to the Size of the component subtype.
---
--- TEST DESCRIPTION:
--- This test defines and packs several types, and checks that the sizes
--- of the resulting objects is as expected.
---
--- APPLICABILITY CRITERIA:
--- All implementations must attempt to compile this test.
---
--- For implementations validating against Systems Programming Annex (C):
--- this test must execute and report PASSED.
---
--- For implementations not validating against Annex C:
--- this test may report compile time errors at one or more points
--- indicated by "-- ANX-C RQMT", in which case it may be graded as
--- inapplicable. Otherwise, the test must execute and report PASSED.
---
---
--- CHANGE HISTORY:
--- 22 JUL 95 SAIC Initial version
--- 08 MAY 96 SAIC Strengthened for 2.1
--- 29 JAN 98 EDS Deleted check that Component_Size is really a
--- factor of Word_Size.
---!
-
------------------------------------------------------------------ CD20001_0
-
-with System;
-package CD20001_0 is
-
- type Wordlong_Bool_Array is array(1..System.Word_Size) of Boolean;
- pragma Pack(Wordlong_Bool_Array); -- ANX-C RQMT
-
- type Def_Rep_Components is range 0..2**(System.Storage_Unit-2);
-
- type Spec_Rep_Components is range 0..2**(System.Storage_Unit-2);
- for Spec_Rep_Components'Size use System.Storage_Unit; -- ANX-C RQMT
-
- type Packed_Array_Def_Components is array(1..32) of Def_Rep_Components;
- pragma Pack(Packed_Array_Def_Components); -- ANX-C RQMT
-
- type Packed_Array_Spec_Components is array(1..32) of Spec_Rep_Components;
- pragma Pack(Packed_Array_Spec_Components); -- ANX-C RQMT
-
- procedure TC_Check_Values;
-
-end CD20001_0;
-
--- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
-
-with Report;
-with TCTouch;
-package body CD20001_0 is
-
- procedure TC_Check_Values is
- My_Word : Wordlong_Bool_Array := (others => False);
-
- Cited_Unit : Spec_Rep_Components := 0;
-
- Packed_Array : Packed_Array_Def_Components := (others => 0);
-
- Cited_Packed : Packed_Array_Spec_Components := (others => 0);
-
- begin
- TCTouch.Assert( My_Word'Size = System.Word_Size,
- "pragma Pack on array of Booleans does not pack one Boolean per bit" );
-
- TCTouch.Assert( My_Word'Component_Size = 1,
- "size of Boolean array component not 1 bit");
-
- TCTouch.Assert( Cited_Unit'Size = System.Storage_Unit,
- "Object specified to be Storage_Unit bits not " &
- "Storage_Unit bits in size");
-
- TCTouch.Assert( Packed_Array'Component_Size <= System.Storage_Unit,
- "Packed array component expected to be less than or " &
- "equal to Storage_Unit bits in size is greater than " &
- "Storage_Unit bits in size");
-
- TCTouch.Assert( Cited_Packed'Component_Size = System.Storage_Unit,
- "Array component specified to be Storage_Unit " &
- "bits not Storage_Unit bits in size");
-
- end TC_Check_Values;
-
-end CD20001_0;
-
------------------------------------------------------------------ CD20001_1
-
-with System;
-package CD20001_1 is
-
- type Bits_2 is range 0..2**2-1;
- for Bits_2'Size use 2; -- ANX-C RQMT
-
- type Bits_3 is range 0..2**3-1;
- for Bits_3'Size use 3; -- ANX-C RQMT
-
- type Bits_7 is range 0..2**7-1;
- for Bits_7'Size use 7; -- ANX-C RQMT
-
- type Bits_8 is range 0..2**8-1;
- for Bits_8'Size use 8; -- ANX-C RQMT
-
- type Bits_9 is range 0..2**9-1;
- for Bits_9'Size use 9; -- ANX-C RQMT
-
- type Bits_15 is range 0..2**15-1;
- for Bits_15'Size use 15; -- ANX-C RQMT
-
- type Pact_Aray_2 is array(0..31) of Bits_2;
- pragma Pack( Pact_Aray_2 ); -- ANX-C RQMT
-
- type Pact_Aray_3 is array(0..31) of Bits_3;
- pragma Pack( Pact_Aray_3 ); -- ANX-C RQMT
-
- type Pact_Aray_7 is array(0..31) of Bits_7;
- pragma Pack( Pact_Aray_7 ); -- ANX-C RQMT
-
- type Pact_Aray_8 is array(0..31) of Bits_8;
- pragma Pack( Pact_Aray_8 ); -- ANX-C RQMT
-
- type Pact_Aray_9 is array(0..31) of Bits_9;
- pragma Pack( Pact_Aray_9 ); -- ANX-C RQMT
-
- type Pact_Aray_15 is array(0..31) of Bits_15;
- pragma Pack( Pact_Aray_15 ); -- ANX-C RQMT
-
-
- procedure TC_Check_Values;
-
-end CD20001_1;
-
--- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
-
-with Report;
-with TCTouch;
-package body CD20001_1 is
-
- function Next_Factor ( Value : Positive ) return Integer is
- -- Returns the factor of Word_Size that is next larger than Value.
- -- If Value is greater than Word_Size, then returns Word_Size.
- Test : Integer := Value;
- Found : Boolean := False;
- begin -- Next_Factor
- while not Found and Test <= System.Word_Size loop
- if System.Word_Size mod Test = 0 then
- Found := True;
- else
- Test := Test + 1;
- end if;
- end loop;
- if Found then
- return Test;
- else
- return System.Word_Size;
- end if;
- end Next_Factor;
-
- procedure TC_Check_Values is
- begin
-
- if Pact_Aray_2'Component_Size > Next_Factor ( Bits_2'Size ) then
- Report.Failed
- ( "2 bit element Packed Array'Component_Size too big" );
- end if;
-
- TCTouch.Assert( Pact_Aray_2'Component_Size <= Pact_Aray_2'Size,
- "2 bit Component_Size greater than array size" );
-
- if Pact_Aray_3'Component_Size > Next_Factor ( Bits_3'Size ) then
- Report.Failed
- ( "3 bit element Packed Array'Component_Size too big" );
- end if;
-
- TCTouch.Assert( Pact_Aray_3'Component_Size <= Pact_Aray_3'Size,
- "3 bit Component_Size greater than array size" );
-
- if Pact_Aray_7'Component_Size > Next_Factor ( Bits_7'Size ) then
- Report.Failed
- ( "7 bit element Packed Array'Component_Size too big" );
- end if;
-
- TCTouch.Assert( Pact_Aray_7'Component_Size <= Pact_Aray_7'Size,
- "7 bit Component_Size greater than array size" );
-
- if Pact_Aray_8'Component_Size > Next_Factor ( Bits_8'Size ) then
- Report.Failed
- ( "8 bit element Packed Array'Component_Size too big" );
- end if;
-
- TCTouch.Assert( Pact_Aray_8'Component_Size <= Pact_Aray_8'Size,
- "8 bit Component_Size greater than array size" );
-
- if System.Word_Size > 8 then
-
- if Pact_Aray_9'Component_Size > Next_Factor ( Bits_9'Size ) then
- Report.Failed
- ( "9 bit element Packed Array'Component_Size too big" );
- end if;
-
- TCTouch.Assert( Pact_Aray_9'Component_Size <= Pact_Aray_9'Size,
- "9 bit Component_Size greater than array size" );
-
- if Pact_Aray_15'Component_Size > Next_Factor ( Bits_15'Size ) then
- Report.Failed
- ( "15 bit element Packed Array'Component_Size too big" );
- end if;
-
- TCTouch.Assert( Pact_Aray_15'Component_Size <= Pact_Aray_15'Size,
- "15 bit Component_Size greater than array size" );
-
- end if;
-
- end TC_Check_Values;
-
-end CD20001_1;
-
-------------------------------------------------------------------- CD20001
-
-with Report;
-with CD20001_0;
-with CD20001_1;
-
-procedure CD20001 is
-
-begin -- Main test procedure.
-
- Report.Test ("CD20001", "Check that packed records are packed as tightly " &
- "as possible. Check that Boolean objects are " &
- "packed one to a bit. " &
- "Check that the Component_Size for a packed " &
- "array type is the value which is less than or " &
- "equal to the Size of the component type, " &
- "rounded up to the nearest factor of word_size" );
-
- CD20001_0.TC_Check_Values;
-
- CD20001_1.TC_Check_Values;
-
- Report.Result;
-
-end CD20001;
diff --git a/gcc/testsuite/ada/acats/tests/cd/cd30001.a b/gcc/testsuite/ada/acats/tests/cd/cd30001.a
deleted file mode 100644
index d65e1450836..00000000000
--- a/gcc/testsuite/ada/acats/tests/cd/cd30001.a
+++ /dev/null
@@ -1,284 +0,0 @@
--- CD30001.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that X'Address produces a useful result when X is an aliased
--- object.
--- Check that X'Address produces a useful result when X is an object of
--- a by-reference type.
--- Check that X'Address produces a useful result when X is an entity
--- whose Address has been specified.
---
--- Check that aliased objects and subcomponents are allocated on storage
--- element boundaries. Check that objects and subcomponents of by
--- reference types are allocated on storage element boundaries.
---
--- Check that for an array X, X'Address points at the first component
--- of the array, and not at the array bounds.
---
--- TEST DESCRIPTION:
--- This test defines a data structure (an array of records) where each
--- aspect of the data structure is aliased. The test checks 'Address
--- for each "layer" of aliased objects.
---
--- APPLICABILITY CRITERIA:
--- All implementations must attempt to compile this test.
---
--- For implementations validating against Systems Programming Annex (C):
--- this test must execute and report PASSED.
---
--- For implementations not validating against Annex C:
--- this test may report compile time errors at one or more points
--- indicated by "-- ANX-C RQMT", in which case it may be graded as inapplicable.
--- Otherwise, the test must execute and report PASSED.
---
---
--- CHANGE HISTORY:
--- 22 JUL 95 SAIC Initial version
--- 08 MAY 96 SAIC Reinforced for 2.1
--- 16 FEB 98 EDS Modified documentation
---!
-
------------------------------------------------------------------ CD30001_0
-
-with SPPRT13;
-package CD30001_0 is
-
- -- Check that X'Address produces a useful result when X is an aliased
- -- object.
- -- Check that X'Address produces a useful result when X is an object of
- -- a by-reference type.
- -- Check that X'Address produces a useful result when X is an entity
- -- whose Address has been specified.
- -- (using the new form of "for X'Address use ...")
- --
- -- Check that aliased objects and subcomponents are allocated on storage
- -- element boundaries. Check that objects and subcomponents of by
- -- reference types are allocated on storage element boundaries.
-
- type Simple_Enum_Type is (Just, A, Little, Bit);
-
- type Data is record
- Aliased_Comp_1 : aliased Simple_Enum_Type;
- Aliased_Comp_2 : aliased Simple_Enum_Type;
- end record;
-
- type Array_W_Aliased_Comps is array(1..2) of aliased Data;
-
- Aliased_Object : aliased Array_W_Aliased_Comps;
-
- Specific_Object : aliased Array_W_Aliased_Comps;
- for Specific_Object'Address use SPPRT13.Variable_Address2; -- ANX-C RQMT.
-
- procedure TC_Check_Aliased_Addresses;
-
- procedure TC_Check_Specific_Addresses;
-
- procedure TC_Check_By_Reference_Types;
-
-end CD30001_0;
-
--- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
-
-with Report;
-with System.Storage_Elements;
-with System.Address_To_Access_Conversions;
-package body CD30001_0 is
-
- package Simple_Enum_Type_Ref_Conv is
- new System.Address_To_Access_Conversions(Simple_Enum_Type);
-
- package Data_Ref_Conv is new System.Address_To_Access_Conversions(Data);
-
- package Array_W_Aliased_Comps_Ref_Conv is
- new System.Address_To_Access_Conversions(Array_W_Aliased_Comps);
-
- use type System.Address;
- use type System.Storage_Elements.Integer_Address;
- use type System.Storage_Elements.Storage_Offset;
-
- procedure TC_Check_Aliased_Addresses is
- use type Simple_Enum_Type_Ref_Conv.Object_Pointer;
- use type Data_Ref_Conv.Object_Pointer;
- use type Array_W_Aliased_Comps_Ref_Conv.Object_Pointer;
-
- begin
-
- -- Check the object Aliased_Object
-
- if Aliased_Object'Address not in System.Address then
- Report.Failed("Aliased_Object'Address not an address");
- end if;
-
- if Array_W_Aliased_Comps_Ref_Conv.To_Pointer(Aliased_Object'Address)
- /= Aliased_Object'Unchecked_Access then
- Report.Failed
- ("'Unchecked_Access does not match expected address value");
- end if;
-
- -- Check the element Aliased_Object(1)
-
- if Data_Ref_Conv.To_Address( Aliased_Object(1)'Access )
- /= Aliased_Object(1)'Address then
- Report.Failed
- ("Array element 'Access does not match expected address value");
- end if;
-
- -- Check that Array'Address points at the first component...
-
- if Array_W_Aliased_Comps_Ref_Conv.To_Address( Aliased_Object'Access )
- /= Aliased_Object(1)'Address then
- Report.Failed
- ("Address of array object does not equal address of first component");
- end if;
-
- -- Check the components of Aliased_Object(2)
-
- if Simple_Enum_Type_Ref_Conv.To_Address(
- Aliased_Object(2).Aliased_Comp_1'Unchecked_Access)
- not in System.Address then
- Report.Failed("Component 2 'Unchecked_Access not a valid address");
- end if;
-
- if Aliased_Object(2).Aliased_Comp_2'Address not in System.Address then
- Report.Failed("Component 2 not located at a valid address ");
- end if;
-
- end TC_Check_Aliased_Addresses;
-
- procedure TC_Check_Specific_Addresses is
- use type System.Address;
- use type System.Storage_Elements.Integer_Address;
- use type Simple_Enum_Type_Ref_Conv.Object_Pointer;
- use type Data_Ref_Conv.Object_Pointer;
- use type Array_W_Aliased_Comps_Ref_Conv.Object_Pointer;
- begin
-
- -- Check the object Specific_Object
-
- if System.Storage_Elements.To_Integer(Specific_Object'Address)
- /= System.Storage_Elements.To_Integer(SPPRT13.Variable_Address2) then
- Report.Failed
- ("Specific_Object not at address specified in representation clause");
- end if;
-
- if Array_W_Aliased_Comps_Ref_Conv.To_Pointer(SPPRT13.Variable_Address2)
- /= Specific_Object'Unchecked_Access then
- Report.Failed("Specific_Object'Unchecked_Access not expected value");
- end if;
-
- -- Check the element Specific_Object(1)
-
- if Data_Ref_Conv.To_Address( Specific_Object(1)'Access )
- /= Specific_Object(1)'Address then
- Report.Failed
- ("Specific Array element 'Access does not correspond to the "
- & "elements 'Address");
- end if;
-
- -- Check that Array'Address points at the first component...
-
- if Array_W_Aliased_Comps_Ref_Conv.To_Address( Specific_Object'Access )
- /= Specific_Object(1)'Address then
- Report.Failed
- ("Address of array object does not equal address of first component");
- end if;
-
- -- Check the components of Specific_Object(2)
-
- if Simple_Enum_Type_Ref_Conv.To_Address(
- Specific_Object(1).Aliased_Comp_1'Access)
- not in System.Address then
- Report.Failed("Access value of first record component for object at " &
- "specific address not a valid address");
- end if;
-
- if Specific_Object(2).Aliased_Comp_2'Address not in System.Address then
- Report.Failed("Second record component for object at specific " &
- "address not located at a valid address");
- end if;
-
- end TC_Check_Specific_Addresses;
-
--- Check that X'Address produces a useful result when X is an object of
--- a by-reference type.
-
- type Tagged_But_Not_Exciting is tagged record
- A_Bit_Of_Data : Boolean;
- end record;
-
- Tagged_Object : Tagged_But_Not_Exciting;
-
- procedure Muck_With_Addresses( It : in out Tagged_But_Not_Exciting;
- Its_Address : in System.Address ) is
- begin
- if It'Address /= Its_Address then
- Report.Failed("Address of object passed by reference does not " &
- "match address of object passed" );
- end if;
- end Muck_With_Addresses;
-
- procedure TC_Check_By_Reference_Types is
- begin
- Muck_With_Addresses( Tagged_Object, Tagged_Object'Address );
- end TC_Check_By_Reference_Types;
-
-end CD30001_0;
-
-------------------------------------------------------------------- CD30001
-
-with Report;
-with CD30001_0;
-procedure CD30001 is
-
-begin -- Main test procedure.
-
- Report.Test ("CD30001",
- "Check that X'Address produces a useful result when X is " &
- "an aliased object, or an entity whose Address has been " &
- "specified" );
-
--- Check that X'Address produces a useful result when X is an aliased
--- object.
---
--- Check that aliased objects and subcomponents are allocated on storage
--- element boundaries. Check that objects and subcomponents of by
--- reference types are allocated on storage element boundaries.
-
- CD30001_0.TC_Check_Aliased_Addresses;
-
--- Check that X'Address produces a useful result when X is an entity
--- whose Address has been specified.
-
- CD30001_0.TC_Check_Specific_Addresses;
-
--- Check that X'Address produces a useful result when X is an object of
--- a by-reference type.
-
- CD30001_0.TC_Check_By_Reference_Types;
-
- Report.Result;
-
-end CD30001;
diff --git a/gcc/testsuite/ada/acats/tests/cd/cd30002.a b/gcc/testsuite/ada/acats/tests/cd/cd30002.a
deleted file mode 100644
index 7b6fff713ee..00000000000
--- a/gcc/testsuite/ada/acats/tests/cd/cd30002.a
+++ /dev/null
@@ -1,207 +0,0 @@
--- CD30002.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that the implementation supports Alignments for subtypes and
--- objects specified as factors and multiples of the number of storage
--- elements per word, unless those values cannot be loaded and stored.
--- Check that the largest alignment returned by default is supported.
---
--- Check that the implementation supports Alignments supported by the
--- target linker for stand-alone library-level objects of statically
--- constrained subtypes.
---
--- TEST DESCRIPTION:
--- This test defines several types and objects, specifying various
--- alignments for them (as factors and multiples of the number of
--- storage elements per word). It then checks the alignments by
--- declaring some objects, and checking that the integer values of
--- their addresses is mod the specified alignment. This will not
--- prevent false passes where the lucky compiler gets it right by
--- chance, but will catch compilers that specifically do not obey
--- the alignment clauses.
---
--- APPLICABILITY CRITERIA:
--- All implementations must attempt to compile this test.
---
--- For implementations validating against Systems Programming Annex (C):
--- this test must execute and report PASSED.
---
--- For implementations not validating against Annex C:
--- this test may report compile time errors at one or more points
--- indicated by "-- ANX-C RQMT", in which case it may be graded as inapplicable.
--- Otherwise, the test must execute and report PASSED.
---
---
--- CHANGE HISTORY:
--- 22 JUL 95 SAIC Initial version
--- 09 MAY 96 SAIC Strengthened for 2.1
--- 26 FEB 97 PWB.CTA Allowed for unexpected word sizes
--- 16 FEB 98 EDS Modified documentation.
--- 26 SEP 98 RLB Fixed value on line 130 so check and dec. match.
--- 30 OCT 98 RLB Split Multiple_Alignment and revised the
--- calculation to work on all targets.
--- 18 JAN 99 RLB Repaired again to work on targets where word size
--- equals storage unit.
---!
-
------------------------------------------------------------------ CD30002_0
-
-with Impdef;
-with System.Storage_Elements;
-package CD30002_0 is
-
- S_Units_per_Word : constant := System.Word_Size/System.Storage_Unit;
- -- Must be 1 or greater.
-
- Multiple_Type_Alignment : constant :=
- Integer'Min ( Impdef.Max_Default_Alignment,
- 2 * S_Units_per_Word );
- -- Calculate a reasonable alignment, but not larger than the
- -- implementation is required to support.
-
- Multiple_Object_Alignment : constant :=
- Integer'Min ( Impdef.Max_Linker_Alignment,
- 2 * S_Units_per_Word );
- -- Calculate a reasonable object alignment, but not larger than
- -- the implementation is required to support.
-
- Small_Alignment : constant :=
- Integer'Max ( S_Units_per_Word / 2, 1);
- -- Calculate a reasonable small alignment, but not less than 1.
- -- (If S_Units_per_Word = 1, 1/2 => 0 which causes problems
- -- verifying alignment.)
-
- subtype Storage_Element is System.Storage_Elements.Storage_Element;
-
- type Some_Stuff is array(1..S_Units_Per_Word) of Storage_Element;
- for Some_Stuff'Alignment
- use Impdef.Max_Default_Alignment; -- ANX-C RQMT.
-
- Library_Level_Object : Some_Stuff;
- for Library_Level_Object'Alignment
- use Impdef.Max_Linker_Alignment; -- ANX-C RQMT.
-
- type Quarter is mod 4; -- two bits
- for Quarter'Alignment use Small_Alignment; -- ANX-C RQMT.
-
- type Half is mod 16; -- nibble
- for Half'Alignment use Multiple_Type_Alignment; -- ANX-C RQMT.
-
- type O_Some_Stuff is array(1..S_Units_Per_Word) of Storage_Element;
-
- type O_Quarter is mod 4; -- two bits
-
- type O_Half is mod 16; -- nibble
-
-end CD30002_0;
-
--- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
-
--- there is no package body CD30002_0
-
-------------------------------------------------------------------- CD30002
-
-with Report;
-with Impdef;
-with CD30002_0;
-with System.Storage_Elements;
-procedure CD30002 is
-
- My_Stuff : CD30002_0.Some_Stuff;
- -- Impdef.Max_Default_Alignment
-
- My_Quarter : CD30002_0.Quarter;
- -- CD30002_0.S_Units_per_Word / 2
-
- My_Half : CD30002_0.Half;
- -- CD30002_0.S_Units_per_Word * 2
-
- Stuff_Object : CD30002_0.O_Some_Stuff;
- for Stuff_Object'Alignment
- use Impdef.Max_Default_Alignment; -- ANX-C RQMT.
-
- Quarter_Object : CD30002_0.O_Quarter;
- for Quarter_Object'Alignment
- use CD30002_0.Small_Alignment; -- ANX-C RQMT.
-
- Half_Object : CD30002_0.O_Half;
- for Half_Object'Alignment
- use CD30002_0.Multiple_Object_Alignment; -- ANX-C RQMT.
-
- subtype IntAdd is System.Storage_Elements.Integer_Address;
- use type System.Storage_Elements.Integer_Address;
-
- function A2I(Value: System.Address) return IntAdd renames
- System.Storage_Elements.To_Integer;
-
- NAC : constant String := " not aligned correctly";
-
-begin -- Main test procedure.
-
- Report.Test ("CD30002", "Check that the implementation supports " &
- "Alignments for subtypes and objects specified " &
- "as factors and multiples of the number of " &
- "storage elements per word, unless those values " &
- "cannot be loaded and stored. Check that the " &
- "largest alignment returned by default is " &
- "supported. Check that the implementation " &
- "supports Alignments supported by the target " &
- "linker for stand-alone library-level objects " &
- "of statically constrained subtypes" );
-
- if A2I(CD30002_0.Library_Level_Object'Address)
- mod Impdef.Max_Linker_Alignment /= 0 then
- Report.Failed("Library_Level_Object" & NAC);
- end if;
-
- if A2I(My_Stuff'Address) mod Impdef.Max_Default_Alignment /= 0 then
- Report.Failed("Max alignment subtype" & NAC);
- end if;
-
- if A2I(My_Quarter'Address) mod (CD30002_0.Small_Alignment) /= 0 then
- Report.Failed("Factor of words subtype" & NAC);
- end if;
-
- if A2I(My_Half'Address) mod (CD30002_0.Multiple_Type_Alignment) /= 0 then
- Report.Failed("Multiple of words subtype" & NAC);
- end if;
-
- if A2I(Stuff_Object'Address) mod Impdef.Max_Default_Alignment /= 0 then
- Report.Failed("Stuff alignment object" & NAC);
- end if;
-
- if A2I(Quarter_Object'Address)
- mod (CD30002_0.Small_Alignment) /= 0 then
- Report.Failed("Factor of words object" & NAC);
- end if;
-
- if A2I(Half_Object'Address) mod (CD30002_0.Multiple_Object_Alignment) /= 0 then
- Report.Failed("Multiple of words object" & NAC);
- end if;
-
- Report.Result;
-
-end CD30002;
diff --git a/gcc/testsuite/ada/acats/tests/cd/cd30003.a b/gcc/testsuite/ada/acats/tests/cd/cd30003.a
deleted file mode 100644
index af414490f42..00000000000
--- a/gcc/testsuite/ada/acats/tests/cd/cd30003.a
+++ /dev/null
@@ -1,227 +0,0 @@
--- CD30003.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that a Size clause for an object is supported if the specified
--- size is at least as large as the subtype's size, and correspond to a
--- size in storage elements that is a multiple of the object's (non-zero)
--- Alignment. RM 13.3(43)
---
--- TEST DESCRIPTION:
--- This test defines several types and then asserts specific sizes for
--- the, it then checks that the size set is reported back.
---
--- APPLICABILITY CRITERIA:
--- All implementations must attempt to compile this test.
---
--- For implementations validating against Systems Programming Annex (C):
--- this test must execute and report PASSED.
---
--- For implementations not validating against Annex C:
--- this test may report compile time errors at one or more points
--- indicated by "-- ANX-C RQMT", in which case it may be graded as inapplicable.
--- Otherwise, the test must execute and report PASSED.
---
---
--- CHANGE HISTORY:
--- 22 JUL 95 SAIC Initial version
--- 08 MAY 96 SAIC Corrected and strengthened for 2.1
--- 14 FEB 97 PWB.CTA Changed 'Size specifications to multiples
--- of System.Storage_Unit; restricted 'Size spec
--- for enumeration object to max integer size.
--- 16 FEB 98 EDS Modify Documentation.
--- 25 JAN 99 RLB Repaired to properly set and check sizes.
--- 29 JAN 99 RLB Added Pack pragma needed for some implementations.
--- Corrected to support a Storage_Unit size < 8.
---!
-
-------------------------------------------------------------------- CD30003
-
-with Report;
-with System;
-procedure CD30003 is
-
- ---------------------------------------------------------------------------
- -- types and subtypes
- ---------------------------------------------------------------------------
-
- type Bit is mod 2**1;
- for Bit'Size use 1; -- ANX-C RQMT.
-
- type Byte is mod 2**8;
- for Byte'Size use 8; -- ANX-C RQMT.
-
- type Smallword is mod 2**8;
- for Smallword'size use 16; -- ANX-C RQMT.
-
- type Byte_Array is array(1..4) of Byte;
- pragma Pack(Byte_Array); -- ANX-C RQMT.
- -- size should be 32
-
- type Smallword_Array is array(1..4) of Smallword;
- pragma Pack(Smallword_Array); -- Required if Storage_Unit > 16. -- ANX-C RQMT.
-
- -- Use to calulate maximum required size:
- type Max_Modular is mod System.Max_Binary_Modulus;
- type Max_Integer is range System.Min_Int .. System.Max_Int;
- Enum_Size : constant := Integer'Min (32,
- Integer'Min (Max_Modular'Size, Max_Integer'Size));
- type Transmission_Data is ( Empty, Input, Output, IO, Control );
- for Transmission_Data'Size use Enum_Size; -- ANX-C RQMT.
-
- -- Sizes to try:
-
- -- The basic sizes are based on a "normal" Storage_Unit = 8 implementation.
- -- We then use formulas to insure that the specified sizes meet the
- -- the minimum level of support and AI-0051.
-
- Modular_Single_Size : constant := Integer'Min (((8 + (System.Storage_Unit-1))
- /System.Storage_Unit)*System.Storage_Unit, Max_Modular'Size);
- -- Calulate an appropriate, legal, and required to be supported size to
- -- try, which is the size of Byte. Note that object sizes must be
- -- a multiple of the storage unit for the compiler.
-
- Modular_Double_Size : constant := Integer'Min (((16 + (System.Storage_Unit-1))
- /System.Storage_Unit)*System.Storage_Unit, Max_Modular'Size);
-
- Modular_Quad_Size : constant := Integer'Min (((32 + (System.Storage_Unit-1))
- /System.Storage_Unit)*System.Storage_Unit, Max_Modular'Size);
-
- Array_Quad_Size : constant := ((4 * 8 + (System.Storage_Unit-1))
- /System.Storage_Unit)*System.Storage_Unit;
-
- Array_Octo_Size : constant := ((4 * 16 + (System.Storage_Unit-1))
- /System.Storage_Unit)*System.Storage_Unit;
-
- Rounded_Enum_Size : constant := ((Enum_Size + (System.Storage_Unit-1))
- /System.Storage_Unit)*System.Storage_Unit;
-
- Enum_Quad_Size : constant := Integer'Min (((32 + (System.Storage_Unit-1))
- /System.Storage_Unit)*System.Storage_Unit,
- Integer'Min (Max_Modular'Size, Max_Integer'Size));
-
-
- ---------------------------------------------------------------------------
- -- objects
- ---------------------------------------------------------------------------
-
- Bit_8 : Bit :=0;
- for Bit_8'Size use System.Storage_Unit; -- ANX-C RQMT.
-
- Bit_G : Bit :=0;
- for Bit_G'Size use Modular_Double_Size; -- ANX-C RQMT.
-
- Byte_8 : Byte :=0;
- for Byte_8'Size use Modular_Single_Size; -- ANX-C RQMT.
-
- Byte_G : Byte :=0;
- for Byte_G'Size use Modular_Double_Size; -- ANX-C RQMT.
-
- Smallword_1 : Smallword :=0;
- for Smallword_1'Size use Modular_Double_Size; -- ANX-C RQMT.
-
- Smallword_2 : Smallword :=0;
- for Smallword_2'Size use Modular_Quad_Size; -- ANX-C RQMT.
-
- Byte_Array_1 : Byte_Array := (others=>0);
- for Byte_Array_1'Size use Array_Quad_Size; -- ANX-C RQMT.
-
- Smallword_Array_1 : Smallword_Array := (others=>0);
- for Smallword_Array_1'Size use Array_Octo_Size; -- ANX-C RQMT.
-
- Transmission_Data_1 : aliased Transmission_Data := Empty;
-
- Transmission_Data_2 : Transmission_Data := Control;
- for Transmission_Data_2'Size use Enum_Quad_Size; -- ANX-C RQMT.
-
-begin -- Main test procedure.
-
- Report.Test ("CD30003", "Check that Size clauses are supported for " &
- "values at least as large as the subtypes " &
- "size, and correspond to a size in storage " &
- "elements that is a multiple of the objects " &
- "(non-zero) Alignment" );
-
- if Bit_8'Size /= System.Storage_Unit then
- Report.Failed("Expected Bit_8'Size =" & Integer'Image(System.Storage_Unit)
- & " , actually =" & Integer'Image(Bit_8'Size));
- end if;
-
- if Bit_G'Size /= Modular_Double_Size then
- Report.Failed("Expected Bit_G'Size =" & Integer'Image(Modular_Double_Size)
- & " , actually =" & Integer'Image(Bit_G'Size));
- end if;
-
- if Byte_8'Size /= Modular_Single_Size then
- Report.Failed("Expected Byte_8'Size =" & Integer'Image(Modular_Single_Size)
- & " , actually =" & Integer'Image(Byte_8'Size));
- end if;
-
- if Byte_G'Size /= Modular_Double_Size then
- Report.Failed("Expected Bit_G'Size =" & Integer'Image(Modular_Double_Size)
- & " , actually =" & Integer'Image(Byte_G'Size));
- end if;
-
- if Smallword_1'Size /= Modular_Double_Size then
- Report.Failed("Expected Smallword_1'Size =" &
- Integer'Image(Modular_Double_Size) &
- ", actually =" & Integer'Image(Smallword_1'Size));
- end if;
-
- if Smallword_2'Size /= Modular_Quad_Size then
- Report.Failed("Expected Smallword_2'Size =" &
- Integer'Image(Modular_Quad_Size) &
- ", actually =" & Integer'Image(Smallword_2'Size));
- end if;
-
- if Byte_Array_1'Size /= Array_Quad_Size then
- Report.Failed("Expected Byte_Array_1'Size =" &
- Integer'Image(Array_Quad_Size) &
- ", actually =" & Integer'Image(Byte_Array_1'Size));
- end if;
-
- if Smallword_Array_1'Size /= Array_Octo_Size then
- Report.Failed(
- "Expected Smallword_Array_1'Size =" &
- Integer'Image(Array_Octo_Size) &
- ", actually =" & Integer'Image(Smallword_Array_1'Size));
- end if;
-
- if Transmission_Data_1'Size /= Enum_Size and then
- Transmission_Data_1'Size /= Rounded_Enum_Size then
- Report.Failed(
- "Expected Transmission_Data_1'Size =" & Integer'Image(Rounded_Enum_Size) &
- ", actually =" & Integer'Image(Transmission_Data_1'Size));
- end if;
-
- if Transmission_Data_2'Size /= Enum_Quad_Size then
- Report.Failed(
- "Expected Transmission_Data_2'Size =" & Integer'Image(Enum_Quad_Size) &
- ", actually =" & Integer'Image(Transmission_Data_2'Size));
- end if;
-
- Report.Result;
-
-end CD30003;
diff --git a/gcc/testsuite/ada/acats/tests/cd/cd30004.a b/gcc/testsuite/ada/acats/tests/cd/cd30004.a
deleted file mode 100644
index 1a1bcff1f5d..00000000000
--- a/gcc/testsuite/ada/acats/tests/cd/cd30004.a
+++ /dev/null
@@ -1,215 +0,0 @@
--- CD30004.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
---
---
--- Check that the unspecified Size of static discrete
--- subtypes is the number of bits needed to represent each value
--- belonging to the subtype using an unbiased representation, where
--- space for a sign bit is provided only in the event the subtype
--- contains negative values. Check that for first subtypes specified
--- Sizes are supported reflecting this representation. [ARM 95 13.3(55)].
---
--- TEST DESCRIPTION:
--- This test defines a few types that should have distinctly recognizable
--- sizes. A packed record which should result in very specific bits
--- sizes for it's components is used to check the first part of the
--- objective. The second part of the objective is checked by giving
--- sizes for a similar set of types.
---
--- APPLICABILITY CRITERIA:
--- All implementations must attempt to compile this test.
---
--- For implementations validating against Systems Programming Annex (C):
--- this test must execute and report PASSED.
---
--- For implementations not validating against Annex C:
--- this test may report compile time errors at one or more points
--- indicated by "-- ANX-C RQMT", in which case it may be graded as inapplicable.
--- Otherwise, the test must execute and report PASSED.
---
--- CHANGE HISTORY:
--- 22 JUL 95 SAIC Initial version
--- 06 MAY 96 SAIC Revised for 2.1
--- 26 FEB 97 PWB.CTA Added pragma Pack for type Check_Record
--- 16 FEB 98 EDS Modified Documentation.
--- 06 JUL 99 RLB Repaired comments, removed junk test cases.
--- Added test cases to test that appropriate Size
--- clauses are allowed.
-
---!
------------------------------------------------------------------ CD30004_0
-
-package CD30004_0 is
-
--- Check that the unspecified Size of static discrete and fixed point
--- subtypes are the number of bits needed to represent each value
--- belonging to the subtype using an unbiased representation, where
--- space for a sign bit is provided only in the event the subtype
--- contains negative values. Check that for first subtypes specified
--- Sizes are supported reflecting this representation.
-
- type Bits_2 is ( Zeroth_Bit, Fiercest_Bit, Secants_Bit, Threadless_Bit );
-
- type Bits_3 is range 0..2**3-1;
-
- type Bits_5 is range -2**4+1..2**4-1; -- allow for 1's comp
-
- type Bits_14 is mod 2**14;
-
- type Check_Record is
- record
- B14 : Bits_14;
- B2 : Bits_2;
- B3 : Bits_3;
- B5 : Bits_5;
- C : Character;
- end record;
- pragma Pack ( Check_Record );
-
- procedure TC_Check_Values;
- procedure TC_Check_Specified_Sizes;
-
-end CD30004_0;
-
--- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
-with Report;
-with Impdef;
-package body CD30004_0 is
-
- procedure TC_Check_Values is
- begin
-
- if Bits_2'Size /= 2 then
- if Impdef.Validating_Annex_C then
- Report.Failed("Bits_2'Size not 2 bits");
- else -- Recommended levels of support are not binding.
- Report.Comment("Bits_2'Size not 2 bits");
- end if;
- end if;
-
- if Bits_14'Size /= 14 then
- if Impdef.Validating_Annex_C then
- Report.Failed("Bits_14'Size not 14 bits");
- else
- Report.Comment("Bits_14'Size not 14 bits");
- end if;
- end if;
-
- if Bits_3'Size /= 3 then
- if Impdef.Validating_Annex_C then
- Report.Failed("Bits_3'Size not 3 bits");
- else
- Report.Comment("Bits_3'Size not 3 bits");
- end if;
- end if;
-
- if Bits_5'Size /= 5 then
- if Impdef.Validating_Annex_C then
- Report.Failed("Bits_5'Size not 5 bits");
- else
- Report.Comment("Bits_5'Size not 5 bits");
- end if;
- end if;
-
- if Character'Size /= 8 then
- Report.Failed("Character'Size not 8 bits");
- end if;
-
- if Wide_Character'Size /= 16 then
- Report.Failed("Wide_Character'Size not 16 bits");
- end if;
-
- end TC_Check_Values;
-
- type Spec_Bits_2 is ( Zeroth_Bit, Fiercest_Bit, Secants_Bit, Threadless_Bit );
- for Spec_Bits_2'Size use 2; -- ANX-C RQMT.
-
- type Spec_Bits_3 is range 0..2**3-1;
- for Spec_Bits_3'Size use 3; -- ANX-C RQMT.
-
- type Spec_Bits_5 is range -2**4+1..2**4-1; -- allow for 1's comp
- for Spec_Bits_5'Size use 5; -- ANX-C RQMT.
-
- type Spec_Bits_14 is mod 2**14;
- for Spec_Bits_14'Size use 14; -- ANX-C RQMT.
-
- type Spec_Record is new Check_Record;
- for Spec_Record'Size use 64; -- ANX-C RQMT.
-
- procedure TC_Check_Specified_Sizes is
-
- begin
-
- if Spec_Record'Size /= 64 then
- Report.Failed("Spec_Record'Size not 64 bits");
- end if;
-
- if Spec_Bits_2'Size /= 2 then
- Report.Failed("Spec_Bits_2'Size not 2 bits");
- end if;
-
- if Spec_Bits_14'Size /= 14 then
- Report.Failed("Spec_Bits_14'Size not 14 bits");
- end if;
-
- if Spec_Bits_3'Size /= 3 then
- Report.Failed("Spec_Bits_3'Size not 3 bits");
- end if;
-
- if Spec_Bits_5'Size /= 5 then
- Report.Failed("Spec_Bits_5'Size not 5 bits");
- end if;
-
- end TC_Check_Specified_Sizes;
-
-end CD30004_0;
-
-------------------------------------------------------------------- CD30004
-
-with Report;
-with CD30004_0;
-
-procedure CD30004 is
-
-begin -- Main test procedure.
-
- Report.Test ("CD30004", "Check that the unspecified Size of static " &
- "discrete and fixed point subtypes is the number of bits " &
- "needed to represent each value belonging to the subtype " &
- "using an unbiased representation, where space for a sign " &
- "bit is provided only in the event the subtype contains " &
- "negative values. Check that for first subtypes " &
- "specified Sizes are supported reflecting this " &
- "representation.");
-
- CD30004_0.TC_Check_Values;
-
- CD30004_0.TC_Check_Specified_Sizes;
-
- Report.Result;
-
-end CD30004;
diff --git a/gcc/testsuite/ada/acats/tests/cd/cd33001.a b/gcc/testsuite/ada/acats/tests/cd/cd33001.a
deleted file mode 100644
index 82555054aef..00000000000
--- a/gcc/testsuite/ada/acats/tests/cd/cd33001.a
+++ /dev/null
@@ -1,139 +0,0 @@
--- CD33001.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that Component_Sizes that are a factor of the word
--- size are supported.
---
--- Check that for such Component_Sizes arrays contain no gaps between
--- components.
---
--- TEST DESCRIPTION:
--- This test defines three array types and specifies their layouts
--- using representation specifications for the 'Component_Size and
--- pragma Packs for each. It then checks that the implied assumptions
--- about the resulting layout actually can be made.
---
--- APPLICABILITY CRITERIA:
--- All implementations must attempt to compile this test.
---
--- For implementations validating against Systems Programming Annex (C):
--- this test must execute and report PASSED.
---
--- For implementations not validating against Annex C:
--- this test may report compile time errors at one or more points
--- indicated by "-- ANX-C RQMT", in which case it may be graded as inapplicable.
--- Otherwise, the test must execute and report PASSED.
---
---
--- CHANGE HISTORY:
--- 22 JUL 95 SAIC Initial version
--- 07 MAY 96 SAIC Revised for 2.1
--- 24 AUG 96 SAIC Additional 2.1 revisions
--- 17 FEB 97 PWB.CTA Corrected prefix of 'Component_Size to name
--- array object instead of array subtype
--- 16 FEB 98 EDS Modified documentation.
---!
-
------------------------------------------------------------------ CD33001_0
-
-with System;
-package CD33001_0 is
-
- S_Units_per_Word : constant := System.Word_Size/System.Storage_Unit;
-
- type Nibble is mod 2**4;
-
- type Byte is mod 2**8;
-
- type Half_Stuff is array(Natural range <>) of Nibble;
- for Half_Stuff'Component_Size
- use System.Word_Size / 2; -- factor -- ANX-C RQMT.
- pragma Pack(Half_Stuff); -- ANX-C RQMT.
-
- type Word_Stuff is array(Natural range <>) of Byte;
- for Word_Stuff'Component_Size
- use System.Word_Size; -- ANX-C RQMT.
-
- type Address_Calculator is record
- Item_1 : Nibble;
- Item_2 : Nibble;
- end record;
-
- for Address_Calculator use record
- Item_1 at 0 range 0..3;
- Item_2 at 1 range 0..3;
- end record;
-
- -- given that Item_1 is specified to be at 'Position = 0 and
- -- Item_2 is specified to be at 'Position = 1
- -- by definition (13.5.2(2)) abs(Item_2'Address - Item_1'Address) = 1
-
-end CD33001_0;
-
--- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
-
--- there is no package body CD33001_0
-
-------------------------------------------------------------------- CD33001
-
-with Report;
-with System.Storage_Elements;
-with CD33001_0;
-procedure CD33001 is
-
- use type System.Storage_Elements.Storage_Offset;
-
- A_Half : CD33001_0.Half_Stuff(0..15);
-
- A_Word : CD33001_0.Word_Stuff(0..15);
-
- procedure Unexpected( Message : String; Wanted, Got: Integer ) is
- begin
- Report.Failed( Message & " Wanted:"
- & Integer'Image(Wanted) & " Got:" & Integer'Image(Got) );
- end Unexpected;
-
-begin -- Main test procedure.
-
- Report.Test ("CD33001", "Check that Component_Sizes that are factor of " &
- "the word size are supported. Check that for " &
- "such Component_Sizes arrays contain no gaps " &
- "between components" );
-
- if A_Half'Size /= A_Half'Component_Size * 16 then
- Unexpected("Half word Size",
- CD33001_0.Half_Stuff'Component_Size * 16,
- A_Half'Size );
- end if;
-
- if A_Word(1)'Size /= System.Word_Size then
- Unexpected("Word Size", System.Word_Size, A_Word(1)'Size );
- end if;
-
-
- Report.Result;
-
-end CD33001;
diff --git a/gcc/testsuite/ada/acats/tests/cd/cd33002.a b/gcc/testsuite/ada/acats/tests/cd/cd33002.a
deleted file mode 100644
index 5b3cdbd5f82..00000000000
--- a/gcc/testsuite/ada/acats/tests/cd/cd33002.a
+++ /dev/null
@@ -1,140 +0,0 @@
--- CD33002.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that Component_Sizes that are multiples of the word
--- size are supported.
---
--- Check that for such Component_Sizes arrays contain no gaps between
--- components.
---
--- TEST DESCRIPTION:
--- This test defines three array types and specifies their layouts
--- using representation specifications for the 'Component_Size and
--- pragma Packs for each. It then checks that the implied assumptions
--- about the resulting layout actually can be made.
---
--- APPLICABILITY CRITERIA:
--- All implementations must attempt to compile this test.
---
--- For implementations validating against Systems Programming Annex (C):
--- this test must execute and report PASSED.
---
--- For implementations not validating against Annex C:
--- this test may report compile time errors at one or more points
--- indicated by "-- ANX-C RQMT", in which case it may be graded as inapplicable.
--- Otherwise, the test must execute and report PASSED.
---
---
--- CHANGE HISTORY:
--- 22 JUL 95 SAIC Initial version
--- 07 MAY 96 SAIC Revised for 2.1
--- 24 AUG 96 SAIC Additional 2.1 revisions
--- 16 FEB 98 EDS Modify documentation.
---!
-
------------------------------------------------------------------ CD33002_0
-
-with System;
-package CD33002_0 is
-
- S_Units_per_Word : constant := System.Word_Size/System.Storage_Unit;
-
- type Nibble is mod 2**4;
-
- type Byte is mod 2**8;
-
- type Word_Stuff is array(Natural range <>) of Byte;
- for Word_Stuff'Component_Size
- use System.Word_Size; -- ANX-C RQMT.
- pragma Pack(Word_Stuff); -- ANX-C RQMT.
-
- type Double_Stuff is array(Natural range <>) of Byte;
- for Double_Stuff'Component_Size
- use System.Word_Size * 2; -- multiple -- ANX-C RQMT.
-
- type Address_Calculator is record
- Item_1 : Nibble;
- Item_2 : Nibble;
- end record;
-
- for Address_Calculator use record
- Item_1 at 0 range 0..3;
- Item_2 at 1 range 0..3;
- end record;
-
- -- by definition (13.5.2(2)) abs(Item_2'Address - Item_1'Address) = 1
- -- it therefore follows that:
- -- Address_Calculator'Size = 2 * Addressable_Unit'Size
-
-end CD33002_0;
-
--- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
-
--- there is no package body CD33002_0
-
-------------------------------------------------------------------- CD33002
-
-with Report;
-with TCTouch;
-with System.Storage_Elements;
-with CD33002_0;
-procedure CD33002 is
-
- use type System.Storage_Elements.Storage_Offset;
-
- A_Word : CD33002_0.Word_Stuff(0..15);
-
- A_Double : CD33002_0.Double_Stuff(0..15);
-
- procedure Unexpected( Message : String; Wanted, Got: Integer ) is
- begin
- Report.Failed ( Message & " Wanted:"
- & Integer'Image(Wanted) & " Got:" & Integer'Image(Got) );
- end Unexpected;
-
-begin -- Main test procedure.
-
- Report.Test ("CD33002", "Check that Component_Sizes that are multiples "
- & "of the word size are supported. Check that for "
- & "such Component_Sizes arrays contain no gaps "
- & "between components" );
-
- if A_Word'Size /= CD33002_0.Word_Stuff'Component_Size * 16 then
- Unexpected("Word Size",
- CD33002_0.Word_Stuff'Component_Size * 16,
- A_Word'Size );
- end if;
-
- if A_Double'Size /= CD33002_0.Double_Stuff'Component_Size * 16 then
- Unexpected("Double word Size",
- CD33002_0.Double_Stuff'Component_Size * 16,
- A_Double'Size );
- end if;
-
-
- Report.Result;
-
-end CD33002;
diff --git a/gcc/testsuite/ada/acats/tests/cd/cd40001.a b/gcc/testsuite/ada/acats/tests/cd/cd40001.a
deleted file mode 100644
index 273271fdb8e..00000000000
--- a/gcc/testsuite/ada/acats/tests/cd/cd40001.a
+++ /dev/null
@@ -1,181 +0,0 @@
--- CD40001.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that Enumeration_Representation_Clauses are supported for
--- codes in the range System.Min_Int..System.Max_Int.
---
--- TEST DESCRIPTION:
--- This test defines several types, and checks that the range of the
--- enumeration clause is as expected.
---
--- APPLICABILITY CRITERIA:
--- All implementations must attempt to compile this test.
---
--- For implementations validating against Systems Programming Annex (C):
--- this test must execute and report PASSED.
---
--- For implementations not validating against Annex C:
--- this test may report compile time errors at one or more points
--- indicated by "-- ANX-C RQMT", in which case it may be graded as inapplicable.
--- Otherwise, the test must execute and report PASSED.
---
---
--- CHANGE HISTORY:
--- 22 JUL 95 SAIC Initial version
--- 07 MAY 96 SAIC Revised for 2.1
--- 16 FEB 98 EDS Modified Documentation.
---!
-
-with System;
-with Ada.Unchecked_Conversion;
-package CD40001_0 is
-
- type Press_The_Bounds is ( Negative_Large, Positive_Large );
-
- for Press_The_Bounds use
- ( Negative_Large => System.Min_Int, -- ANX-C RQMT.
- Positive_Large => System.Max_Int ); -- ANX-C RQMT.
-
- type Add_The_Bounds is
- ( Monday, Tuesday, Wednesday, Thursday, Friday, Saturday);
-
- for Add_The_Bounds use
- ( Monday => System.Min_Int, -- ANX-C RQMT.
- Tuesday => System.Min_Int + 1, -- ANX-C RQMT.
- Wednesday => System.Min_Int + 2, -- ANX-C RQMT.
- Thursday => System.Min_Int + 3, -- ANX-C RQMT.
- Friday => System.Min_Int + 4, -- ANX-C RQMT.
- Saturday => System.Min_Int + 5 ); -- ANX-C RQMT.
-
- type Minus_The_Bounds is ( Jan, Feb, Mar, Apr);
-
- for Minus_The_Bounds use
- ( Apr => System.Max_Int, -- ANX-C RQMT.
- Mar => System.Max_Int - 1, -- ANX-C RQMT.
- Feb => System.Max_Int - 2, -- ANX-C RQMT.
- Jan => System.Max_Int - 3 ); -- ANX-C RQMT.
-
- type TC_Integer is range System.Min_Int..System.Max_Int;
-
- procedure TC_Check_Press;
-
- procedure TC_Check_Add;
-
- procedure TC_Check_Minus;
-
- function TC_Compare_Press is new Ada.Unchecked_Conversion
- (Press_The_Bounds, TC_Integer);
-
- function TC_Compare_Add is new Ada.Unchecked_Conversion
- (Add_The_Bounds, TC_Integer);
-
- function TC_Compare_Minus is new Ada.Unchecked_Conversion
- (Minus_The_Bounds, TC_Integer);
-
-end CD40001_0;
-
- --==================================================================--
-
-with Report;
-package body CD40001_0 is
-
- procedure TC_Check_Press is
- My_Press_First : Press_The_Bounds := Negative_Large;
- My_Press_Last : Press_The_Bounds := Positive_Large;
- begin
- if TC_Compare_Press (My_Press_First) /= System.Min_Int or
- TC_Compare_Press (My_Press_Last) /= System.Max_Int
- then
- Report.Failed
- ("Expected enumeration size of System.Min_Int and System.Max_Int " &
- "not available for this implementation");
- end if;
- end TC_Check_Press;
-
- ---------------------------------------------------------------------------
- procedure TC_Check_Add is
- My_Monday : Add_The_Bounds := Monday;
- My_Tuesday : Add_The_Bounds := Tuesday;
- My_Wednesday : Add_The_Bounds := Wednesday;
- My_Thursday : Add_The_Bounds := Thursday;
- My_Friday : Add_The_Bounds := Friday;
- My_Saturday : Add_The_Bounds := Saturday;
- begin
- if TC_Compare_Add (My_Monday) /= (System.Min_Int) or
- TC_Compare_Add (My_Thursday) /= (System.Min_Int + 3) or
- TC_Compare_Add (My_Wednesday) /= (System.Min_Int + 2) or
- TC_Compare_Add (My_Tuesday) /= (System.Min_Int + 1) or
- TC_Compare_Add (My_Saturday) /= (System.Min_Int + 5) or
- TC_Compare_Add (My_Friday) /= (System.Min_Int + 4)
- then
- Report.Failed
- ("Expected enumeration size of System.Min_Int, System.Min_Int + 1 " &
- "through System.Min_Int + 5 not available for this implementation");
- end if;
- end TC_Check_Add;
-
- ---------------------------------------------------------------------------
- procedure TC_Check_Minus is
- My_Jan : Minus_The_Bounds := Jan;
- My_Feb : Minus_The_Bounds := Feb;
- My_Mar : Minus_The_Bounds := Mar;
- My_Apr : Minus_The_Bounds := Apr;
- begin
- if TC_Compare_Minus (My_Jan) /= (System.Max_Int - 3) or
- TC_Compare_Minus (My_Feb) /= (System.Max_Int - 2) or
- TC_Compare_Minus (My_Mar) /= (System.Max_Int - 1) or
- TC_Compare_Minus (My_Apr) /= (System.Max_Int)
- then
- Report.Failed
- ("Expected enumeration size of System.Max_Int, System.Max_Int - 1 " &
- "through System.Max_Int - 3 not available for this implementation");
- end if;
- end TC_Check_Minus;
-
-end CD40001_0;
-
- --==================================================================--
-
-with Report;
-with CD40001_0;
-
-procedure CD40001 is
-
-begin -- Main test procedure.
-
- Report.Test ("CD40001", "Check that Enumeration_Representation_Clauses " &
- "are supported for codes in the range " &
- "System.Min_Int..System.Max_Int" );
-
- CD40001_0.TC_Check_Press;
-
- CD40001_0.TC_Check_Add;
-
- CD40001_0.TC_Check_Minus;
-
- Report.Result;
-
-end CD40001;
diff --git a/gcc/testsuite/ada/acats/tests/cd/cd70001.a b/gcc/testsuite/ada/acats/tests/cd/cd70001.a
deleted file mode 100644
index 48400958804..00000000000
--- a/gcc/testsuite/ada/acats/tests/cd/cd70001.a
+++ /dev/null
@@ -1,201 +0,0 @@
---
--- CD70001.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that package System includes Max_Base_Digits, Address,
--- Null_Address, Word_Size, functions "<", "<=", ">", ">=", "="
--- (with Address parameters and Boolean results), Bit_Order,
--- Default_Bit_Order, Any_Priority, Interrupt_Priority,
--- and Default_Priority.
---
--- Check that package System.Storage_Elements includes all required
--- types and operations.
---
--- TEST DESCRIPTION:
--- The test checks for the existence of the names additional
--- to package system above those names tested for in 9Xbasic.
---
--- This test checks that the semantics provided in Storage_Elements
--- are present and operate marginally within expectations (to the best
--- extent possible in a portable implementation independent fashion).
---
---
--- CHANGE HISTORY:
--- 09 MAY 95 SAIC Initial version
--- 27 JAN 96 SAIC Revised for 2.1; Allow negative address delta
---
---!
-
-with Report;
-with Ada.Text_IO;
-with System.Storage_Elements;
-with System.Address_To_Access_Conversions;
-procedure CD70001 is
- use System;
-
- procedure CD70 is
-
- type Int_Max is range Min_Int .. Max_Int;
-
- My_Int : Int_Max := System.Max_Base_Digits + System.Word_Size;
-
- An_Address : Address;
- An_Other_Address : Address := An_Address'Address;
-
- begin -- 7.0
-
-
- if Default_Bit_Order not in High_Order_First..Low_Order_First then
- Report.Failed ("Default_Bit_Order invalid");
- end if;
-
- if Bit_Order'Pos(High_Order_First) /= 0 then
- Report.Failed ("Bit_Order'Pos(High_Order_First) /= 0");
- end if;
-
- if Bit_Order'Pos(Low_Order_First) /= 1 then
- Report.Failed ("Bit_Order'Pos(Low_Order_First) /= 1");
- end if;
-
- An_Address := My_Int'Address;
-
- if An_Address = Null_Address then
- Report.Failed ("Null_Address matched a real address");
- end if;
-
-
- if An_Address'Address /= An_Other_Address then
- Report.Failed("Value set at elaboration not equal to itself");
- end if;
-
- if An_Address'Address > An_Other_Address
- and An_Address'Address < An_Other_Address then
- Report.Failed("Address is both greater and less!");
- end if;
-
- if not (An_Address'Address >= An_Other_Address
- and An_Address'Address <= An_Other_Address) then
- Report.Failed("Address comparisons wrong");
- end if;
-
-
- if Priority'First /= Any_Priority'First then
- Report.Failed ("Priority'First /= Any_Priority'First");
- end if;
-
- if Interrupt_Priority'First /= Priority'Last+1 then
- Report.Failed ("Interrupt_Priority'First /= Priority'Last+1");
- end if;
-
- if Interrupt_Priority'Last /= Any_Priority'Last then
- Report.Failed ("Interrupt_Priority'Last /= Any_Priority'Last");
- end if;
-
- if Default_Priority /= ((Priority'First + Priority'Last)/2) then
- Report.Failed ("Default_Priority wrong value");
- end if;
-
- end CD70;
-
- procedure CD71 is
- use System.Storage_Elements;
-
- Storehouse_1 : Storage_Array(0..127);
- Storehouse_2 : Storage_Array(0..127);
-
- House_Offset : Storage_Offset;
-
- begin -- 7.1
-
-
- if Storage_Count'First /= 0 then
- Report.Failed ("Storage_Count'First /= 0");
- end if;
-
- if Storage_Count'Last /= Storage_Offset'Last then
- Report.Failed ("Storage_Count'Last /= Storage_Offset'Last");
- end if;
-
-
- if Storage_Element'Size /= Storage_Unit then
- Report.Failed ("Storage_Element'Size /= Storage_Unit");
- end if;
-
- if Storage_Array'Component_Size /= Storage_Unit then
- Report.Failed ("Storage_Array'Element_Size /= Storage_Unit");
- end if;
-
- if Storage_Element'Last+1 /= 0 then
- Report.Failed ("Storage_Element not modular");
- end if;
-
-
- -- "+", "-"( Address, Storage_Offset) and inverse
-
- House_Offset := Storehouse_2'Address - Storehouse_1'Address;
- -- Address - Address = Offset
- -- Note that House_Offset may be a negative value
-
- if House_Offset + Storehouse_1'Address /= Storehouse_2'Address then
- -- Offset + Address = Address
- Report.Failed ("Storage arithmetic non-linear O+A");
- end if;
-
- if Storehouse_1'Address + House_Offset /= Storehouse_2'Address then
- -- Address + Offset = Address
- Report.Failed ("Storage arithmetic non-linear A+O");
- end if;
-
- if Storehouse_2'Address - House_Offset /= Storehouse_1'Address then
- -- Address - Offset = Address
- Report.Failed ("Storage arithmetic non-linear A-O");
- end if;
-
- if (Storehouse_2'Address mod abs(House_Offset) > abs(House_Offset)) then
- -- "mod"( Address, Storage_Offset)
- Report.Failed("Mod arithmetic");
- end if;
-
-
- if Storehouse_1'Address
- /= To_Address(To_Integer(Storehouse_1'Address)) then
- Report.Failed("To_Address, To_Integer not symmetric");
- end if;
-
- end CD71;
-
-
-begin -- Main test procedure.
-
- Report.Test ("CD70001", "Check package System" );
-
- CD70;
-
- CD71;
-
- Report.Result;
-
-end CD70001;
diff --git a/gcc/testsuite/ada/acats/tests/cd/cd72a01.a b/gcc/testsuite/ada/acats/tests/cd/cd72a01.a
deleted file mode 100644
index 9c98cb0c67e..00000000000
--- a/gcc/testsuite/ada/acats/tests/cd/cd72a01.a
+++ /dev/null
@@ -1,165 +0,0 @@
---
--- CD72A01.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that the package System.Address_To_Access_Conversions may be
--- instantiated for various simple types.
---
--- Check that To_Pointer and To_Address are inverse operations.
---
--- Check that To_Pointer(X'Address) equals X'Unchecked_Access for an
--- X that allows Unchecked_Access.
---
--- Check that To_Pointer(Null_Address) returns null.
---
--- TEST DESCRIPTION:
--- This test checks that the semantics provided in
--- Address_To_Access_Conversions are present and operate
--- within expectations (to the best extent possible in a portable
--- implementation independent fashion).
---
--- The functions Address_To_Hex and Hex_To_Address test the invertability
--- of the To_Integer and To_Address functions, along with a great deal
--- of optimizer chaff and protection from the fact that type
--- Storage_Elements.Integer_Address may be either a modular or a signed
--- integer type.
---
--- This test has some interesting usage paradigms in that users
--- occasionally want to store address information in a transportable
--- fashion, and often resort to some textual representation of values.
---
--- APPLICABILITY CRITERIA:
--- All implementations must attempt to compile this test.
---
--- For implementations validating against Systems Programming Annex (C):
--- this test must execute and report PASSED.
---
--- For implementations not validating against Annex C:
--- this test may report compile time errors at one or more points
--- indicated by "-- ANX-C RQMT", in which case it may be graded as inapplicable.
--- Otherwise, the test must execute and report PASSED.
---
--- CHANGE HISTORY:
--- 13 JUL 95 SAIC Initial version (CD72001)
--- 08 FEB 96 SAIC Revised (split) version for 2.1
--- 07 MAY 96 SAIC Additional subtest added for 2.1
--- 16 FEB 98 EDS Modified documentation.
---!
-
-with Report;
-with Impdef;
-with FD72A00;
-with System.Storage_Elements;
-with System.Address_To_Access_Conversions;
-procedure CD72A01 is
- use System;
- use FD72A00;
-
- package Number_ATAC is
- new System.Address_To_Access_Conversions(Number); -- ANX-C RQMT
-
- use type Number_ATAC.Object_Pointer;
-
- type Data is record
- One, Two: aliased Number;
- end record;
-
- package Data_ATAC is
- new System.Address_To_Access_Conversions(Data); -- ANX-C RQMT
-
- use type Data_ATAC.Object_Pointer;
-
- type Test_Cases is ( Addr_Type, Record_Type );
-
- type Naive_Dynamic_String is access String;
-
- type String_Store is array(Test_Cases) of Naive_Dynamic_String;
-
- The_Strings : String_Store;
-
- -- create several aliased objects with distinct values
-
- My_Number : aliased Number := Number'First;
- My_Data : aliased Data := (Number'First,Number'Last);
-
- use type System.Storage_Elements.Integer_Address;
-
-begin -- Main test procedure.
-
- Report.Test ("CD72A01", "Check package " &
- "System.Address_To_Access_Conversions " &
- "for simple types" );
-
- -- take several pointer objects, convert them to addresses, and store
- -- the address as a hexadecimal representation for later reconversion
-
- The_Strings(Addr_Type) := new String'(
- Address_To_Hex(Number_ATAC.To_Address(My_Number'Access)) );
-
- The_Strings(Record_Type) := new String'(
- Address_To_Hex(Data_ATAC.To_Address(My_Data'Access)) );
-
- -- now, reconvert the hexadecimal address values back to pointers,
- -- and check that the dereferenced pointer still designates the
- -- value placed at that location. The use of the intermediate
- -- string representation should foil even the cleverest of optimizers
-
- if Number_ATAC.To_Pointer(
- Hex_To_Address(The_Strings(Addr_Type))).all
- /= Number'First then
- Report.Failed("Number reconversion");
- end if;
-
- if Data_ATAC.To_Pointer(Hex_To_Address(The_Strings(Record_Type))).all
- /= (Number'First,Number'Last) then
- Report.Failed("Data reconversion");
- end if;
-
- -- check that the resulting values are equal to the 'Unchecked_Access
- -- of the value
-
- if Number_ATAC.To_Pointer(
- Hex_To_Address(The_Strings(Addr_Type)))
- /= My_Number'Unchecked_Access then
- Report.Failed("Number Unchecked_Access");
- end if;
-
- if Data_ATAC.To_Pointer(Hex_To_Address(The_Strings(Record_Type)))
- /= My_Data'Unchecked_Access then
- Report.Failed("Data Unchecked_Access");
- end if;
-
- if Number_ATAC.To_Pointer(System.Null_Address) /= null then
- Report.Failed("To_Pointer(Null_Address) /= null");
- end if;
-
- if Number_ATAC.To_Address(null) /= System.Null_Address then
- Report.Failed("To_Address(null) /= Null_Address");
- end if;
-
- Report.Result;
-
-end CD72A01;
diff --git a/gcc/testsuite/ada/acats/tests/cd/cd72a02.a b/gcc/testsuite/ada/acats/tests/cd/cd72a02.a
deleted file mode 100644
index f396edc19f3..00000000000
--- a/gcc/testsuite/ada/acats/tests/cd/cd72a02.a
+++ /dev/null
@@ -1,225 +0,0 @@
--- CD72A02.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that the package System.Address_To_Access_Conversions may be
--- instantiated for various composite types.
---
--- Check that To_Pointer and To_Address are inverse operations.
---
--- Check that To_Pointer(X'Address) equals X'Unchecked_Access for an
--- X that allows Unchecked_Access.
---
--- Check that To_Pointer(Null_Address) returns null.
---
--- TEST DESCRIPTION:
--- This test is identical to CD72A01 with the exception that it tests
--- the composite types where CD72A01 tests "simple" types.
---
--- This test checks that the semantics provided in
--- Address_To_Access_Conversions are present and operate
--- within expectations (to the best extent possible in a portable
--- implementation independent fashion).
---
--- The functions Address_To_Hex and Hex_To_Address test the invertability
--- of the To_Integer and To_Address functions, along with a great deal
--- of optimizer chaff and protection from the fact that type
--- Storage_Elements.Integer_Address may be either a modular or a signed
--- integer type.
---
--- This test has some interesting usage paradigms in that users
--- occasionally want to store address information in a transportable
--- fashion, and often resort to some textual representation of values.
---
--- APPLICABILITY CRITERIA:
--- All implementations must attempt to compile this test.
---
--- For implementations validating against Systems Programming Annex (C):
--- this test must execute and report PASSED.
---
--- For implementations not validating against Annex C:
--- this test may report compile time errors at one or more points
--- indicated by "-- ANX-C RQMT", in which case it may be graded as inapplicable.
--- Otherwise, the test must execute and report PASSED.
---
---
--- CHANGE HISTORY:
--- 13 JUL 95 SAIC Initial version (CD72001)
--- 08 FEB 96 SAIC Split from CD72001 by reviewer request for 2.1
--- 12 NOV 96 SAIC Corrected typo in RM ref
--- 16 FEB 98 EDS Modified documentation.
--- 22 JAN 02 RLB Corrected test description.
---!
-
-with Report;
-with Impdef;
-with FD72A00;
-with System.Storage_Elements;
-with System.Address_To_Access_Conversions;
-procedure CD72A02 is
- use System;
- use FD72A00;
-
- type Tagged_Record is tagged record
- Value : Natural;
- end record;
-
- package Class_ATAC is
- new System.Address_To_Access_Conversions(Tagged_Record'Class);
- -- ANX-C RQMT
-
- use type Class_ATAC.Object_Pointer;
-
- task type TC_Task_Type is
- entry E;
- entry F;
- end TC_Task_Type;
-
- package Task_ATAC is
- new System.Address_To_Access_Conversions(TC_Task_Type);
- -- ANX-C RQMT
-
- use type Task_ATAC.Object_Pointer;
-
- task body TC_Task_Type is
- begin
- select
- accept E;
- or
- accept F;
- Report.Failed("Task rendezvoused on wrong path");
- end select;
- end TC_Task_Type;
-
- protected type TC_Protec is
- procedure E;
- procedure F;
- private
- Visited : Boolean := False;
- end TC_Protec;
-
- package Protected_ATAC is
- new System.Address_To_Access_Conversions(TC_Protec);
- -- ANX-C RQMT
-
- use type Protected_ATAC.Object_Pointer;
-
- protected body TC_Protec is
- procedure E is
- begin
- Visited := True;
- end E;
- procedure F is
- begin
- if not Visited then
- Report.Failed("Protected Object took wrong path");
- end if;
- end F;
- end TC_Protec;
-
- type Test_Cases is ( Tagged_Type, Task_Type, Protected_Type );
-
- type Naive_Dynamic_String is access String;
-
- type String_Store is array(Test_Cases) of Naive_Dynamic_String;
-
- The_Strings : String_Store;
-
- -- create several aliased objects with distinct values
-
- My_Rec : aliased Tagged_Record := (Value => Natural'Last);
- My_Task : aliased TC_Task_Type;
- My_Prot : aliased TC_Protec;
-
- use type System.Storage_Elements.Integer_Address;
-
-begin -- Main test procedure.
-
- Report.Test ("CD72A02", "Check package " &
- "System.Address_To_Access_Conversions " &
- "for composite types" );
-
- -- take several pointer objects, convert them to addresses, and store
- -- the address as a hexadecimal representation for later reconversion
-
- The_Strings(Tagged_Type) := new String'(
- Address_To_Hex(Class_ATAC.To_Address(My_Rec'Access)) );
-
- The_Strings(Task_Type) := new String'(
- Address_To_Hex(Task_ATAC.To_Address(My_Task'Access)) );
-
- The_Strings(Protected_Type) := new String'(
- Address_To_Hex(Protected_ATAC.To_Address(My_Prot'Access)) );
-
- -- now, reconvert the hexadecimal address values back to pointers,
- -- and check that the dereferenced pointer still designates the
- -- value placed at that location. The use of the intermediate
- -- string representation should foil even the cleverest of optimizers
-
- if Tagged_Record(Class_ATAC.To_Pointer(
- Hex_To_Address(The_Strings(Tagged_Type))).all)
- /= Tagged_Record'(Value => Natural'Last) then
- Report.Failed("Tagged_Record reconversion");
- end if;
-
- Task_ATAC.To_Pointer(Hex_To_Address(The_Strings(Task_Type))).E;
-
- begin
- select -- allow for task to have completed.
- My_Task.F; -- should not happen, will call Report.Fail in task
- else
- null; -- expected case, "Report.Pass;"
- end select;
- exception
- when Tasking_Error => null; -- task terminated, which is OK
- end;
-
- Protected_ATAC.To_Pointer(
- Hex_To_Address(The_Strings(Protected_Type))).E;
- My_Prot.F; -- checks that call to E occurred
-
-
- -- check that the resulting values are equal to the 'Unchecked_Access
- -- of the value
-
- if Class_ATAC.To_Pointer(Hex_To_Address(The_Strings(Tagged_Type)))
- /= My_Rec'Unchecked_Access then
- Report.Failed("Tagged_Record Unchecked_Access");
- end if;
-
- if Task_ATAC.To_Pointer(Hex_To_Address(The_Strings(Task_Type)))
- /= My_Task'Unchecked_Access then
- Report.Failed("Task Unchecked_Access");
- end if;
-
- if Protected_ATAC.To_Pointer(
- Hex_To_Address(The_Strings(Protected_Type)))
- /= My_Prot'Unchecked_Access then
- Report.Failed("Protected Unchecked_Access");
- end if;
-
- Report.Result;
-
-end CD72A02;
diff --git a/gcc/testsuite/ada/acats/tests/cd/cd90001.a b/gcc/testsuite/ada/acats/tests/cd/cd90001.a
deleted file mode 100644
index bd5c070a622..00000000000
--- a/gcc/testsuite/ada/acats/tests/cd/cd90001.a
+++ /dev/null
@@ -1,233 +0,0 @@
--- CD90001.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that Unchecked_Conversion is supported and is reversible in
--- the cases where:
--- Source'Size = Target'Size
--- Source'Alignment = Target'Alignment
--- Source and Target are both represented contiguously
--- Bit pattern in Source is a meaningful value of Target type
---
--- TEST DESCRIPTION:
--- This test declares an enumeration type with a representation
--- specification that should fit neatly into an 8 bit object; and a
--- modular type that should also be able to fit easily into 8 bits;
--- uses size representation clauses on both of them for 8 bit
--- representations. It then defines two instances of
--- Unchecked_Conversion; to convert both ways between the types.
--- Using several distinctive values, it checks that the conversions
--- are performed, and reversible.
--- As a second case, the above is performed with an integer type and
--- a packed array of booleans.
---
--- APPLICABILITY CRITERIA:
--- All implementations must attempt to compile this test.
---
--- For implementations validating against Systems Programming Annex (C):
--- this test must execute and report PASSED.
---
--- For implementations not validating against Annex C:
--- this test may report compile time errors at one or more points
--- indicated by "-- ANX-C RQMT", in which case it may be graded as inapplicable.
--- Otherwise, the test must execute and report PASSED.
---
---
--- CHANGE HISTORY:
--- 22 JUL 95 SAIC Initial version
--- 07 MAY 96 SAIC Changed Boolean to Character for 2.1
--- 27 JUL 96 SAIC Allowed for partial N/A to be PASS
--- 14 FEB 97 PWB.CTA Corrected "=" to "/=" in alignment check.
--- 16 FEB 98 EDS Modified documentation.
---!
-
------------------------------------------------------------------ CD90001_0
-
-with Report;
-with Unchecked_Conversion;
-package CD90001_0 is
-
- -- Case 1 : Modular <=> Enumeration
-
- type Eight_Bits is mod 2**8;
- for Eight_Bits'Size use 8;
-
- type User_Enums is ( One, Two, Four, Eight,
- Sixteen, Thirty_Two, Sixty_Four, One_Twenty_Eight );
- for User_Enums'Size use 8;
-
- for User_Enums use
- ( One => 1, -- ANX-C RQMT.
- Two => 2, -- ANX-C RQMT.
- Four => 4, -- ANX-C RQMT.
- Eight => 8, -- ANX-C RQMT.
- Sixteen => 16, -- ANX-C RQMT.
- Thirty_Two => 32, -- ANX-C RQMT.
- Sixty_Four => 64, -- ANX-C RQMT.
- One_Twenty_Eight => 128 ); -- ANX-C RQMT.
-
- function EB_2_UE is new Unchecked_Conversion( Eight_Bits, User_Enums );
-
- function UE_2_EB is new Unchecked_Conversion( User_Enums, Eight_Bits );
-
- procedure TC_Check_Case_1;
-
- -- Case 2 : Integer <=> Packed Character array
-
- type Signed_16 is range -2**15+1 .. 2**15-1;
- -- +1, -1 allows for both 1's and 2's comp
-
- type Bits_16 is array(0..1) of Character;
- pragma Pack(Bits_16); -- ANX-C RQMT.
-
- function S16_2_B16 is new Unchecked_Conversion( Signed_16, Bits_16 );
-
- function B16_2_S16 is new Unchecked_Conversion( Bits_16, Signed_16 );
-
- procedure TC_Check_Case_2;
-
-end CD90001_0;
-
--- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
-
-with Report;
-package body CD90001_0 is
-
- Check_List : constant array(1..8) of Eight_Bits
- := ( 1, 2, 4, 8, 16, 32, 64, 128 );
-
- Check_Enum : constant array(1..8) of User_Enums
- := ( One, Two, Four, Eight,
- Sixteen, Thirty_Two, Sixty_Four, One_Twenty_Eight );
-
- procedure TC_Check_Case_1 is
- Mod_Value : Eight_Bits;
- Enum_Val : User_Enums;
- begin
- for I in Check_List'Range loop
-
- if EB_2_UE(Check_List(I)) /= Check_Enum(I) then
- Report.Failed("EB => UE conversion failed");
- end if;
-
- if Check_List(I) /= UE_2_EB(Check_Enum(I)) then
- Report.Failed ("EU => EB conversion failed");
- end if;
-
- end loop;
- end TC_Check_Case_1;
-
- procedure TC_Check_Case_2 is
- S: Signed_16;
- T,U: Signed_16;
- B: Bits_16;
- C,D: Bits_16; -- allow for byte swapping
- begin
- --FDEC_BA98_7654_3210
- S := 2#0011_0000_0111_0111#;
- B := S16_2_B16( S );
- C := ( Character'Val(2#0011_0000#), Character'Val(2#0111_0111#) );
- D := ( Character'Val(2#0111_0111#), Character'Val(2#0011_0000#) );
-
- if (B /= C) and (B /= D) then
- Report.Failed("Int => Chararray conversion failed");
- end if;
-
- B := ( Character'Val(2#0011_1100#), Character'Val(2#0101_0101#) );
- S := B16_2_S16( B );
- T := 2#0011_1100_0101_0101#;
- U := 2#0101_0101_0011_1100#;
-
- if (S /= T) and (S /= U) then
- Report.Failed("Chararray => Int conversion failed");
- end if;
-
- end TC_Check_Case_2;
-
-end CD90001_0;
-
-------------------------------------------------------------------- CD90001
-
-with Report;
-with CD90001_0;
-
-procedure CD90001 is
-
- Eight_NA : Boolean := False;
- Sixteen_NA : Boolean := False;
-
-begin -- Main test procedure.
-
- Report.Test ("CD90001", "Check that Unchecked_Conversion is supported " &
- "and is reversible in appropriate cases" );
- Eight_Bit_Case:
- begin
- if CD90001_0.User_Enums'Size /= CD90001_0.Eight_Bits'Size then
- Report.Comment("The sizes of the 8 bit types used in this test "
- & "do not match" );
- Eight_NA := True;
- elsif CD90001_0.User_Enums'Alignment /= CD90001_0.Eight_Bits'Alignment then
- Report.Comment("The alignments of the 8 bit types used in this "
- & "test do not match" );
- Eight_NA := True;
- else
- CD90001_0.TC_Check_Case_1;
- end if;
-
- exception
- when Constraint_Error =>
- Report.Failed("Constraint_Error raised in 8 bit case");
- when others =>
- Report.Failed("Unexpected exception raised in 8 bit case");
- end Eight_Bit_Case;
-
- Sixteen_Bit_Case:
- begin
- if CD90001_0.Signed_16'Size /= CD90001_0.Bits_16'Size then
- Report.Comment("The sizes of the 16 bit types used in this test "
- & "do not match" );
- Sixteen_NA := True;
- elsif CD90001_0.Signed_16'Alignment = CD90001_0.Bits_16'Alignment then
- Report.Comment("The alignments of the 16 bit types used in this "
- & "test do not match" );
- Sixteen_NA := True;
- else
- CD90001_0.TC_Check_Case_2;
- end if;
-
- exception
- when Constraint_Error =>
- Report.Failed("Constraint_Error raised in 16 bit case");
- when others =>
- Report.Failed("Unexpected exception raised in 16 bit case");
- end Sixteen_Bit_Case;
-
- if Eight_NA and Sixteen_NA then
- Report.Not_Applicable("No cases in this test apply");
- end if;
-
- Report.Result;
-
-end CD90001;
diff --git a/gcc/testsuite/ada/acats/tests/cd/cd92001.a b/gcc/testsuite/ada/acats/tests/cd/cd92001.a
deleted file mode 100644
index d07ff4881a5..00000000000
--- a/gcc/testsuite/ada/acats/tests/cd/cd92001.a
+++ /dev/null
@@ -1,229 +0,0 @@
--- CD92001.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that if X denotes a scalar object, X'Valid
--- yields true if an only if the object denoted by X is normal and
--- has a valid representation.
---
--- TEST DESCRIPTION:
--- Using Unchecked_Conversion, Image and Value attributes, combined
--- with string manipulation, cause valid and invalid values to be
--- stored in various objects. Check their validity with the
--- attribute 'Valid. Invalid objects are created in a loop which
--- performs a simplistic check to ensure that the values being used
--- are indeed not valid, then assigns the value using an instance of
--- Unchecked_Conversion. The creation of the tables of valid values
--- is trivial.
---
--- APPLICABILITY CRITERIA:
--- All implementations must attempt to compile this test.
---
--- For implementations validating against Systems Programming Annex (C):
--- this test must execute and report PASSED.
---
--- For implementations not validating against Annex C:
--- this test may report compile time errors at one or more points
--- indicated by "-- N/A => ERROR", in which case it may be graded as
--- inapplicable. Otherwise, the test must execute and report PASSED.
---
---
--- CHANGE HISTORY:
--- 10 MAY 95 SAIC Initial version
--- 07 MAY 96 SAIC Changed U_C to Ada.U_C for 2.1
--- 05 JAN 99 RLB Added Component_Size clauses to compensate
--- for the fact that there is no required size
--- for either the enumeration or modular components.
---!
-
-with Report;
-with Ada.Unchecked_Conversion;
-with System;
-procedure CD92001 is
-
- type Sparse_Enumerated is
- ( Help, Home, Page_Up, Del, EndK,
- Page_Down, Up, Left, Down, Right );
-
- for Sparse_Enumerated use ( Help => 2,
- Home => 4,
- Page_Up => 8,
- Del => 16,
- EndK => 32,
- Page_Down => 64,
- Up => 128,
- Left => 256,
- Down => 512,
- Right => 1024 );
-
- type Mod_10 is mod 10;
-
- type Default_Enumerated is ( Zero, One, Two, Three, Four,
- Five, Six, Seven, Eight, Nine,
- Clear, '=', '/', '*', '-',
- '+', Enter );
- for Default_Enumerated'Size use 8;
-
- Default_Enumerated_Count : constant := 17;
-
- type Mod_By_Enum_Items is mod Default_Enumerated_Count;
-
- type Mod_Same_Size_As_Sparse_Enum is mod 2**12;
- -- Sparse_Enumerated 'Size;
-
- type Mod_Same_Size_As_Def_Enum is mod 2**8;
- -- Default_Enumerated'Size;
-
- subtype Test_Width is Positive range 1..100;
-
- -- Note: There is no required relationship between 'Size and 'Component_Size,
- -- so we must use component_size clauses here.
- -- We use the following expressions to insure that the component size is a
- -- multiple of the Storage_Unit.
- Sparse_Component_Size : constant := ((Sparse_Enumerated'Size / System.Storage_Unit) +
- Boolean'Pos((Sparse_Enumerated'Size mod System.Storage_Unit) /= 0)) *
- System.Storage_Unit;
- Default_Component_Size : constant := ((Default_Enumerated'Size / System.Storage_Unit) +
- Boolean'Pos((Sparse_Enumerated'Size mod System.Storage_Unit) /= 0)) *
- System.Storage_Unit;
-
- type Sparse_Enum_Table is array(Test_Width) of Sparse_Enumerated;
- for Sparse_Enum_Table'Component_Size use Sparse_Component_Size; -- N/A => ERROR.
- type Def_Enum_Table is array(Test_Width) of Default_Enumerated;
- for Def_Enum_Table'Component_Size use Default_Component_Size; -- N/A => ERROR.
-
- type Sparse_Mod_Table is
- array(Test_Width) of Mod_Same_Size_As_Sparse_Enum;
- for Sparse_Mod_Table'Component_Size use Sparse_Component_Size; -- N/A => ERROR.
-
- type Default_Mod_Table is
- array(Test_Width) of Mod_Same_Size_As_Def_Enum;
- for Default_Mod_Table'Component_Size use Default_Component_Size; -- N/A => ERROR.
-
- function UC_Sparse_Mod_Enum is
- new Ada.Unchecked_Conversion( Sparse_Mod_Table, Sparse_Enum_Table );
-
- function UC_Def_Mod_Enum is
- new Ada.Unchecked_Conversion( Default_Mod_Table, Def_Enum_Table );
-
- Valid_Sparse_Values : Sparse_Enum_Table;
- Valid_Def_Values : Def_Enum_Table;
-
- Sample_Enum_Value_Table : Sparse_Mod_Table;
- Sample_Def_Value_Table : Default_Mod_Table;
-
-
- -- fill the Valid tables with valid values for conversion
- procedure Fill_Valid is
- K : Mod_10 := 0;
- P : Mod_By_Enum_Items := 0;
- begin
- for I in Test_Width loop
- Valid_Sparse_Values(I) := Sparse_Enumerated'Val( K );
- Valid_Def_Values(I) := Default_Enumerated'Val( Integer(P) );
- K := K +1;
- P := P +1;
- end loop;
- end Fill_Valid;
-
- -- fill the Sample tables with invalid values for conversion
- procedure Fill_Invalid is
- K : Mod_Same_Size_As_Sparse_Enum := 1;
- P : Mod_Same_Size_As_Def_Enum := 1;
- begin
- for I in Test_Width loop
- K := K +13;
- if K mod 2 = 0 then -- oops, that would be a valid value
- K := K +1;
- end if;
- if P = Mod_Same_Size_As_Def_Enum'Last
- or P < Default_Enumerated_Count then -- that would be valid
- P := Default_Enumerated_Count + 1;
- else
- P := P +1;
- end if;
- Sample_Enum_Value_Table(I) := K;
- Sample_Def_Value_Table(I) := P;
- end loop;
-
- Valid_Sparse_Values := UC_Sparse_Mod_Enum(Sample_Enum_Value_Table);
- Valid_Def_Values := UC_Def_Mod_Enum(Sample_Def_Value_Table);
-
- end Fill_Invalid;
-
- -- fill the tables with second set of valid values for conversion
- procedure Refill_Valid is
- K : Mod_10 := 0;
- P : Mod_By_Enum_Items := 0;
-
- Table : Array(Mod_10) of Mod_Same_Size_As_Sparse_Enum
- := ( 2, 4, 8, 16, 32, 64, 128, 256, 512, 1024 );
-
- begin
- for I in Test_Width loop
- Sample_Enum_Value_Table(I) := Table(K);
- Sample_Def_Value_Table(I) := Mod_Same_Size_As_Def_Enum(P);
- K := K +1;
- P := P +1;
- end loop;
- Valid_Sparse_Values := UC_Sparse_Mod_Enum(Sample_Enum_Value_Table);
- Valid_Def_Values := UC_Def_Mod_Enum(Sample_Def_Value_Table);
- end Refill_Valid;
-
- procedure Validate(Expect_Valid: Boolean) is
- begin -- here's where we actually use the tested attribute
-
- for K in Test_Width loop
- if Valid_Sparse_Values(K)'Valid /= Expect_Valid then
- Report.Failed("Expected 'Valid =" & Boolean'Image(Expect_Valid)
- & " for Sparse item " & Integer'Image(K) );
- end if;
- end loop;
-
- for P in Test_Width loop
- if Valid_Def_Values(P)'Valid /= Expect_Valid then
- Report.Failed("Expected 'Valid =" & Boolean'Image(Expect_Valid)
- & " for Default item " & Integer'Image(P) );
- end if;
- end loop;
-
- end Validate;
-
-begin -- Main test procedure.
-
- Report.Test ("CD92001", "Check object attribute: X'Valid" );
-
- Fill_Valid;
- Validate(True);
-
- Fill_Invalid;
- Validate(False);
-
- Refill_Valid;
- Validate(True);
-
- Report.Result;
-
-end CD92001;
diff --git a/gcc/testsuite/ada/acats/tests/cd/cdb0a01.a b/gcc/testsuite/ada/acats/tests/cd/cdb0a01.a
deleted file mode 100644
index 566fad13883..00000000000
--- a/gcc/testsuite/ada/acats/tests/cd/cdb0a01.a
+++ /dev/null
@@ -1,305 +0,0 @@
--- CDB0A01.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that a storage pool may be user_determined, and that storage
--- is allocated by calling Allocate.
---
--- Check that a storage.pool may be specified using 'Storage_Pool
--- and that S'Storage_Pool denotes the storage pool of the type S.
---
--- TEST DESCRIPTION:
--- The package System.Storage_Pools is exercised by two very similar
--- packages which define a tree type and exercise it in a simple manner.
--- One package uses a user defined pool. The other package uses a
--- storage pool assigned by the implementation; Storage_Size is
--- specified for this pool.
--- The dispatching procedures Allocate and Deallocate are tested as an
--- intentional side effect of the tree packages.
---
--- For completeness, the actions of the tree packages are checked for
--- correct operation.
---
--- TEST FILES:
--- The following files comprise this test:
---
--- FDB0A00.A (foundation code)
--- CDB0A01.A
---
---
--- CHANGE HISTORY:
--- 02 JUN 95 SAIC Initial version
--- 07 MAY 96 SAIC Removed ambiguity with CDB0A02
--- 13 FEB 97 PWB.CTA Corrected lexically ordered string literal
---!
-
----------------------------------------------------------------- CDB0A01_1
-
----------------------------------------------------------- FDB0A00.Pool1
-
-package FDB0A00.Pool1 is
- User_Pool : Stack_Heap( 5_000 );
-end FDB0A00.Pool1;
-
----------------------------------------------------------- FDB0A00.Comparator
-
-with System.Storage_Pools;
-package FDB0A00.Comparator is
-
- function "="( A,B : System.Storage_Pools.Root_Storage_Pool'Class )
- return Boolean;
-
-end FDB0A00.Comparator;
-
--- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
-
-with TCTouch;
-package body FDB0A00.Comparator is
-
- function "="( A,B : System.Storage_Pools.Root_Storage_Pool'Class )
- return Boolean is
- use type System.Address;
- begin
- return A'Address = B'Address;
- end "=";
-
-end FDB0A00.Comparator;
-
----------------------------------------------------------------- CDB0A01_2
-
-with FDB0A00.Pool1;
-package CDB0A01_2 is
-
- type Cell;
- type User_Pool_Tree is access Cell;
-
- for User_Pool_Tree'Storage_Pool use FDB0A00.Pool1.User_Pool;
-
- type Cell is record
- Data : Character;
- Left,Right : User_Pool_Tree;
- end record;
-
- procedure Insert( Item: Character; On_Tree : in out User_Pool_Tree );
-
- procedure Traverse( The_Tree : User_Pool_Tree );
-
- procedure Defoliate( The_Tree : in out User_Pool_Tree );
-
-end CDB0A01_2;
-
--- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
-
-with TCTouch;
-with Unchecked_Deallocation;
-package body CDB0A01_2 is
- procedure Deallocate is new Unchecked_Deallocation(Cell,User_Pool_Tree);
-
- -- Sort: zeros on the left, ones on the right...
- procedure Insert( Item: Character; On_Tree : in out User_Pool_Tree ) is
- begin
- if On_Tree = null then
- On_Tree := new Cell'(Item,null,null);
- elsif Item > On_Tree.Data then
- Insert(Item,On_Tree.Right);
- else
- Insert(Item,On_Tree.Left);
- end if;
- end Insert;
-
- procedure Traverse( The_Tree : User_Pool_Tree ) is
- begin
- if The_Tree = null then
- null; -- how very symmetrical
- else
- Traverse(The_Tree.Left);
- TCTouch.Touch(The_Tree.Data);
- Traverse(The_Tree.Right);
- end if;
- end Traverse;
-
- procedure Defoliate( The_Tree : in out User_Pool_Tree ) is
- begin
-
- if The_Tree.Left /= null then
- Defoliate(The_Tree.Left);
- end if;
-
- if The_Tree.Right /= null then
- Defoliate(The_Tree.Right);
- end if;
-
- Deallocate(The_Tree);
-
- end Defoliate;
-
-end CDB0A01_2;
-
----------------------------------------------------------------- CDB0A01_3
-
-with FDB0A00.Pool1;
-package CDB0A01_3 is
-
- type Cell;
- type System_Pool_Tree is access Cell;
-
- for System_Pool_Tree'Storage_Size use 2000;
-
- -- assumptions: Cell is <= 20 storage_units
- -- Tree building exercise requires O(15) cells
- -- 2000 > 20 * 15 by a generous margin
-
- type Cell is record
- Data: Character;
- Left,Right : System_Pool_Tree;
- end record;
-
- procedure Insert( Item: Character; On_Tree : in out System_Pool_Tree );
-
- procedure Traverse( The_Tree : System_Pool_Tree );
-
- procedure Defoliate( The_Tree : in out System_Pool_Tree );
-
-end CDB0A01_3;
-
--- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
-
-with TCTouch;
-with Unchecked_Deallocation;
-package body CDB0A01_3 is
- procedure Deallocate is new Unchecked_Deallocation(Cell,System_Pool_Tree);
-
- -- Sort: zeros on the left, ones on the right...
- procedure Insert( Item: Character; On_Tree : in out System_Pool_Tree ) is
- begin
- if On_Tree = null then
- On_Tree := new Cell'(Item,null,null);
- elsif Item > On_Tree.Data then
- Insert(Item,On_Tree.Right);
- else
- Insert(Item,On_Tree.Left);
- end if;
- end Insert;
-
- procedure Traverse( The_Tree : System_Pool_Tree ) is
- begin
- if The_Tree = null then
- null; -- how very symmetrical
- else
- Traverse(The_Tree.Left);
- TCTouch.Touch(The_Tree.Data);
- Traverse(The_Tree.Right);
- end if;
- end Traverse;
-
- procedure Defoliate( The_Tree : in out System_Pool_Tree ) is
- begin
-
- if The_Tree.Left /= null then
- Defoliate(The_Tree.Left);
- end if;
-
- if The_Tree.Right /= null then
- Defoliate(The_Tree.Right);
- end if;
-
- Deallocate(The_Tree);
-
- end Defoliate;
-
-end CDB0A01_3;
-
------------------------------------------------------------------- CDB0A01
-
-with Report;
-with TCTouch;
-with FDB0A00.Comparator;
-with FDB0A00.Pool1;
-with CDB0A01_2;
-with CDB0A01_3;
-
-procedure CDB0A01 is
-
- Banyan : CDB0A01_2.User_Pool_Tree;
- Torrey : CDB0A01_3.System_Pool_Tree;
-
- use type CDB0A01_2.User_Pool_Tree;
- use type CDB0A01_3.System_Pool_Tree;
-
- Countess : constant String := "Ada Augusta Lovelace";
- Cenosstu : constant String := " AALaaacdeeglostuuv";
- Insertion : constant String := "AAAAAAAAAAAAAAAAAAAA";
- Deallocation : constant String := "DDDDDDDDDDDDDDDDDDDD";
-
-begin -- Main test procedure.
-
- Report.Test ("CDB0A01", "Check that a storage pool may be " &
- "user_determined, and that storage is " &
- "allocated by calling Allocate. Check that " &
- "a storage.pool may be specified using " &
- "'Storage_Pool and that S'Storage_Pool denotes " &
- "the storage pool of the type S" );
-
--- Check that S'Storage_Pool denotes the storage pool for the type S.
-
- TCTouch.Assert(
- FDB0A00.Comparator."="(FDB0A00.Pool1.User_Pool,
- CDB0A01_2.User_Pool_Tree'Storage_Pool ),
- "'Storage_Pool not correct for CDB0A01_2.User_Pool_Tree");
-
- TCTouch.Assert_Not(
- FDB0A00.Comparator."="(FDB0A00.Pool1.User_Pool,
- CDB0A01_3.System_Pool_Tree'Storage_Pool ),
- "'Storage_Pool not correct for CDB0A01_3.System_Pool_Tree");
-
--- Check that storage is allocated by calling Allocate.
-
- for Count in Countess'Range loop
- CDB0A01_2.Insert( Countess(Count), Banyan );
- end loop;
- TCTouch.Validate(Insertion, "Allocate calls via CDB0A01_2" );
-
- for Count in Countess'Range loop
- CDB0A01_3.Insert( Countess(Count), Torrey );
- end loop;
- TCTouch.Validate("", "Allocate calls via CDB0A01_3" );
-
- CDB0A01_2.Traverse(Banyan);
- TCTouch.Validate(Cenosstu, "Traversal of Banyan" );
-
- CDB0A01_3.Traverse(Torrey);
- TCTouch.Validate(Cenosstu, "Traversal of Torrey" );
-
- CDB0A01_2.Defoliate(Banyan);
- TCTouch.Validate(Deallocation, "Deforestation of Banyan" );
- TCTouch.Assert(Banyan = null, "Banyan Deallocation result not null");
-
- CDB0A01_3.Defoliate(Torrey);
- TCTouch.Validate("", "Deforestation of Torrey" );
- TCTouch.Assert(Torrey = null, "Torrey Deallocation result not null");
-
- Report.Result;
-
-end CDB0A01;
diff --git a/gcc/testsuite/ada/acats/tests/cd/cdb0a02.a b/gcc/testsuite/ada/acats/tests/cd/cdb0a02.a
deleted file mode 100644
index 6a7fca54a2c..00000000000
--- a/gcc/testsuite/ada/acats/tests/cd/cdb0a02.a
+++ /dev/null
@@ -1,329 +0,0 @@
--- CDB0A02.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that several access types can share the same pool.
---
--- Check that any exception propagated by Allocate is
--- propagated by the allocator.
---
--- Check that for an access type S, S'Max_Size_In_Storage_Elements
--- denotes the maximum values for Size_In_Storage_Elements that will
--- be requested via Allocate.
---
--- TEST DESCRIPTION:
--- After checking correct operation of the tree packages, the limits of
--- the storage pools (first the shared user defined storage pool, then
--- the system storage pool) are intentionally exceeded. The test checks
--- that the correct exception is raised.
---
---
--- TEST FILES:
--- The following files comprise this test:
---
--- FDB0A00.A (foundation code)
--- CDB0A02.A
---
---
--- CHANGE HISTORY:
--- 10 AUG 95 SAIC Initial version
--- 07 MAY 96 SAIC Disambiguated for 2.1
--- 13 FEB 97 PWB.CTA Reduced minimum allowable
--- Max_Size_In_Storage_Units, for implementations
--- with larger storage units
--- 25 JAN 01 RLB Removed dubious checks on Max_Size_In_Storage_Units;
--- tightened important one.
-
---!
-
----------------------------------------------------------- FDB0A00.Pool2
-
-package FDB0A00.Pool2 is
- Pond : Stack_Heap( 5_000 );
-end FDB0A00.Pool2;
-
----------------------------------------------------------------- CDB0A02_2
-
-with FDB0A00.Pool2;
-package CDB0A02_2 is
-
- type Small_Cell;
- type Small_Tree is access Small_Cell;
-
- for Small_Tree'Storage_Pool use FDB0A00.Pool2.Pond; -- first usage
-
- type Small_Cell is record
- Data: Character;
- Left,Right : Small_Tree;
- end record;
-
- procedure Insert( Item: Character; On_Tree : in out Small_Tree );
-
- procedure Traverse( The_Tree : Small_Tree );
-
- procedure Defoliate( The_Tree : in out Small_Tree );
-
- procedure TC_Exceed_Pool;
-
- Pool_Max_Elements : constant := 6000;
- -- to guarantee overflow in TC_Exceed_Pool
-
-end CDB0A02_2;
-
--- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
-
-with TCTouch;
-with Report;
-with Unchecked_Deallocation;
-package body CDB0A02_2 is
- procedure Deallocate is new Unchecked_Deallocation(Small_Cell,Small_Tree);
-
- -- Sort: zeros on the left, ones on the right...
- procedure Insert( Item: Character; On_Tree : in out Small_Tree ) is
- begin
- if On_Tree = null then
- On_Tree := new Small_Cell'(Item,null,null);
- elsif Item > On_Tree.Data then
- Insert(Item,On_Tree.Right);
- else
- Insert(Item,On_Tree.Left);
- end if;
- end Insert;
-
- procedure Traverse( The_Tree : Small_Tree ) is
- begin
- if The_Tree = null then
- null; -- how very symmetrical
- else
- Traverse(The_Tree.Left);
- TCTouch.Touch(The_Tree.Data);
- Traverse(The_Tree.Right);
- end if;
- end Traverse;
-
- procedure Defoliate( The_Tree : in out Small_Tree ) is
- begin
-
- if The_Tree.Left /= null then
- Defoliate(The_Tree.Left);
- end if;
-
- if The_Tree.Right /= null then
- Defoliate(The_Tree.Right);
- end if;
-
- Deallocate(The_Tree);
-
- end Defoliate;
-
- procedure TC_Exceed_Pool is
- Wild_Branch : Small_Tree;
- begin
- for Ever in 1..Pool_Max_Elements loop
- Wild_Branch := new Small_Cell'('a', Wild_Branch, Wild_Branch);
- TCTouch.Validate("A","Allocating element for overflow");
- end loop;
- Report.Failed(" Pool_Overflow not raised on exceeding user pool size");
- exception
- when FDB0A00.Pool_Overflow => null; -- anticipated case
- when others =>
- Report.Failed("wrong exception raised in user Exceed_Pool");
- end TC_Exceed_Pool;
-
-end CDB0A02_2;
-
----------------------------------------------------------------- CDB0A02_3
-
--- This package is essentially identical to CDB0A02_2, except that the size
--- of a cell is significantly larger. This is used to check that different
--- access types may share a single pool
-
-with FDB0A00.Pool2;
-package CDB0A02_3 is
-
- type Large_Cell;
- type Large_Tree is access Large_Cell;
-
- for Large_Tree'Storage_Pool use FDB0A00.Pool2.Pond; -- second usage
-
- type Large_Cell is record
- Data: Character;
- Extra_Data : String(1..2);
- Left,Right : Large_Tree;
- end record;
-
- procedure Insert( Item: Character; On_Tree : in out Large_Tree );
-
- procedure Traverse( The_Tree : Large_Tree );
-
- procedure Defoliate( The_Tree : in out Large_Tree );
-
-end CDB0A02_3;
-
--- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
-
-with TCTouch;
-with Unchecked_Deallocation;
-package body CDB0A02_3 is
- procedure Deallocate is new Unchecked_Deallocation(Large_Cell,Large_Tree);
-
- -- Sort: zeros on the left, ones on the right...
- procedure Insert( Item: Character; On_Tree : in out Large_Tree ) is
- begin
- if On_Tree = null then
- On_Tree := new Large_Cell'(Item,(Item,Item),null,null);
- elsif Item > On_Tree.Data then
- Insert(Item,On_Tree.Right);
- else
- Insert(Item,On_Tree.Left);
- end if;
- end Insert;
-
- procedure Traverse( The_Tree : Large_Tree ) is
- begin
- if The_Tree = null then
- null; -- how very symmetrical
- else
- Traverse(The_Tree.Left);
- TCTouch.Touch(The_Tree.Data);
- Traverse(The_Tree.Right);
- end if;
- end Traverse;
-
- procedure Defoliate( The_Tree : in out Large_Tree ) is
- begin
-
- if The_Tree.Left /= null then
- Defoliate(The_Tree.Left);
- end if;
-
- if The_Tree.Right /= null then
- Defoliate(The_Tree.Right);
- end if;
-
- Deallocate(The_Tree);
-
- end Defoliate;
-
-end CDB0A02_3;
-
------------------------------------------------------------------- CDB0A02
-
-with Report;
-with TCTouch;
-with System.Storage_Elements;
-with CDB0A02_2;
-with CDB0A02_3;
-with FDB0A00;
-
-procedure CDB0A02 is
-
- Banyan : CDB0A02_2.Small_Tree;
- Torrey : CDB0A02_3.Large_Tree;
-
- use type CDB0A02_2.Small_Tree;
- use type CDB0A02_3.Large_Tree;
-
- Countess1 : constant String := "Ada ";
- Countess2 : constant String := "Augusta ";
- Countess3 : constant String := "Lovelace";
- Cenosstu : constant String := " AALaaacdeeglostuuv";
- Insertion : constant String := "AAAAAAAAAAAAAAAAAAAA"
- & "AAAAAAAAAAAAAAAAAAAA";
- Deallocation : constant String := "DDDDDDDDDDDDDDDDDDDD";
-
-begin -- Main test procedure.
-
- Report.Test ("CDB0A02", "Check that several access types can share " &
- "the same pool. Check that any exception " &
- "propagated by Allocate is propagated by the " &
- "allocator. Check that for an access type S, " &
- "S'Max_Size_In_Storage_Elements denotes the " &
- "maximum values for Size_In_Storage_Elements " &
- "that will be requested via Allocate" );
-
- -- Check that access types can share the same pool.
-
- for Count in Countess1'Range loop
- CDB0A02_2.Insert( Countess1(Count), Banyan );
- end loop;
-
- for Count in Countess1'Range loop
- CDB0A02_3.Insert( Countess1(Count), Torrey );
- end loop;
-
- for Count in Countess2'Range loop
- CDB0A02_2.Insert( Countess2(Count), Banyan );
- end loop;
-
- for Count in Countess2'Range loop
- CDB0A02_3.Insert( Countess2(Count), Torrey );
- end loop;
-
- for Count in Countess3'Range loop
- CDB0A02_2.Insert( Countess3(Count), Banyan );
- end loop;
-
- for Count in Countess3'Range loop
- CDB0A02_3.Insert( Countess3(Count), Torrey );
- end loop;
-
- TCTouch.Validate(Insertion, "Allocate calls via CDB0A02_2" );
-
-
- CDB0A02_2.Traverse(Banyan);
- TCTouch.Validate(Cenosstu, "Traversal of Banyan" );
-
- CDB0A02_3.Traverse(Torrey);
- TCTouch.Validate(Cenosstu, "Traversal of Torrey" );
-
- CDB0A02_2.Defoliate(Banyan);
- TCTouch.Validate(Deallocation, "Deforestation of Banyan" );
- TCTouch.Assert(Banyan = null, "Banyan Deallocation result not null");
-
- CDB0A02_3.Defoliate(Torrey);
- TCTouch.Validate(Deallocation, "Deforestation of Torrey" );
- TCTouch.Assert(Torrey = null, "Torrey Deallocation result not null");
-
- -- Check that for an access type S, S'Max_Size_In_Storage_Elements
- -- denotes the maximum values for Size_In_Storage_Elements that will
- -- be requested via Allocate. (Of course, all we can do is check that
- -- whatever was requested of Allocate did not exceed the values of the
- -- attributes.)
-
- TCTouch.Assert( FDB0A00.TC_Largest_Request in 1 ..
- System.Storage_Elements.Storage_Count'Max (
- CDB0A02_2.Small_Cell'Max_Size_In_Storage_Elements,
- CDB0A02_3.Large_Cell'Max_Size_In_Storage_Elements),
- "An object of excessive size was allocated. Size: "
- & System.Storage_Elements.Storage_Count'Image(FDB0A00.TC_Largest_Request));
-
- -- Check that an exception raised in Allocate is propagated by the allocator.
-
- CDB0A02_2.TC_Exceed_Pool;
-
- Report.Result;
-
-end CDB0A02;
diff --git a/gcc/testsuite/ada/acats/tests/cd/cdd1001.a b/gcc/testsuite/ada/acats/tests/cd/cdd1001.a
deleted file mode 100644
index 3e16f5d4f97..00000000000
--- a/gcc/testsuite/ada/acats/tests/cd/cdd1001.a
+++ /dev/null
@@ -1,94 +0,0 @@
--- CDD1001.A
---
--- Grant of Unlimited Rights
---
--- The Ada Conformity Assessment Authority (ACAA) holds unlimited
--- rights in the software and documentation contained herein. Unlimited
--- rights are the same as those granted by the U.S. Government for older
--- parts of the Ada Conformity Assessment Test Suite, and are defined
--- in DFAR 252.227-7013(a)(19). By making this public release, the ACAA
--- intends to confer upon all recipients unlimited rights equal to those
--- held by the ACAA. These rights include rights to use, duplicate,
--- release or disclose the released technical data and computer software
--- in whole or in part, in any manner and for any purpose whatsoever, and
--- to have or permit others to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that components of Stream_Element_Array are aliased. (Defect
--- Report 8652/0044).
---
--- APPLICABILITY CRITERIA:
--- All implementations must attempt to compile this test.
---
--- For implementations for which Stream_Element'Size is a multiple of
--- System.Storage_Unit, this test must execute.
---
--- For other implementations, if this test compiles without error messages
--- at compilation, it must bind and execute.
---
--- PASS/FAIL CRITERIA:
--- For implementations for which Stream_Element'Size is a multiple of
--- System.Storage_Unit, this test must execute, report PASSED, and
--- complete normally, otherwise the test FAILS.
---
--- For other implementations:
--- PASSING behavior is:
--- this test executes, reports PASSED, and completes normally
--- or
--- this test produces at least one error message at compilation, and
--- the error message is associated with one of the items marked:
--- -- N/A => ERROR.
---
--- All other behaviors are FAILING.
---
---
--- CHANGE HISTORY:
--- 12 FEB 2001 PHL Initial version
--- 15 MAR 2001 RLB Readied for release.
-
---!
-with Ada.Streams;
-use Ada.Streams;
-with Report;
-use Report;
-procedure CDD1001 is
-
- type Acc is access all Stream_Element;
-
- A : Stream_Element_Array
- (Stream_Element_Offset (Ident_Int (1)) ..
- Stream_Element_Offset (Ident_Int (10)));
- B : array (A'Range) of Acc;
-begin
- Test ("CDD1001",
- "Check that components of Stream_Element_Array are aliased");
-
- for I in A'Range loop
- A (I) := Stream_Element (Ident_Int (Integer (I)) * Ident_Int (3));
- end loop;
-
- for I in B'Range loop
- B (I) := A (I)'Access; -- N/A => ERROR.
- end loop;
-
- for I in B'Range loop
- if B (I).all /= Stream_Element
- (Ident_Int (Integer (I)) * Ident_Int (3)) then
- Failed ("Unable to build access values 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
deleted file mode 100644
index 3184dded8d4..00000000000
--- a/gcc/testsuite/ada/acats/tests/cd/cdd2001.a
+++ /dev/null
@@ -1,203 +0,0 @@
--- CDD2001.A
---
--- Grant of Unlimited Rights
---
--- The Ada Conformity Assessment Authority (ACAA) holds unlimited
--- rights in the software and documentation contained herein. Unlimited
--- rights are the same as those granted by the U.S. Government for older
--- parts of the Ada Conformity Assessment Test Suite, and are defined
--- in DFAR 252.227-7013(a)(19). By making this public release, the ACAA
--- intends to confer upon all recipients unlimited rights equal to those
--- held by the ACAA. These rights include rights to use, duplicate,
--- release or disclose the released technical data and computer software
--- in whole or in part, in any manner and for any purpose whatsoever, and
--- to have or permit others to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that the default implementation of Read and Input raise End_Error
--- if the end of stream is reached before the reading of a value is
--- completed. (Defect Report 8652/0045,
--- Technical Corrigendum 13.13.2(35.1/1)).
---
--- CHANGE HISTORY:
--- 12 FEB 2001 PHL Initial version.
--- 29 JUN 2001 RLB Reformatted for ACATS.
---
---!
-
-with Ada.Streams;
-use Ada.Streams;
-package CDD2001_0 is
-
- type My_Stream (Size : Stream_Element_Count) is new Root_Stream_Type with
- record
- First : Stream_Element_Offset := 1;
- Last : Stream_Element_Offset := 0;
- Contents : Stream_Element_Array (1 .. Size);
- end record;
-
- procedure Clear (Stream : in out My_Stream);
-
- procedure Read (Stream : in out My_Stream;
- Item : out Stream_Element_Array;
- Last : out Stream_Element_Offset);
-
- procedure Write (Stream : in out My_Stream; Item : in Stream_Element_Array);
-
-end CDD2001_0;
-
-package body CDD2001_0 is
-
- procedure Clear (Stream : in out My_Stream) is
- begin
- Stream.First := 1;
- Stream.Last := 0;
- end Clear;
-
- procedure Read (Stream : in out My_Stream;
- Item : out Stream_Element_Array;
- Last : out Stream_Element_Offset) is
- begin
- if Item'Length >= Stream.Last - Stream.First + 1 then
- Item (Item'First .. Item'First + Stream.Last - Stream.First) :=
- Stream.Contents (Stream.First .. Stream.Last);
- Last := Item'First + Stream.Last - Stream.First;
- Stream.First := Stream.Last + 1;
- else
- Item := Stream.Contents (Stream.First ..
- Stream.First + Item'Length - 1);
- Last := Item'Last;
- Stream.First := Stream.First + Item'Length;
- end if;
- end Read;
-
- procedure Write (Stream : in out My_Stream;
- Item : in Stream_Element_Array) is
- begin
- Stream.Contents (Stream.Last + 1 .. Stream.Last + Item'Length) := Item;
- Stream.Last := Stream.Last + Item'Length;
- end Write;
-
-end CDD2001_0;
-
-with Ada.Exceptions;
-use Ada.Exceptions;
-with CDD2001_0;
-use CDD2001_0;
-with Io_Exceptions;
-use Io_Exceptions;
-with Report;
-use Report;
-procedure CDD2001 is
-
- subtype Int is Integer range -20 .. 20;
-
- type R (D : Int) is
- record
- C1 : Character := Ident_Char ('a');
- case D is
- when 0 .. 20 =>
- C2 : String (1 .. D) := (others => Ident_Char ('b'));
- when others =>
- C3, C4 : Float := Float (-D);
- end case;
- end record;
-
- S : aliased My_Stream (200);
-
-begin
- Test
- ("CDD2001",
- "Check that the default implementation of Read and Input " &
- "raise End_Error if the end of stream is reached before the " &
- "reading of a value is completed");
-
- Read:
- declare
- X : R (Ident_Int (13));
- begin
- Clear (S);
-
- -- A complete object.
- R'Write (S'Access, X);
- X.C1 := Ident_Char ('A');
- X.C2 := (others => Ident_Char ('B'));
- R'Read (S'Access, X);
- if X.C1 /= Ident_Char ('a') or X.C2 /=
- (1 .. 13 => Ident_Char ('b')) then
- Failed ("Read did not produce the expected result");
- end if;
-
- Clear (S);
-
- -- Not enough data.
- Character'Write (S'Access, 'a');
- String'Write (S'Access, "bbb");
-
- begin
- R'Read (S'Access, X);
- Failed
- ("No exception raised when the end of stream is reached " &
- "before the reading of a value is completed - 1");
- exception
- when End_Error =>
- null;
- when E: others =>
- Failed ("Wrong Exception " & Exception_Name (E) &
- " - " & Exception_Information (E) &
- " - " & Exception_Message (E) & " - 1");
- end;
-
- end Read;
-
- Input:
- declare
- X : R (Ident_Int (-11));
- begin
- Clear (S);
-
- -- A complete object.
- R'Output (S'Access, X);
- X.C1 := Ident_Char ('A');
- X.C3 := 4.0;
- X.C4 := 5.0;
- X := R'Input (S'Access);
- if X.C1 /= Ident_Char ('a') or X.C3 /= 11.0 or X.C4 /= 11.0 then
- Failed ("Input did not produce the expected result");
- end if;
-
- Clear (S);
-
- -- Not enough data.
- Integer'Output (S'Access, Ident_Int (-11)); -- The discriminant
- Character'Output (S'Access, 'a');
- Float'Output (S'Access, 11.0);
-
- begin
- X := R'Input (S'Access);
- Failed
- ("No exception raised when the end of stream is reached " &
- "before the reading of a value is completed - 2");
- exception
- when End_Error =>
- null;
- when E: others =>
- Failed ("Wrong exception " & Exception_Name (E) &
- " - " & Exception_Message (E) & " - 2");
- end;
-
- end Input;
-
- Result;
-end CDD2001;
-
diff --git a/gcc/testsuite/ada/acats/tests/cd/cdd2a01.a b/gcc/testsuite/ada/acats/tests/cd/cdd2a01.a
deleted file mode 100644
index 7c8000ce04c..00000000000
--- a/gcc/testsuite/ada/acats/tests/cd/cdd2a01.a
+++ /dev/null
@@ -1,379 +0,0 @@
--- CDD2A01.A
---
--- Grant of Unlimited Rights
---
--- The Ada Conformity Assessment Authority (ACAA) holds unlimited
--- rights in the software and documentation contained herein. Unlimited
--- rights are the same as those granted by the U.S. Government for older
--- parts of the Ada Conformity Assessment Test Suite, and are defined
--- in DFAR 252.227-7013(a)(19). By making this public release, the ACAA
--- intends to confer upon all recipients unlimited rights equal to those
--- held by the ACAA. These rights include rights to use, duplicate,
--- release or disclose the released technical data and computer software
--- in whole or in part, in any manner and for any purpose whatsoever, and
--- to have or permit others to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that the Read and Write attributes for a type extension are created
--- from the parent type's attribute (which may be user-defined) and those
--- for the extension components. Also check that the default Input and
--- Output attributes are used for a type extension, even if the parent
--- type's attribute is user-defined. (Defect Report 8652/0040,
--- as reflected in Technical Corrigendum 1, penultimate sentence of
--- 13.13.2(9/1) and 13.13.2(25/1)).
---
--- CHANGE HISTORY:
--- 30 JUL 2001 PHL Initial version.
--- 5 DEC 2001 RLB Reformatted for ACATS.
---
---!
-with Ada.Streams;
-use Ada.Streams;
-with FDD2A00;
-use FDD2A00;
-with Report;
-use Report;
-procedure CDD2A01 is
-
- Input_Output_Error : exception;
-
- type Int is range 1 .. 1000;
- type Str is array (Int range <>) of Character;
-
- procedure Read (Stream : access Root_Stream_Type'Class;
- Item : out Int'Base);
- procedure Write (Stream : access Root_Stream_Type'Class; Item : Int'Base);
- function Input (Stream : access Root_Stream_Type'Class) return Int'Base;
- procedure Output (Stream : access Root_Stream_Type'Class; Item : Int'Base);
-
- for Int'Read use Read;
- for Int'Write use Write;
- for Int'Input use Input;
- for Int'Output use Output;
-
-
- type Parent (D1, D2 : Int; B : Boolean) is tagged
- record
- S : Str (D1 .. D2);
- case B is
- when False =>
- C1 : Integer;
- when True =>
- C2 : Float;
- end case;
- end record;
-
- procedure Read (Stream : access Root_Stream_Type'Class; Item : out Parent);
- procedure Write (Stream : access Root_Stream_Type'Class; Item : Parent);
- function Input (Stream : access Root_Stream_Type'Class) return Parent;
- procedure Output (Stream : access Root_Stream_Type'Class; Item : Parent);
-
- for Parent'Read use Read;
- for Parent'Write use Write;
- for Parent'Input use Input;
- for Parent'Output use Output;
-
-
- procedure Actual_Read
- (Stream : access Root_Stream_Type'Class; Item : out Int) is
- begin
- Integer'Read (Stream, Integer (Item));
- end Actual_Read;
-
- procedure Actual_Write
- (Stream : access Root_Stream_Type'Class; Item : Int) is
- begin
- Integer'Write (Stream, Integer (Item));
- end Actual_Write;
-
- function Actual_Input (Stream : access Root_Stream_Type'Class) return Int is
- begin
- return Int (Integer'Input (Stream));
- end Actual_Input;
-
- procedure Actual_Output
- (Stream : access Root_Stream_Type'Class; Item : Int) is
- begin
- Integer'Output (Stream, Integer (Item));
- end Actual_Output;
-
-
- procedure Actual_Read
- (Stream : access Root_Stream_Type'Class; Item : out Parent) is
- begin
- case Item.B is
- when False =>
- Item.C1 := 7;
- when True =>
- Float'Read (Stream, Item.C2);
- end case;
- Str'Read (Stream, Item.S);
- end Actual_Read;
-
- procedure Actual_Write
- (Stream : access Root_Stream_Type'Class; Item : Parent) is
- begin
- case Item.B is
- when False =>
- null; -- Don't write C1
- when True =>
- Float'Write (Stream, Item.C2);
- end case;
- Str'Write (Stream, Item.S);
- end Actual_Write;
-
- function Actual_Input
- (Stream : access Root_Stream_Type'Class) return Parent is
- X : Parent (1, 1, True);
- begin
- raise Input_Output_Error;
- return X;
- end Actual_Input;
-
- procedure Actual_Output
- (Stream : access Root_Stream_Type'Class; Item : Parent) is
- begin
- raise Input_Output_Error;
- end Actual_Output;
-
- package Int_Ops is new Counting_Stream_Ops (T => Int'Base,
- Actual_Write => Actual_Write,
- Actual_Input => Actual_Input,
- Actual_Read => Actual_Read,
- Actual_Output => Actual_Output);
-
- package Parent_Ops is
- new Counting_Stream_Ops (T => Parent,
- Actual_Write => Actual_Write,
- Actual_Input => Actual_Input,
- Actual_Read => Actual_Read,
- Actual_Output => Actual_Output);
-
- procedure Read (Stream : access Root_Stream_Type'Class; Item : out Int'Base)
- renames Int_Ops.Read;
- procedure Write (Stream : access Root_Stream_Type'Class; Item : Int'Base)
- renames Int_Ops.Write;
- function Input (Stream : access Root_Stream_Type'Class) return Int'Base
- renames Int_Ops.Input;
- procedure Output (Stream : access Root_Stream_Type'Class; Item : Int'Base)
- renames Int_Ops.Output;
-
- procedure Read (Stream : access Root_Stream_Type'Class; Item : out Parent)
- renames Parent_Ops.Read;
- procedure Write (Stream : access Root_Stream_Type'Class; Item : Parent)
- renames Parent_Ops.Write;
- function Input (Stream : access Root_Stream_Type'Class) return Parent
- renames Parent_Ops.Input;
- procedure Output (Stream : access Root_Stream_Type'Class; Item : Parent)
- renames Parent_Ops.Output;
-
- type Derived1 is new Parent with
- record
- C3 : Int;
- end record;
-
- type Derived2 (D : Int) is new Parent (D1 => D,
- D2 => D,
- B => False) with
- record
- C3 : Int;
- end record;
-
-begin
- Test ("CDD2A01",
- "Check that the Read and Write attributes for a type " &
- "extension are created from the parent type's " &
- "attribute (which may be user-defined) and those for the " &
- "extension components; also check that the default input " &
- "and output attributes are used for a type extension, even " &
- "if the parent type's attribute is user-defined");
-
- Test1:
- declare
- S : aliased My_Stream (1000);
- X1 : Derived1 (D1 => Int (Ident_Int (2)),
- D2 => Int (Ident_Int (5)),
- B => Ident_Bool (True));
- Y1 : Derived1 := (D1 => 3,
- D2 => 6,
- B => False,
- S => Str (Ident_Str ("3456")),
- C1 => Ident_Int (100),
- C3 => Int (Ident_Int (88)));
- X2 : Derived1 (D1 => Int (Ident_Int (2)),
- D2 => Int (Ident_Int (5)),
- B => Ident_Bool (True));
- begin
- X1.S := Str (Ident_Str ("bcde"));
- X1.C2 := Float (Ident_Int (4));
- X1.C3 := Int (Ident_Int (99));
-
- Derived1'Write (S'Access, X1);
- if Int_Ops.Get_Counts /=
- (Read => 0, Write => 1, Input => 0, Output => 0) then
- Failed ("Error writing extension components - 1");
- end if;
- if Parent_Ops.Get_Counts /=
- (Read => 0, Write => 1, Input => 0, Output => 0) then
- Failed ("Didn't call parent type's Write - 1");
- end if;
-
- Derived1'Read (S'Access, X2);
- if Int_Ops.Get_Counts /=
- (Read => 1, Write => 1, Input => 0, Output => 0) then
- Failed ("Error reading extension components - 1");
- end if;
- if Parent_Ops.Get_Counts /=
- (Read => 1, Write => 1, Input => 0, Output => 0) then
- Failed ("Didn't call inherited Read - 1");
- end if;
-
- if X2 /= (D1 => 2,
- D2 => 5,
- B => True,
- S => Str (Ident_Str ("bcde")),
- C2 => Float (Ident_Int (4)),
- C3 => Int (Ident_Int (99))) then
- Failed
- ("Inherited Read and Write are not inverses of each other - 1");
- end if;
-
- begin
- Derived1'Output (S'Access, Y1);
- if Int_Ops.Get_Counts /=
- (Read => 1, Write => 4, Input => 0, Output => 0) then
- Failed ("Error writing extension components - 2");
- end if;
- if Parent_Ops.Get_Counts /=
- (Read => 1, Write => 2, Input => 0, Output => 0) then
- Failed ("Didn't call inherited Write - 2");
- end if;
- exception
- when Input_Output_Error =>
- Failed ("Did call inherited Output - 2");
- end;
-
- begin
- declare
- Y2 : Derived1 := Derived1'Input (S'Access);
- begin
- if Int_Ops.Get_Counts /=
- (Read => 4, Write => 4, Input => 0, Output => 0) then
- Failed ("Error reading extension components - 2");
- end if;
- if Parent_Ops.Get_Counts /=
- (Read => 2, Write => 2, Input => 0, Output => 0) then
- Failed ("Didn't call inherited Read - 2");
- end if;
- if Y2 /= (D1 => 3,
- D2 => 6,
- B => False,
- S => Str (Ident_Str ("3456")),
- C1 => Ident_Int (7),
- C3 => Int (Ident_Int (88))) then
- Failed
- ("Input and Output are not inverses of each other - 2");
- end if;
- end;
- exception
- when Input_Output_Error =>
- Failed ("Did call inherited Input - 2");
- end;
-
- end Test1;
-
- Test2:
- declare
- S : aliased My_Stream (1000);
- X1 : Derived2 (D => Int (Ident_Int (7)));
- Y1 : Derived2 := (D => 8,
- S => Str (Ident_Str ("8")),
- C1 => Ident_Int (200),
- C3 => Int (Ident_Int (77)));
- X2 : Derived2 (D => Int (Ident_Int (7)));
- begin
- X1.S := Str (Ident_Str ("g"));
- X1.C1 := Ident_Int (4);
- X1.C3 := Int (Ident_Int (666));
-
- Derived2'Write (S'Access, X1);
- if Int_Ops.Get_Counts /=
- (Read => 4, Write => 5, Input => 0, Output => 0) then
- Failed ("Error writing extension components - 3");
- end if;
- if Parent_Ops.Get_Counts /=
- (Read => 2, Write => 3, Input => 0, Output => 0) then
- Failed ("Didn't call inherited Write - 3");
- end if;
-
- Derived2'Read (S'Access, X2);
- if Int_Ops.Get_Counts /=
- (Read => 5, Write => 5, Input => 0, Output => 0) then
- Failed ("Error reading extension components - 3");
- end if;
- if Parent_Ops.Get_Counts /=
- (Read => 3, Write => 3, Input => 0, Output => 0) then
- Failed ("Didn't call inherited Read - 3");
- end if;
-
- if X2 /= (D => 7,
- S => Str (Ident_Str ("g")),
- C1 => Ident_Int (7),
- C3 => Int (Ident_Int (666))) then
- Failed ("Read and Write are not inverses of each other - 3");
- end if;
-
- begin
- Derived2'Output (S'Access, Y1);
- if Int_Ops.Get_Counts /=
- (Read => 5, Write => 7, Input => 0, Output => 0) then
- Failed ("Error writing extension components - 4");
- end if;
- if Parent_Ops.Get_Counts /=
- (Read => 3, Write => 4, Input => 0, Output => 0) then
- Failed ("Didn't call inherited Write - 4");
- end if;
- exception
- when Input_Output_Error =>
- Failed ("Did call inherited Output - 4");
- end;
-
- begin
- declare
- Y2 : Derived2 := Derived2'Input (S'Access);
- begin
- if Int_Ops.Get_Counts /=
- (Read => 7, Write => 7, Input => 0, Output => 0) then
- Failed ("Error reading extension components - 4");
- end if;
- if Parent_Ops.Get_Counts /=
- (Read => 4, Write => 4, Input => 0, Output => 0) then
- Failed ("Didn't call inherited Read - 4");
- end if;
- if Y2 /= (D => 8,
- S => Str (Ident_Str ("8")),
- C1 => Ident_Int (7),
- C3 => Int (Ident_Int (77))) then
- Failed
- ("Input and Output are not inverses of each other - 4");
- end if;
- end;
- exception
- when Input_Output_Error =>
- Failed ("Did call inherited Input - 4");
- end;
-
- end Test2;
-
- Result;
-end CDD2A01;
diff --git a/gcc/testsuite/ada/acats/tests/cd/cdd2a02.a b/gcc/testsuite/ada/acats/tests/cd/cdd2a02.a
deleted file mode 100644
index 854431c3488..00000000000
--- a/gcc/testsuite/ada/acats/tests/cd/cdd2a02.a
+++ /dev/null
@@ -1,345 +0,0 @@
--- CDD2A02.A
---
--- Grant of Unlimited Rights
---
--- The Ada Conformity Assessment Authority (ACAA) holds unlimited
--- rights in the software and documentation contained herein. Unlimited
--- rights are the same as those granted by the U.S. Government for older
--- parts of the Ada Conformity Assessment Test Suite, and are defined
--- in DFAR 252.227-7013(a)(19). By making this public release, the ACAA
--- intends to confer upon all recipients unlimited rights equal to those
--- held by the ACAA. These rights include rights to use, duplicate,
--- release or disclose the released technical data and computer software
--- in whole or in part, in any manner and for any purpose whatsoever, and
--- to have or permit others to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that the Read, Write, Input, and Output attributes are inherited
--- for untagged derived types. (Defect Report 8652/0040,
--- as reflected in Technical Corrigendum 1, 13.13.2(8.1/1) and
--- 13.13.2(25/1)).
---
--- CHANGE HISTORY:
--- 30 JUL 2001 PHL Initial version.
--- 5 DEC 2001 RLB Reformatted for ACATS.
---
---!
-with Ada.Streams;
-use Ada.Streams;
-with FDD2A00;
-use FDD2A00;
-with Report;
-use Report;
-procedure CDD2A02 is
-
- type Int is range 1 .. 10;
- type Str is array (Int range <>) of Character;
-
- procedure Read (Stream : access Root_Stream_Type'Class;
- Item : out Int'Base);
- procedure Write (Stream : access Root_Stream_Type'Class; Item : Int'Base);
- function Input (Stream : access Root_Stream_Type'Class) return Int'Base;
- procedure Output (Stream : access Root_Stream_Type'Class; Item : Int'Base);
-
- for Int'Read use Read;
- for Int'Write use Write;
- for Int'Input use Input;
- for Int'Output use Output;
-
-
- type Parent (D1, D2 : Int; B : Boolean) is
- record
- S : Str (D1 .. D2);
- case B is
- when False =>
- C1 : Integer;
- when True =>
- C2 : Float;
- end case;
- end record;
-
- procedure Read (Stream : access Root_Stream_Type'Class; Item : out Parent);
- procedure Write (Stream : access Root_Stream_Type'Class; Item : Parent);
- function Input (Stream : access Root_Stream_Type'Class) return Parent;
- procedure Output (Stream : access Root_Stream_Type'Class; Item : Parent);
-
- for Parent'Read use Read;
- for Parent'Write use Write;
- for Parent'Input use Input;
- for Parent'Output use Output;
-
-
- procedure Actual_Read
- (Stream : access Root_Stream_Type'Class; Item : out Int) is
- begin
- Integer'Read (Stream, Integer (Item));
- end Actual_Read;
-
- procedure Actual_Write
- (Stream : access Root_Stream_Type'Class; Item : Int) is
- begin
- Integer'Write (Stream, Integer (Item));
- end Actual_Write;
-
- function Actual_Input (Stream : access Root_Stream_Type'Class) return Int is
- begin
- return Int (Integer'Input (Stream));
- end Actual_Input;
-
- procedure Actual_Output
- (Stream : access Root_Stream_Type'Class; Item : Int) is
- begin
- Integer'Output (Stream, Integer (Item));
- end Actual_Output;
-
-
- procedure Actual_Read
- (Stream : access Root_Stream_Type'Class; Item : out Parent) is
- begin
- case Item.B is
- when False =>
- Item.C1 := 7;
- when True =>
- Float'Read (Stream, Item.C2);
- end case;
- Str'Read (Stream, Item.S);
- end Actual_Read;
-
- procedure Actual_Write
- (Stream : access Root_Stream_Type'Class; Item : Parent) is
- begin
- case Item.B is
- when False =>
- null; -- Don't write C1
- when True =>
- Float'Write (Stream, Item.C2);
- end case;
- Str'Write (Stream, Item.S);
- end Actual_Write;
-
- function Actual_Input
- (Stream : access Root_Stream_Type'Class) return Parent is
- D1, D2 : Int;
- B : Boolean;
- begin
- Int'Read (Stream, D2);
- Boolean'Read (Stream, B);
- Int'Read (Stream, D1);
-
- declare
- Item : Parent (D1 => D1, D2 => D2, B => B);
- begin
- Parent'Read (Stream, Item);
- return Item;
- end;
-
- end Actual_Input;
-
- procedure Actual_Output
- (Stream : access Root_Stream_Type'Class; Item : Parent) is
- begin
- Int'Write (Stream, Item.D2);
- Boolean'Write (Stream, Item.B);
- Int'Write (Stream, Item.D1);
- Parent'Write (Stream, Item);
- end Actual_Output;
-
- package Int_Ops is new Counting_Stream_Ops (T => Int'Base,
- Actual_Write => Actual_Write,
- Actual_Input => Actual_Input,
- Actual_Read => Actual_Read,
- Actual_Output => Actual_Output);
-
- package Parent_Ops is
- new Counting_Stream_Ops (T => Parent,
- Actual_Write => Actual_Write,
- Actual_Input => Actual_Input,
- Actual_Read => Actual_Read,
- Actual_Output => Actual_Output);
-
- procedure Read (Stream : access Root_Stream_Type'Class; Item : out Int'Base)
- renames Int_Ops.Read;
- procedure Write (Stream : access Root_Stream_Type'Class; Item : Int'Base)
- renames Int_Ops.Write;
- function Input (Stream : access Root_Stream_Type'Class) return Int'Base
- renames Int_Ops.Input;
- procedure Output (Stream : access Root_Stream_Type'Class; Item : Int'Base)
- renames Int_Ops.Output;
-
- procedure Read (Stream : access Root_Stream_Type'Class; Item : out Parent)
- renames Parent_Ops.Read;
- procedure Write (Stream : access Root_Stream_Type'Class; Item : Parent)
- renames Parent_Ops.Write;
- function Input (Stream : access Root_Stream_Type'Class) return Parent
- renames Parent_Ops.Input;
- procedure Output (Stream : access Root_Stream_Type'Class; Item : Parent)
- renames Parent_Ops.Output;
-
-begin
- Test ("CDD2A02", "Check that the Read, Write, Input, and Output " &
- "attributes are inherited for untagged derived types");
-
- Test1:
- declare
- type Derived1 is new Parent;
- S : aliased My_Stream (1000);
- X1 : Derived1 (D1 => Int (Ident_Int (2)),
- D2 => Int (Ident_Int (5)), B => Ident_Bool (True));
- Y1 : Derived1 := (D1 => 3,
- D2 => 6,
- B => False,
- S => Str (Ident_Str ("3456")),
- C1 => Ident_Int (100));
- X2 : Derived1 (D1 => Int (Ident_Int (2)),
- D2 => Int (Ident_Int (5)), B => Ident_Bool (True));
- begin
- X1.S := Str (Ident_Str ("bcde"));
- X1.C2 := Float (Ident_Int (4));
-
- Derived1'Write (S'Access, X1);
- if Int_Ops.Get_Counts /=
- (Read => 0, Write => 0, Input => 0, Output => 0) then
- Failed ("Error writing discriminants - 1");
- end if;
- if Parent_Ops.Get_Counts /=
- (Read => 0, Write => 1, Input => 0, Output => 0) then
- Failed ("Didn't call inherited Write - 1");
- end if;
-
- Derived1'Read (S'Access, X2);
- if Int_Ops.Get_Counts /=
- (Read => 0, Write => 0, Input => 0, Output => 0) then
- Failed ("Error reading discriminants - 1");
- end if;
- if Parent_Ops.Get_Counts /=
- (Read => 1, Write => 1, Input => 0, Output => 0) then
- Failed ("Didn't call inherited Read - 1");
- end if;
-
- if X2 /= (D1 => 2,
- D2 => 5,
- B => True,
- S => Str (Ident_Str ("bcde")),
- C2 => Float (Ident_Int (4))) then
- Failed
- ("Inherited Read and Write are not inverses of each other - 1");
- end if;
-
- Derived1'Output (S'Access, Y1);
- if Int_Ops.Get_Counts /=
- (Read => 0, Write => 2, Input => 0, Output => 0) then
- Failed ("Error writing discriminants - 2");
- end if;
- if Parent_Ops.Get_Counts /=
- (Read => 1, Write => 2, Input => 0, Output => 1) then
- Failed ("Didn't call inherited Output - 2");
- end if;
-
- declare
- Y2 : Derived1 := Derived1'Input (S'Access);
- begin
- if Int_Ops.Get_Counts /=
- (Read => 2, Write => 2, Input => 0, Output => 0) then
- Failed ("Error reading discriminants - 2");
- end if;
- if Parent_Ops.Get_Counts /=
- (Read => 2, Write => 2, Input => 1, Output => 1) then
- Failed ("Didn't call inherited Input - 2");
- end if;
-
- if Y2 /= (D1 => 3,
- D2 => 6,
- B => False,
- S => Str (Ident_Str ("3456")),
- C1 => Ident_Int (7)) then
- Failed
- ("Inherited Input and Output are not inverses of each other - 2");
- end if;
- end;
- end Test1;
-
- Test2:
- declare
- type Derived2 (D : Int) is new Parent (D1 => D,
- D2 => D,
- B => False);
- S : aliased My_Stream (1000);
- X1 : Derived2 (D => Int (Ident_Int (7)));
- Y1 : Derived2 := (D => 8,
- S => Str (Ident_Str ("8")),
- C1 => Ident_Int (200));
- X2 : Derived2 (D => Int (Ident_Int (7)));
- begin
- X1.S := Str (Ident_Str ("g"));
- X1.C1 := Ident_Int (4);
-
- Derived2'Write (S'Access, X1);
- if Int_Ops.Get_Counts /=
- (Read => 2, Write => 2, Input => 0, Output => 0) then
- Failed ("Error writing discriminants - 3");
- end if;
- if Parent_Ops.Get_Counts /=
- (Read => 2, Write => 3, Input => 1, Output => 1) then
- Failed ("Didn't call inherited Write - 3");
- end if;
-
- Derived2'Read (S'Access, X2);
- if Int_Ops.Get_Counts /=
- (Read => 2, Write => 2, Input => 0, Output => 0) then
- Failed ("Error reading discriminants - 3");
- end if;
- if Parent_Ops.Get_Counts /=
- (Read => 3, Write => 3, Input => 1, Output => 1) then
- Failed ("Didn't call inherited Read - 3");
- end if;
-
- if X2 /= (D => 7,
- S => Str (Ident_Str ("g")),
- C1 => Ident_Int (7)) then
- Failed
- ("Inherited Read and Write are not inverses of each other - 3");
- end if;
-
- Derived2'Output (S'Access, Y1);
- if Int_Ops.Get_Counts /=
- (Read => 2, Write => 4, Input => 0, Output => 0) then
- Failed ("Error writing discriminants - 4");
- end if;
- if Parent_Ops.Get_Counts /=
- (Read => 3, Write => 4, Input => 1, Output => 2) then
- Failed ("Didn't call inherited Output - 4");
- end if;
-
- declare
- Y2 : Derived2 := Derived2'Input (S'Access);
- begin
- if Int_Ops.Get_Counts /=
- (Read => 4, Write => 4, Input => 0, Output => 0) then
- Failed ("Error reading discriminants - 4");
- end if;
- if Parent_Ops.Get_Counts /=
- (Read => 4, Write => 4, Input => 2, Output => 2) then
- Failed ("Didn't call inherited Input - 4");
- end if;
-
- if Y2 /= (D => 8,
- S => Str (Ident_Str ("8")),
- C1 => Ident_Int (7)) then
- Failed
- ("Inherited Input and Output are not inverses of each other - 4");
- end if;
- end;
- end Test2;
-
- Result;
-end CDD2A02;
diff --git a/gcc/testsuite/ada/acats/tests/cd/cdd2a03.a b/gcc/testsuite/ada/acats/tests/cd/cdd2a03.a
deleted file mode 100644
index b4c2917724d..00000000000
--- a/gcc/testsuite/ada/acats/tests/cd/cdd2a03.a
+++ /dev/null
@@ -1,325 +0,0 @@
--- CDD2A03.A
---
--- Grant of Unlimited Rights
---
--- The Ada Conformity Assessment Authority (ACAA) holds unlimited
--- rights in the software and documentation contained herein. Unlimited
--- rights are the same as those granted by the U.S. Government for older
--- parts of the Ada Conformity Assessment Test Suite, and are defined
--- in DFAR 252.227-7013(a)(19). By making this public release, the ACAA
--- intends to confer upon all recipients unlimited rights equal to those
--- held by the ACAA. These rights include rights to use, duplicate,
--- release or disclose the released technical data and computer software
--- in whole or in part, in any manner and for any purpose whatsoever, and
--- to have or permit others to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that the default Read and Write attributes for a limited type
--- extension are created from the parent type's attribute (which may be
--- user-defined) and those for the extension components, if the extension
--- components are non-limited or have user-defined attributes. Check that
--- such limited type extension attributes are callable (Defect Report
--- 8652/0040, as reflected in Technical Corrigendum 1, penultimate sentence
--- of 13.13.2(9/1) and 13.13.2(36/1)).
---
--- CHANGE HISTORY:
--- 1 AUG 2001 PHL Initial version.
--- 3 DEC 2001 RLB Reformatted for ACATS.
---
---!
-with Ada.Streams;
-use Ada.Streams;
-with FDD2A00;
-use FDD2A00;
-with Report;
-use Report;
-procedure CDD2A03 is
-
- Input_Output_Error : exception;
-
- type Int is range 1 .. 1000;
- type Str is array (Int range <>) of Character;
-
- procedure Read (Stream : access Root_Stream_Type'Class;
- Item : out Int'Base);
- procedure Write (Stream : access Root_Stream_Type'Class; Item : Int'Base);
- function Input (Stream : access Root_Stream_Type'Class) return Int'Base;
- procedure Output (Stream : access Root_Stream_Type'Class; Item : Int'Base);
-
- for Int'Read use Read;
- for Int'Write use Write;
- for Int'Input use Input;
- for Int'Output use Output;
-
-
- type Lim is limited
- record
- C : Int;
- end record;
-
- procedure Read (Stream : access Root_Stream_Type'Class; Item : out Lim);
- procedure Write (Stream : access Root_Stream_Type'Class; Item : Lim);
- function Input (Stream : access Root_Stream_Type'Class) return Lim;
- procedure Output (Stream : access Root_Stream_Type'Class; Item : Lim);
-
- for Lim'Read use Read;
- for Lim'Write use Write;
- for Lim'Input use Input;
- for Lim'Output use Output;
-
-
- type Parent (D1, D2 : Int; B : Boolean) is tagged limited
- record
- S : Str (D1 .. D2);
- case B is
- when False =>
- C1 : Integer;
- when True =>
- C2 : Float;
- end case;
- end record;
-
- procedure Read (Stream : access Root_Stream_Type'Class; Item : out Parent);
- procedure Write (Stream : access Root_Stream_Type'Class; Item : Parent);
- function Input (Stream : access Root_Stream_Type'Class) return Parent;
- procedure Output (Stream : access Root_Stream_Type'Class; Item : Parent);
-
- for Parent'Read use Read;
- for Parent'Write use Write;
- for Parent'Input use Input;
- for Parent'Output use Output;
-
-
- procedure Actual_Read
- (Stream : access Root_Stream_Type'Class; Item : out Int) is
- begin
- Integer'Read (Stream, Integer (Item));
- end Actual_Read;
-
- procedure Actual_Write
- (Stream : access Root_Stream_Type'Class; Item : Int) is
- begin
- Integer'Write (Stream, Integer (Item));
- end Actual_Write;
-
- function Actual_Input (Stream : access Root_Stream_Type'Class) return Int is
- begin
- return Int (Integer'Input (Stream));
- end Actual_Input;
-
- procedure Actual_Output
- (Stream : access Root_Stream_Type'Class; Item : Int) is
- begin
- Integer'Output (Stream, Integer (Item));
- end Actual_Output;
-
-
- procedure Actual_Read
- (Stream : access Root_Stream_Type'Class; Item : out Lim) is
- begin
- Integer'Read (Stream, Integer (Item.C));
- end Actual_Read;
-
- procedure Actual_Write
- (Stream : access Root_Stream_Type'Class; Item : Lim) is
- begin
- Integer'Write (Stream, Integer (Item.C));
- end Actual_Write;
-
- function Actual_Input (Stream : access Root_Stream_Type'Class) return Lim is
- Result : Lim;
- begin
- Result.C := Int (Integer'Input (Stream));
- return Result;
- end Actual_Input;
-
- procedure Actual_Output
- (Stream : access Root_Stream_Type'Class; Item : Lim) is
- begin
- Integer'Output (Stream, Integer (Item.C));
- end Actual_Output;
-
-
- procedure Actual_Read
- (Stream : access Root_Stream_Type'Class; Item : out Parent) is
- begin
- case Item.B is
- when False =>
- Item.C1 := 7;
- when True =>
- Float'Read (Stream, Item.C2);
- end case;
- Str'Read (Stream, Item.S);
- end Actual_Read;
-
- procedure Actual_Write
- (Stream : access Root_Stream_Type'Class; Item : Parent) is
- begin
- case Item.B is
- when False =>
- null; -- Don't write C1
- when True =>
- Float'Write (Stream, Item.C2);
- end case;
- Str'Write (Stream, Item.S);
- end Actual_Write;
-
- function Actual_Input
- (Stream : access Root_Stream_Type'Class) return Parent is
- X : Parent (1, 1, True);
- begin
- raise Input_Output_Error;
- return X;
- end Actual_Input;
-
- procedure Actual_Output
- (Stream : access Root_Stream_Type'Class; Item : Parent) is
- begin
- raise Input_Output_Error;
- end Actual_Output;
-
- package Int_Ops is new Counting_Stream_Ops (T => Int'Base,
- Actual_Write => Actual_Write,
- Actual_Input => Actual_Input,
- Actual_Read => Actual_Read,
- Actual_Output => Actual_Output);
-
- package Lim_Ops is new Counting_Stream_Ops (T => Lim,
- Actual_Write => Actual_Write,
- Actual_Input => Actual_Input,
- Actual_Read => Actual_Read,
- Actual_Output => Actual_Output);
-
- package Parent_Ops is
- new Counting_Stream_Ops (T => Parent,
- Actual_Write => Actual_Write,
- Actual_Input => Actual_Input,
- Actual_Read => Actual_Read,
- Actual_Output => Actual_Output);
-
- procedure Read (Stream : access Root_Stream_Type'Class; Item : out Int'Base)
- renames Int_Ops.Read;
- procedure Write (Stream : access Root_Stream_Type'Class; Item : Int'Base)
- renames Int_Ops.Write;
- function Input (Stream : access Root_Stream_Type'Class) return Int'Base
- renames Int_Ops.Input;
- procedure Output (Stream : access Root_Stream_Type'Class; Item : Int'Base)
- renames Int_Ops.Output;
-
- procedure Read (Stream : access Root_Stream_Type'Class; Item : out Lim)
- renames Lim_Ops.Read;
- procedure Write (Stream : access Root_Stream_Type'Class; Item : Lim)
- renames Lim_Ops.Write;
- function Input (Stream : access Root_Stream_Type'Class) return Lim
- renames Lim_Ops.Input;
- procedure Output (Stream : access Root_Stream_Type'Class; Item : Lim)
- renames Lim_Ops.Output;
-
- procedure Read (Stream : access Root_Stream_Type'Class; Item : out Parent)
- renames Parent_Ops.Read;
- procedure Write (Stream : access Root_Stream_Type'Class; Item : Parent)
- renames Parent_Ops.Write;
- function Input (Stream : access Root_Stream_Type'Class) return Parent
- renames Parent_Ops.Input;
- procedure Output (Stream : access Root_Stream_Type'Class; Item : Parent)
- renames Parent_Ops.Output;
-
- type Derived1 is new Parent with
- record
- C3 : Int;
- end record;
-
- type Derived2 (D : Int) is new Parent (D1 => D,
- D2 => D,
- B => False) with
- record
- C3 : Lim;
- end record;
-
-begin
- Test ("CDD2A03",
- "Check that the default Read and Write attributes for a limited " &
- "type extension are created from the parent type's " &
- "attribute (which may be user-defined) and those for the " &
- "extension components, if the extension components are " &
- "non-limited or have user-defined attributes; check that such " &
- "limited type extension attributes are callable");
-
- Test1:
- declare
- S : aliased My_Stream (1000);
- X1 : Derived1 (D1 => Int (Ident_Int (2)),
- D2 => Int (Ident_Int (5)),
- B => Ident_Bool (True));
- X2 : Derived1 (D1 => Int (Ident_Int (2)),
- D2 => Int (Ident_Int (5)),
- B => Ident_Bool (True));
- begin
- X1.S := Str (Ident_Str ("bcde"));
- X1.C2 := Float (Ident_Int (4));
- X1.C3 := Int (Ident_Int (99));
-
- Derived1'Write (S'Access, X1);
- if Int_Ops.Get_Counts /=
- (Read => 0, Write => 1, Input => 0, Output => 0) then
- Failed ("Error writing extension components - 1");
- end if;
- if Parent_Ops.Get_Counts /=
- (Read => 0, Write => 1, Input => 0, Output => 0) then
- Failed ("Didn't call parent type's Write - 1");
- end if;
-
- Derived1'Read (S'Access, X2);
- if Int_Ops.Get_Counts /=
- (Read => 1, Write => 1, Input => 0, Output => 0) then
- Failed ("Error reading extension components - 1");
- end if;
- if Parent_Ops.Get_Counts /=
- (Read => 1, Write => 1, Input => 0, Output => 0) then
- Failed ("Didn't call inherited Read - 1");
- end if;
- end Test1;
-
- Test2:
- declare
- S : aliased My_Stream (1000);
- X1 : Derived2 (D => Int (Ident_Int (7)));
- X2 : Derived2 (D => Int (Ident_Int (7)));
- begin
- X1.S := Str (Ident_Str ("g"));
- X1.C1 := Ident_Int (4);
- X1.C3.C := Int (Ident_Int (666));
-
- Derived2'Write (S'Access, X1);
- if Lim_Ops.Get_Counts /=
- (Read => 0, Write => 1, Input => 0, Output => 0) then
- Failed ("Error writing extension components - 2");
- end if;
- if Parent_Ops.Get_Counts /=
- (Read => 1, Write => 2, Input => 0, Output => 0) then
- Failed ("Didn't call inherited Write - 2");
- end if;
-
- Derived2'Read (S'Access, X2);
- if Lim_Ops.Get_Counts /=
- (Read => 1, Write => 1, Input => 0, Output => 0) then
- Failed ("Error reading extension components - 2");
- end if;
- if Parent_Ops.Get_Counts /=
- (Read => 2, Write => 2, Input => 0, Output => 0) then
- Failed ("Didn't call inherited Read - 2");
- end if;
- end Test2;
-
- Result;
-end CDD2A03;
diff --git a/gcc/testsuite/ada/acats/tests/cd/cde0001.a b/gcc/testsuite/ada/acats/tests/cd/cde0001.a
deleted file mode 100644
index 59db2256f6f..00000000000
--- a/gcc/testsuite/ada/acats/tests/cd/cde0001.a
+++ /dev/null
@@ -1,324 +0,0 @@
--- CDE0001.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that the following names can be used in the declaration of a
--- generic formal parameter (object, array type, or access type) without
--- causing freezing of the named type:
--- (1) The name of a private type,
--- (2) A name that denotes a subtype of a private type, and
--- (3) A name that denotes a composite type with a subcomponent of a
--- private type (or subtype).
--- Check for untagged and tagged types.
---
--- TEST DESCRIPTION:
--- This transition test defines private and limited private types,
--- subtypes of these private types, records and arrays of both types and
--- subtypes, a tagged type and a private extension.
--- This test creates examples where the above types are used in the
--- definition of several generic formal type parameters (object, array
--- type, or access type) in both visible and private parts. These
--- visible and private generic packages are instantiated in the body of
--- the public child and the private child, respectively.
--- The main program utilizes the functions declared in the public child
--- to verify results of the instantiations.
---
--- Inspired by B74103F.ADA.
---
---
--- CHANGE HISTORY:
--- 12 Mar 96 SAIC Initial version for ACVC 2.1.
--- 05 Oct 96 SAIC ACVC 2.1: Added pragma Elaborate for CDE0001.
--- 21 Nov 98 RLB Added pragma Elaborate for CDE0001 to CDE0001_3.
---!
-
-package CDE0001_0 is
-
- subtype Small_Int is Integer range 1 .. 2;
-
- type Private_Type is private;
- type Limited_Private is limited private;
-
- subtype Private_Subtype is Private_Type;
- subtype Limited_Private_Subtype is Limited_Private;
-
- type Array_Of_LP_Subtype is array (1..2) of Limited_Private_Subtype;
-
- type Rec_Of_Limited_Private is
- record
- C1 : Limited_Private;
- end record;
-
- type Rec_Of_Private_SubType is
- record
- C1 : Private_SubType;
- end record;
-
- type Tag_Type is tagged
- record
- C1 : Small_Int;
- end record;
-
- type New_TagType is new Tag_Type with private;
-
- generic
-
- Formal_Obj01 : in out Private_Type; -- Formal objects defined
- Formal_Obj02 : in out Limited_Private; -- by names of private
- Formal_Obj03 : in out Private_Subtype; -- types, names that
- Formal_Obj04 : in out Limited_Private_Subtype; -- denotes subtypes of
- Formal_Obj05 : in out New_TagType; -- the private types.
-
- package CDE0001_1 is
- procedure Assign_Objects;
-
- end CDE0001_1;
-
-private
-
- generic
- -- Formal array types of a private type, a composite type with a
- -- subcomponent of a private type.
-
- type Formal_Arr01 is array (Small_Int) of Private_Type;
- type Formal_Arr02 is array (Small_Int) of Rec_Of_Limited_Private;
-
- -- Formal access types of composite types with a subcomponent of
- -- a private subtype.
-
- type Formal_Acc01 is access Rec_Of_Private_Subtype;
- type Formal_Acc02 is access Array_Of_LP_Subtype;
-
- package CDE0001_2 is
-
- procedure Assign_Arrays (P1 : out Formal_Arr01;
- P2 : out Formal_Arr02);
-
- procedure Assign_Access (P1 : out Formal_Acc01;
- P2 : out Formal_Acc02);
-
- end CDE0001_2;
-
- ----------------------------------------------------------
- type Private_Type is range 1 .. 10;
- type Limited_Private is (Eh, Bee, Sea, Dee);
- type New_TagType is new Tag_Type with
- record
- C2 : Private_Type;
- end record;
-
-end CDE0001_0;
-
- --==================================================================--
-
-package body CDE0001_0 is
-
- package body CDE0001_1 is
-
- procedure Assign_Objects is
- begin
- Formal_Obj01 := Private_Type'First;
- Formal_Obj02 := Limited_Private'Last;
- Formal_Obj03 := Private_Subtype'Last;
- Formal_Obj04 := Limited_Private_Subtype'First;
- Formal_Obj05 := New_TagType'(C1 => 2, C2 => Private_Type'Last);
-
- end Assign_Objects;
-
- end CDE0001_1;
-
- --===========================================================--
-
- package body CDE0001_2 is
-
- procedure Assign_Arrays (P1 : out Formal_Arr01;
- P2 : out Formal_Arr02) is
- begin
- P1(1) := Private_Type'Pred(Private_Type'Last);
- P1(2) := Private_Type'Succ(Private_Type'First);
- P2(1).C1 := Limited_Private'Succ(Limited_Private'First);
- P2(2).C1 := Limited_Private'Pred(Limited_Private'Last);
-
- end Assign_Arrays;
-
- -----------------------------------------------------------------
- procedure Assign_Access (P1 : out Formal_Acc01;
- P2 : out Formal_Acc02) is
- begin
- P1 := new Rec_Of_Private_Subtype'(C1 => Private_Subtype'Last);
- P2 := new Array_Of_LP_Subtype'(Eh, Dee);
-
- end Assign_Access;
-
- end CDE0001_2;
-
-end CDE0001_0;
-
- --==================================================================--
-
--- The following private child package instantiates its parent private generic
--- package.
-
-with CDE0001_0;
-pragma Elaborate (CDE0001_0); -- So generic unit can be instantiated.
-private
-package CDE0001_0.CDE0001_3 is
-
- type Arr01 is array (Small_Int) of Private_Type;
- type Arr02 is array (Small_Int) of Rec_Of_Limited_Private;
- type Acc01 is access Rec_Of_Private_Subtype;
- type Acc02 is access Array_Of_LP_Subtype;
-
- package Formal_Types_Pck is new CDE0001_2 (Arr01, Arr02, Acc01, Acc02);
-
- Arr01_Obj : Arr01;
- Arr02_Obj : Arr02;
- Acc01_Obj : Acc01;
- Acc02_Obj : Acc02;
-
-end CDE0001_0.CDE0001_3;
-
- --==================================================================--
-
-package CDE0001_0.CDE0001_4 is
-
- -- The following functions check the private types defined in the parent
- -- and the private child package from within the client program.
-
- function Verify_Objects return Boolean;
-
- function Verify_Arrays return Boolean;
-
- function Verify_Access return Boolean;
-
-end CDE0001_0.CDE0001_4;
-
- --==================================================================--
-
-with CDE0001_0.CDE0001_3; -- private sibling.
-
-pragma Elaborate (CDE0001_0.CDE0001_3);
-
-package body CDE0001_0.CDE0001_4 is
-
- Obj1 : Private_Type := 2;
- Obj2 : Limited_Private := Bee;
- Obj3 : Private_Subtype := 3;
- Obj4 : Limited_Private_Subtype := Sea;
- Obj5 : New_TagType := (1, 5);
-
- -- Instantiate the generic package declared in the visible part of
- -- the parent.
-
- package Formal_Obj_Pck is new CDE0001_1 (Obj1, Obj2, Obj3, Obj4, Obj5);
-
- ---------------------------------------------------
- function Verify_Objects return Boolean is
- Result : Boolean := False;
- begin
- if Obj1 = 1 and
- Obj2 = Dee and
- Obj3 = 10 and
- Obj4 = Eh and
- Obj5.C1 = 2 and
- Obj5.C2 = 10 then
- Result := True;
- end if;
-
- return Result;
-
- end Verify_Objects;
-
- ---------------------------------------------------
- function Verify_Arrays return Boolean is
- Result : Boolean := False;
- begin
- if CDE0001_0.CDE0001_3.Arr01_Obj(1) = 9 and
- CDE0001_0.CDE0001_3.Arr01_Obj(2) = 2 and
- CDE0001_0.CDE0001_3.Arr02_Obj(1).C1 = Bee and
- CDE0001_0.CDE0001_3.Arr02_Obj(2).C1 = Sea then
- Result := True;
- end if;
-
- return Result;
-
- end Verify_Arrays;
-
- ---------------------------------------------------
- function Verify_Access return Boolean is
- Result : Boolean := False;
- begin
- if CDE0001_0.CDE0001_3.Acc01_Obj.C1 = 10 and
- CDE0001_0.CDE0001_3.Acc02_Obj(1) = Eh and
- CDE0001_0.CDE0001_3.Acc02_Obj(2) = Dee then
- Result := True;
- end if;
-
- return Result;
-
- end Verify_Access;
-
-begin
-
- Formal_Obj_Pck.Assign_Objects;
-
- CDE0001_0.CDE0001_3.Formal_Types_Pck.Assign_Arrays
- (CDE0001_0.CDE0001_3.Arr01_Obj, CDE0001_0.CDE0001_3.Arr02_Obj);
- CDE0001_0.CDE0001_3.Formal_Types_Pck.Assign_Access
- (CDE0001_0.CDE0001_3.Acc01_Obj, CDE0001_0.CDE0001_3.Acc02_Obj);
-
-end CDE0001_0.CDE0001_4;
-
- --==================================================================--
-
-with Report;
-with CDE0001_0.CDE0001_4;
-
-procedure CDE0001 is
-
-begin
-
- Report.Test ("CDE0001", "Check that the name of the private type, a " &
- "name that denotes a subtype of the private type, or a " &
- "name that denotes a composite type with a subcomponent " &
- "of a private type can be used in the declaration of a " &
- "generic formal type parameter without causing freezing " &
- "of the named type");
-
- if not CDE0001_0.CDE0001_4.Verify_Objects then
- Report.Failed ("Wrong values for formal objects");
- end if;
-
- if not CDE0001_0.CDE0001_4.Verify_Arrays then
- Report.Failed ("Wrong values for formal array types");
- end if;
-
- if not CDE0001_0.CDE0001_4.Verify_Access then
- Report.Failed ("Wrong values for formal access types");
- end if;
-
- Report.Result;
-
-end CDE0001;
diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxa3001.a b/gcc/testsuite/ada/acats/tests/cxa/cxa3001.a
deleted file mode 100644
index 9c7e25b977c..00000000000
--- a/gcc/testsuite/ada/acats/tests/cxa/cxa3001.a
+++ /dev/null
@@ -1,507 +0,0 @@
--- CXA3001.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that the character classification functions defined in
--- package Ada.Characters.Handling produce correct results when provided
--- constant arguments from package Ada.Characters.Latin_1.
---
--- TEST DESCRIPTION:
--- This test checks the character classification functions of package
--- Ada.Characters.Handling. In the evaluation of each function, loops
--- are constructed to examine the function with as many values of type
--- Character (Ada.Characters.Latin_1 constants) as possible in an
--- amount of code that is about equal to the amount of code required
--- to examine the function with a few representative input values and
--- endpoint values.
--- The usage paradigm being demonstrated by this test is that of the
--- functions being used to assign to boolean variables, as well as
--- serving as boolean conditions.
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 29 Apr 95 SAIC Fixed subtest checking Is_Graphic function.
---
---!
-
-with Ada.Characters.Latin_1;
-with Ada.Characters.Handling;
-with Report;
-
-procedure CXA3001 is
-
-begin
-
- Report.Test ("CXA3001", "Check that the character classification " &
- "functions defined in package " &
- "Ada.Characters.Handling produce " &
- "correct results when provided constant " &
- "arguments from package Ada.Characters.Latin_1");
-
- Test_Block:
- declare
-
- package AC renames Ada.Characters;
- package ACH renames Ada.Characters.Handling;
-
- TC_Boolean : Boolean := False;
-
- begin
-
- -- Over the next six statements/blocks of code, evaluate functions
- -- Is_Control and Is_Graphic with control character and non-control
- -- character values.
-
- for i in Character'Pos(AC.Latin_1.NUL) ..
- Character'Pos(AC.Latin_1.US) loop
- if not ACH.Is_Control(Character'Val(i)) then
- Report.Failed ("Incorrect result from function Is_Control - 1");
- end if;
- if ACH.Is_Graphic(Character'Val(i)) then
- Report.Failed ("Incorrect result from function Is_Graphic - 1");
- end if;
- end loop;
-
-
- for i in Character'Pos(AC.Latin_1.Space) ..
- Character'Pos(AC.Latin_1.Tilde) loop
- if not ACH.Is_Graphic(Character'Val(i)) then
- Report.Failed ("Incorrect result from function Is_Graphic - 2");
- end if;
- if ACH.Is_Control(Character'Val(i)) then
- Report.Failed ("Incorrect result from function Is_Control - 2");
- end if;
- end loop;
-
-
- for i in Character'Pos(AC.Latin_1.Reserved_128) ..
- Character'Pos(AC.Latin_1.APC) loop
- if not ACH.Is_Control(Character'Val(i)) then
- Report.Failed ("Incorrect result from function Is_Control - 3");
- end if;
- TC_Boolean := ACH.Is_Graphic(Character'Val(i));
- if TC_Boolean then
- Report.Failed ("Incorrect result from function Is_Graphic - 3");
- TC_Boolean := False;
- end if;
- end loop;
-
- for i in Character'Pos(AC.Latin_1.No_Break_Space) ..
- Character'Pos(AC.Latin_1.LC_Y_Diaeresis) loop
- TC_Boolean := ACH.Is_Control(Character'Val(i));
- if TC_Boolean then
- Report.Failed ("Incorrect result from function Is_Control - 4");
- TC_Boolean := False;
- end if;
- if not ACH.Is_Graphic(Character'Val(i)) then
- Report.Failed ("Incorrect result from function Is_Graphic - 4");
- end if;
- end loop;
-
- -- Check renamed constants.
-
- if not (ACH.Is_Control(AC.Latin_1.IS4) and
- ACH.Is_Control(AC.Latin_1.IS3) and
- ACH.Is_Control(AC.Latin_1.IS2) and
- ACH.Is_Control(AC.Latin_1.IS1)) or
- (ACH.Is_Control(AC.Latin_1.NBSP) or
- ACH.Is_Control(AC.Latin_1.Paragraph_Sign) or
- ACH.Is_Control(AC.Latin_1.Minus_Sign) or
- ACH.Is_Control(AC.Latin_1.Ring_Above))
- then
- Report.Failed ("Incorrect result from function Is_Control - 5");
- end if;
-
- if (ACH.Is_Graphic(AC.Latin_1.IS4) or
- ACH.Is_Graphic(AC.Latin_1.IS3) or
- ACH.Is_Graphic(AC.Latin_1.IS2) or
- ACH.Is_Graphic(AC.Latin_1.IS1)) or
- not (ACH.Is_Graphic(AC.Latin_1.NBSP) and
- ACH.Is_Graphic(AC.Latin_1.Paragraph_Sign) and
- ACH.Is_Graphic(AC.Latin_1.Minus_Sign) and
- ACH.Is_Graphic(AC.Latin_1.Ring_Above))
- then
- Report.Failed ("Incorrect result from function Is_Graphic - 5");
- end if;
-
-
- -- Evaluate function Is_Letter with letter/non-letter inputs.
-
- for i in Character'Pos('A') .. Character'Pos('Z') loop
- if not ACH.Is_Letter(Character'Val(i)) then
- Report.Failed ("Incorrect Is_Letter result - 1");
- end if;
- end loop;
-
- for i in Character'Pos(AC.Latin_1.LC_A) ..
- Character'Pos(AC.Latin_1.LC_Z) loop
- if not ACH.Is_Letter(Character'Val(i)) then
- Report.Failed ("Incorrect Is_Letter result - 2");
- end if;
- end loop;
-
- for i in Character'Pos(AC.Latin_1.UC_A_Grave) ..
- Character'Pos(AC.Latin_1.UC_O_Diaeresis) loop
- if not ACH.Is_Letter(Character'Val(i)) then
- Report.Failed ("Incorrect Is_Letter result - 3");
- end if;
- end loop;
-
- for i in Character'Pos(AC.Latin_1.UC_O_Oblique_Stroke) ..
- Character'Pos(AC.Latin_1.LC_O_Diaeresis) loop
- if not ACH.Is_Letter(Character'Val(i)) then
- Report.Failed ("Incorrect Is_Letter result - 4");
- end if;
- end loop;
-
- for i in Character'Pos(AC.Latin_1.LC_O_Oblique_Stroke) ..
- Character'Pos(AC.Latin_1.LC_Y_Diaeresis) loop
- if not ACH.Is_Letter(Character'Val(i)) then
- Report.Failed ("Incorrect Is_Letter result - 5");
- end if;
- end loop;
-
- -- Check for rejection of non-letters.
- for i in Character'Pos(AC.Latin_1.NUL) ..
- Character'Pos(AC.Latin_1.Commercial_At) loop
- if ACH.Is_Letter(Character'Val(i)) then
- Report.Failed ("Incorrect Is_Letter result - 6");
- end if;
- end loop;
-
-
- -- Evaluate function Is_Lower with lower case/non-lower case inputs.
-
- for i in Character'Pos(AC.Latin_1.LC_A) ..
- Character'Pos(AC.Latin_1.LC_Z) loop
- if not ACH.Is_Lower(Character'Val(i)) then
- Report.Failed ("Incorrect Is_Lower result - 1");
- end if;
- end loop;
-
- for i in Character'Pos(AC.Latin_1.LC_A_Grave) ..
- Character'Pos(AC.Latin_1.LC_O_Diaeresis) loop
- if not ACH.Is_Lower(Character'Val(i)) then
- Report.Failed ("Incorrect Is_Lower result - 2");
- end if;
- end loop;
-
- for i in Character'Pos(AC.Latin_1.LC_O_Oblique_Stroke) ..
- Character'Pos(AC.Latin_1.LC_Y_Diaeresis) loop
- if not ACH.Is_Lower(Character'Val(i)) then
- Report.Failed ("Incorrect Is_Lower result - 3");
- end if;
- end loop;
-
- if ACH.Is_Lower('A') or
- ACH.Is_Lower(AC.Latin_1.UC_Icelandic_Eth) or
- ACH.Is_Lower(AC.Latin_1.Number_Sign) or
- ACH.Is_Lower(AC.Latin_1.Cedilla) or
- ACH.Is_Lower(AC.Latin_1.SYN) or
- ACH.Is_Lower(AC.Latin_1.ESA)
- then
- Report.Failed ("Incorrect Is_Lower result - 4");
- end if;
-
-
- -- Evaluate function Is_Upper with upper case/non-upper case inputs.
-
- for i in Character'Pos('A') .. Character'Pos('Z') loop
- if not ACH.Is_Upper(Character'Val(i)) then
- Report.Failed ("Incorrect Is_Upper result - 1");
- end if;
- end loop;
-
- for i in Character'Pos(AC.Latin_1.UC_A_Grave) ..
- Character'Pos(AC.Latin_1.UC_O_Diaeresis) loop
- if not ACH.Is_Upper(Character'Val(i)) then
- Report.Failed ("Incorrect Is_Upper result - 2");
- end if;
- end loop;
-
- for i in Character'Pos(AC.Latin_1.UC_O_Oblique_Stroke) ..
- Character'Pos(AC.Latin_1.UC_Icelandic_Thorn) loop
- if not ACH.Is_Upper(Character'Val(i)) then
- Report.Failed ("Incorrect Is_Upper result - 3");
- end if;
- end loop;
-
- if ACH.Is_Upper('8') or
- ACH.Is_Upper(AC.Latin_1.LC_A_Ring ) or
- ACH.Is_Upper(AC.Latin_1.Dollar_Sign) or
- ACH.Is_Upper(AC.Latin_1.Broken_Bar) or
- ACH.Is_Upper(AC.Latin_1.ETB) or
- ACH.Is_Upper(AC.Latin_1.VTS)
- then
- Report.Failed ("Incorrect Is_Upper result - 4");
- end if;
-
-
- for i in Character'Pos('a') .. Character'Pos('z') loop
- if ACH.Is_Upper(Character'Val(i)) then
- Report.Failed ("Incorrect Is_Upper result - 5");
- end if;
- end loop;
-
-
- -- Evaluate function Is_Basic with basic/non-basic inputs.
- -- (Note: Basic letters are those without diacritical marks.)
-
- for i in Character'Pos('A') .. Character'Pos('Z') loop
- if not ACH.Is_Basic(Character'Val(i)) then
- Report.Failed ("Incorrect Is_Basic result - 1");
- end if;
- end loop;
-
- for i in Character'Pos(AC.Latin_1.LC_A) ..
- Character'Pos(AC.Latin_1.LC_Z) loop
- if not ACH.Is_Basic(Character'Val(i)) then
- Report.Failed ("Incorrect Is_Basic result - 2");
- end if;
- end loop;
-
-
- if not (ACH.Is_Basic(AC.Latin_1.UC_AE_Diphthong) and
- ACH.Is_Basic(AC.Latin_1.LC_AE_Diphthong) and
- ACH.Is_Basic(AC.Latin_1.LC_German_Sharp_S) and
- ACH.Is_Basic(AC.Latin_1.LC_Icelandic_Eth) and
- ACH.Is_Basic(AC.Latin_1.LC_Icelandic_Thorn) and
- ACH.Is_Basic(AC.Latin_1.UC_Icelandic_Eth) and
- ACH.Is_Basic(AC.Latin_1.UC_Icelandic_Thorn))
- then
- Report.Failed ("Incorrect Is_Basic result - 3");
- end if;
-
- -- Check for rejection of non-basics.
- if ACH.Is_Basic(AC.Latin_1.UC_A_Tilde) or
- ACH.Is_Basic(AC.Latin_1.LC_A_Grave) or
- ACH.Is_Basic(AC.Latin_1.Ampersand) or
- ACH.Is_Basic(AC.Latin_1.Yen_Sign) or
- ACH.Is_Basic(AC.Latin_1.NAK) or
- ACH.Is_Basic(AC.Latin_1.SS2)
- then
- Report.Failed ("Incorrect Is_Basic result - 4");
- end if;
-
-
-
- for i in Character'Pos(AC.Latin_1.NUL) ..
- Character'Pos(AC.Latin_1.Commercial_At) loop
- if ACH.Is_Basic(Character'Val(i)) then
- Report.Failed ("Incorrect Is_Basic result - 5");
- end if;
- end loop;
-
-
- -- Evaluate functions Is_Digit and Is_Decimal_Digit (a rename of
- -- Is_Digit) with decimal digit/non-digit inputs.
-
-
- if not (ACH.Is_Digit('0') and
- ACH.Is_Decimal_Digit('9')) or
- ACH.Is_Digit ('a') or -- Hex digits.
- ACH.Is_Decimal_Digit ('f') or
- ACH.Is_Decimal_Digit ('A') or
- ACH.Is_Digit ('F')
- then
- Report.Failed ("Incorrect Is_Digit/Is_Decimal_Digit result - 1");
- end if;
-
- if ACH.Is_Digit (AC.Latin_1.Full_Stop) or
- ACH.Is_Decimal_Digit (AC.Latin_1.Dollar_Sign) or
- ACH.Is_Digit (AC.Latin_1.Number_Sign) or
- ACH.Is_Decimal_Digit (AC.Latin_1.Left_Parenthesis) or
- ACH.Is_Digit (AC.Latin_1.Right_Parenthesis)
- then
- Report.Failed ("Incorrect Is_Digit/Is_Decimal_Digit result - 2");
- end if;
-
-
- -- Evaluate functions Is_Hexadecimal_Digit with hexadecimal digit and
- -- non-hexadecimal digit inputs.
-
- for i in Character'Pos('0') .. Character'Pos('9') loop
- if not ACH.Is_Hexadecimal_Digit(Character'Val(i)) then
- Report.Failed ("Incorrect Is_Hexadecimal_Digit result - 1");
- end if;
- end loop;
-
- for i in Character'Pos('A') .. Character'Pos('F') loop
- if not ACH.Is_Hexadecimal_Digit(Character'Val(i)) then
- Report.Failed ("Incorrect Is_Hexadecimal_Digit result - 2");
- end if;
- end loop;
-
- for i in Character'Pos(AC.Latin_1.LC_A) ..
- Character'Pos(AC.Latin_1.LC_F) loop
- if not ACH.Is_Hexadecimal_Digit(Character'Val(i)) then
- Report.Failed ("Incorrect Is_Hexadecimal_Digit result - 3");
- end if;
- end loop;
-
-
- if ACH.Is_Hexadecimal_Digit (AC.Latin_1.Minus_Sign) or
- ACH.Is_Hexadecimal_Digit (AC.Latin_1.Hyphen) or
- ACH.Is_Hexadecimal_Digit (AC.Latin_1.LC_G) or
- ACH.Is_Hexadecimal_Digit (AC.Latin_1.LC_Z) or
- ACH.Is_Hexadecimal_Digit ('G') or
- ACH.Is_Hexadecimal_Digit (AC.Latin_1.Cent_Sign) or
- ACH.Is_Hexadecimal_Digit (AC.Latin_1.Pound_Sign)
- then
- Report.Failed ("Incorrect Is_HexaDecimal_Digit result - 4");
- end if;
-
-
- -- Evaluate functions Is_Alphanumeric and Is_Special with
- -- letters, digits, and non-alphanumeric inputs.
-
- for i in Character'Pos(AC.Latin_1.NUL) ..
- Character'Pos(AC.Latin_1.US) loop
- if ACH.Is_Alphanumeric(Character'Val(i)) then
- Report.Failed ("Incorrect Is_Alphanumeric result - 1");
- end if;
- TC_Boolean := ACH.Is_Special(Character'Val(i));
- if TC_Boolean then
- Report.Failed ("Incorrect Is_Special result - 1");
- TC_Boolean := False;
- end if;
- end loop;
-
- for i in Character'Pos(AC.Latin_1.Reserved_128) ..
- Character'Pos(AC.Latin_1.APC) loop
- TC_Boolean := ACH.Is_Alphanumeric(Character'Val(i));
- if TC_Boolean then
- Report.Failed ("Incorrect Is_Alphanumeric result - 2");
- TC_Boolean := False;
- end if;
- if ACH.Is_Special(Character'Val(i)) then
- Report.Failed ("Incorrect Is_Special result - 2");
- end if;
- end loop;
-
- for i in Character'Pos(AC.Latin_1.Space) ..
- Character'Pos(AC.Latin_1.Solidus) loop
- TC_Boolean := ACH.Is_Alphanumeric(Character'Val(i));
- if TC_Boolean then
- Report.Failed ("Incorrect Is_Alphanumeric result - 3");
- TC_Boolean := False;
- end if;
- if not ACH.Is_Special(Character'Val(i)) then
- Report.Failed ("Incorrect Is_Special result - 3");
- end if;
- end loop;
-
- for i in Character'Pos('A') .. Character'Pos('Z') loop
- if not ACH.Is_Alphanumeric(Character'Val(i)) then
- Report.Failed ("Incorrect Is_Alphanumeric result - 4");
- end if;
- TC_Boolean := ACH.Is_Special(Character'Val(i));
- if TC_Boolean then
- Report.Failed ("Incorrect Is_Special result - 4");
- TC_Boolean := False;
- end if;
- end loop;
-
- for i in Character'Pos('0') .. Character'Pos('9') loop
- if not ACH.Is_Alphanumeric(Character'Val(i)) then
- Report.Failed ("Incorrect Is_Alphanumeric result - 5");
- end if;
- TC_Boolean := ACH.Is_Special(Character'Val(i));
- if TC_Boolean then
- Report.Failed ("Incorrect Is_Special result - 5");
- TC_Boolean := False;
- end if;
- end loop;
-
- for i in Character'Pos(AC.Latin_1.LC_A) ..
- Character'Pos(AC.Latin_1.LC_Z) loop
- if not ACH.Is_Alphanumeric(Character'Val(i)) then
- Report.Failed ("Incorrect Is_Alphanumeric result - 6");
- end if;
- TC_Boolean := ACH.Is_Special(Character'Val(i));
- if TC_Boolean then
- Report.Failed ("Incorrect Is_Special result - 6");
- TC_Boolean := False;
- end if;
- end loop;
-
- for i in Character'Pos(AC.Latin_1.No_Break_Space) ..
- Character'Pos(AC.Latin_1.Inverted_Question) loop
- TC_Boolean := ACH.Is_Alphanumeric(Character'Val(i));
- if TC_Boolean then
- Report.Failed ("Incorrect Is_Alphanumeric result - 7");
- TC_Boolean := False;
- end if;
- if not ACH.Is_Special(Character'Val(i)) then
- Report.Failed ("Incorrect Is_Special result - 7");
- end if;
- end loop;
-
- for i in Character'Pos(AC.Latin_1.UC_A_Grave) ..
- Character'Pos(AC.Latin_1.UC_O_Diaeresis) loop
- if not ACH.Is_Alphanumeric(Character'Val(i)) then
- Report.Failed ("Incorrect Is_Alphanumeric result - 8");
- end if;
- TC_Boolean := ACH.Is_Special(Character'Val(i));
- if TC_Boolean then
- Report.Failed ("Incorrect Is_Special result - 8");
- TC_Boolean := False;
- end if;
- end loop;
-
- for i in Character'Pos(AC.Latin_1.UC_O_Oblique_Stroke) ..
- Character'Pos(AC.Latin_1.LC_O_Diaeresis) loop
- if not ACH.Is_Alphanumeric(Character'Val(i)) then
- Report.Failed ("Incorrect Is_Alphanumeric result - 9");
- end if;
- TC_Boolean := ACH.Is_Special(Character'Val(i));
- if TC_Boolean then
- Report.Failed ("Incorrect Is_Special result - 9");
- TC_Boolean := False;
- end if;
- end loop;
-
- for i in Character'Pos(AC.Latin_1.LC_O_Oblique_Stroke) ..
- Character'Pos(AC.Latin_1.LC_Y_Diaeresis) loop
- if not ACH.Is_Alphanumeric(Character'Val(i)) then
- Report.Failed ("Incorrect Is_Alphanumeric result - 10");
- end if;
- TC_Boolean := ACH.Is_Special(Character'Val(i));
- if TC_Boolean then
- Report.Failed ("Incorrect Is_Special result - 10");
- TC_Boolean := False;
- end if;
- end loop;
-
-
- exception
- when others => Report.Failed ("Exception raised during processing");
- end Test_Block;
-
-
- Report.Result;
-
-end CXA3001;
diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxa3002.a b/gcc/testsuite/ada/acats/tests/cxa/cxa3002.a
deleted file mode 100644
index 12d98fdfe70..00000000000
--- a/gcc/testsuite/ada/acats/tests/cxa/cxa3002.a
+++ /dev/null
@@ -1,318 +0,0 @@
--- CXA3002.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that the conversion functions for Characters and Strings
--- defined in package Ada.Characters.Handling provide correct results
--- when given character/string input parameters.
---
--- TEST DESCRIPTION:
--- This test checks the output of the To_Lower, To_Upper, and
--- To_Basic functions for both Characters and Strings. Each function
--- is called with input parameters that are within the appropriate
--- range of values, and also with values outside the specified
--- range (i.e., lower case 'a' to To_Lower). The functions are also
--- used in combination with one another, with the result of one function
--- providing the actual input parameter value to another.
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 22 Dec 94 SAIC Corrected evaluations of Functions In Combination.
---
---!
-
-with Ada.Characters.Latin_1;
-with Ada.Characters.Handling;
-with Report;
-
-procedure CXA3002 is
-
- package AC renames Ada.Characters;
- package ACH renames Ada.Characters.Handling;
-
-begin
-
- Report.Test ("CXA3002", "Check that the conversion functions for " &
- "Characters and Strings defined in package " &
- "Ada.Characters.Handling provide correct " &
- "results when given character/string input " &
- "parameters");
-
-
- Character_Block:
- declare
- Offset : constant Integer := Character'Pos('a') - Character'Pos('A');
- begin
-
- -- Function To_Lower for Characters
-
- if ACH.To_Lower('A') /= 'a' or ACH.To_Lower('Z') /= 'z' then
- Report.Failed ("Incorrect operation of function To_Lower - 1");
- end if;
-
-
- for i in Character'Pos('A') .. Character'Pos('Z') loop
- if ACH.To_Lower(Character'Val(i)) /= Character'Val(i + Offset) then
- Report.Failed ("Incorrect operation of function To_Lower - 2");
- end if;
- end loop;
-
-
- if (ACH.To_Lower(AC.Latin_1.UC_A_Grave) /=
- AC.Latin_1.LC_A_Grave) or
- (ACH.To_Lower(AC.Latin_1.UC_Icelandic_Thorn) /=
- AC.Latin_1.LC_Icelandic_Thorn)
- then
- Report.Failed ("Incorrect operation of function To_Lower - 3");
- end if;
-
-
- if ACH.To_Lower('c') /= 'c' or
- ACH.To_Lower('w') /= 'w' or
- ACH.To_Lower(AC.Latin_1.CR) /= AC.Latin_1.CR or
- ACH.To_Lower(AC.Latin_1.LF) /= AC.Latin_1.LF or
- ACH.To_Lower(AC.Latin_1.Comma) /= AC.Latin_1.Comma or
- ACH.To_Lower(AC.Latin_1.Question) /= AC.Latin_1.Question or
- ACH.To_Lower('0') /= '0' or
- ACH.To_Lower('9') /= '9'
- then
- Report.Failed ("Incorrect operation of function To_Lower - 4");
- end if;
-
-
- --- Function To_Upper for Characters
-
-
- if not (ACH.To_Upper('b') = 'B') and (ACH.To_Upper('y') = 'Y') then
- Report.Failed ("Incorrect operation of function To_Upper - 1");
- end if;
-
-
- for i in Character'Pos(AC.Latin_1.LC_A) ..
- Character'Pos(AC.Latin_1.LC_Z) loop
- if ACH.To_Upper(Character'Val(i)) /= Character'Val(i - Offset) then
- Report.Failed ("Incorrect operation of function To_Upper - 2");
- end if;
- end loop;
-
-
- if (ACH.To_Upper(AC.Latin_1.LC_U_Diaeresis) /=
- AC.Latin_1.UC_U_Diaeresis) or
- (ACH.To_Upper(AC.Latin_1.LC_A_Ring) /=
- AC.Latin_1.UC_A_Ring)
- then
- Report.Failed ("Incorrect operation of function To_Upper - 3");
- end if;
-
-
- if not (ACH.To_Upper('F') = 'F' and
- ACH.To_Upper('U') = 'U' and
- ACH.To_Upper(AC.Latin_1.LC_German_Sharp_S) =
- AC.Latin_1.LC_German_Sharp_S and
- ACH.To_Upper(AC.Latin_1.LC_Y_Diaeresis) =
- AC.Latin_1.LC_Y_Diaeresis)
- then
- Report.Failed ("Incorrect operation of function To_Upper - 4");
- end if;
-
-
- --- Function To_Basic for Characters
-
-
- if ACH.To_Basic(AC.Latin_1.LC_A_Circumflex) /=
- ACH.To_Basic(AC.Latin_1.LC_A_Tilde) or
- ACH.To_Basic(AC.Latin_1.LC_E_Grave) /=
- ACH.To_Basic(AC.Latin_1.LC_E_Acute) or
- ACH.To_Basic(AC.Latin_1.LC_I_Circumflex) /=
- ACH.To_Basic(AC.Latin_1.LC_I_Diaeresis) or
- ACH.To_Basic(AC.Latin_1.UC_O_Tilde) /=
- ACH.To_Basic(AC.Latin_1.UC_O_Acute) or
- ACH.To_Basic(AC.Latin_1.UC_U_Grave) /=
- ACH.To_Basic(AC.Latin_1.UC_U_Acute) or
- ACH.To_Basic(AC.Latin_1.LC_Y_Acute) /=
- ACH.To_Basic(AC.Latin_1.LC_Y_Diaeresis)
- then
- Report.Failed ("Incorrect operation of function To_Basic - 1");
- end if;
-
-
- if ACH.To_Basic('Y') /= 'Y' or
- ACH.To_Basic(AC.Latin_1.LC_E_Acute) /= 'e' or
- ACH.To_Basic('6') /= '6' or
- ACH.To_Basic(AC.Latin_1.LC_R) /= 'r'
- then
- Report.Failed ("Incorrect operation of function To_Basic - 2");
- end if;
-
-
- -- Using Functions (for Characters) in Combination
-
-
- if (ACH.To_Upper(ACH.To_Lower('A')) /= 'A' ) or
- (ACH.To_Upper(ACH.To_Lower(AC.Latin_1.UC_A_Acute)) /=
- AC.Latin_1.UC_A_Acute )
- then
- Report.Failed("Incorrect operation of functions in combination - 1");
- end if;
-
-
- if ACH.To_Basic(ACH.To_Lower(ACH.To_Upper(AC.Latin_1.LC_U_Grave))) /=
- 'u'
- then
- Report.Failed("Incorrect operation of functions in combination - 2");
- end if;
-
-
- if ACH.To_Lower (ACH.To_Basic
- (ACH.To_Upper(AC.Latin_1.LC_O_Diaeresis))) /= 'o'
- then
- Report.Failed("Incorrect operation of functions in combination - 3");
- end if;
-
-
- exception
- when others => Report.Failed ("Exception raised in Character_Block");
- end Character_Block;
-
-
- String_Block:
- declare
-
- LC_String : constant String := "az" &
- AC.Latin_1.LC_A_Grave &
- AC.Latin_1.LC_C_Cedilla;
-
- UC_String : constant String := "AZ" &
- AC.Latin_1.UC_A_Grave &
- AC.Latin_1.UC_C_Cedilla;
-
- LC_Basic_String : constant String := "aei" & 'o' & 'u';
-
- LC_NonBasic_String : constant String := AC.Latin_1.LC_A_Diaeresis &
- AC.Latin_1.LC_E_Circumflex &
- AC.Latin_1.LC_I_Acute &
- AC.Latin_1.LC_O_Tilde &
- AC.Latin_1.LC_U_Grave;
-
- UC_Basic_String : constant String := "AEIOU";
-
- UC_NonBasic_String : constant String := AC.Latin_1.UC_A_Tilde &
- AC.Latin_1.UC_E_Acute &
- AC.Latin_1.UC_I_Grave &
- AC.Latin_1.UC_O_Diaeresis &
- AC.Latin_1.UC_U_Circumflex;
-
- LC_Special_String : constant String := "ab" &
- AC.Latin_1.LC_German_Sharp_S &
- AC.Latin_1.LC_Y_Diaeresis;
-
- UC_Special_String : constant String := "AB" &
- AC.Latin_1.LC_German_Sharp_S &
- AC.Latin_1.LC_Y_Diaeresis;
-
- begin
-
- -- Function To_Lower for Strings
-
-
- if ACH.To_Lower (UC_String) /= LC_String or
- ACH.To_Lower (LC_String) /= LC_String
- then
- Report.Failed ("Incorrect result from To_Lower for strings - 1");
- end if;
-
-
- if ACH.To_Lower (UC_Basic_String) /= LC_Basic_String then
- Report.Failed ("Incorrect result from To_Lower for strings - 2");
- end if;
-
-
- -- Function To_Upper for Strings
-
-
- if not (ACH.To_Upper (LC_String) = UC_String) then
- Report.Failed ("Incorrect result from To_Upper for strings - 1");
- end if;
-
-
- if ACH.To_Upper (LC_Basic_String) /= UC_Basic_String or
- ACH.To_Upper (UC_String) /= UC_String
- then
- Report.Failed ("Incorrect result from To_Upper for strings - 2");
- end if;
-
-
- if ACH.To_Upper (LC_Special_String) /= UC_Special_String then
- Report.Failed ("Incorrect result from To_Upper for strings - 3");
- end if;
-
-
-
- -- Function To_Basic for Strings
-
-
- if (ACH.To_Basic (LC_String) /= "azac") or
- (ACH.To_Basic (UC_String) /= "AZAC")
- then
- Report.Failed ("Incorrect result from To_Basic for Strings - 1");
- end if;
-
-
- if ACH.To_Basic (LC_NonBasic_String) /= LC_Basic_String then
- Report.Failed ("Incorrect result from To_Basic for Strings - 2");
- end if;
-
-
- if ACH.To_Basic (UC_NonBasic_String) /= UC_Basic_String then
- Report.Failed ("Incorrect result from To_Basic for Strings - 3");
- end if;
-
-
- -- Using Functions (for Strings) in Combination
-
-
- if ACH.To_Upper(ACH.To_Lower(UC_Basic_String)) /= UC_Basic_String or
- ACH.To_Lower(ACH.To_Upper(LC_Basic_String)) /= LC_Basic_String
- then
- Report.Failed ("Incorrect operation of functions in combination - 4");
- end if;
-
-
- if (ACH.To_Basic(ACH.To_Lower(UC_NonBasic_String)) /= LC_Basic_String) or
- (ACH.To_Basic(ACH.To_Upper(LC_NonBasic_String)) /= UC_Basic_String)
- then
- Report.Failed ("Incorrect operation of functions in combination - 5");
- end if;
-
-
- exception
- when others => Report.Failed ("Exception raised in String_Block");
- end String_Block;
-
-
- Report.Result;
-
-end CXA3002;
diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxa3003.a b/gcc/testsuite/ada/acats/tests/cxa/cxa3003.a
deleted file mode 100644
index f469ef8b539..00000000000
--- a/gcc/testsuite/ada/acats/tests/cxa/cxa3003.a
+++ /dev/null
@@ -1,243 +0,0 @@
--- CXA3003.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that the functions defined in package Ada.Characters.Handling
--- for use in classifying and converting characters between the ISO 646
--- and type Character sets produce the correct results with both
--- Character and String input values.
---
--- TEST DESCRIPTION:
--- This test is designed to exercise the classification and conversion
--- functions (between Character and ISO_646 types) found in package
--- Ada.Characters.Handling. Two subprograms are defined, a procedure for
--- characters, a function for strings, that will utilize these functions
--- to validate and change characters in variables. In the procedure, if
--- a character argument is found to be outside the subtype ISO_646, this
--- character is evaluated to determine whether it is also a letter.
--- If it is a letter, the character is converted to a basic character and
--- returned. If it is not a letter, the character is exchanged with an
--- asterisk. In the case of the function subprogram designed for strings,
--- if a character component of a string argument is outside the subtype
--- ISO_646, that character is substituted with an asterisk.
---
--- Arguments for the defined subprograms consist of ISO_646 characters,
--- non-ISO_646 characters, strings with only ISO_646 characters, and
--- strings with non-ISO_646 characters. The character and string values
--- are then validated to determine that the expected results were
--- obtained.
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 29 Apr 95 SAIC Modified identifier string lengths.
--- 31 Oct 95 SAIC Update and repair for ACVC 2.0.1.
---
---!
-
-with Ada.Characters.Latin_1;
-with Ada.Characters.Handling;
-with Report;
-
-procedure CXA3003 is
-
-begin
-
- Report.Test ("CXA3003", "Check that the functions defined in package " &
- "Ada.Characters.Handling for use in " &
- "classifying and converting characters " &
- "between the ISO 646 and type Character sets " &
- "produce the correct results with both " &
- "Character and String input values" );
-
- Test_Block:
- declare
-
- -- ISO_646 Characters
-
- Char_1,
- TC_Char_1 : Character := Ada.Characters.Latin_1.NUL; -- Control Char
- Char_2,
- TC_Char_2 : Character := Ada.Characters.Latin_1.Colon; -- Graphic Char
- Char_3,
- TC_Char_3 : Character := '4';
- Char_4,
- TC_Char_4 : Character := 'Z';
- Char_5,
- TC_Char_5 : Character := Ada.Characters.Latin_1.LC_W; -- w
-
- New_ISO_646_Char : Character := '*';
-
-
- -- Non-ISO_646 Characters
-
- Char_Array : array (6..10) of Character :=
- (Ada.Characters.Latin_1.SSA,
- Ada.Characters.Latin_1.Cent_Sign,
- Ada.Characters.Latin_1.Cedilla,
- Ada.Characters.Latin_1.UC_A_Ring,
- Ada.Characters.Latin_1.LC_A_Ring);
-
- TC_Char : constant Character := '*';
-
- -- ISO_646 Strings
-
- Str_1,
- TC_Str_1 : String (1..5) := "ABCDE";
-
- Str_2,
- TC_Str_2 : String (1..5) := "#$%^&";
-
-
- -- Non-ISO_646 Strings
-
- Str_3 : String (1..8) := "$123.45" &
- Ada.Characters.Latin_1.Cent_Sign;
- TC_Str_3 : String (1..8) := "$123.45*";
-
- Str_4 : String (1..7) := "abc" &
- Ada.Characters.Latin_1.Cedilla &
- "efg";
- TC_Str_4 : String (1..7) := "abc*efg";
-
- Str_5 : String (1..3) := Ada.Characters.Latin_1.LC_E_Grave &
- Ada.Characters.Latin_1.LC_T &
- Ada.Characters.Latin_1.LC_E_Acute;
- TC_Str_5 : String (1..3) := "*t*";
-
- ---
-
- procedure Validate_Character (Char : in out Character) is
- -- If parameter Char is an ISO_646 character, Char will be returned,
- -- otherwise the following constant will be returned.
- Star : constant Ada.Characters.Handling.ISO_646 :=
- Ada.Characters.Latin_1.Asterisk;
- begin
- if Ada.Characters.Handling.Is_ISO_646(Char) then
- -- Check that the Is_ISO_646 function provide a correct result.
- if Character'Pos(Char) > 127 then
- Report.Failed("Is_ISO_646 returns a false positive result");
- end if;
- else
- if Character'Pos(Char) < 128 then
- Report.Failed("Is_ISO_646 returns a false negative result");
- end if;
- end if;
- -- Cross-check Is_ISO_646 with To_ISO_646. '*' will be returned
- -- if Char is not in the ISO_646 set.
- Char := Ada.Characters.Handling.To_ISO_646(Char, Star);
- exception
- when others => Report.Failed ("Exception in Validate_Character");
- end Validate_Character;
-
- ---
-
- function Validate_String (Str : String) return String is
- New_ISO_646_Char : constant Ada.Characters.Handling.ISO_646 :=
- Ada.Characters.Latin_1.Asterisk;
- begin
- -- Checking that the string contains non-ISO_646 characters at this
- -- point is not strictly necessary, since the function To_ISO_646
- -- will perform that check as part of its processing, and would
- -- return the original string if no modification were necessary.
- -- However, this format allows for the testing of both functions.
-
- if not Ada.Characters.Handling.Is_ISO_646(Str) then
- return Ada.Characters.Handling.To_ISO_646
- (Item => Str, Substitute => New_ISO_646_Char);
- else
- return Str;
- end if;
- exception
- when others => Report.Failed ("Exception in Validate_String");
- return Str;
- end Validate_String;
-
-
- begin
-
- -- Check each character in turn, and if the character does not belong
- -- to the ISO_646 subset of type Character, replace it with an
- -- asterisk. If the character is a member of the subset, the character
- -- should be returned unchanged.
-
- Validate_Character (Char_1);
- Validate_Character (Char_2);
- Validate_Character (Char_3);
- Validate_Character (Char_4);
- Validate_Character (Char_5);
-
- if Char_1 /= TC_Char_1 or Char_2 /= TC_Char_2 or
- Char_3 /= TC_Char_3 or Char_4 /= TC_Char_4 or
- Char_5 /= TC_Char_5
- then
- Report.Failed ("Incorrect ISO_646 character substitution");
- end if;
-
- -- Non-ISO_646 characters
-
- for i in 6..10 loop
- Validate_Character (Char_Array(i));
- end loop;
-
- for i in 6..10 loop
- if Char_Array(i) /= TC_Char then
- Report.Failed ("Character position " & Integer'Image(i) &
- " not replaced correctly");
- end if;
- end loop;
-
-
-
- -- Check each string, and if the string contains characters that do not
- -- belong to the ISO_646 subset of type Character, replace that character
- -- in the string with an asterisk. If the string is comprised of only
- -- ISO_646 characters, the string should be returned unchanged.
-
-
- Str_1 := Validate_String (Str_1);
- Str_2 := Validate_String (Str_2);
- Str_3 := Validate_String (Str_3);
- Str_4 := Validate_String (Str_4);
- Str_5 := Validate_String (Str_5);
-
-
- if Str_1 /= TC_Str_1 or
- Str_2 /= TC_Str_2 or
- Str_3 /= TC_Str_3 or
- Str_4 /= TC_Str_4 or
- Str_5 /= TC_Str_5
- then
- Report.Failed ("Incorrect ISO_646 character substitution in string");
- end if;
-
-
- exception
- when others => Report.Failed ("Exception raised in Test_Block");
- end Test_Block;
-
- Report.Result;
-
-end CXA3003;
diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxa3004.a b/gcc/testsuite/ada/acats/tests/cxa/cxa3004.a
deleted file mode 100644
index ed2023e37e5..00000000000
--- a/gcc/testsuite/ada/acats/tests/cxa/cxa3004.a
+++ /dev/null
@@ -1,235 +0,0 @@
--- CXA3004.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that the functions defined in package Ada.Characters.Handling
--- for classification of and conversion between Wide_Character and
--- Character values produce correct results when given the appropriate
--- Character and String inputs.
---
--- TEST DESCRIPTION:
--- This test demonstrates the functions defined in package
--- Ada.Characters.Handling which provide for the classification of and
--- conversion between Wide_Characters and Characters, in character
--- variables and strings.
--- Each of the functions is provided with input values that are of the
--- appropriate range. The results of the function processing are
--- subsequently evaluated.
---
--- APPLICABILITY CRITERIA:
--- Applicable to all implementations using the Latin_1 set as the
--- definition of Character.
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 27 Dec 94 SAIC Corrected variable names.
---
---!
-
-with Report;
-with Ada.Characters.Handling;
-
-procedure CXA3004 is
-begin
-
- Report.Test ("CXA3004", "Check that the functions defined in package " &
- "Ada.Characters.Handling for classification " &
- "of and conversion between Wide_Character and " &
- "Character values produce correct results " &
- "when given the appropriate Character " &
- "and String inputs");
-
- Test_Block:
- declare
-
- package ACH renames Ada.Characters.Handling;
-
- Char_End : Integer := 255;
- WC_Start : Integer := 256;
- Sub_Char : Character := '*';
-
- Blank : Character := ' ';
- First_Char : Character := Character'First;
- Last_Char : Character := Character'Last;
- F_Char : Character := 'F';
-
-
- First_Wide_Char : Wide_Character := Wide_Character'First;
- Last_Non_Wide_Char : Wide_Character := Wide_Character'Val(Char_End);
- First_Unique_Wide_Char : Wide_Character := Wide_Character'Val(WC_Start);
- Last_Wide_Char : Wide_Character := Wide_Character'Last;
-
- A_String : String (1..3) := First_Char & 'X' & Last_Char;
- A_Wide_String : Wide_String (1..3) := First_Wide_Char &
- ACH.To_Wide_Character('X') &
- ACH.To_Wide_Character(Last_Char);
-
- Unique_Wide_String : Wide_String (1..2) := First_Unique_Wide_Char &
- Last_Wide_Char;
-
- Mixed_Wide_String : Wide_String (1..6) := ACH.To_Wide_Character('A') &
- First_Wide_Char &
- Last_Non_Wide_Char &
- First_Unique_Wide_Char &
- Last_Wide_Char &
- ACH.To_Wide_Character('Z');
-
-
- Basic_Char : Character := 'A';
- Basic_Wide_Char : Wide_Character := 'A';
- Basic_String : String (1..6) := "ABCXYZ";
- Basic_Wide_String : Wide_String (1..6) := "ABCXYZ";
-
- begin
-
-
- -- Function Is_Character
-
-
- if not ACH.Is_Character(First_Wide_Char) then
- Report.Failed ("Incorrect result from Is_Character - 1");
- end if;
-
-
- if ACH.Is_Character(First_Unique_Wide_Char) or
- ACH.Is_Character(Last_Wide_Char)
- then
- Report.Failed ("Incorrect result from Is_Character - 2");
- end if;
-
-
- -- Function Is_String
-
-
- if not ACH.Is_String(A_Wide_String) then
- Report.Failed ("Incorrect result from Is_String - 1");
- end if;
-
-
- if ACH.Is_String(Unique_Wide_String) or
- ACH.Is_String(Mixed_Wide_String)
- then
- Report.Failed ("Incorrect result from Is_String - 2");
- end if;
-
-
- -- Function To_Character
-
-
- -- Use default substitution character in call of To_Character.
-
- if ACH.To_Character(First_Wide_Char) /= First_Char or
- ACH.To_Character(Last_Non_Wide_Char) /= Last_Char
- then
- Report.Failed ("Incorrect result from To_Character - 1");
- end if;
-
-
- -- Provide a substitution character for use with To_Character.
-
- if ACH.To_Character(First_Unique_Wide_Char, Blank) /= Blank or
- ACH.To_Character(First_Unique_Wide_Char, Sub_Char) /= Sub_Char or
- ACH.To_Character(Last_Wide_Char) /= ' ' -- default
- then
- Report.Failed ("Incorrect result from To_Character - 2");
- end if;
-
-
- -- Function To_String
-
-
- if ACH.To_String(A_Wide_String) /= A_String then
- Report.Failed ("Incorrect result from To_String - 1");
- end if;
-
-
- if ACH.To_String(Unique_Wide_String, Sub_Char) /= "**" then
- Report.Failed ("Incorrect result from To_String - 2");
- end if;
-
-
-
- if ACH.To_String(Mixed_Wide_String, Sub_Char) /=
- ('A' & First_Char & Last_Char & "**" & 'Z') or
- ACH.To_String(Mixed_Wide_String, Sub_Char) /=
- (ACH.To_Character(Mixed_Wide_String(1), Sub_Char) &
- ACH.To_Character(Mixed_Wide_String(2), Sub_Char) &
- ACH.To_Character(Mixed_Wide_String(3), Sub_Char) &
- ACH.To_Character(Mixed_Wide_String(4), Sub_Char) &
- ACH.To_Character(Mixed_Wide_String(5), Sub_Char) &
- ACH.To_Character(Mixed_Wide_String(6), Sub_Char))
- then
- Report.Failed ("Incorrect result from To_String - 3");
- end if;
-
-
- -- Function To_Wide_Character
-
-
- if ACH.To_Wide_Character(Basic_Char) /= Basic_Wide_Char then
- Report.Failed ("Incorrect result from To_Wide_Character");
- end if;
-
-
- -- Function To_Wide_String
-
-
- if not (ACH.To_Wide_String(Basic_String) = Basic_Wide_String) then
- Report.Failed ("Incorrect result from To_Wide_String");
- end if;
-
-
- -- Functions Used In Combination
-
- if not ACH.Is_Character (ACH.To_Wide_Character (
- ACH.To_Character(First_Wide_Char)))
- then
- Report.Failed ("Incorrect result from functions in combination - 1");
- end if;
-
-
- if not ACH.Is_String(ACH.To_Wide_String(ACH.To_String(A_Wide_String)))
- then
- Report.Failed ("Incorrect result from functions in combination - 2");
- end if;
-
-
- if ACH.To_String(ACH.To_Wide_Character('A') &
- ACH.To_Wide_Character(F_Char) &
- ACH.To_Wide_Character('Z')) /= "AFZ"
- then
- Report.Failed ("Incorrect result from functions in combination - 3");
- end if;
-
-
- exception
- when others => Report.Failed ("Exception raised in Test_Block");
- end Test_Block;
-
-
- Report.Result;
-
-end CXA3004;
diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxa4001.a b/gcc/testsuite/ada/acats/tests/cxa/cxa4001.a
deleted file mode 100644
index d850acd4a72..00000000000
--- a/gcc/testsuite/ada/acats/tests/cxa/cxa4001.a
+++ /dev/null
@@ -1,218 +0,0 @@
--- CXA4001.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that the types, operations, and other entities defined within
--- the package Ada.Strings.Maps are available and/or produce correct
--- results.
---
--- TEST DESCRIPTION:
--- This test demonstrates the availability and function of the types and
--- operations defined in package Ada.Strings.Maps. It demonstrates the
--- use of these types and functions as they would be used in common
--- programming practice.
--- Character set creation, assignment, and comparison are evaluated
--- in this test. Each of the functions provided in package
--- Ada.Strings.Maps is utilized in creating or manipulating set objects,
--- and the function results are evaluated for correctness.
--- Character sequences are examined using the functions provided for
--- manipulating objects of this type. Likewise, character maps are
--- created, and their contents evaluated. Exception raising conditions
--- from the function To_Mapping are also created.
--- Note: Throughout this test, the set logical operators are printed in
--- capital letters to enhance their visibility.
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
---
---!
-
-with Ada.Strings.Maps;
-with Report;
-
-procedure CXA4001 is
-
- use Ada.Strings;
- use type Maps.Character_Set;
-
-begin
-
- Report.Test ("CXA4001", "Check that the types, operations, and other " &
- "entities defined within the package " &
- "Ada.Strings.Maps are available and/or produce " &
- "correct results");
-
- Test_Block:
- declare
-
- MidPoint_Letter : constant := 13;
- Last_Letter : constant := 26;
-
- Vowels : constant Maps.Character_Sequence := "aeiou";
- Quasi_Vowel : constant Character := 'y';
-
- Alphabet : Maps.Character_Sequence (1..Last_Letter);
- Half_Alphabet : Maps.Character_Sequence (1..MidPoint_Letter);
- Inverse_Alphabet : Maps.Character_Sequence (1..Last_Letter);
-
- Alphabet_Set,
- Consonant_Set,
- Vowel_Set,
- Full_Vowel_Set,
- First_Half_Set,
- Second_Half_Set : Maps.Character_Set;
-
- begin
-
- -- Load the alphabet string for use in creating sets.
-
-
- for i in 0..12 loop
- Half_Alphabet(i+1) := Character'Val(Character'Pos('a') + i);
- end loop;
-
- for i in 0..25 loop
- Alphabet(i+1) := Character'Val(Character'Pos('a') + i);
- end loop;
-
-
- -- Initialize a series of Character_Set objects.
-
- Alphabet_Set := Maps.To_Set(Alphabet);
- Vowel_Set := Maps.To_Set(Vowels);
- Full_Vowel_Set := Vowel_Set OR Maps.To_Set(Quasi_Vowel);
- Consonant_Set := Vowel_Set XOR Alphabet_Set;
-
- First_Half_Set := Maps.To_Set(Half_Alphabet);
- Second_Half_Set := Alphabet_Set XOR First_Half_Set;
-
-
- -- Evaluation of Set objects, operators, and functions.
-
- if Alphabet_Set /= (Vowel_Set OR Consonant_Set) then
- Report.Failed("Incorrect set combinations using OR operator");
- end if;
-
-
- for i in 1..5 loop
- if not Maps.Is_In(Vowels(i), Vowel_Set) or
- not Maps.Is_In(Vowels(i), Alphabet_Set) or
- Maps.Is_In(Vowels(i), Consonant_Set)
- then
- Report.Failed("Incorrect function Is_In use with set " &
- "combinations - " & Integer'Image(i));
- end if;
- end loop;
-
-
- if Maps.Is_Subset(Vowel_Set, First_Half_Set) or
- Maps."<="(Vowel_Set, Second_Half_Set) or
- not Maps.Is_Subset(Vowel_Set, Alphabet_Set)
- then
- Report.Failed("Incorrect set evaluation using Is_Subset function");
- end if;
-
-
- if not (Full_Vowel_Set = Maps.To_Set("aeiouy")) then
- Report.Failed("Incorrect result for ""="" set operator");
- end if;
-
-
- if not ((Vowel_Set AND First_Half_Set) OR
- (Full_Vowel_Set AND Second_Half_Set)) = Full_Vowel_Set then
- Report.Failed
- ("Incorrect result for AND, OR, or ""="" set operators");
- end if;
-
-
- if (Alphabet_Set AND Maps.Null_Set) /= Maps.Null_Set or
- (Alphabet_Set OR Maps.Null_Set) /= Alphabet_Set
- then
- Report.Failed("Incorrect result for AND or OR set operators");
- end if;
-
-
- Vowel_Set := Full_Vowel_Set;
- Vowel_Set := Vowel_Set AND (NOT Maps.To_Set(Quasi_Vowel));
-
- if not (Vowels = Maps.To_Sequence(Vowel_Set)) then
- Report.Failed("Incorrect Set to Sequence translation");
- end if;
-
-
- for i in 1..26 loop
- Inverse_Alphabet(i) := Alphabet(27-i);
- end loop;
-
- declare
- Inverse_Map : Maps.Character_Mapping :=
- Maps.To_Mapping(Alphabet, Inverse_Alphabet);
- begin
- if Maps.Value(Maps.Identity, 'b') /= Maps.Value(Inverse_Map,'y')
- then
- Report.Failed("Incorrect Inverse mapping");
- end if;
- end;
-
-
- -- Check that Translation_Error is raised when a character is
- -- repeated in the parameter "From" string.
- declare
- Bad_Map : Maps.Character_Mapping;
- begin
- Bad_Map := Maps.To_Mapping(From => "aa", To => "yz");
- Report.Failed("Exception not raised with repeated character");
- 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
deleted file mode 100644
index 583621ab4d9..00000000000
--- a/gcc/testsuite/ada/acats/tests/cxa/cxa4002.a
+++ /dev/null
@@ -1,182 +0,0 @@
--- CXA4002.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that the subprograms defined in package Ada.Strings.Fixed are
--- available, and that they produce correct results. Specifically,
--- check the subprograms Index, "*" (string constructor function),
--- Count, Trim, and Replace_Slice.
---
--- TEST DESCRIPTION:
--- This test demonstrates how certain Fixed string functions are used
--- to eliminate specific substrings from portions of text. A procedure
--- is defined that will take as parameters a source string along with
--- a substring that is to be completely removed from the source string.
--- The source string is parsed using the Index function, and any substring
--- slices are replaced in the source string by a series of X's (based on
--- the length of the substring.)
--- Three lines of text are provided to this procedure, and the resulting
--- substitutions are compared with expected results to validate the
--- string processing.
--- A global accumulator is updated with the number of occurrences of the
--- substring in the source string.
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
---
---!
-
-with Ada.Strings;
-with Ada.Strings.Fixed;
-with Ada.Strings.Maps;
-with Report;
-
-procedure CXA4002 is
-
-begin
-
- Report.Test ("CXA4002", "Check that the subprograms defined in package " &
- "Ada.Strings.Fixed are available, and that " &
- "they produce correct results");
-
- Test_Block:
- declare
-
- TC_Total : Natural := 0;
- Number_Of_Lines : constant := 3;
-
- type Restricted_Words_Array_Type is array (1..10) of String (1..10);
-
- Restricted_Words : Restricted_Words_Array_Type :=
- (" platoon", " marines ", " Marines ",
- "north ", "south ", " east",
- " beach ", " airport", "airfield ",
- " road ");
-
- subtype Line_Of_Text_Type is String(1..25);
- type Page_Of_Text_Type is array (1..Number_Of_Lines)
- of Line_Of_Text_Type;
-
- Text_Page : Page_Of_Text_Type := ("The platoon of Marines ",
- "moved south on the south ",
- "road to the airfield. ");
-
- TC_Revised_Line_1 : constant String := "The XXXXXXX of XXXXXXX ";
- TC_Revised_Line_2 : constant String := "moved XXXXX on the XXXXX ";
- TC_Revised_Line_3 : constant String := "XXXX to the XXXXXXXX. ";
-
- ---
-
- procedure Censor (Source_String : in out String;
- Pattern_String : in String) is
-
- -- Create a replacement string that is the same length as the
- -- pattern string being removed.
- Replacement : constant String := -- "*"
- Ada.Strings.Fixed."*"(Pattern_String'Length, 'X');
-
- Going : Ada.Strings.Direction := Ada.Strings.Forward;
- Map : constant Ada.Strings.Maps.Character_Mapping :=
- Ada.Strings.Maps.Identity;
- Start_Pos,
- Index : Natural := Source_String'First;
-
-
- begin -- Censor
-
- -- Accumulate count of total replacement operations.
-
- TC_Total := TC_Total + -- Count
- Ada.Strings.Fixed.Count (Source => Source_String,
- Pattern => Pattern_String,
- Mapping => Map);
- loop
-
- Index := Ada.Strings.Fixed.Index -- Index
- (Source_String(Start_Pos..Source_String'Last),
- Pattern_String,
- Going,
- Map);
-
- exit when Index = 0; -- No matches, exit loop.
-
- -- if a match was found, modify the substring.
- Ada.Strings.Fixed.Replace_Slice -- Replace_Slice
- (Source_String,
- Index,
- Index + Pattern_String'Length - 1,
- Replacement);
- Start_Pos := Index + Pattern_String'Length;
-
- end loop;
-
- end Censor;
-
-
- begin
-
- -- Invoke Censor subprogram to cleanse text.
- -- Loop through each line of text, and check for the presence of each
- -- restricted word.
- -- Use the Trim function to eliminate leading or trailing blanks from
- -- the restricted word parameters.
-
- for Line in 1..Number_Of_Lines loop
- for Word in Restricted_Words'Range loop
- Censor (Text_Page(Line),
- Ada.Strings.Fixed.Trim(Restricted_Words(Word), -- Trim
- Ada.Strings.Both));
- end loop;
- end loop;
-
-
- -- Validate results.
-
- if TC_Total /= 6 then
- Report.Failed ("Incorrect number of substitutions performed");
- end if;
-
- if Text_Page(1) /= TC_Revised_Line_1 then
- Report.Failed ("Incorrect substitutions on Line 1");
- end if;
-
- if Text_Page(2) /= TC_Revised_Line_2 then
- Report.Failed ("Incorrect substitutions on Line 2");
- end if;
-
- if Text_Page(3) /= TC_Revised_Line_3 then
- Report.Failed ("Incorrect substitutions on Line 3");
- end if;
-
-
- exception
- when others => Report.Failed ("Exception raised in Test_Block");
- end Test_Block;
-
-
- Report.Result;
-
-end CXA4002;
diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxa4003.a b/gcc/testsuite/ada/acats/tests/cxa/cxa4003.a
deleted file mode 100644
index cd57a929616..00000000000
--- a/gcc/testsuite/ada/acats/tests/cxa/cxa4003.a
+++ /dev/null
@@ -1,326 +0,0 @@
--- CXA4003.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that the subprograms defined in package Ada.Strings.Fixed are
--- available, and that they produce correct results. Specifically,
--- check the subprograms Index, Index_Non_Blank, Head, Tail, Translate,
--- Find_Token, Move, Overwrite, and Replace_Slice.
---
--- TEST DESCRIPTION:
--- This test demonstrates how certain fixed string operations could be
--- used in string information processing. A procedure is defined that
--- will extract portions of a 50 character string that correspond to
--- certain data items (i.e., name, address, state, zip code). These
--- parsed items will then be added to the appropriate fields of data
--- base elements. These data base elements are then compared for
--- accuracy against a similar set of predefined data base elements.
---
--- A variety of fixed string processing subprograms are used in this
--- test. Each parsing operation uses a different combination
--- of the available subprograms to accomplish the same goal, therefore
--- continuity of approach to string parsing is not seen in this test.
--- However, a wide variety of possible approaches are demonstrated, while
--- exercising a large number of the total predefined subprograms of
--- package Ada.Strings.Fixed.
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
---
---!
-
-with Ada.Strings.Fixed;
-with Ada.Strings.Maps;
-with Report;
-
-procedure CXA4003 is
-
-begin
-
- Report.Test ("CXA4003", "Check that the subprograms defined in package " &
- "Ada.Strings.Fixed are available, and that they " &
- "produce correct results");
-
- Test_Block:
- declare
-
- Number_Of_Info_Strings : constant Natural := 3;
- DB_Size : constant Natural := Number_Of_Info_Strings;
- Count : Natural := 0;
- Finished_Processing : Boolean := False;
- Blank_String : constant String := " ";
-
- subtype Info_String_Type is String (1..50);
- type Info_String_Storage_Type is
- array (1..Number_Of_Info_Strings) of Info_String_Type;
-
-
- subtype Name_Type is String (1..10);
- subtype Street_Number_Type is String (1..5);
- subtype Street_Name_Type is String (1..10);
- subtype City_Type is String (1..10);
- subtype State_Type is String (1..2);
- subtype Zip_Code_Type is String (1..5);
-
- type Data_Base_Element_Type is
- record
- Name : Name_Type := (others => ' ');
- Street_Number : Street_Number_Type := (others => ' ');
- Street_Name : Street_Name_Type := (others => ' ');
- City : City_Type := (others => ' ');
- State : State_Type := (others => ' ');
- Zip_Code : Zip_Code_Type := (others => ' ');
- end record;
-
- type Data_Base_Type is array (1..DB_Size) of Data_Base_Element_Type;
-
- Data_Base : Data_Base_Type;
-
- ---
-
- Info_String_1 : Info_String_Type :=
- "Joe_Jones 123 Sixth_St San_Diego CA 98765";
-
- Info_String_2 : Info_String_Type :=
- "Sam_Smith 56789 S._Seventh Carlsbad CA 92177";
-
- Info_String_3 : Info_String_Type :=
- "Jane_Brown 1219 Info_Lane Tuscon AZ 85643";
-
-
- Info_Strings : Info_String_Storage_Type := (1 => Info_String_1,
- 2 => Info_String_2,
- 3 => Info_String_3);
-
-
-
- TC_DB_Element_1 : Data_Base_Element_Type :=
- ("Joe Jones ", "123 ", "Sixth St ", "San Diego ", "CA", "98765");
-
- TC_DB_Element_2 : Data_Base_Element_Type :=
- ("Sam Smith ", "56789", "S. Seventh", "Carlsbad ", "CA", "92177");
-
- TC_DB_Element_3 : Data_Base_Element_Type :=
- ("Jane Brown", "1219 ", "Info Lane ", "Tuscon ", "AZ", "85643");
-
- TC_Data_Base : Data_Base_Type := (TC_DB_Element_1,
- TC_DB_Element_2,
- TC_DB_Element_3);
-
- ---
-
-
- procedure Store_Information
- (Info_String : in Info_String_Type;
- DB_Record : in out Data_Base_Element_Type) is
-
- package AS renames Ada.Strings;
- use type AS.Maps.Character_Set;
-
- UnderScore : AS.Maps.Character_Sequence := "_";
- Blank : AS.Maps.Character_Sequence := " ";
-
- Start,
- Stop : Natural := 0;
-
- Underscore_to_Blank_Map : constant AS.Maps.Character_Mapping :=
- AS.Maps.To_Mapping(From => UnderScore,
- To => Blank);
-
- Numeric_Set : constant AS.Maps.Character_Set :=
- AS.Maps.To_Set("0123456789");
-
- Cal : constant AS.Maps.Character_Sequence := "CA";
- California_Set : constant AS.Maps.Character_Set :=
- AS.Maps.To_Set(Cal);
- Arizona_Set : constant AS.Maps.Character_Set :=
- AS.Maps.To_Set("AZ");
- Nevada_Set : constant AS.Maps.Character_Set :=
- AS.Maps.To_Set("NV");
-
- begin
-
- -- Find the starting position of the name field (first non-blank),
- -- then, from that position, find the end of the name field (first
- -- blank).
-
- Start := AS.Fixed.Index_Non_Blank(Info_String);
- Stop := AS.Fixed.Index (Info_String(Start..Info_String'Length),
- AS.Maps.To_Set(' '),
- AS.Inside,
- AS.Forward) - 1 ;
-
- -- Store the name field in the data base element field for "Name".
-
- DB_Record.Name := AS.Fixed.Head(Info_String(1..Stop),
- DB_Record.Name'Length);
-
- -- Replace any underscore characters in the name field
- -- that were used to separate first/middle/last names.
-
- AS.Fixed.Translate (DB_Record.Name, Underscore_to_Blank_Map);
-
-
- -- Continue the extraction process; now find the position of
- -- the street number in the string.
-
- Start := Stop + 1;
-
- AS.Fixed.Find_Token(Info_String(Start..Info_String'Length),
- Numeric_Set,
- AS.Inside,
- Start,
- Stop);
-
- -- Store the street number field in the appropriate data base
- -- element.
- -- No modification of the default parameters of procedure Move
- -- is required.
-
- AS.Fixed.Move(Source => Info_String(Start..Stop),
- Target => DB_Record.Street_Number);
-
-
- -- Continue the extraction process; find the street name in the
- -- info string. Skip blanks to the start of the street name, then
- -- search for the index of the next blank character in the string.
-
- Start :=
- AS.Fixed.Index_Non_Blank(Info_String(Stop+1..Info_String'Length));
-
- Stop :=
- AS.Fixed.Index(Info_String(Start..Info_String'Length),
- Blank_String) - 1;
-
- -- Store the street name in the appropriate data base element field.
-
- AS.Fixed.Overwrite(DB_Record.Street_Name,
- 1,
- Info_String(Start..Stop));
-
- -- Replace any underscore characters in the street name field
- -- that were used as word separation.
-
- DB_Record.Street_Name := AS.Fixed.Translate(DB_Record.Street_Name,
- Underscore_to_Blank_Map);
-
-
- -- Continue the extraction; remove the city name from the string.
-
- Start :=
- AS.Fixed.Index_Non_Blank(Info_String(Stop+1..Info_String'Length));
-
- Stop :=
- AS.Fixed.Index(Info_String(Start..Info_String'Length),
- Blank_String) - 1;
-
- -- Store the city name field in the appropriate data base element.
-
- AS.Fixed.Replace_Slice(DB_Record.City,
- 1,
- DB_Record.City'Length,
- Info_String(Start..Stop));
-
- -- Replace any underscore characters in the city name field
- -- that were used as word separation.
-
- AS.Fixed.Translate (DB_Record.City, Underscore_to_Blank_Map);
-
-
- -- Continue the extraction; remove the state identifier from the
- -- info string.
-
- Start := Stop + 1;
-
- AS.Fixed.Find_Token(Info_String(Start..Info_String'Length),
- AS.Maps."OR"(California_Set,
- AS.Maps."OR"(Nevada_Set, Arizona_Set)),
- AS.Inside,
- Start,
- Stop);
-
- -- Store the state indicator into the data base element.
-
- AS.Fixed.Move(Source => Info_String(Start..Stop),
- Target => DB_Record.State,
- Drop => Ada.Strings.Right,
- Justify => Ada.Strings.Left,
- Pad => AS.Space);
-
-
- -- Continue the extraction process; remove the final data item in
- -- the info string, the zip code, and place it into the
- -- corresponding data base element.
-
- DB_Record.Zip_Code := AS.Fixed.Tail(Info_String,
- DB_Record.Zip_Code'Length);
-
- exception
- when AS.Length_Error =>
- Report.Failed ("Length_Error raised in procedure");
- when AS.Pattern_Error =>
- Report.Failed ("Pattern_Error raised in procedure");
- when AS.Translation_Error =>
- Report.Failed ("Translation_Error raised in procedure");
- when others =>
- Report.Failed ("Exception raised in procedure");
- end Store_Information;
-
-
- begin
-
- -- Loop thru the information strings, extract the name and address
- -- information, place this info into elements of the data base.
-
- while not Finished_Processing loop
-
- Count := Count + 1;
-
- Store_Information (Info_Strings(Count), Data_Base(Count));
-
- Finished_Processing := (Count = Number_Of_Info_Strings);
-
- end loop;
-
-
- -- Verify that the string processing was successful.
-
- for i in 1..DB_Size loop
- if Data_Base(i) /= TC_Data_Base(i) then
- Report.Failed
- ("Data processing error on record " & Integer'Image(i));
- end if;
- end loop;
-
-
- exception
- when others => Report.Failed ("Exception raised in Test_Block");
- end Test_Block;
-
-
- Report.Result;
-
-end CXA4003;
diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxa4004.a b/gcc/testsuite/ada/acats/tests/cxa/cxa4004.a
deleted file mode 100644
index ec11f7d50f9..00000000000
--- a/gcc/testsuite/ada/acats/tests/cxa/cxa4004.a
+++ /dev/null
@@ -1,431 +0,0 @@
--- CXA4004.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that the subprograms defined in package Ada.Strings.Fixed are
--- available, and that they produce correct results. Specifically, check
--- the subprograms Count, Find_Token, Index, Index_Non_Blank, and Move.
---
--- TEST DESCRIPTION:
--- This test, when combined with tests CXA4002,3, and 5 will provide
--- thorough coverage of the functionality found in Ada.Strings.Fixed.
--- This test contains many small, specific test cases, situations that
--- although common in user environments, are often difficult to generate
--- in large numbers in a application-based test.
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 10 Apr 95 SAIC Corrected subtest for Move, Drop=Right.
---
---!
-
-with Report;
-with Ada.Strings;
-with Ada.Strings.Fixed;
-with Ada.Strings.Maps;
-
-procedure CXA4004 is
-begin
-
- Report.Test("CXA4004", "Check that the subprograms defined in " &
- "package Ada.Strings.Fixed are available, " &
- "and that they produce correct results");
-
- Test_Block:
- declare
-
- package ASF renames Ada.Strings.Fixed;
- package Maps renames Ada.Strings.Maps;
-
- Result_String : String(1..10) := (others => Ada.Strings.Space);
-
- Source_String1 : String(1..5) := "abcde"; -- odd length string
- Source_String2 : String(1..6) := "abcdef"; -- even length string
- Source_String3 : String(1..12) := "abcdefghijkl";
- Source_String4 : String(1..12) := "abcdefghij "; -- last two ch pad
- Source_String5 : String(1..12) := " cdefghijkl"; -- first two ch pad
- Source_String6 : String(1..12) := "abcdefabcdef";
-
- Location : Natural := 0;
- Slice_Start : Positive;
- Slice_End,
- Slice_Count : Natural := 0;
-
- CD_Set : Maps.Character_Set := Maps.To_Set("cd");
- ABCD_Set : Maps.Character_Set := Maps.To_Set("abcd");
- A_to_F_Set : Maps.Character_Set := Maps.To_Set("abcdef");
-
- CD_to_XY_Map : Maps.Character_Mapping :=
- Maps.To_Mapping(From => "cd", To => "xy");
-
- begin
-
- -- Procedure Move
-
- -- Evaluate the Procedure Move with various combinations of
- -- parameters.
-
- -- Justify = Left (default case)
-
- ASF.Move(Source => Source_String1, -- "abcde"
- Target => Result_String);
-
- if Result_String /= "abcde " then
- Report.Failed("Incorrect result from Move with Justify = Left");
- end if;
-
- -- Justify = Right
-
- ASF.Move(Source => Source_String2, -- "abcdef"
- Target => Result_String,
- Drop => Ada.Strings.Error,
- Justify => Ada.Strings.Right);
-
- if Result_String /= " abcdef" then
- Report.Failed("Incorrect result from Move with Justify = Right");
- end if;
-
- -- Justify = Center (two cases, odd and even pad lengths)
-
- ASF.Move(Source_String1, -- "abcde"
- Result_String,
- Ada.Strings.Error,
- Ada.Strings.Center,
- 'x'); -- non-default padding.
-
- if Result_String /= "xxabcdexxx" then -- Unequal padding added right
- Report.Failed("Incorrect result from Move with Justify = Center-1");
- end if;
-
- ASF.Move(Source_String2, -- "abcdef"
- Result_String,
- Ada.Strings.Error,
- Ada.Strings.Center);
-
- if Result_String /= " abcdef " then -- Equal padding added on L/R.
- Report.Failed("Incorrect result from Move with Justify = Center-2");
- end if;
-
- -- When the source string is longer than the target string, several
- -- cases can be examined, with the results depending on the value of
- -- the Drop parameter.
-
- -- Drop = Left
-
- ASF.Move(Source => Source_String3, -- "abcdefghijkl"
- Target => Result_String,
- Drop => Ada.Strings.Left);
-
- if Result_String /= "cdefghijkl" then
- Report.Failed("Incorrect result from Move with Drop = Left");
- end if;
-
- -- Drop = Right
-
- ASF.Move(Source_String3, Result_String, Ada.Strings.Right);
-
- if Result_String /= "abcdefghij" then
- Report.Failed("Incorrect result from Move with Drop = Right");
- end if;
-
- -- Drop = Error
- -- The effect in this case depends on the value of the justify
- -- parameter, and on whether any characters in Source other than
- -- Pad would fail to be copied.
-
- -- Drop = Error, Justify = Left, right overflow characters are pad.
-
- ASF.Move(Source => Source_String4, -- "abcdefghij "
- Target => Result_String,
- Drop => Ada.Strings.Error,
- Justify => Ada.Strings.Left);
-
- if not(Result_String = "abcdefghij") then -- leftmost 10 characters
- Report.Failed("Incorrect result from Move with Drop = Error - 1");
- end if;
-
- -- Drop = Error, Justify = Right, left overflow characters are pad.
-
- ASF.Move(Source_String5, -- " cdefghijkl"
- Result_String,
- Ada.Strings.Error,
- Ada.Strings.Right);
-
- if Result_String /= "cdefghijkl" then -- rightmost 10 characters
- Report.Failed("Incorrect result from Move with Drop = Error - 2");
- end if;
-
- -- In other cases of Drop=Error, Length_Error is propagated, such as:
-
- begin
-
- ASF.Move(Source_String3, -- 12 characters, no Pad.
- Result_String, -- 10 characters
- Ada.Strings.Error,
- Ada.Strings.Left);
-
- Report.Failed("Length_Error not raised by Move - 1");
-
- exception
- when Ada.Strings.Length_Error => null; -- OK
- when others =>
- Report.Failed("Incorrect exception raised by Move - 1");
- end;
-
-
-
- -- Function Index
- -- (Other usage examples of this function found in CXA4002-3.)
- -- Check when the pattern is not found in the source.
-
- if ASF.Index("abcdef", "gh") /= 0 or
- ASF.Index("abcde", "abcdef") /= 0 or -- pattern > source
- ASF.Index("xyz",
- "abcde",
- Ada.Strings.Backward) /= 0 or
- ASF.Index("", "ab") /= 0 or -- null source string.
- ASF.Index("abcde", " ") /= 0 -- blank pattern.
- then
- Report.Failed("Incorrect result from Index, no pattern match");
- end if;
-
- -- Check that Pattern_Error is raised when the pattern is the
- -- null string.
- begin
- Location := ASF.Index(Source_String6, -- "abcdefabcdef"
- "", -- null pattern string.
- Ada.Strings.Forward);
- Report.Failed("Pattern_Error not raised by Index");
- exception
- when Ada.Strings.Pattern_Error => null; -- OK, expected exception.
- when others =>
- Report.Failed("Incorrect exception raised by Index, null pattern");
- end;
-
- -- Use the search direction "backward" to locate the particular
- -- pattern within the source string.
-
- Location := ASF.Index(Source_String6, -- "abcdefabcdef"
- "de", -- slice 4..5, 10..11
- Ada.Strings.Backward); -- search from right end.
-
- if Location /= 10 then
- Report.Failed("Incorrect result from Index going Backward");
- end if;
-
- -- Using the version of Index testing character set membership,
- -- check combinations of forward/backward, inside/outside parameter
- -- configurations.
-
- if ASF.Index(Source => Source_String1, -- "abcde"
- Set => CD_Set,
- Test => Ada.Strings.Inside,
- Going => Ada.Strings.Forward) /= 3 or -- 'c' at pos 3.
- ASF.Index(Source_String6, -- "abcdefabcdef"
- CD_Set,
- Ada.Strings.Outside,
- Ada.Strings.Backward) /= 12 or -- 'f' at position 12
- ASF.Index(Source_String6, -- "abcdefabcdef"
- CD_Set,
- Ada.Strings.Inside,
- Ada.Strings.Backward) /= 10 or -- 'd' at position 10
- ASF.Index("cdcdcdcdacdcdcdcd",
- CD_Set,
- Ada.Strings.Outside,
- Ada.Strings.Forward) /= 9 -- 'a' at position 9
- then
- Report.Failed("Incorrect result from function Index for sets - 1");
- end if;
-
- -- Additional interesting uses/combinations using Index for sets.
-
- if ASF.Index("cd", -- same size, str-set
- CD_Set,
- Ada.Strings.Inside,
- Ada.Strings.Forward) /= 1 or -- 'c' at position 1
- ASF.Index("abcd", -- same size, str-set,
- Maps.To_Set("efgh"), -- different contents.
- Ada.Strings.Outside,
- Ada.Strings.Forward) /= 1 or
- ASF.Index("abccd", -- set > string
- Maps.To_Set("acegik"),
- Ada.Strings.Inside,
- Ada.Strings.Backward) /= 4 or -- 'c' at position 4
- ASF.Index("abcde",
- Maps.Null_Set) /= 0 or
- ASF.Index("", -- Null string.
- CD_Set) /= 0 or
- ASF.Index("abc ab", -- blank included
- Maps.To_Set("e "), -- in string and set.
- Ada.Strings.Inside,
- Ada.Strings.Backward) /= 4 -- blank in string.
- then
- Report.Failed("Incorrect result from function Index for sets - 2");
- end if;
-
-
-
- -- Function Index_Non_Blank.
- -- (Other usage examples of this function found in CXA4002-3.)
-
-
- if ASF.Index_Non_Blank(Source => Source_String4, -- "abcdefghij "
- Going => Ada.Strings.Backward) /= 10 or
- ASF.Index_Non_Blank("abc def ghi jkl ",
- Ada.Strings.Backward) /= 15 or
- ASF.Index_Non_Blank(" abcdef") /= 3 or
- ASF.Index_Non_Blank(" ") /= 0
- then
- Report.Failed("Incorrect result from Index_Non_Blank");
- end if;
-
-
-
- -- Function Count
- -- (Other usage examples of this function found in CXA4002-3.)
-
- if ASF.Count("abababa", "aba") /= 2 or
- ASF.Count("abababa", "ab" ) /= 3 or
- ASF.Count("babababa", "ab") /= 3 or
- ASF.Count("abaabaaba", "aba") /= 3 or
- ASF.Count("xxxxxxxxxxxxxxxxxxxy", "xy") /= 1 or
- ASF.Count("xxxxxxxxxxxxxxxxxxxx", "x") /= 20
- then
- Report.Failed("Incorrect result from Function Count");
- end if;
-
- -- Determine the number of slices of Source that when mapped to a
- -- non-identity map, match the pattern string.
-
- Slice_Count := ASF.Count(Source_String6, -- "abcdefabcdef"
- "xy",
- CD_to_XY_Map); -- maps 'c' to 'x', 'd' to 'y'
-
- if Slice_Count /= 2 then -- two slices "xy" in "mapped" Source_String6
- Report.Failed("Incorrect result from Count with non-identity map");
- end if;
-
- -- If the pattern supplied to Function Count is the null string, then
- -- Pattern_Error is propagated.
-
- declare
- The_Null_String : constant String := "";
- begin
- Slice_Count := ASF.Count(Source_String6, The_Null_String);
- Report.Failed("Pattern_Error not raised by Function Count");
- exception
- when Ada.Strings.Pattern_Error => null; -- OK
- when others =>
- Report.Failed("Incorrect exception from Count with null pattern");
- end;
-
-
- -- Function Count returning the number of characters in a particular
- -- set that are found in source string.
-
- if ASF.Count(Source_String6, CD_Set) /= 4 then -- 2 'c' and 'd' chars.
- Report.Failed("Incorrect result from Count with set");
- end if;
-
-
-
- -- Function Find_Token.
- -- (Other usage examples of this function found in CXA4002-3.)
-
- ASF.Find_Token(Source => Source_String6, -- First slice with no
- Set => ABCD_Set, -- 'a', 'b', 'c', or 'd'
- Test => Ada.Strings.Outside, -- is "ef" at 5..6.
- First => Slice_Start,
- Last => Slice_End);
-
- if Slice_Start /= 5 or Slice_End /= 6 then
- Report.Failed("Incorrect result from Find_Token - 1");
- end if;
-
- -- If no appropriate slice is contained by the source string, then the
- -- value returned in Last is zero, and the value in First is
- -- Source'First.
-
- ASF.Find_Token(Source_String6, -- "abcdefabcdef"
- A_to_F_Set, -- Set of characters 'a' thru 'f'.
- Ada.Strings.Outside, -- No characters outside this set.
- Slice_Start,
- Slice_End);
-
- if Slice_Start /= Source_String6'First or Slice_End /= 0 then
- Report.Failed("Incorrect result from Find_Token - 2");
- end if;
-
- -- Additional testing of Find_Token.
-
- ASF.Find_Token("eabcdabcddcab",
- ABCD_Set,
- Ada.Strings.Inside,
- Slice_Start,
- Slice_End);
-
- if Slice_Start /= 2 or Slice_End /= 13 then
- Report.Failed("Incorrect result from Find_Token - 3");
- end if;
-
- ASF.Find_Token("efghijklabcdabcd",
- ABCD_Set,
- Ada.Strings.Outside,
- Slice_Start,
- Slice_End);
-
- if Slice_Start /= 1 or Slice_End /= 8 then
- Report.Failed("Incorrect result from Find_Token - 4");
- end if;
-
- ASF.Find_Token("abcdefgabcdabcd",
- ABCD_Set,
- Ada.Strings.Outside,
- Slice_Start,
- Slice_End);
-
- if Slice_Start /= 5 or Slice_End /= 7 then
- Report.Failed("Incorrect result from Find_Token - 5");
- end if;
-
- ASF.Find_Token("abcdcbabcdcba",
- ABCD_Set,
- Ada.Strings.Inside,
- Slice_Start,
- Slice_End);
-
- if Slice_Start /= 1 or Slice_End /= 13 then
- Report.Failed("Incorrect result from Find_Token - 6");
- end if;
-
-
- exception
- when others => Report.Failed("Exception raised in Test_Block");
- end Test_Block;
-
- Report.Result;
-
-end CXA4004;
diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxa4005.a b/gcc/testsuite/ada/acats/tests/cxa/cxa4005.a
deleted file mode 100644
index d61f853ca0e..00000000000
--- a/gcc/testsuite/ada/acats/tests/cxa/cxa4005.a
+++ /dev/null
@@ -1,683 +0,0 @@
--- CXA4005.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that the subprograms defined in package Ada.Strings.Fixed are
--- available, and that they produce correct results. Specifically,
--- check the subprograms Delete, Head, Insert, Overwrite, Replace_Slice,
--- Tail, Trim, and "*".
---
--- TEST DESCRIPTION:
--- This test, when combined with tests CXA4002-4 will provide coverage
--- of the functionality found in Ada.Strings.Fixed.
--- This test contains many small, specific test cases, situations that
--- although common in user environments, are often difficult to generate
--- in large numbers in a application-based test. They represent
--- individual usage paradigms in-the-small.
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 11 Apr 95 SAIC Corrected acceptance conditions of certain
--- subtests.
--- 06 Nov 95 SAIC Fixed bugs for ACVC 2.0.1.
--- 22 Feb 01 PHL Check that the lower bound of the result is 1.
--- 13 Mar 01 RLB Fixed a couple of ACATS style violations;
--- removed pointless checks of procedures.
--- Added checks of other functions. These changes
--- were made to test Defect Report 8652/0049, as
--- reflected in Technical Corrigendum 1.
---
---!
-
-with Report;
-with Ada.Strings;
-with Ada.Strings.Fixed;
-with Ada.Strings.Maps;
-
-procedure CXA4005 is
-
- type TC_Name_Holder is access String;
- Name : TC_Name_Holder;
-
- function TC_Check (S : String) return String is
- begin
- if S'First /= 1 then
- Report.Failed ("Lower bound of result of function " & Name.all &
- " is" & Integer'Image (S'First));
- end if;
- return S;
- end TC_Check;
-
- procedure TC_Set_Name (N : String) is
- begin
- Name := new String'(N);
- end TC_Set_Name;
-
-begin
-
- Report.Test("CXA4005", "Check that the subprograms defined in " &
- "package Ada.Strings.Fixed are available, " &
- "and that they produce correct results");
-
- Test_Block:
- declare
-
- package ASF renames Ada.Strings.Fixed;
- package Maps renames Ada.Strings.Maps;
-
- Result_String,
- Delete_String,
- Insert_String,
- Trim_String,
- Overwrite_String : String(1..10) := (others => Ada.Strings.Space);
-
- Source_String1 : String(1..5) := "abcde"; -- odd length string
- Source_String2 : String(1..6) := "abcdef"; -- even length string
- Source_String3 : String(1..12) := "abcdefghijkl";
- Source_String4 : String(1..12) := "abcdefghij "; -- last two ch pad
- Source_String5 : String(1..12) := " cdefghijkl"; -- first two ch pad
- Source_String6 : String(1..12) := "abcdefabcdef";
-
- Location : Natural := 0;
- Slice_Start : Positive;
- Slice_End,
- Slice_Count : Natural := 0;
-
- CD_Set : Maps.Character_Set := Maps.To_Set("cd");
- X_Set : Maps.Character_Set := Maps.To_Set('x');
- ABCD_Set : Maps.Character_Set := Maps.To_Set("abcd");
- A_to_F_Set : Maps.Character_Set := Maps.To_Set("abcdef");
-
- CD_to_XY_Map : Maps.Character_Mapping :=
- Maps.To_Mapping(From => "cd", To => "xy");
-
- begin
-
- -- Procedure Replace_Slice
- -- The functionality of this procedure
- -- is similar to procedure Move, and
- -- is tested here in the same manner, evaluated
- -- with various combinations of parameters.
-
- -- Index_Error propagation when Low > Source'Last + 1
-
- begin
- ASF.Replace_Slice(Result_String,
- Result_String'Last + 2, -- should raise exception
- Result_String'Last,
- "xxxxxxx");
- Report.Failed("Index_Error not raised by Replace_Slice - 1");
- exception
- when Ada.Strings.Index_Error => null; -- OK, expected exception.
- when others =>
- Report.Failed("Incorrect exception from Replace_Slice - 1");
- end;
-
- -- Index_Error propagation when High < Source'First - 1
-
- begin
- ASF.Replace_Slice(Result_String(5..10),
- 5,
- 3, -- should raise exception since < 'First - 1.
- "xxxxxxx");
- Report.Failed("Index_Error not raised by Replace_Slice - 2");
- exception
- when Ada.Strings.Index_Error => null; -- OK, expected exception.
- when others =>
- Report.Failed("Incorrect exception from Replace_Slice - 2");
- end;
-
- -- Justify = Left (default case)
-
- Result_String := "XXXXXXXXXX";
-
- ASF.Replace_Slice(Source => Result_String,
- Low => 1,
- High => 10,
- By => Source_String1); -- "abcde"
-
- if Result_String /= "abcde " then
- Report.Failed("Incorrect result from Replace_Slice - Justify = Left");
- end if;
-
- -- Justify = Right
-
- ASF.Replace_Slice(Source => Result_String,
- Low => 1,
- High => Result_String'Last,
- By => Source_String2, -- "abcdef"
- Drop => Ada.Strings.Error,
- Justify => Ada.Strings.Right);
-
- if Result_String /= " abcdef" then
- Report.Failed("Incorrect result from Replace_Slice - Justify=Right");
- end if;
-
- -- Justify = Center (two cases, odd and even pad lengths)
-
- ASF.Replace_Slice(Result_String,
- 1,
- Result_String'Last,
- Source_String1, -- "abcde"
- Ada.Strings.Error,
- Ada.Strings.Center,
- 'x'); -- non-default padding.
-
- if Result_String /= "xxabcdexxx" then -- Unequal padding added right
- Report.Failed("Incorrect result, Replace_Slice - Justify=Center - 1");
- end if;
-
- ASF.Replace_Slice(Result_String,
- 1,
- Result_String'Last,
- Source_String2, -- "abcdef"
- Ada.Strings.Error,
- Ada.Strings.Center);
-
- if Result_String /= " abcdef " then -- Equal padding added on L/R.
- Report.Failed("Incorrect result from Replace_Slice with " &
- "Justify = Center - 2");
- end if;
-
- -- When the source string is longer than the target string, several
- -- cases can be examined, with the results depending on the value of
- -- the Drop parameter.
-
- -- Drop = Left
-
- ASF.Replace_Slice(Result_String,
- 1,
- Result_String'Last,
- Source_String3, -- "abcdefghijkl"
- Drop => Ada.Strings.Left);
-
- if Result_String /= "cdefghijkl" then
- Report.Failed("Incorrect result from Replace_Slice - Drop=Left");
- end if;
-
- -- Drop = Right
-
- ASF.Replace_Slice(Result_String,
- 1,
- Result_String'Last,
- Source_String3, -- "abcdefghijkl"
- Ada.Strings.Right);
-
- if Result_String /= "abcdefghij" then
- Report.Failed("Incorrect result, Replace_Slice with Drop=Right");
- end if;
-
- -- Drop = Error
-
- -- The effect in this case depends on the value of the justify
- -- parameter, and on whether any characters in Source other than
- -- Pad would fail to be copied.
-
- -- Drop = Error, Justify = Left, right overflow characters are pad.
-
- ASF.Replace_Slice(Result_String,
- 1,
- Result_String'Last,
- Source_String4, -- "abcdefghij "
- Drop => Ada.Strings.Error,
- Justify => Ada.Strings.Left);
-
- if not(Result_String = "abcdefghij") then -- leftmost 10 characters
- Report.Failed("Incorrect result, Replace_Slice - Drop = Error - 1");
- end if;
-
- -- Drop = Error, Justify = Right, left overflow characters are pad.
-
- ASF.Replace_Slice(Source => Result_String,
- Low => 1,
- High => Result_String'Last,
- By => Source_String5, -- " cdefghijkl"
- Drop => Ada.Strings.Error,
- Justify => Ada.Strings.Right);
-
- if Result_String /= "cdefghijkl" then -- rightmost 10 characters
- Report.Failed("Incorrect result, Replace_Slice - Drop = Error - 2");
- end if;
-
- -- In other cases of Drop=Error, Length_Error is propagated, such as:
-
- begin
-
- ASF.Replace_Slice(Source => Result_String,
- Low => 1,
- High => Result_String'Last,
- By => Source_String3, -- "abcdefghijkl"
- Drop => Ada.Strings.Error);
-
- Report.Failed("Length_Error not raised by Replace_Slice - 1");
-
- exception
- when Ada.Strings.Length_Error => null; -- OK
- when others =>
- Report.Failed("Incorrect exception from Replace_Slice - 3");
- end;
-
-
- -- Function Replace_Slice
-
- TC_Set_Name ("Replace_Slice");
-
- if TC_Check (ASF.Replace_Slice("abcde", 3, 3, "x"))
- /= "abxde" or -- High = Low
- TC_Check (ASF.Replace_Slice("abc", 2, 3, "xyz")) /= "axyz" or
- TC_Check (ASF.Replace_Slice("abcd", 4, 1, "xy"))
- /= "abcxyd" or -- High < Low
- TC_Check (ASF.Replace_Slice("abc", 2, 3, "x")) /= "ax" or
- TC_Check (ASF.Replace_Slice("a", 1, 1, "z")) /= "z"
- then
- Report.Failed("Incorrect result from Function Replace_Slice - 1");
- end if;
-
- if TC_Check (ASF.Replace_Slice("abcde", 5, 5, "z"))
- /= "abcdz" or -- By length 1
- TC_Check (ASF.Replace_Slice("abc", 1, 3, "xyz"))
- /= "xyz" or -- High > Low
- TC_Check (ASF.Replace_Slice("abc", 3, 2, "xy"))
- /= "abxyc" or -- insert
- TC_Check (ASF.Replace_Slice("a", 1, 1, "xyz")) /= "xyz"
- then
- Report.Failed("Incorrect result from Function Replace_Slice - 2");
- end if;
-
-
-
- -- Function Insert.
-
- TC_Set_Name ("Insert");
-
- declare
- New_String : constant String :=
- TC_Check (
- ASF.Insert(Source => Source_String1(2..5), -- "bcde"
- Before => 3,
- New_Item => Source_String2)); -- "abcdef"
- begin
- if New_String /= "babcdefcde" then
- Report.Failed("Incorrect result from Function Insert - 1");
- end if;
- end;
-
- if TC_Check (ASF.Insert("a", 1, "z")) /= "za" or
- TC_Check (ASF.Insert("abc", 3, "")) /= "abc" or
- TC_Check (ASF.Insert("abc", 1, "z")) /= "zabc"
- then
- Report.Failed("Incorrect result from Function Insert - 2");
- end if;
-
- begin
- if TC_Check (ASF.Insert(Source => Source_String1(2..5), -- "bcde"
- Before => Report.Ident_Int(7),
- New_Item => Source_String2)) -- "abcdef"
- /= "babcdefcde" then
- Report.Failed("Index_Error not raised by Insert - 3A");
- else
- Report.Failed("Index_Error not raised by Insert - 3B");
- end if;
- exception
- when Ada.Strings.Index_Error => null; -- OK, expected exception.
- when others =>
- Report.Failed("Incorrect exception from Insert - 3");
- end;
-
-
- -- Procedure Insert
-
- -- Drop = Right
-
- ASF.Insert(Source => Insert_String,
- Before => 6,
- New_Item => Source_String2, -- "abcdef"
- Drop => Ada.Strings.Right);
-
- if Insert_String /= " abcde" then -- last char of New_Item dropped.
- Report.Failed("Incorrect result from Insert with Drop = Right");
- end if;
-
- -- Drop = Left
-
- ASF.Insert(Source => Insert_String, -- 10 char string
- Before => 2, -- 9 chars, 2..10 available
- New_Item => Source_String3, -- 12 characters long.
- Drop => Ada.Strings.Left); -- truncate from Left.
-
- if Insert_String /= "l abcde" then -- 10 chars, leading blank.
- Report.Failed("Incorrect result from Insert with Drop=Left");
- end if;
-
- -- Drop = Error
-
- begin
- ASF.Insert(Source => Result_String, -- 10 chars
- Before => Result_String'Last,
- New_Item => "abcdefghijk",
- Drop => Ada.Strings.Error);
- Report.Failed("Exception not raised by Procedure Insert");
- exception
- when Ada.Strings.Length_Error => null; -- OK, expected exception
- when others =>
- Report.Failed("Incorrect exception raised by Procedure Insert");
- end;
-
-
-
- -- Function Overwrite
-
- TC_Set_Name ("Overwrite");
-
- Overwrite_String := TC_Check (
- ASF.Overwrite(Result_String, -- 10 chars
- 1, -- starting at pos=1
- Source_String3(1..10)));
-
- if Overwrite_String /= Source_String3(1..10) then
- Report.Failed("Incorrect result from Function Overwrite - 1");
- end if;
-
-
- if TC_Check (ASF.Overwrite("abcdef", 4, "xyz")) /= "abcxyz" or
- TC_Check (ASF.Overwrite("a", 1, "xyz"))
- /= "xyz" or -- chars appended
- TC_Check (ASF.Overwrite("abc", 3, " "))
- /= "ab " or -- blanks appended
- TC_Check (ASF.Overwrite("abcde", 1, "z" )) /= "zbcde"
- then
- Report.Failed("Incorrect result from Function Overwrite - 2");
- end if;
-
-
-
- -- Procedure Overwrite, with truncation.
-
- ASF.Overwrite(Source => Overwrite_String, -- 10 characters.
- Position => 1,
- New_Item => Source_String3, -- 12 characters.
- Drop => Ada.Strings.Left);
-
- if Overwrite_String /= "cdefghijkl" then
- Report.Failed("Incorrect result from Overwrite with Drop=Left");
- end if;
-
- -- The default drop value is Right, used here.
-
- ASF.Overwrite(Source => Overwrite_String, -- 10 characters.
- Position => 1,
- New_Item => Source_String3); -- 12 characters.
-
- if Overwrite_String /= "abcdefghij" then
- Report.Failed("Incorrect result from Overwrite with Drop=Right");
- end if;
-
- -- Drop = Error
-
- begin
- ASF.Overwrite(Source => Overwrite_String, -- 10 characters.
- Position => 1,
- New_Item => Source_String3, -- 12 characters.
- Drop => Ada.Strings.Error);
- Report.Failed("Exception not raised by Procedure Overwrite");
- exception
- when Ada.Strings.Length_Error => null; -- OK, expected exception.
- when others =>
- Report.Failed
- ("Incorrect exception raised by Procedure Overwrite");
- end;
-
- Overwrite_String := "ababababab";
- ASF.Overwrite(Overwrite_String, Overwrite_String'Last, "z");
- ASF.Overwrite(Overwrite_String, Overwrite_String'First,"z");
- ASF.Overwrite(Overwrite_String, 5, "zz");
-
- if Overwrite_String /= "zbabzzabaz" then
- Report.Failed("Incorrect result from Procedure Overwrite");
- end if;
-
-
-
- -- Function Delete
-
- TC_Set_Name ("Delete");
-
- declare
- New_String1 : constant String := -- This returns a 4 char string.
- TC_Check (ASF.Delete(Source => Source_String3,
- From => 3,
- Through => 10));
- New_String2 : constant String := -- This returns Source.
- TC_Check (ASF.Delete(Source_String3, 10, 3));
- begin
- if New_String1 /= "abkl" or
- New_String2 /= Source_String3
- then
- Report.Failed("Incorrect result from Function Delete - 1");
- end if;
- end;
-
- if TC_Check (ASF.Delete("a", 1, 1))
- /= "" or -- Source length = 1
- TC_Check (ASF.Delete("abc", 1, 2))
- /= "c" or -- From = Source'First
- TC_Check (ASF.Delete("abc", 3, 3))
- /= "ab" or -- From = Source'Last
- TC_Check (ASF.Delete("abc", 3, 1))
- /= "abc" -- From > Through
- then
- Report.Failed("Incorrect result from Function Delete - 2");
- end if;
-
-
-
- -- Procedure Delete
-
- -- Justify = Left
-
- Delete_String := Source_String3(1..10); -- Initialize to "abcdefghij"
-
- ASF.Delete(Source => Delete_String,
- From => 6,
- Through => Delete_String'Last,
- Justify => Ada.Strings.Left,
- Pad => 'x'); -- pad with char 'x'
-
- if Delete_String /= "abcdexxxxx" then
- Report.Failed("Incorrect result from Delete - Justify = Left");
- end if;
-
- -- Justify = Right
-
- ASF.Delete(Source => Delete_String, -- Remove x"s from end and
- From => 6, -- shift right.
- Through => Delete_String'Last,
- Justify => Ada.Strings.Right,
- Pad => 'x'); -- pad with char 'x' on left.
-
- if Delete_String /= "xxxxxabcde" then
- Report.Failed("Incorrect result from Delete - Justify = Right");
- end if;
-
- -- Justify = Center
-
- ASF.Delete(Source => Delete_String,
- From => 1,
- Through => 5,
- Justify => Ada.Strings.Center,
- Pad => 'z');
-
- if Delete_String /= "zzabcdezzz" then -- extra pad char on right side.
- Report.Failed("Incorrect result from Delete - Justify = Center");
- end if;
-
-
-
- -- Function Trim
- -- Use non-identity character sets to perform the trim operation.
-
- TC_Set_Name ("Trim");
-
- Trim_String := "cdabcdefcd";
-
- -- Remove the "cd" from each end of the string. This will not effect
- -- the "cd" slice at 5..6.
-
- declare
- New_String : constant String :=
- TC_Check (ASF.Trim(Source => Trim_String,
- Left => CD_Set, Right => CD_Set));
- begin
- if New_String /= Source_String2 then -- string "abcdef"
- Report.Failed("Incorrect result from Trim with character sets");
- end if;
- end;
-
- if TC_Check (ASF.Trim("abcdef", Maps.Null_Set, Maps.Null_Set))
- /= "abcdef" then
- Report.Failed("Incorrect result from Trim with Null sets");
- end if;
-
- if TC_Check (ASF.Trim("cdxx", CD_Set, X_Set)) /= "" then
- Report.Failed("Incorrect result from Trim, string removal");
- end if;
-
-
- -- Procedure Trim
-
- -- Justify = Right
-
- ASF.Trim(Source => Trim_String,
- Left => CD_Set,
- Right => CD_Set,
- Justify => Ada.Strings.Right,
- Pad => 'x');
-
- if Trim_String /= "xxxxabcdef" then
- Report.Failed("Incorrect result from Trim with Justify = Right");
- end if;
-
- -- Justify = Left
-
- ASF.Trim(Source => Trim_String,
- Left => X_Set,
- Right => Maps.Null_Set,
- Justify => Ada.Strings.Left,
- Pad => Ada.Strings.Space);
-
- if Trim_String /= "abcdef " then -- Padded with 4 blanks on right.
- Report.Failed("Incorrect result from Trim with Justify = Left");
- end if;
-
- -- Justify = Center
-
- ASF.Trim(Source => Trim_String,
- Left => ABCD_Set,
- Right => CD_Set,
- Justify => Ada.Strings.Center,
- Pad => 'x');
-
- if Trim_String /= "xxef xx" then -- Padded with 2 pad chars on L/R
- Report.Failed("Incorrect result from Trim with Justify = Center");
- end if;
-
-
-
- -- Function Head, demonstrating use of padding.
-
- TC_Set_Name ("Head");
-
- -- Use the characters of Source_String1 ("abcde") and pad the
- -- last five characters of Result_String with 'x' characters.
-
-
- Result_String := TC_CHeck (ASF.Head(Source_String1, 10, 'x'));
-
- if Result_String /= "abcdexxxxx" then
- Report.Failed("Incorrect result from Function Head with padding");
- end if;
-
- if TC_Check (ASF.Head(" ab ", 2)) /= " " or
- TC_Check (ASF.Head("a", 6, 'A')) /= "aAAAAA" or
- TC_Check (ASF.Head("abcdefgh", 3, 'x')) /= "abc" or
- TC_Check (ASF.Head(ASF.Head("abc ", 7, 'x'), 10, 'X'))
- /= "abc xxXXX"
- then
- Report.Failed("Incorrect result from Function Head");
- end if;
-
-
-
- -- Function Tail, demonstrating use of padding.
-
- TC_Set_Name ("Tail");
-
- -- Use the characters of Source_String1 ("abcde") and pad the
- -- first five characters of Result_String with 'x' characters.
-
- Result_String := TC_Check (ASF.Tail(Source_String1, 10, 'x'));
-
- if Result_String /= "xxxxxabcde" then
- Report.Failed("Incorrect result from Function Tail with padding");
- end if;
-
- if TC_Check (ASF.Tail("abcde ", 5))
- /= "cde " or -- blanks, back
- TC_Check (ASF.Tail(" abc ", 8, ' '))
- /= " abc " or -- blanks, front/back
- TC_Check (ASF.Tail("", 5, 'Z'))
- /= "ZZZZZ" or -- pad characters only
- TC_Check (ASF.Tail("abc", 0))
- /= "" or -- null result
- TC_Check (ASF.Tail("abcdefgh", 3))
- /= "fgh" or
- TC_Check (ASF.Tail(ASF.Tail(" abc ", 6, 'x'),
- 10,
- 'X')) /= "XXXXx abc "
- then
- Report.Failed("Incorrect result from Function Tail");
- end if;
-
-
- -- Function "*" - with (Natural, String) parameters
-
- TC_Set_Name ("""*""");
-
- if TC_Check (ASF."*"(3, Source_String1)) /= "abcdeabcdeabcde" or
- TC_Check (ASF."*"(2, Source_String2)) /= Source_String6 or
- TC_Check (ASF."*"(4, Source_String1(1..2))) /= "abababab" or
- TC_Check (ASF."*"(0, Source_String1)) /= ""
- then
- Report.Failed("Incorrect result from Function ""*"" with strings");
- end if;
-
- exception
- when others => Report.Failed("Exception raised in Test_Block");
- end Test_Block;
-
- Report.Result;
-
-end CXA4005;
diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxa4006.a b/gcc/testsuite/ada/acats/tests/cxa/cxa4006.a
deleted file mode 100644
index e1d7f46f5ae..00000000000
--- a/gcc/testsuite/ada/acats/tests/cxa/cxa4006.a
+++ /dev/null
@@ -1,319 +0,0 @@
--- CXA4006.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that the subprograms defined in package Ada.Strings.Bounded are
--- available, and that they produce correct results. Specifically, check
--- the subprograms Length, Slice, "&", To_Bounded_String, Append, Index,
--- To_String, Replace_Slice, Trim, Overwrite, Delete, Insert, and
--- Translate.
---
--- TEST DESCRIPTION:
--- This test demonstrates the uses of a variety of the string functions
--- found in the package Ada.Strings.Bounded, simulating the operations
--- found in a text processing package.
--- With bounded strings, the length of each "line" of text can vary up
--- to the instantiated maximum, allowing one to view a page of text as
--- a series of expandable lines. This provides flexibility in text
--- formatting of individual lines (strings).
--- Several subprograms are defined, all of which attempt to take advantage
--- of as many different bounded string utilities as possible. Often,
--- an operation that is being performed in a subprogram using a certain
--- bounded string utility could more efficiently be performed using a
--- a different utility. However, in the interest of including as broad
--- coverage as possible, a mixture of utilities is invoked in this test.
--- A simulated page of text is provided as a parameter to the test
--- defined subprograms, and the appropriate processing performed. The
--- processed page of text is then compared to a predefined "finished"
--- page, and test passage/failure is based on the results of this
--- comparison.
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
---
---!
-
-with Ada.Strings;
-with Ada.Strings.Bounded;
-with Ada.Strings.Maps;
-with Report;
-
-procedure CXA4006 is
-
-begin
-
- Report.Test ("CXA4006", "Check that the subprograms defined in package " &
- "Ada.Strings.Bounded are available, and that " &
- "they produce correct results");
-
- Test_Block:
- declare
-
- Characters_Per_Line : constant Positive := 40;
- Lines_Per_Page : constant Natural := 4;
-
- package BS_40 is new
- Ada.Strings.Bounded.Generic_Bounded_Length(Characters_Per_Line);
- use type BS_40.Bounded_String;
-
- type Page_Type is array (1..Lines_Per_Page) of BS_40.Bounded_String;
-
- -- Note: Misspellings below are intentional.
-
- Line1 : BS_40.Bounded_String :=
- BS_40.To_Bounded_String("ada is a progrraming language designed");
- Line2 : BS_40.Bounded_String :=
- BS_40.To_Bounded_String("to support the construction of long-");
- Line3 : BS_40.Bounded_String :=
- BS_40.To_Bounded_String("lived, highly reliabel software ");
- Line4 : BS_40.Bounded_String :=
- BS_40.To_Bounded_String("systems");
-
- Page : Page_Type := (1 => Line1, 2 => Line2, 3 => Line3, 4 => Line4);
-
- Finished_Page : Page_Type :=
- (BS_40.To_Bounded_String("Ada is a programming language designed"),
- BS_40.To_Bounded_String("to support the construction of long-"),
- BS_40.To_Bounded_String("lived, HIGHLY RELIABLE software systems."),
- BS_40.To_Bounded_String(""));
-
- ---
-
- procedure Compress (Page : in out Page_Type) is
- Clear_Line : Natural := Lines_Per_Page;
- begin
- -- If two consecutive lines on the page are together less than the
- -- maximum line length, then append those two lines, move up all
- -- lower lines on the page, and blank out the last line.
- for i in 1..Lines_Per_Page - 1 loop
- if BS_40.Length(Page(i)) + BS_40.Length(Page(i+1)) <=
- BS_40.Max_Length
- then
- Page(i) := BS_40."&"(Page(i),
- Page(i+1)); -- "&" (bounded, bounded)
-
- for j in i+1..Lines_Per_Page - 1 loop
- Page(j) :=
- BS_40.To_Bounded_String
- (BS_40.Slice(Page(j+1),
- 1,
- BS_40.Length(Page(j+1))));
- Clear_Line := j + 1;
- end loop;
- Page(Clear_Line) := BS_40.Null_Bounded_String;
- end if;
- end loop;
- end Compress;
-
- ---
-
- procedure Format (Page : in out Page_Type) is
- Sm_Ada : BS_40.Bounded_String := BS_40.To_Bounded_String("ada");
- Cap_Ada : constant String := "Ada";
- Char_Pos : Natural := 0;
- Finished : Boolean := False;
- Line : Natural := Page_Type'Last;
- begin
-
- -- Add a period to the end of the last line.
- while Line >= Page_Type'First and not Finished loop
- if Page(Line) /= BS_40.Null_Bounded_String and
- BS_40.Length(Page(Line)) <= BS_40.Max_Length
- then
- Page(Line) := BS_40.Append(Page(Line), '.');
- Finished := True;
- end if;
- Line := Line - 1;
- end loop;
-
- -- Replace all occurrences of "ada" with "Ada".
- for Line in Page_Type'First .. Page_Type'Last loop
- Finished := False;
- while not Finished loop
- Char_Pos := BS_40.Index(Source => Page(Line),
- Pattern => BS_40.To_String(Sm_Ada),
- Going => Ada.Strings.Backward);
- -- A zero is returned by function Index if no occurrences of
- -- the pattern string are found.
- Finished := (Char_Pos = 0);
- if not Finished then
- BS_40.Replace_Slice
- (Source => Page(Line),
- Low => Char_Pos,
- High => Char_Pos + BS_40.Length(Sm_Ada) - 1,
- By => Cap_Ada);
- end if;
- end loop; -- while loop
- end loop; -- for loop
-
- end Format;
-
- ---
-
- procedure Spell_Check (Page : in out Page_Type) is
- type Spelling_Type is (Incorrect, Correct);
- type Word_Array_Type is array (Spelling_Type)
- of BS_40.Bounded_String;
- type Dictionary_Type is array (1..2) of Word_Array_Type;
-
- -- Note that the "words" in the dictionary will require various
- -- amounts of Trimming prior to their use in the string functions.
- Dictionary : Dictionary_Type :=
- (1 => (BS_40.To_Bounded_String(" reliabel "),
- BS_40.To_Bounded_String(" reliable ")),
- 2 => (BS_40.To_Bounded_String(" progrraming "),
- BS_40.To_Bounded_String(" programming ")));
-
- Pos : Natural := Natural'First;
- Finished : Boolean := False;
-
- begin
-
- for Line in Page_Type'Range loop
-
- -- Search for the first incorrectly spelled word in the Dictionary,
- -- if it is found, replace it with the correctly spelled word,
- -- using the Overwrite function.
-
- while not Finished loop
- Pos :=
- BS_40.Index(Page(Line),
- BS_40.To_String(
- BS_40.Trim(Dictionary(1)(Incorrect),
- Ada.Strings.Both)),
- Ada.Strings.Forward);
- Finished := (Pos = 0);
- if not Finished then
- Page(Line) :=
- BS_40.Overwrite(Page(Line),
- Pos,
- BS_40.To_String
- (BS_40.Trim(Dictionary(1)(Correct),
- Ada.Strings.Both)));
- end if;
- end loop;
-
- Finished := False;
-
- -- Search for the second incorrectly spelled word in the
- -- Dictionary, if it is found, replace it with the correctly
- -- spelled word, using the Delete procedure and Insert function.
-
- while not Finished loop
- Pos :=
- BS_40.Index(Page(Line),
- BS_40.To_String(
- BS_40.Trim(Dictionary(2)(Incorrect),
- Ada.Strings.Both)),
- Ada.Strings.Forward);
-
- Finished := (Pos = 0);
-
- if not Finished then
- BS_40.Delete
- (Page(Line),
- Pos,
- Pos + BS_40.To_String
- (BS_40.Trim(Dictionary(2)(Incorrect),
- Ada.Strings.Both))'Length-1);
- Page(Line) :=
- BS_40.Insert(Page(Line),
- Pos,
- BS_40.To_String
- (BS_40.Trim(Dictionary(2)(Correct),
- Ada.Strings.Both)));
- end if;
- end loop;
-
- Finished := False;
-
- end loop;
- end Spell_Check;
-
- ---
-
- procedure Bold (Page : in out Page_Type) is
- Key_Word : constant String := "highly reliable";
- Bold_Mapping : constant Ada.Strings.Maps.Character_Mapping :=
- Ada.Strings.Maps.To_Mapping(From => " abcdefghijklmnopqrstuvwxyz",
- To => " ABCDEFGHIJKLMNOPQRSTUVWXYZ");
- Pos : Natural := Natural'First;
- Finished : Boolean := False;
- begin
- -- This procedure is designed to change the case of the phrase
- -- "highly reliable" into upper case (a type of "Bolding").
- -- All instances of the phrase on all lines of the page will be
- -- modified.
-
- for Line in Page_Type'First .. Page_Type'Last loop
- while not Finished loop
- Pos := BS_40.Index(Page(Line), Key_Word);
- Finished := (Pos = 0);
- if not Finished then
-
- BS_40.Overwrite
- (Page(Line),
- Pos,
- BS_40.To_String
- (BS_40.Translate
- (BS_40.To_Bounded_String
- (BS_40.Slice(Page(Line),
- Pos,
- Pos + Key_Word'Length - 1)),
- Bold_Mapping)));
-
- end if;
- end loop;
- Finished := False;
- end loop;
- end Bold;
-
-
- begin
-
- Compress(Page);
- Format(Page);
- Spell_Check(Page);
- Bold(Page);
-
- for i in 1..Lines_Per_Page loop
- if BS_40.To_String(Page(i)) /= BS_40.To_String(Finished_Page(i)) or
- BS_40.Length(Page(i)) /= BS_40.Length(Finished_Page(i))
- then
- Report.Failed("Incorrect modification of Page, Line " &
- Integer'Image(i));
- end if;
- end loop;
-
-
- exception
- when others => Report.Failed ("Exception raised in Test_Block");
- end Test_Block;
-
-
- Report.Result;
-
-end CXA4006;
diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxa4007.a b/gcc/testsuite/ada/acats/tests/cxa/cxa4007.a
deleted file mode 100644
index fca15d367b5..00000000000
--- a/gcc/testsuite/ada/acats/tests/cxa/cxa4007.a
+++ /dev/null
@@ -1,334 +0,0 @@
--- CXA4007.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that the subprograms defined in package Ada.Strings.Bounded are
--- available, and that they produce correct results. Specifically, check
--- the subprograms Append, Count, Element, Find_Token, Head,
--- Index_Non_Blank, Replace_Element, Replicate, Tail, To_Bounded_String,
--- "&", ">", "<", ">=", "<=", and "*".
---
--- TEST DESCRIPTION:
--- This test, when taken in conjunction with tests CXA400[6,8,9], will
--- constitute a test of all the functionality contained in package
--- Ada.Strings.Bounded. This test uses a variety of the
--- subprograms defined in the bounded string package in ways typical
--- of common usage. Different combinations of available subprograms
--- are used to accomplish similar bounded string processing goals.
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 22 Dec 94 SAIC Changed obsolete constant to Ada.Strings.Space.
---
---!
-
-with Ada.Strings;
-with Ada.Strings.Bounded;
-with Ada.Strings.Maps;
-with Report;
-
-procedure CXA4007 is
-
-begin
-
- Report.Test ("CXA4007", "Check that the subprograms defined in package " &
- "Ada.Strings.Bounded are available, and that " &
- "they produce correct results");
-
- Test_Block:
- declare
-
- package BS80 is new Ada.Strings.Bounded.Generic_Bounded_Length(80);
- use type BS80.Bounded_String;
-
- Part1 : constant String := "Rum";
- Part2 : Character := 'p';
- Part3 : BS80.Bounded_String := BS80.To_Bounded_String("el");
- Part4 : Character := 's';
- Part5 : BS80.Bounded_String := BS80.To_Bounded_String("tilt");
- Part6 : String(1..3) := "ski";
-
- Full_Catenate_String,
- Full_Append_String,
- Constructed_String,
- Drop_String,
- Replicated_String,
- Token_String : BS80.Bounded_String;
-
- CharA : Character := 'A';
- CharB : Character := 'B';
- CharC : Character := 'C';
- CharD : Character := 'D';
- CharE : Character := 'E';
- CharF : Character := 'F';
-
- ABStr : String(1..15) := "AAAAABBBBBBBBBB";
- StrB : String(1..2) := "BB";
- StrE : String(1..2) := "EE";
-
-
- begin
-
- -- Evaluation of the overloaded forms of the "&" operator defined
- -- for instantiations of Bounded Strings.
-
- Full_Catenate_String :=
- BS80."&"(Part2, -- Char & Bnd Str
- BS80."&"(Part3, -- Bnd Str & Bnd Str
- BS80."&"(Part4, -- Char & Bnd Str
- BS80."&"(Part5, -- Bnd Str & Bnd Str
- BS80.To_Bounded_String(Part6)))));
-
- Full_Catenate_String :=
- Part1 & Full_Catenate_String; -- Str & Bnd Str
- Full_Catenate_String :=
- Full_Catenate_String & 'n'; -- Bnd Str & Char
-
-
- -- Evaluation of the overloaded forms of function Append.
-
- Full_Append_String :=
- BS80.Append(Part2, -- Char,Bnd
- BS80.Append(Part3, -- Bnd, Bnd
- BS80.Append(Part4, -- Char,Bnd
- BS80.Append(BS80.To_String(Part5), -- Str,Bnd
- BS80.To_Bounded_String(Part6)))));
-
- Full_Append_String :=
- BS80.Append(BS80.To_Bounded_String(Part1), -- Bnd , Str
- BS80.To_String(Full_Append_String));
-
- Full_Append_String :=
- BS80.Append(Left => Full_Append_String,
- Right => 'n'); -- Bnd, Char
-
-
- -- Validate the resulting bounded strings.
-
- if Full_Catenate_String < Full_Append_String or
- Full_Catenate_String > Full_Append_String or
- not (Full_Catenate_String = Full_Append_String and
- Full_Catenate_String <= Full_Append_String and
- Full_Catenate_String >= Full_Append_String)
- then
- Report.Failed("Incorrect results from bounded string catenation" &
- " and comparison");
- end if;
-
-
- -- Evaluate the overloaded forms of the Constructor function "*" and
- -- the Replicate function.
-
- Constructed_String :=
- (2 * CharA) & -- "AA"
- (2 * StrB) & -- "AABBBB"
- (3 * BS80."*"(2, CharC)) & -- "AABBBBCCCCCC"
- BS80.Replicate(3,
- BS80.Replicate(2, CharD)) & -- "AABBBBCCCCCCDDDDDD"
- BS80.Replicate(2, StrE) & -- "AABBBBCCCCCCDDDDDDEEEE"
- BS80.Replicate(2, CharF); -- "AABBBBCCCCCCDDDDDDEEEEFF"
-
-
- -- Use of Function Replicate that involves dropping characters. The
- -- attempt to replicate the 15 character string six times will exceed
- -- the 80 character bound of the string. Therefore, the result should
- -- be the catenation of 5 copies of the 15 character string, followed
- -- by 5 'A' characters (the first five characters of the 6th
- -- replication) with the remaining characters of the 6th replication
- -- dropped.
-
- Drop_String :=
- BS80.Replicate(Count => 6,
- Item => ABStr, -- "AAAAABBBBBBBBBB"
- Drop => Ada.Strings.Right);
-
- if BS80.Element(Drop_String, 1) /= 'A' or
- BS80.Element(Drop_String, 6) /= 'B' or
- BS80.Element(Drop_String, 76) /= 'A' or
- BS80.Element(Drop_String, 80) /= 'A'
- then
- Report.Failed("Incorrect result from Replicate with Drop");
- end if;
-
-
- -- Use function Index_Non_Blank in the evaluation of the
- -- Constructed_String.
-
- if BS80.Index_Non_Blank(Constructed_String, Ada.Strings.Forward) /=
- BS80.To_String(Constructed_String)'First or
- BS80.Index_Non_Blank(Constructed_String, Ada.Strings.Backward) /=
- BS80.Length(Constructed_String)
- then
- Report.Failed("Incorrect results from constructor functions");
- end if;
-
-
-
- declare
-
- -- Define character set objects for use with the Count function.
- -- Constructed_String = "AABBBBCCCCCCDDDDDDEEEEFF" from above.
-
- A_Set : Ada.Strings.Maps.Character_Set :=
- Ada.Strings.Maps.To_Set(BS80.Element(Constructed_String,1));
- B_Set : Ada.Strings.Maps.Character_Set :=
- Ada.Strings.Maps.To_Set(BS80.Element(Constructed_String,3));
- C_Set : Ada.Strings.Maps.Character_Set :=
- Ada.Strings.Maps.To_Set(BS80.Element(Constructed_String,7));
- D_Set : Ada.Strings.Maps.Character_Set :=
- Ada.Strings.Maps.To_Set(BS80.Element(Constructed_String,13));
- E_Set : Ada.Strings.Maps.Character_Set :=
- Ada.Strings.Maps.To_Set(BS80.Element(Constructed_String,19));
- F_Set : Ada.Strings.Maps.Character_Set :=
- Ada.Strings.Maps.To_Set(BS80.Element(Constructed_String,23));
-
-
- Start : Positive;
- Stop : Natural := 0;
-
- begin
-
- -- Evaluate the results from function Count by comparing the number
- -- of A's to the number of F's, B's to E's, and C's to D's in the
- -- Constructed_String.
- -- There should be an equal number of each of the characters that
- -- are being compared (i.e., 2 A's and F's, 4 B's and E's, etc)
-
- if BS80.Count(Constructed_String, A_Set) /=
- BS80.Count(Constructed_String, F_Set) or
- BS80.Count(Constructed_String, B_Set) /=
- BS80.Count(Constructed_String, E_Set) or
- not (BS80.Count(Constructed_String, C_Set) =
- BS80.Count(Constructed_String, D_Set))
- then
- Report.Failed("Incorrect result from function Count");
- end if;
-
-
- -- Evaluate the functions Head, Tail, and Find_Token.
- -- Create the Token_String from the Constructed_String above.
-
- Token_String :=
- BS80.Tail(BS80.Head(Constructed_String, 3), 2) & -- "AB" &
- BS80.Head(BS80.Tail(Constructed_String, 13), 2) & -- "CD" &
- BS80.Head(BS80.Tail(Constructed_String, 3), 2); -- "EF"
-
- if Token_String /= BS80.To_Bounded_String("ABCDEF") then
- Report.Failed("Incorrect result from Catenation of Token_String");
- end if;
-
-
- -- Find the starting/ending position of the first A in the
- -- Token_String (both should be 1, only one A appears in string).
- -- The Function Head uses the default pad character to return a
- -- bounded string longer than its input parameter bounded string.
-
- BS80.Find_Token(BS80.Head(Token_String, 10), -- Default pad.
- A_Set,
- Ada.Strings.Inside,
- Start,
- Stop);
-
- if Start /= 1 and Stop /= 1 then
- Report.Failed("Incorrect result from Find_Token - 1");
- end if;
-
-
- -- Find the starting/ending position of the first non-AB slice in
- -- the "head" five characters of Token_String (slice CDE at
- -- positions 3-5)
-
- BS80.Find_Token(BS80.Head(Token_String, 5), -- "ABCDE"
- Ada.Strings.Maps."OR"(A_Set, B_Set), -- Set (AB)
- Ada.Strings.Outside,
- Start,
- Stop);
-
- if Start /= 3 and Stop /= 5 then
- Report.Failed("Incorrect result from Find_Token - 2");
- end if;
-
-
- -- Find the starting/ending position of the first CD slice in
- -- the "tail" eight characters (including two pad characters)
- -- of Token_String (slice CD at positions 5-6 of the tail
- -- portion specified)
-
- BS80.Find_Token(BS80.Tail(Token_String, 8,
- Ada.Strings.Space), -- " ABCDEF"
- Ada.Strings.Maps."OR"(C_Set, D_Set), -- Set (CD)
- Ada.Strings.Inside,
- Start,
- Stop);
-
- if Start /= 5 and Stop /= 6 then
- Report.Failed("Incorrect result from Find_Token - 3");
- end if;
-
-
- -- Evaluate the Replace_Element procedure.
-
- -- Token_String = "ABCDEF"
-
- BS80.Replace_Element(Token_String, 3, BS80.Element(Token_String,4));
-
- -- Token_String = "ABDDEF"
-
- BS80.Replace_Element(Source => Token_String,
- Index => 2,
- By => BS80.Element(Token_String, 5));
-
- -- Token_String = "AEDDEF"
-
- BS80.Replace_Element(Token_String,
- 1,
- BS80.Element(BS80.Tail(Token_String, 2), 2));
-
- -- Token_String = "FEDDEF"
- -- Evaluate this result.
-
- if BS80.Element(Token_String, BS80.To_String(Token_String)'First) /=
- BS80.Element(Token_String, BS80.To_String(Token_String)'Last) or
- BS80.Count(Token_String, D_Set) /=
- BS80.Count(Token_String, E_Set) or
- BS80.Index_Non_Blank(BS80.Head(Token_String,6)) /=
- BS80.Index_Non_Blank(BS80.Tail(Token_String,6)) or
- BS80.Head(Token_String, 1) /=
- BS80.Tail(Token_String, 1)
- then
- Report.Failed("Incorrect result from operations in combination");
- end if;
-
- end;
-
- exception
- when others => Report.Failed ("Exception raised in Test_Block");
- end Test_Block;
-
-
- Report.Result;
-
-end CXA4007;
diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxa4008.a b/gcc/testsuite/ada/acats/tests/cxa/cxa4008.a
deleted file mode 100644
index 629305f767a..00000000000
--- a/gcc/testsuite/ada/acats/tests/cxa/cxa4008.a
+++ /dev/null
@@ -1,662 +0,0 @@
--- CXA4008.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that the subprograms defined in package Ada.Strings.Bounded are
--- available, and that they produce correct results, especially under
--- conditions where truncation of the result is required. Specifically,
--- check the subprograms Append, Count with non-Identity maps, Index with
--- non-Identity maps, Index with Set parameters, Insert (function and
--- procedure), Replace_Slice (function and procedure), To_Bounded_String,
--- and Translate.
---
--- TEST DESCRIPTION:
--- This test, in conjunction with tests CXA4006, CXA4007, and CXA4009,
--- will provide coverage of the most common usages of the functionality
--- found in the Ada.Strings.Bounded package. It deals in large part
--- with truncation effects and options. This test contains many small,
--- specific test cases, situations that are often difficult to generate
--- in large numbers in an application-based test. These cases represent
--- specific usage paradigms in-the-small.
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 10 Apr 95 SAIC Corrected acceptance condition of subtest for
--- Function Append with Truncation = Left.
--- 31 Oct 95 SAIC Update and repair for ACVC 2.0.1.
---
---!
-
-with Report;
-with Ada.Strings.Maps.Constants;
-with Ada.Strings.Bounded;
-with Ada.Strings.Maps;
-
-procedure CXA4008 is
-
-begin
-
- Report.Test("CXA4008", "Check that the subprograms defined in " &
- "package Ada.Strings.Bounded are available, " &
- "and that they produce correct results, " &
- "especially under conditions where " &
- "truncation of the result is required");
-
- Test_Block:
- declare
-
- package AS renames Ada.Strings;
- package ASB renames Ada.Strings.Bounded;
- package ASC renames Ada.Strings.Maps.Constants;
- package Maps renames Ada.Strings.Maps;
-
- package B10 is new ASB.Generic_Bounded_Length(Max => 10);
- use type B10.Bounded_String;
-
- Result_String : B10.Bounded_String;
- Test_String : B10.Bounded_String;
- AtoE_Bnd_Str : B10.Bounded_String := B10.To_Bounded_String("abcde");
- FtoJ_Bnd_Str : B10.Bounded_String := B10.To_Bounded_String("fghij");
- AtoJ_Bnd_Str : B10.Bounded_String :=
- B10.To_Bounded_String("abcdefghij");
-
- Location : Natural := 0;
- Total_Count : Natural := 0;
-
- CD_Set : Maps.Character_Set := Maps.To_Set("cd");
-
- AB_to_YZ_Map : Maps.Character_Mapping :=
- Maps.To_Mapping(From => "ab", To => "yz");
-
- CD_to_XY_Map : Maps.Character_Mapping :=
- Maps.To_Mapping(From => "cd", To => "xy");
-
-
- begin
- -- Function To_Bounded_String with Truncation
- -- Evaluate the function Append with parameters that will
- -- cause the truncation of the result.
-
- -- Drop = Error (default case, Length_Error will be raised)
-
- begin
- Test_String :=
- B10.To_Bounded_String("Much too long for this bounded string");
- Report.Failed("Length Error not raised by To_Bounded_String");
- exception
- when AS.Length_Error => null; -- Expected exception raised.
- when others =>
- Report.Failed("Incorrect exception raised by To_Bounded_String");
- end;
-
- -- Drop = Left
-
- Test_String := B10.To_Bounded_String(Source => "abcdefghijklmn",
- Drop => Ada.Strings.Left);
-
- if Test_String /= B10.To_Bounded_String("efghijklmn") then
- Report.Failed
- ("Incorrect result from To_Bounded_String, Drop = Left");
- end if;
-
- -- Drop = Right
-
- Test_String := B10.To_Bounded_String(Source => "abcdefghijklmn",
- Drop => Ada.Strings.Right);
-
- if not(Test_String = AtoJ_Bnd_Str) then
- Report.Failed
- ("Incorrect result from To_Bounded_String, Drop = Right");
- end if;
-
-
-
-
- -- Function Append with Truncation
- -- Evaluate the function Append with parameters that will
- -- cause the truncation of the result.
-
- -- Drop = Error (default case, Length_Error will be raised)
-
- begin
- -- Append (Bnd Str, Bnd Str);
- Result_String :=
- B10.Append(B10.To_Bounded_String("abcde"),
- B10.To_Bounded_String("fghijk")); -- 11 char
- Report.Failed("Length_Error not raised by Append - 1");
- exception
- when AS.Length_Error => null; -- OK, correct exception raised.
- when others =>
- Report.Failed("Incorrect exception raised by Append - 1");
- end;
-
- begin
- -- Append (Str, Bnd Str);
- Result_String := B10.Append(B10.To_String(AtoE_Bnd_Str),
- B10.To_Bounded_String("fghijk"),
- AS.Error);
- Report.Failed("Length_Error not raised by Append - 2");
- exception
- when AS.Length_Error => null; -- OK, correct exception raised.
- when others =>
- Report.Failed("Incorrect exception raised by Append - 2");
- end;
-
- begin
- -- Append (Bnd Str, Char);
- Result_String :=
- B10.Append(B10.To_Bounded_String("abcdefghij"), 'k');
- Report.Failed("Length_Error not raised by Append - 3");
- exception
- when AS.Length_Error => null; -- OK, correct exception raised.
- when others =>
- Report.Failed("Incorrect exception raised by Append - 3");
- end;
-
- -- Drop = Left
-
- -- Append (Bnd Str, Bnd Str)
- Result_String := B10.Append(B10.To_Bounded_String("abcdefgh"), -- 8 chs
- B10.To_Bounded_String("ijklmn"), -- 6 chs
- Ada.Strings.Left);
-
- if Result_String /= B10.To_Bounded_String("efghijklmn") then -- 10 chars
- Report.Failed("Incorrect truncation performed by Append - 4");
- end if;
-
- -- Append (Bnd Str, Str)
- Result_String :=
- B10.Append(B10.To_Bounded_String("abcdefghij"),
- "xyz",
- Ada.Strings.Left);
-
- if Result_String /= B10.To_Bounded_String("defghijxyz") then
- Report.Failed("Incorrect truncation performed by Append - 5");
- end if;
-
- -- Append (Char, Bnd Str)
-
- Result_String := B10.Append('A',
- B10.To_Bounded_String("abcdefghij"),
- Ada.Strings.Left);
-
- if Result_String /= B10.To_Bounded_String("abcdefghij") then
- Report.Failed("Incorrect truncation performed by Append - 6");
- end if;
-
- -- Drop = Right
-
- -- Append (Bnd Str, Bnd Str)
- Result_String := B10.Append(FtoJ_Bnd_Str,
- AtoJ_Bnd_Str,
- Ada.Strings.Right);
-
- if Result_String /= B10.To_Bounded_String("fghijabcde") then
- Report.Failed("Incorrect truncation performed by Append - 7");
- end if;
-
- -- Append (Str, Bnd Str)
- Result_String := B10.Append(B10.To_String(AtoE_Bnd_Str),
- AtoJ_Bnd_Str,
- Ada.Strings.Right);
-
- if Result_String /= B10.To_Bounded_String("abcdeabcde") then
- Report.Failed("Incorrect truncation performed by Append - 8");
- end if;
-
- -- Append (Char, Bnd Str)
- Result_String := B10.Append('A', AtoJ_Bnd_Str, Ada.Strings.Right);
-
- if Result_String /= B10.To_Bounded_String("Aabcdefghi") then
- Report.Failed("Incorrect truncation performed by Append - 9");
- end if;
-
-
- -- Function Index with non-Identity map.
- -- Evaluate the function Index with a non-identity map
- -- parameter which will cause mapping of the source parameter
- -- prior to the evaluation of the index position search.
-
- Location := B10.Index(Source => AtoJ_Bnd_Str, -- "abcdefghij"
- Pattern => "xy",
- Going => Ada.Strings.Forward,
- Mapping => CD_to_XY_Map); -- change "cd" to "xy"
-
- if Location /= 3 then
- Report.Failed("Incorrect result from Index, non-Identity map - 1");
- end if;
-
- Location := B10.Index(B10.To_Bounded_String("AND IF MAN"),
- "an",
- Ada.Strings.Backward,
- ASC.Lower_Case_Map);
-
- if Location /= 9 then
- Report.Failed("Incorrect result from Index, non-Identity map - 2");
- end if;
-
- Location := B10.Index(Source => B10.To_Bounded_String("The the"),
- Pattern => "the",
- Going => Ada.Strings.Forward,
- Mapping => ASC.Lower_Case_Map);
-
- if Location /= 1 then
- Report.Failed("Incorrect result from Index, non-Identity map - 3");
- end if;
-
-
- if B10.Index(B10.To_Bounded_String("abcd"), -- Pattern = Source
- "abcd") /= 1 or
- B10.Index(B10.To_Bounded_String("abc"), -- Pattern < Source
- "abcd") /= 0 or
- B10.Index(B10.Null_Bounded_String, -- Source = Null
- "abc") /= 0
- then
- Report.Failed("Incorrect result from Index with string patterns");
- end if;
-
-
- -- Function Index (for Sets).
- -- This version of Index uses Sets as the basis of the search.
-
- -- Test = Inside, Going = Forward (Default case).
- Location :=
- B10.Index(Source => B10.To_Bounded_String("abcdeabcde"),
- Set => CD_Set, -- set containing 'c' and 'd'
- Test => Ada.Strings.Inside,
- Going => Ada.Strings.Forward);
-
- if not (Location = 3) then -- position of first 'c' in source.
- Report.Failed("Incorrect result from Index using Sets - 1");
- end if;
-
- -- Test = Inside, Going = Backward.
- Location :=
- B10.Index(Source => B10."&"(AtoE_Bnd_Str, AtoE_Bnd_Str),
- Set => CD_Set, -- set containing 'c' and 'd'
- Test => Ada.Strings.Inside,
- Going => Ada.Strings.Backward);
-
- if not (Location = 9) then -- position of last 'd' in source.
- Report.Failed("Incorrect result from Index using Sets - 2");
- end if;
-
- -- Test = Outside, Going = Forward.
- Location := B10.Index(B10.To_Bounded_String("deddacd"),
- CD_Set,
- Test => Ada.Strings.Outside,
- Going => Ada.Strings.Forward);
-
- if Location /= 2 then -- position of 'e' in source.
- Report.Failed("Incorrect result from Index using Sets - 3");
- end if;
-
- -- Test = Outside, Going = Backward.
- Location := B10.Index(B10.To_Bounded_String("deddacd"),
- CD_Set,
- Ada.Strings.Outside,
- Ada.Strings.Backward);
-
- if Location /= 5 then -- correct position of 'a'.
- Report.Failed("Incorrect result from Index using Sets - 4");
- end if;
-
- if B10.Index(B10.To_Bounded_String("cd"), -- Source = Set
- CD_Set) /= 1 or
- B10.Index(B10.To_Bounded_String("c"), -- Source < Set
- CD_Set) /= 1 or
- B10.Index(B10.Null_Bounded_String, -- Source = Null
- CD_Set) /= 0 or
- B10.Index(AtoE_Bnd_Str, -- "abcde"
- Maps.Null_Set) /= 0 or -- Null set
- B10.Index(AtoE_Bnd_Str,
- Maps.To_Set('x')) /= 0 -- No match.
- then
- Report.Failed("Incorrect result from Index using Sets - 5");
- end if;
-
-
- -- Function Count with non-Identity mapping.
- -- Evaluate the function Count with a non-identity map
- -- parameter which will cause mapping of the source parameter
- -- prior to the evaluation of the number of matching patterns.
-
- Total_Count :=
- B10.Count(Source => B10.To_Bounded_String("abbabaabab"),
- Pattern => "yz",
- Mapping => AB_to_YZ_Map);
-
- if Total_Count /= 4 then
- Report.Failed
- ("Incorrect result from function Count, non-Identity map - 1");
- end if;
-
- -- And a few with identity maps as well.
-
- if B10.Count(B10.To_Bounded_String("ABABABABAB"),
- "ABA",
- Maps.Identity) /= 2 or
- B10.Count(B10.To_Bounded_String("ADCBADABCD"),
- "AB",
- Maps.To_Mapping("CD", "AB")) /= 5 or
- B10.Count(B10.To_Bounded_String("aaaaaaaaaa"),
- "aaa") /= 3 or
- B10.Count(B10.To_Bounded_String("XX"), -- Source < Pattern
- "XXX",
- Maps.Identity) /= 0 or
- B10.Count(AtoE_Bnd_Str, -- Source = Pattern
- "abcde") /= 1 or
- B10.Count(B10.Null_Bounded_String, -- Source = Null
- " ") /= 0
- then
- Report.Failed
- ("Incorrect result from function Count, w,w/o mapping");
- end if;
-
-
- -- Procedure Translate
-
- -- Partial mapping of source.
-
- Test_String := B10.To_Bounded_String("abcdeabcab");
-
- B10.Translate(Source => Test_String, Mapping => AB_to_YZ_Map);
-
- if Test_String /= B10.To_Bounded_String("yzcdeyzcyz") then
- Report.Failed("Incorrect result from procedure Translate - 1");
- end if;
-
- -- Total mapping of source.
-
- Test_String := B10.To_Bounded_String("abbaaababb");
-
- B10.Translate(Source => Test_String, Mapping => ASC.Upper_Case_Map);
-
- if Test_String /= B10.To_Bounded_String("ABBAAABABB") then
- Report.Failed("Incorrect result from procedure Translate - 2");
- end if;
-
- -- No mapping of source.
-
- Test_String := B10.To_Bounded_String("xyzsypcc");
-
- B10.Translate(Source => Test_String, Mapping => AB_to_YZ_Map);
-
- if Test_String /= B10.To_Bounded_String("xyzsypcc") then
- Report.Failed("Incorrect result from procedure Translate - 3");
- end if;
-
- -- Map > 2 characters, partial mapping.
-
- Test_String := B10.To_Bounded_String("have faith");
-
- B10.Translate(Test_String,
- Maps.To_Mapping("aeiou", "AEIOU"));
-
- if Test_String /= B10.To_Bounded_String("hAvE fAIth") then
- Report.Failed("Incorrect result from procedure Translate - 4");
- end if;
-
-
- -- Function Replace_Slice
- -- Evaluate function Replace_Slice with
- -- a variety of Truncation options.
-
- -- Drop = Error (Default)
-
- begin
- Test_String := AtoJ_Bnd_Str;
- Result_String :=
- B10.Replace_Slice(Source => Test_String, -- "abcdefghij"
- Low => 3,
- High => 5, -- 3-5, 3 chars.
- By => "xxxxxx"); -- more than 3.
- Report.Failed("Length_Error not raised by Function Replace_Slice");
- exception
- when AS.Length_Error => null; -- Correct exception raised.
- when others =>
- Report.Failed
- ("Incorrect exception raised by Function Replace_Slice");
- end;
-
- -- Drop = Left
-
- Result_String :=
- B10.Replace_Slice(Source => Test_String, -- "abcdefghij"
- Low => 7,
- High => 10, -- 7-10, 4 chars.
- By => "xxxxxx", -- 6 chars.
- Drop => Ada.Strings.Left);
-
- if Result_String /= B10.To_Bounded_String("cdefxxxxxx") then -- drop a,b
- Report.Failed
- ("Incorrect result from Function Replace Slice, Drop = Left");
- end if;
-
- -- Drop = Right
-
- Result_String :=
- B10.Replace_Slice(Source => Test_String, -- "abcdefghij"
- Low => 2,
- High => 5, -- 2-5, 4 chars.
- By => "xxxxxx", -- 6 chars.
- Drop => Ada.Strings.Right);
-
- if Result_String /= B10.To_Bounded_String("axxxxxxfgh") then -- drop i,j
- Report.Failed
- ("Incorrect result from Function Replace Slice, Drop = Right");
- end if;
-
- -- Low = High = Source'Last, "By" length = 1.
-
- if B10.Replace_Slice(AtoE_Bnd_Str,
- B10.To_String(AtoE_Bnd_Str)'Last,
- B10.To_String(AtoE_Bnd_Str)'Last,
- "X",
- Ada.Strings.Error) /=
- B10.To_Bounded_String("abcdX")
- then
- Report.Failed("Incorrect result from Function Replace_Slice");
- end if;
-
-
-
- -- Procedure Replace_Slice
- -- Evaluate procedure Replace_Slice with
- -- a variety of Truncation options.
-
- -- Drop = Error (Default)
-
- begin
- Test_String := AtoJ_Bnd_Str;
- B10.Replace_Slice(Source => Test_String, -- "abcdefghij"
- Low => 3,
- High => 5, -- 3-5, 3 chars.
- By => "xxxxxx"); -- more than 3.
- Report.Failed("Length_Error not raised by Procedure Replace_Slice");
- exception
- when AS.Length_Error => null; -- Correct exception raised.
- when others =>
- Report.Failed
- ("Incorrect exception raised by Procedure Replace_Slice");
- end;
-
- -- Drop = Left
-
- Test_String := AtoJ_Bnd_Str;
- B10.Replace_Slice(Source => Test_String, -- "abcdefghij"
- Low => 7,
- High => 9, -- 7-9, 3 chars.
- By => "xxxxx", -- 5 chars.
- Drop => Ada.Strings.Left);
-
- if Test_String /= B10.To_Bounded_String("cdefxxxxxj") then -- drop a,b
- Report.Failed
- ("Incorrect result from Procedure Replace Slice, Drop = Left");
- end if;
-
- -- Drop = Right
-
- Test_String := AtoJ_Bnd_Str;
- B10.Replace_Slice(Source => Test_String, -- "abcdefghij"
- Low => 1,
- High => 3, -- 1-3, 3chars.
- By => "xxxx", -- 4 chars.
- Drop => Ada.Strings.Right);
-
- if Test_String /= B10.To_Bounded_String("xxxxdefghi") then -- drop j
- Report.Failed
- ("Incorrect result from Procedure Replace Slice, Drop = Right");
- end if;
-
- -- High = Source'First, Low > High (Insert before Low).
-
- Test_String := AtoE_Bnd_Str;
- B10.Replace_Slice(Source => Test_String, -- "abcde"
- Low => B10.To_String(Test_String)'Last,
- High => B10.To_String(Test_String)'First,
- By => "XXXX", -- 4 chars.
- Drop => Ada.Strings.Right);
-
- if Test_String /= B10.To_Bounded_String("abcdXXXXe") then
- Report.Failed
- ("Incorrect result from Procedure Replace Slice");
- end if;
-
-
-
- -- Function Insert with Truncation
- -- Drop = Error (Default).
-
- begin
- Result_String :=
- B10.Insert(Source => AtoJ_Bnd_Str, -- "abcdefghij"
- Before => 2,
- New_Item => "xyz");
- Report.Failed("Length_Error not raised by Function Insert");
- exception
- when AS.Length_Error => null; -- Correct exception raised.
- when others =>
- Report.Failed("Incorrect exception raised by Function Insert");
- end;
-
- -- Drop = Left
-
- Result_String :=
- B10.Insert(Source => AtoJ_Bnd_Str, -- "abcdefghij"
- Before => 5,
- New_Item => "xyz", -- 3 additional chars.
- Drop => Ada.Strings.Left);
-
- if B10.To_String(Result_String) /= "dxyzefghij" then -- drop a, b, c
- Report.Failed("Incorrect result from Function Insert, Drop = Left");
- end if;
-
- -- Drop = Right
-
- Result_String :=
- B10.Insert(Source => B10.To_Bounded_String("abcdef"),
- Before => 2,
- New_Item => "vwxyz", -- 5 additional chars.
- Drop => Ada.Strings.Right);
-
- if B10.To_String(Result_String) /= "avwxyzbcde" then -- drop f.
- Report.Failed("Incorrect result from Function Insert, Drop = Right");
- end if;
-
- -- Additional cases.
-
- if B10.Insert(B10.To_Bounded_String("a"), 1, " B") /=
- B10.To_Bounded_String(" Ba") or
- B10.Insert(B10.Null_Bounded_String, 1, "abcde") /=
- AtoE_Bnd_Str or
- B10.Insert(B10.To_Bounded_String("ab"), 2, "") /=
- B10.To_Bounded_String("ab")
- then
- Report.Failed("Incorrect result from Function Insert");
- end if;
-
-
- -- Procedure Insert
-
- -- Drop = Error (Default).
- begin
- Test_String := AtoJ_Bnd_Str;
- B10.Insert(Source => Test_String, -- "abcdefghij"
- Before => 9,
- New_Item => "wxyz",
- Drop => Ada.Strings.Error);
- Report.Failed("Length_Error not raised by Procedure Insert");
- exception
- when AS.Length_Error => null; -- Correct exception raised.
- when others =>
- Report.Failed("Incorrect exception raised by Procedure Insert");
- end;
-
- -- Drop = Left
-
- Test_String := AtoJ_Bnd_Str;
- B10.Insert(Source => Test_String, -- "abcdefghij"
- Before => B10.Length(Test_String), -- before last char
- New_Item => "xyz", -- 3 additional chars.
- Drop => Ada.Strings.Left);
-
- if B10.To_String(Test_String) /= "defghixyzj" then -- drop a, b, c
- Report.Failed("Incorrect result from Procedure Insert, Drop = Left");
- end if;
-
- -- Drop = Right
-
- Test_String := AtoJ_Bnd_Str;
- B10.Insert(Source => Test_String,
- Before => 4,
- New_Item => "yz", -- 2 additional chars.
- Drop => Ada.Strings.Right);
-
- if B10.To_String(Test_String) /= "abcyzdefgh" then -- drop i,j
- Report.Failed
- ("Incorrect result from Procedure Insert, Drop = Right");
- end if;
-
- -- Before = Source'First, New_Item length = 1.
-
- Test_String := B10.To_Bounded_String(" abc ");
- B10.Insert(Test_String,
- B10.To_String(Test_String)'First,
- "Z");
-
- if Test_String /= B10.To_Bounded_String("Z abc ") then
- Report.Failed("Incorrect result from Procedure Insert");
- end if;
-
-
- exception
- when others => Report.Failed("Exception raised in Test_Block");
- end Test_Block;
-
- Report.Result;
-
-end CXA4008;
diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxa4009.a b/gcc/testsuite/ada/acats/tests/cxa/cxa4009.a
deleted file mode 100644
index f02ef036507..00000000000
--- a/gcc/testsuite/ada/acats/tests/cxa/cxa4009.a
+++ /dev/null
@@ -1,619 +0,0 @@
--- CXA4009.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that the subprograms defined in package Ada.Strings.Bounded are
--- available, and that they produce correct results, especially under
--- conditions where truncation of the result is required. Specifically,
--- check the subprograms Overwrite (function and procedure), Delete,
--- Function Trim (blanks), Trim (Set characters, function and procedure),
--- Head, Tail, and Replicate (characters and strings).
---
--- TEST DESCRIPTION:
--- This test, in conjunction with tests CXA4006, CXA4007, and CXA4008,
--- will provide coverage of the most common usages of the functionality
--- found in the Ada.Strings.Bounded package. It deals in large part
--- with truncation effects and options. This test contains many small,
--- specific test cases, situations that are often difficult to generate
--- in large numbers in an application-based test. These cases represent
--- specific usage paradigms in-the-small.
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 10 Apr 95 SAIC Corrected errors in Procedure Overwrite subtests.
--- 01 Nov 95 SAIC Fixed bugs for ACVC 2.0.1.
---
---!
-
-with Report;
-with Ada.Strings.Bounded;
-with Ada.Strings.Maps;
-
-procedure CXA4009 is
-
-begin
-
- Report.Test("CXA4009", "Check that the subprograms defined in " &
- "package Ada.Strings.Bounded are available, " &
- "and that they produce correct results, " &
- "especially under conditions where " &
- "truncation of the result is required");
-
- Test_Block:
- declare
-
- package AS renames Ada.Strings;
- package ASB renames Ada.Strings.Bounded;
- package Maps renames Ada.Strings.Maps;
-
- package B10 is new ASB.Generic_Bounded_Length(Max => 10);
- use type B10.Bounded_String;
-
- Result_String : B10.Bounded_String;
- Test_String : B10.Bounded_String;
- AtoE_Bnd_Str : B10.Bounded_String := B10.To_Bounded_String("abcde");
- FtoJ_Bnd_Str : B10.Bounded_String := B10.To_Bounded_String("fghij");
- AtoJ_Bnd_Str : B10.Bounded_String :=
- B10.To_Bounded_String("abcdefghij");
-
- Location : Natural := 0;
- Total_Count : Natural := 0;
-
- CD_Set : Maps.Character_Set := Maps.To_Set("cd");
- XY_Set : Maps.Character_Set := Maps.To_Set("xy");
-
-
- begin
-
- -- Function Overwrite with Truncation
- -- Drop = Error (Default).
-
- begin
- Test_String := AtoJ_Bnd_Str;
- Result_String :=
- B10.Overwrite(Source => Test_String, -- "abcdefghij"
- Position => 9,
- New_Item => "xyz",
- Drop => AS.Error);
- Report.Failed("Exception not raised by Function Overwrite");
- exception
- when AS.Length_Error => null; -- Expected exception raised.
- when others =>
- Report.Failed("Incorrect exception raised by Function Overwrite");
- end;
-
- -- Drop = Left
-
- Result_String :=
- B10.Overwrite(Source => Test_String, -- "abcdefghij"
- Position => B10.Length(Test_String), -- 10
- New_Item => "xyz",
- Drop => Ada.Strings.Left);
-
- if B10.To_String(Result_String) /= "cdefghixyz" then -- drop a,b
- Report.Failed
- ("Incorrect result from Function Overwrite, Drop = Left");
- end if;
-
- -- Drop = Right
-
- Result_String := B10.Overwrite(Test_String, -- "abcdefghij"
- 3,
- "xxxyyyzzz",
- Ada.Strings.Right);
-
- if B10.To_String(Result_String) /= "abxxxyyyzz" then -- one 'z' dropped
- Report.Failed
- ("Incorrect result from Function Overwrite, Drop = Right");
- end if;
-
- -- Additional cases of function Overwrite.
-
- if B10.Overwrite(B10.To_Bounded_String("a"), -- Source length = 1
- 1,
- " abc ") /=
- B10.To_Bounded_String(" abc ") or
- B10.Overwrite(B10.Null_Bounded_String, -- Null source
- 1,
- "abcdefghij") /=
- AtoJ_Bnd_Str or
- B10.Overwrite(AtoE_Bnd_Str,
- B10.To_String(AtoE_Bnd_Str)'First,
- " ") /= -- New_Item = 1
- B10.To_Bounded_String(" bcde")
- then
- Report.Failed("Incorrect result from Function Overwrite");
- end if;
-
-
-
- -- Procedure Overwrite
- -- Correct usage, no truncation.
-
- Test_String := AtoE_Bnd_Str; -- "abcde"
- B10.Overwrite(Test_String, 2, "xyz");
-
- if Test_String /= B10.To_Bounded_String("axyze") then
- Report.Failed("Incorrect result from Procedure Overwrite - 1");
- end if;
-
- Test_String := B10.To_Bounded_String("abc");
- B10.Overwrite(Test_String, 2, ""); -- New_Item is null string.
-
- if Test_String /= B10.To_Bounded_String("abc") then
- Report.Failed("Incorrect result from Procedure Overwrite - 2");
- end if;
-
- -- Drop = Error (Default).
-
- begin
- Test_String := AtoJ_Bnd_Str;
- B10.Overwrite(Source => Test_String, -- "abcdefghij"
- Position => 8,
- New_Item => "uvwxyz");
- Report.Failed("Exception not raised by Procedure Overwrite");
- exception
- when AS.Length_Error => null; -- Expected exception raised.
- when others =>
- Report.Failed("Incorrect exception raised by Procedure Overwrite");
- end;
-
- -- Drop = Left
-
- Test_String := AtoJ_Bnd_Str;
- B10.Overwrite(Source => Test_String, -- "abcdefghij"
- Position => B10.Length(Test_String) - 2, -- 8
- New_Item => "uvwxyz",
- Drop => Ada.Strings.Left);
-
- if B10.To_String(Test_String) /= "defguvwxyz" then -- drop a-c
- Report.Failed
- ("Incorrect result from Procedure Overwrite, Drop = Left");
- end if;
-
- -- Drop = Right
-
- Test_String := AtoJ_Bnd_Str;
- B10.Overwrite(Test_String, -- "abcdefghij"
- 3,
- "xxxyyyzzz",
- Ada.Strings.Right);
-
- if B10.To_String(Test_String) /= "abxxxyyyzz" then -- one 'z' dropped
- Report.Failed
- ("Incorrect result from Procedure Overwrite, Drop = Right");
- end if;
-
-
-
- -- Function Delete
-
- if B10.Delete(Source => AtoJ_Bnd_Str, -- "abcdefghij"
- From => 3,
- Through => 8) /=
- B10."&"(B10.Head(AtoJ_Bnd_Str, 2),
- B10.Tail(AtoJ_Bnd_Str, 2)) or
- B10.Delete(AtoJ_Bnd_Str, 6, B10.Length(AtoJ_Bnd_Str)) /=
- AtoE_Bnd_Str or
- B10.Delete(AtoJ_Bnd_Str, 1, 5) /=
- FtoJ_Bnd_Str or
- B10.Delete(AtoE_Bnd_Str, 4, 5) /=
- B10.Delete(AtoJ_Bnd_Str, 4, B10.Length(AtoJ_Bnd_Str))
- then
- Report.Failed("Incorrect result from Function Delete - 1");
- end if;
-
- if B10.Delete(B10.To_Bounded_String("a"), 1, 1) /=
- B10.Null_Bounded_String or
- B10.Delete(AtoE_Bnd_Str,
- 5,
- B10.To_String(AtoE_Bnd_Str)'First) /=
- AtoE_Bnd_Str or
- B10.Delete(AtoE_Bnd_Str,
- B10.To_String(AtoE_Bnd_Str)'Last,
- B10.To_String(AtoE_Bnd_Str)'Last) /=
- B10.To_Bounded_String("abcd")
- then
- Report.Failed("Incorrect result from Function Delete - 2");
- end if;
-
-
-
- -- Function Trim
-
- declare
-
- Text : B10.Bounded_String := B10.To_Bounded_String("Text");
- type Bnd_Array_Type is array (1..5) of B10.Bounded_String;
- Bnd_Array : Bnd_Array_Type :=
- (B10.To_Bounded_String(" Text"),
- B10.To_Bounded_String("Text "),
- B10.To_Bounded_String(" Text "),
- B10.To_Bounded_String("Text Text"), -- Ensure no inter-string
- B10.To_Bounded_String(" Text Text")); -- trimming of blanks.
-
- begin
-
- for i in Bnd_Array_Type'Range loop
- case i is
- when 4 =>
- if B10.Trim(Bnd_Array(i), AS.Both) /=
- Bnd_Array(i) then -- no change
- Report.Failed("Incorrect result from Function Trim - 4");
- end if;
- when 5 =>
- if B10.Trim(Bnd_Array(i), AS.Both) /=
- B10."&"(Text, B10."&"(' ', Text)) then
- Report.Failed("Incorrect result from Function Trim - 5");
- end if;
- when others =>
- if B10.Trim(Bnd_Array(i), AS.Both) /= Text then
- Report.Failed("Incorrect result from Function Trim - " &
- Integer'Image(i));
- end if;
- end case;
- end loop;
-
- end;
-
-
-
- -- Function Trim using Sets
-
- -- Trim characters in sets from both sides of the bounded string.
- if B10.Trim(Source => B10.To_Bounded_String("ddabbaxx"),
- Left => CD_Set,
- Right => XY_Set) /=
- B10.To_Bounded_String("abba")
- then
- Report.Failed
- ("Incorrect result from Fn Trim - Sets, Left & Right side - 1");
- end if;
-
- -- Ensure that the characters in the set provided as the actual to
- -- parameter Right are not trimmed from the left side of the bounded
- -- string; likewise for the opposite side. Only "cd" trimmed from left
- -- side, and only "xy" trimmed from right side.
-
- if B10.Trim(B10.To_Bounded_String("cdxyabcdxy"), CD_Set, XY_Set) /=
- B10.To_Bounded_String("xyabcd")
- then
- Report.Failed
- ("Incorrect result from Fn Trim - Sets, Left & Right side - 2");
- end if;
-
- -- Ensure that characters contained in the sets are not trimmed from
- -- the "interior" of the bounded string, just the appropriate ends.
-
- if B10.Trim(B10.To_Bounded_String("cdabdxabxy"), CD_Set, XY_Set) /=
- B10.To_Bounded_String("abdxab")
- then
- Report.Failed
- ("Incorrect result from Fn Trim - Sets, Left & Right side - 3");
- end if;
-
- -- Trim characters in set from right side only. No change to Left side.
-
- if B10.Trim(B10.To_Bounded_String("abxyzddcd"), XY_Set, CD_Set) /=
- B10.To_Bounded_String("abxyz")
- then
- Report.Failed
- ("Incorrect result from Fn Trim - Sets, Right side");
- end if;
-
- -- Trim no characters on either side of the bounded string.
-
- Result_String := B10.Trim(AtoJ_Bnd_Str, CD_Set, XY_Set);
- if Result_String /= AtoJ_Bnd_Str then
- Report.Failed("Incorrect result from Fn Trim - Sets, Neither side");
- end if;
-
- if B10.Trim(AtoE_Bnd_Str, Maps.Null_Set, Maps.Null_Set) /=
- AtoE_Bnd_Str or
- B10.Trim(B10.To_Bounded_String("dcddcxyyxx"),
- CD_Set,
- XY_Set) /=
- B10.Null_Bounded_String
- then
- Report.Failed("Incorrect result from Function Trim");
- end if;
-
-
-
- -- Procedure Trim using Sets
-
- -- Trim characters in sets from both sides of the bounded string.
-
- Test_String := B10.To_Bounded_String("dcabbayx");
- B10.Trim(Source => Test_String,
- Left => CD_Set,
- Right => XY_Set);
-
- if Test_String /= B10.To_Bounded_String("abba") then
- Report.Failed
- ("Incorrect result from Proc Trim - Sets, Left & Right side - 1");
- end if;
-
- -- Ensure that the characters in the set provided as the actual to
- -- parameter Right are not trimmed from the left side of the bounded
- -- string; likewise for the opposite side. Only "cd" trimmed from left
- -- side, and only "xy" trimmed from right side.
-
- Test_String := B10.To_Bounded_String("cdxyabcdxy");
- B10.Trim(Test_String, CD_Set, XY_Set);
-
- if Test_String /= B10.To_Bounded_String("xyabcd") then
- Report.Failed
- ("Incorrect result from Proc Trim - Sets, Left & Right side - 2");
- end if;
-
- -- Ensure that characters contained in the sets are not trimmed from
- -- the "interior" of the bounded string, just the appropriate ends.
-
- Test_String := B10.To_Bounded_String("cdabdxabxy");
- B10.Trim(Test_String, CD_Set, XY_Set);
-
- if not (Test_String = B10.To_Bounded_String("abdxab")) then
- Report.Failed
- ("Incorrect result from Proc Trim - Sets, Left & Right side - 3");
- end if;
-
- -- Trim characters in set from Left side only. No change to Right side.
-
- Test_String := B10.To_Bounded_String("cccdabxyz");
- B10.Trim(Test_String, CD_Set, XY_Set);
-
- if Test_String /= B10.To_Bounded_String("abxyz") then
- Report.Failed
- ("Incorrect result from Proc Trim for Sets, Left side only");
- end if;
-
- -- Trim no characters on either side of the bounded string.
-
- Test_String := AtoJ_Bnd_Str;
- B10.Trim(Test_String, CD_Set, CD_Set);
-
- if Test_String /= AtoJ_Bnd_Str then
- Report.Failed("Incorrect result from Proc Trim-Sets, Neither side");
- end if;
-
-
-
- -- Function Head with Truncation
- -- Drop = Error (Default).
-
- begin
- Result_String := B10.Head(Source => AtoJ_Bnd_Str, -- max length
- Count => B10.Length(AtoJ_Bnd_Str) + 1,
- Pad => 'X');
- Report.Failed("Length_Error not raised by Function Head");
- exception
- when AS.Length_Error => null; -- Expected exception raised.
- when others =>
- Report.Failed("Incorrect exception raised by Function Head");
- end;
-
- -- Drop = Left
-
- -- Pad characters (5) are appended to the right end of the string
- -- (which is initially at its maximum length), then the first five
- -- characters of the intermediate result are dropped to conform to
- -- the maximum size limit of the bounded string (10).
-
- Result_String := B10.Head(B10.To_Bounded_String("ABCDEFGHIJ"),
- 15,
- 'x',
- Ada.Strings.Left);
-
- if Result_String /= B10.To_Bounded_String("FGHIJxxxxx") then
- Report.Failed("Incorrect result from Function Head, Drop = Left");
- end if;
-
- -- Drop = Right
-
- -- Pad characters (6) are appended to the left end of the string
- -- (which is initially at one less than its maximum length), then the
- -- last five characters of the intermediate result are dropped
- -- (which in this case are the pad characters) to conform to the
- -- maximum size limit of the bounded string (10).
-
- Result_String := B10.Head(B10.To_Bounded_String("ABCDEFGHI"),
- 15,
- 'x',
- Ada.Strings.Right);
-
- if Result_String /= B10.To_Bounded_String("ABCDEFGHIx") then
- Report.Failed("Incorrect result from Function Head, Drop = Right");
- end if;
-
- -- Additional cases.
-
- if B10.Head(B10.Null_Bounded_String, 5) /=
- B10.To_Bounded_String(" ") or
- B10.Head(AtoE_Bnd_Str,
- B10.Length(AtoE_Bnd_Str)) /=
- AtoE_Bnd_Str
- then
- Report.Failed("Incorrect result from Function Head");
- end if;
-
-
-
- -- Function Tail with Truncation
- -- Drop = Error (Default Case)
-
- begin
- Result_String := B10.Tail(Source => AtoJ_Bnd_Str, -- max length
- Count => B10.Length(AtoJ_Bnd_Str) + 1,
- Pad => Ada.Strings.Space,
- Drop => Ada.Strings.Error);
- Report.Failed("Length_Error not raised by Function Tail");
- exception
- when AS.Length_Error => null; -- Expected exception raised.
- when others =>
- Report.Failed("Incorrect exception raised by Function Tail");
- end;
-
- -- Drop = Left
-
- -- Pad characters (5) are appended to the left end of the string
- -- (which is initially at two less than its maximum length), then
- -- the first three characters of the intermediate result (in this
- -- case, 3 pad characters) are dropped.
-
- Result_String := B10.Tail(B10.To_Bounded_String("ABCDEFGH"), -- 8 ch
- 13,
- 'x',
- Ada.Strings.Left);
-
- if Result_String /= B10.To_Bounded_String("xxABCDEFGH") then
- Report.Failed("Incorrect result from Function Tail, Drop = Left");
- end if;
-
- -- Drop = Right
-
- -- Pad characters (3) are appended to the left end of the string
- -- (which is initially at its maximum length), then the last three
- -- characters of the intermediate result are dropped.
-
- Result_String := B10.Tail(B10.To_Bounded_String("ABCDEFGHIJ"),
- 13,
- 'x',
- Ada.Strings.Right);
-
- if Result_String /= B10.To_Bounded_String("xxxABCDEFG") then
- Report.Failed("Incorrect result from Function Tail, Drop = Right");
- end if;
-
- -- Additional cases.
-
- if B10.Tail(B10.Null_Bounded_String, 3, ' ') /=
- B10.To_Bounded_String(" ") or
- B10.Tail(AtoE_Bnd_Str,
- B10.To_String(AtoE_Bnd_Str)'First) /=
- B10.To_Bounded_String("e")
- then
- Report.Failed("Incorrect result from Function Tail");
- end if;
-
-
-
- -- Function Replicate (#, Char) with Truncation
- -- Drop = Error (Default).
-
- begin
- Result_String := B10.Replicate(Count => B10.Max_Length + 5,
- Item => 'A',
- Drop => AS.Error);
- Report.Failed
- ("Length_Error not raised by Replicate for characters");
- exception
- when AS.Length_Error => null; -- Expected exception raised.
- when others =>
- Report.Failed
- ("Incorrect exception raised by Replicate for characters");
- end;
-
- -- Drop = Left, Right
- -- Since this version of Replicate uses character parameters, the
- -- result after truncation from left or right will appear the same.
- -- The result will be a 10 character bounded string, composed of 10
- -- "Item" characters.
-
- if B10.Replicate(Count => 20, Item => 'A', Drop => Ada.Strings.Left) /=
- B10.Replicate(15, 'A', Ada.Strings.Right)
- then
- Report.Failed("Incorrect result from Replicate for characters - 1");
- end if;
-
- -- Blank-filled 10 character bounded strings.
-
- if B10.Replicate(B10.Max_Length + 1, ' ', Drop => Ada.Strings.Left) /=
- B10.Replicate(B10.Max_Length, Ada.Strings.Space)
- then
- Report.Failed("Incorrect result from Replicate for characters - 2");
- end if;
-
- -- Additional cases.
-
- if B10.Replicate(0, 'a') /= B10.Null_Bounded_String or
- B10.Replicate(1, 'a') /= B10.To_Bounded_String("a")
- then
- Report.Failed("Incorrect result from Replicate for characters - 3");
- end if;
-
-
-
- -- Function Replicate (#, String) with Truncation
- -- Drop = Error (Default).
-
- begin
- Result_String := B10.Replicate(Count => 5, -- result would be 15.
- Item => "abc");
- Report.Failed
- ("Length_Error not raised by Replicate for strings");
- exception
- when AS.Length_Error => null; -- Expected exception raised.
- when others =>
- Report.Failed
- ("Incorrect exception raised by Replicate for strings");
- end;
-
- -- Drop = Left
-
- Result_String := B10.Replicate(3, "abcd", Drop => Ada.Strings.Left);
-
- if Result_String /= B10.To_Bounded_String("cdabcdabcd") then
- Report.Failed
- ("Incorrect result from Replicate for strings, Drop = Left");
- end if;
-
- -- Drop = Right
-
- Result_String := B10.Replicate(3, "abcd", Drop => Ada.Strings.Right);
-
- if Result_String /= B10.To_Bounded_String("abcdabcdab") then
- Report.Failed
- ("Incorrect result from Replicate for strings, Drop = Right");
- end if;
-
- -- Additional cases.
-
- if B10.Replicate(10, "X") /= B10.To_Bounded_String("XXXXXXXXXX") or
- B10.Replicate(10, "") /= B10.Null_Bounded_String or
- B10.Replicate( 0, "ab") /= B10.Null_Bounded_String
- then
- Report.Failed("Incorrect result from Replicate for strings");
- end if;
-
-
- exception
- when others => Report.Failed("Exception raised in Test_Block");
- end Test_Block;
-
- Report.Result;
-
-end CXA4009;
diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxa4010.a b/gcc/testsuite/ada/acats/tests/cxa/cxa4010.a
deleted file mode 100644
index 8646b12b5e4..00000000000
--- a/gcc/testsuite/ada/acats/tests/cxa/cxa4010.a
+++ /dev/null
@@ -1,275 +0,0 @@
--- CXA4010.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that the subprograms defined in package Ada.Strings.Unbounded
--- are available, and that they produce correct results. Specifically,
--- check the subprograms To_String, To_Unbounded_String, Insert, "&",
--- "*", Length, Slice, Replace_Slice, Overwrite, Index, Index_Non_Blank,
--- Head, Tail, and "=", "<=", ">=".
---
--- TEST DESCRIPTION:
--- This test demonstrates the uses of many of the subprograms defined
--- in package Ada.Strings.Unbounded for use with unbounded strings.
--- The test simulates how unbounded strings could be used
--- to simulate paragraphs of text. Modifications could be easily be
--- performed using the provided subprograms (although in this test, the
--- main modification performed was the addition of more text to the
--- string). One would not have to worry about the formatting of the
--- paragraph until it was finished and correct in content. Then, once
--- all required editing is complete, the unbounded strings can be divided
--- up into the appropriate lengths based on particular formatting
--- requirements. The test then compares the formatted text product
--- with a predefined "finished product".
---
--- This test uses a large number of the subprograms provided
--- by package Ada.Strings.Unbounded. Often, the processing involved
--- could have been performed more efficiently using a minimum number
--- of the subprograms, in conjunction with loops, etc. However, for
--- testing purposes, and in the interest of minimizing the number of
--- tests developed, subprogram variety and feature mixing was stressed.
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
---
---!
-
-with Report;
-with Ada.Strings.Maps;
-with Ada.Strings.Unbounded;
-
-procedure CXA4010 is
-begin
-
- Report.Test ("CXA4010", "Check that the subprograms defined in " &
- "package Ada.Strings.Unbounded are available, " &
- "and that they produce correct results");
-
- Test_Block:
- declare
-
- package ASUnb renames Ada.Strings.Unbounded;
- use type ASUnb.Unbounded_String;
- use Ada.Strings;
-
- Pamphlet_Paragraph_Count : constant := 2;
- Lines : constant := 4;
- Line_Length : constant := 40;
-
- type Document_Type is array (Positive range <>)
- of ASUnb.Unbounded_String;
-
- type Camera_Ready_Copy_Type is array (1..Lines)
- of String (1..Line_Length);
-
- Pamphlet : Document_Type (1..Pamphlet_Paragraph_Count);
-
- Camera_Ready_Copy : Camera_Ready_Copy_Type :=
- (others => (others => Ada.Strings.Space));
-
- TC_Finished_Product : Camera_Ready_Copy_Type :=
- ( 1 => "Ada is a programming language designed ",
- 2 => "to support long-lived, reliable software",
- 3 => " systems. ",
- 4 => "Go with Ada! ");
-
- -----
-
-
- procedure Enter_Text_Into_Document (Document : in out Document_Type) is
- begin
-
- -- Fill in both "paragraphs" of the document. Each unbounded string
- -- functions as an individual paragraph, containing an unspecified
- -- number of characters.
- -- Use a variety of different unbounded string subprograms to load
- -- the data.
-
- Document(1) := ASUnb.To_Unbounded_String("Ada is a language");
-
- -- Insert the word "programming" prior to "language".
- Document(1) :=
- ASUnb.Insert(Document(1),
- ASUnb.Index(Document(1),
- "language"),
- ASUnb.To_String("progra" & -- Str &
- ASUnb."*"(2,'m') & -- Unbd &
- "ing ")); -- Str
-
-
- -- Overwrite the word "language" with "language" + additional text.
- Document(1) :=
- ASUnb.Overwrite(Document(1),
- ASUnb.Index(Document(1),
- ASUnb.To_String(
- ASUnb.Tail(Document(1), 8, ' ')),
- Ada.Strings.Backward),
- "language designed to support long-lifed");
-
-
- -- Replace the word "lifed" with "lived".
- Document(1) :=
- ASUnb.Replace_Slice(Document(1),
- ASUnb.Index(Document(1), "lifed"),
- ASUnb.Length(Document(1)),
- "lived");
-
-
- -- Overwrite the word "lived" with "lived" + additional text.
- Document(1) :=
- ASUnb.Overwrite(Document(1),
- ASUnb.Index(Document(1),
- ASUnb.To_String(
- ASUnb.Tail(Document(1), 5, ' ')),
- Ada.Strings.Backward),
- "lived, reliable software systems.");
-
-
- -- Use several of the overloaded versions of "&" to form this
- -- unbounded string.
-
- Document(2) := 'G' &
- ASUnb.To_Unbounded_String("o ") &
- ASUnb.To_Unbounded_String("with") &
- ' ' &
- "Ada!";
-
- end Enter_Text_Into_Document;
-
-
- -----
-
-
- procedure Create_Camera_Ready_Copy
- (Document : in Document_Type;
- Camera_Copy : out Camera_Ready_Copy_Type) is
- begin
- -- Break the unbounded strings into fixed lengths.
-
- -- Search the first unbounded string for portions of text that
- -- are less than or equal to the length of a string in the
- -- Camera_Ready_Copy_Type object.
-
- Camera_Copy(1) := -- Take characters 1-39,
- ASUnb.Slice(Document(1), -- and append a blank space.
- 1,
- ASUnb.Index(ASUnb.To_Unbounded_String(
- ASUnb.Slice(Document(1),
- 1,
- Line_Length)),
- Ada.Strings.Maps.To_Set(' '),
- Ada.Strings.Inside,
- Ada.Strings.Backward)) & ' ';
-
- Camera_Copy(2) := -- Take characters 40-79.
- ASUnb.Slice(Document(1),
- 40,
- (ASUnb.Index_Non_Blank -- Should return 79
- (ASUnb.To_Unbounded_String
- (ASUnb.Slice(Document(1), -- Slice (40..79)
- 40,
- 79)),
- Ada.Strings.Backward) + 39)); -- Increment since
- -- this slice starts
- -- at 40.
-
- Camera_Copy(3)(1..9) := ASUnb.Slice(Document(1), -- Characters 80-88
- 80,
- ASUnb.Length(Document(1)));
-
-
- -- Break the second unbounded string into the appropriate length.
- -- It is only twelve characters in length, so the entire unbounded
- -- string will be placed on one string of the output object.
-
- Camera_Copy(4)(1..ASUnb.Length(Document(2))) :=
- ASUnb.To_String(ASUnb.Head(Document(2),
- ASUnb.Length(Document(2))));
-
- end Create_Camera_Ready_Copy;
-
-
- -----
-
-
- function Valid_Proofread (Draft, Master : Camera_Ready_Copy_Type)
- return Boolean is
- begin
-
- -- Evaluate strings for equality, using the operators defined in
- -- package Ada.Strings.Unbounded. The less than/greater than or
- -- equal comparisons should evaluate to "equals => True".
-
- if ASUnb.To_Unbounded_String(Draft(1)) = -- "="(Unb,Unb)
- ASUnb.To_Unbounded_String(Master(1)) and
- ASUnb.To_Unbounded_String(Draft(2)) <= -- "<="(Unb,Unb)
- ASUnb.To_Unbounded_String(Master(2)) and
- ASUnb.To_Unbounded_String(Draft(3)) >= -- ">="(Unb,Unb)
- ASUnb.To_Unbounded_String(Master(3)) and
- ASUnb.To_Unbounded_String(Draft(4)) = -- "="(Unb,Unb)
- ASUnb.To_Unbounded_String(Master(4))
- then
- return True;
- else
- return False;
- end if;
-
- end Valid_Proofread;
-
-
- -----
-
-
- begin
-
- -- Enter text into the unbounded string paragraphs of the document.
-
- Enter_Text_Into_Document (Pamphlet);
-
-
- -- Reformat the unbounded strings into fixed string format.
-
- Create_Camera_Ready_Copy (Document => Pamphlet,
- Camera_Copy => Camera_Ready_Copy);
-
-
- -- Verify the conversion process.
-
- if not Valid_Proofread (Draft => Camera_Ready_Copy,
- Master => TC_Finished_Product)
- then
- Report.Failed ("Incorrect string processing result");
- end if;
-
-
- exception
- when others => Report.Failed ("Exception raised in Test_Block");
- end Test_Block;
-
-
- Report.Result;
-
-end CXA4010;
diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxa4011.a b/gcc/testsuite/ada/acats/tests/cxa/cxa4011.a
deleted file mode 100644
index 05388a04ba7..00000000000
--- a/gcc/testsuite/ada/acats/tests/cxa/cxa4011.a
+++ /dev/null
@@ -1,376 +0,0 @@
--- CXA4011.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that the subprograms defined in package Ada.Strings.Unbounded
--- are available, and that they produce correct results. Specifically,
--- check the subprograms To_Unbounded_String, "&", ">", "<", Element,
--- Replace_Element, Count, Find_Token, Translate, Trim, Delete, and
--- "*".
---
--- TEST DESCRIPTION:
--- This test demonstrates the uses of many of the subprograms defined
--- in package Ada.Strings.Unbounded for use with unbounded strings.
--- The test simulates how unbounded strings could be processed in a
--- user environment, using the subprograms provided in this package.
---
--- This test uses a variety of the subprograms defined in the unbounded
--- string package in ways typical of common usage, with different
--- combinations of available subprograms being used to accomplish
--- similar unbounded string processing goals.
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 27 Feb 95 SAIC Test description modification.
--- 01 Nov 95 SAIC Update and repair for ACVC 2.0.1.
---
---!
-
-with Report;
-with Ada.Strings.Maps;
-with Ada.Strings.Unbounded;
-
-procedure CXA4011 is
-begin
-
- Report.Test ("CXA4011", "Check that the subprograms defined in " &
- "package Ada.Strings.Unbounded are available, " &
- "and that they produce correct results");
-
- Test_Block:
- declare
-
- package ASUnb renames Ada.Strings.Unbounded;
- use Ada.Strings;
- use type Maps.Character_Set;
- use type ASUnb.Unbounded_String;
-
- Cad_String : ASUnb.Unbounded_String :=
- ASUnb.To_Unbounded_String("cad");
-
- Complete_String : ASUnb.Unbounded_String :=
- ASUnb.To_Unbounded_String("Incomplete") &
- Ada.Strings.Space &
- ASUnb.To_Unbounded_String("String");
-
- Incomplete_String : ASUnb.Unbounded_String :=
- ASUnb.To_Unbounded_String("ncomplete Strin");
-
- Incorrect_Spelling : ASUnb.Unbounded_String :=
- ASUnb.To_Unbounded_String("Guob Dai");
-
- Magic_String : ASUnb.Unbounded_String :=
- ASUnb.To_Unbounded_String("abracadabra");
-
- Incantation : ASUnb.Unbounded_String := Magic_String;
-
-
- A_Small_G : Character := 'g';
- A_Small_D : Character := 'd';
-
- ABCD_Set : Maps.Character_Set := Maps.To_Set("abcd");
- B_Set : Maps.Character_Set := Maps.To_Set('b');
- AB_Set : Maps.Character_Set := Maps."OR"(Maps.To_Set('a'), B_Set);
-
- Code_Map : Maps.Character_Mapping :=
- Maps.To_Mapping(From => "abcd", To => "wxyz");
- Reverse_Code_Map : Maps.Character_Mapping :=
- Maps.To_Mapping(From => "wxyz", To => "abcd");
- Non_Existent_Map : Maps.Character_Mapping :=
- Maps.To_Mapping(From => "jkl", To => "mno");
-
-
- Token_Start : Positive;
- Token_End : Natural := 0;
- Matching_Letters : Natural := 0;
-
-
- begin
-
- -- "&"
-
- -- Prepend an 'I' and append a 'g' to the string.
- Incomplete_String := ASUnb."&"('I', Incomplete_String); -- Char & Unb
- Incomplete_String := ASUnb."&"(Incomplete_String,
- A_Small_G); -- Unb & Char
-
- if Incomplete_String < Complete_String or
- Incomplete_String > Complete_String or
- Incomplete_String /= Complete_String
- then
- Report.Failed("Incorrect result from use of ""&"" operator");
- end if;
-
-
- -- Element
-
- -- Last element of the unbounded string should be a 'g'.
- if ASUnb.Element(Incomplete_String, ASUnb.Length(Incomplete_String)) /=
- A_Small_G
- then
- Report.Failed("Incorrect result from use of Function Element - 1");
- end if;
-
- if ASUnb.Element(Incomplete_String, 2) /=
- ASUnb.Element(ASUnb.Tail(Incomplete_String, 2), 1) or
- ASUnb.Element(ASUnb.Head(Incomplete_String, 4), 2) /=
- ASUnb.Element(ASUnb.To_Unbounded_String("wnqz"), 2)
- then
- Report.Failed("Incorrect result from use of Function Element - 2");
- end if;
-
-
- -- Replace_Element
-
- -- The unbounded string Incorrect_Spelling starts as "Guob Dai", and
- -- is transformed by the following three procedure calls to "Good Day".
-
- ASUnb.Replace_Element(Incorrect_Spelling, 2, 'o');
-
- ASUnb.Replace_Element(Incorrect_Spelling,
- ASUnb.Index(Incorrect_Spelling, B_Set),
- A_Small_D);
-
- ASUnb.Replace_Element(Source => Incorrect_Spelling,
- Index => ASUnb.Length(Incorrect_Spelling),
- By => 'y');
-
- if Incorrect_Spelling /= ASUnb.To_Unbounded_String("Good Day") then
- Report.Failed("Incorrect result from Procedure Replace_Element");
- end if;
-
-
- -- Count
-
- -- Determine the number of characters in the unbounded string that
- -- are contained in the set.
-
- Matching_Letters := ASUnb.Count(Source => Magic_String,
- Set => ABCD_Set);
-
- if Matching_Letters /= 9 then
- Report.Failed
- ("Incorrect result from Function Count with Set parameter");
- end if;
-
- -- Determine the number of occurrences of the following pattern strings
- -- in the unbounded string Magic_String.
-
- if ASUnb.Count(Magic_String, "ab") /=
- (ASUnb.Count(Magic_String, "ac") + ASUnb.Count(Magic_String, "ad")) or
- ASUnb.Count(Magic_String, "ab") /= 2
- then
- Report.Failed
- ("Incorrect result from Function Count with String parameter");
- end if;
-
-
- -- Find_Token
-
- ASUnb.Find_Token(Magic_String, -- Find location of first "ab".
- AB_Set, -- Should be (1..2).
- Ada.Strings.Inside,
- Token_Start,
- Token_End);
-
- if Natural(Token_Start) /= ASUnb.To_String(Magic_String)'First or
- Token_End /= ASUnb.Index(Magic_String, B_Set)
- then
- Report.Failed("Incorrect result from Procedure Find_Token - 1");
- end if;
-
-
- ASUnb.Find_Token(Source => Magic_String, -- Find location of char 'r'
- Set => ABCD_Set, -- in string, should be (3..3)
- Test => Ada.Strings.Outside,
- First => Token_Start,
- Last => Token_End);
-
- if Natural(Token_Start) /= 3 or
- Token_End /= 3 then
- Report.Failed("Incorrect result from Procedure Find_Token - 2");
- end if;
-
-
- ASUnb.Find_Token(Magic_String, -- No 'g' is in the string, so
- Maps.To_Set(A_Small_G), -- the result parameters should
- Ada.Strings.Inside, -- be First = Source'First and
- First => Token_Start, -- Last = 0.
- Last => Token_End);
-
- if Token_Start /= ASUnb.To_String(Magic_String)'First or
- Token_End /= 0
- then
- Report.Failed("Incorrect result from Procedure Find_Token - 3");
- end if;
-
-
- -- Translate
-
- -- Use a mapping ("abcd" -> "wxyz") to transform the contents of
- -- the unbounded string.
- -- Magic_String = "abracadabra"
-
- Incantation := ASUnb.Translate(Magic_String, Code_Map);
-
- if Incantation /= ASUnb.To_Unbounded_String("wxrwywzwxrw") then
- Report.Failed("Incorrect result from Function Translate");
- end if;
-
- -- Use the inverse mapping of the one above to return the "translated"
- -- unbounded string to its original form.
-
- ASUnb.Translate(Incantation, Reverse_Code_Map);
-
- -- The map contained in the following call to Translate contains one
- -- element, and this element is not found in the unbounded string, so
- -- this call to Translate should have no effect on the unbounded string.
-
- if Incantation /= ASUnb.Translate(Magic_String, Non_Existent_Map) then
- Report.Failed("Incorrect result from Procedure Translate");
- end if;
-
-
- -- Trim
-
- Trim_Block:
- declare
-
- XYZ_Set : Maps.Character_Set := Maps.To_Set("xyz");
- PQR_Set : Maps.Character_Set := Maps.To_Set("pqr");
-
- Pad : constant ASUnb.Unbounded_String :=
- ASUnb.To_Unbounded_String("Pad");
-
- The_New_Ada : constant ASUnb.Unbounded_String :=
- ASUnb.To_Unbounded_String("Ada9X");
-
- Space_Array : array (1..4) of ASUnb.Unbounded_String :=
- (ASUnb.To_Unbounded_String(" Pad "),
- ASUnb.To_Unbounded_String("Pad "),
- ASUnb.To_Unbounded_String(" Pad"),
- Pad);
-
- String_Array : array (1..5) of ASUnb.Unbounded_String :=
- (ASUnb.To_Unbounded_String("xyzxAda9Xpqr"),
- ASUnb.To_Unbounded_String("Ada9Xqqrp"),
- ASUnb.To_Unbounded_String("zxyxAda9Xqpqr"),
- ASUnb.To_Unbounded_String("xxxyAda9X"),
- The_New_Ada);
-
- begin
-
- -- Examine the version of Trim that removes blanks from
- -- the left and/or right of a string.
-
- for i in 1..4 loop
- if ASUnb.Trim(Space_Array(i), Ada.Strings.Both) /= Pad then
- Report.Failed("Incorrect result from Trim for spaces - " &
- Integer'Image(i));
- end if;
- end loop;
-
- -- Examine the version of Trim that removes set characters from
- -- the left and right of a string.
-
- for i in 1..5 loop
- if ASUnb.Trim(String_Array(i),
- Left => XYZ_Set,
- Right => PQR_Set) /= The_New_Ada then
- Report.Failed
- ("Incorrect result from Trim for set characters - " &
- Integer'Image(i));
- end if;
- end loop;
-
- end Trim_Block;
-
-
- -- Delete
-
- -- Use the Delete function to remove the first four and last four
- -- characters from the string.
-
- if ASUnb.Delete(Source => ASUnb.Delete(Magic_String,
- 8,
- ASUnb.Length(Magic_String)),
- From => ASUnb.To_String(Magic_String)'First,
- Through => 4) /=
- Cad_String
- then
- Report.Failed("Incorrect results from Function Delete");
- end if;
-
-
- -- Constructors ("*")
-
- Constructor_Block:
- declare
-
- SOS : ASUnb.Unbounded_String;
-
- Dot : constant ASUnb.Unbounded_String :=
- ASUnb.To_Unbounded_String("Dot_");
- Dash : constant String := "Dash_";
-
- Distress : ASUnb.Unbounded_String :=
- ASUnb.To_Unbounded_String("Dot_Dot_Dot_") &
- ASUnb.To_Unbounded_String("Dash_Dash_Dash_") &
- ASUnb.To_Unbounded_String("Dot_Dot_Dot");
-
- Repeat : constant Natural := 3;
- Separator : constant Character := '_';
-
- Separator_Set : Maps.Character_Set := Maps.To_Set(Separator);
-
- begin
-
- -- Use the following constructor forms to construct the string
- -- "Dot_Dot_Dot_Dash_Dash_Dash_Dot_Dot_Dot". Note that the
- -- trailing underscore in the string is removed in the call to
- -- Trim in the If statement condition.
-
- SOS := ASUnb."*"(Repeat, Dot); -- "*"(#, Unb Str)
-
- SOS := SOS &
- ASUnb."*"(Repeat, Dash) & -- "*"(#, Str)
- ASUnb."*"(Repeat, Dot); -- "*"(#, Unb Str)
-
- if ASUnb.Trim(SOS, Maps.Null_Set, Separator_Set) /= Distress then
- Report.Failed("Incorrect results from Function ""*""");
- end if;
-
- end Constructor_Block;
-
-
- exception
- when others => Report.Failed ("Exception raised in Test_Block");
- end Test_Block;
-
-
- Report.Result;
-
-end CXA4011;
diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxa4012.a b/gcc/testsuite/ada/acats/tests/cxa/cxa4012.a
deleted file mode 100644
index 5ab12b6dfa9..00000000000
--- a/gcc/testsuite/ada/acats/tests/cxa/cxa4012.a
+++ /dev/null
@@ -1,305 +0,0 @@
--- CXA4012.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that the types, operations, and other entities defined within
--- the package Ada.Strings.Wide_Maps are available and produce correct
--- results.
---
--- TEST DESCRIPTION:
--- This test demonstrates the availability and function of the types and
--- operations defined in package Ada.Strings.Wide_Maps. It demonstrates
--- the use of these types and functions as they would be used in common
--- programming practice.
--- Wide_Character set creation, assignment, and comparison are evaluated
--- in this test. Each of the functions provided in package
--- Ada.Strings.Wide_Maps is utilized in creating or manipulating set
--- objects, and the function results are evaluated for correctness.
--- Wide_Character sequences are examined using the functions provided for
--- manipulating objects of this type. Likewise, Wide_Character maps are
--- created, and their contents evaluated. Exception raising conditions
--- from the function To_Mapping are also created.
--- Note: Throughout this test, the set logical operators are printed in
--- capital letters to enhance their visibility.
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 01 Nov 95 SAIC Update and repair for ACVC 2.0.1.
---
---!
-
-with Ada.Characters.Handling;
-with Ada.Strings.Wide_Maps;
-
-package CXA40120 is
-
- function Equiv (Ch : Character) return Wide_Character;
- function Equiv (Str : String)
- return Ada.Strings.Wide_Maps.Wide_Character_Sequence;
- function X_Map(From : Wide_Character) return Wide_Character;
-
-end CXA40120;
-
-package body CXA40120 is
-
- -- The following two functions are used to translate character and string
- -- values to "Wide" values. They will be applied to certain Wide_Map
- -- subprogram parameters to simulate the use of Wide_Characters and
- -- Wide_Character_Sequences in actual practice.
- -- Note: These functions do not actually return "equivalent" wide
- -- characters to their character inputs, just "non-character"
- -- wide characters.
-
- function Equiv (Ch : Character) return Wide_Character is
- C : Character := Ch;
- begin
- if Ch = ' ' then
- return Ada.Characters.Handling.To_Wide_Character(C);
- else
- return Wide_Character'Val(Character'Pos(Ch) +
- Character'Pos(Character'Last) + 1);
- end if;
- end Equiv;
-
- function Equiv (Str : String)
- return Ada.Strings.Wide_Maps.Wide_Character_Sequence is
- use Ada.Strings;
- WS : Wide_Maps.Wide_Character_Sequence(Str'First..Str'Last);
- begin
- for i in Str'First..Str'Last loop
- WS(i) := Equiv(Str(i));
- end loop;
- return WS;
- end Equiv;
-
- function X_Map(From : Wide_Character) return Wide_Character is
- begin
- return Equiv('X');
- end X_Map;
-
-end CXA40120;
-
-
-
-with CXA40120;
-with Ada.Characters.Handling;
-with Ada.Strings.Wide_Maps;
-with Report;
-
-procedure CXA4012 is
-
- use CXA40120;
- use Ada.Strings;
-
-begin
-
- Report.Test ("CXA4012", "Check that the types, operations, and other " &
- "entities defined within the package " &
- "Ada.Strings.Wide_Maps are available and " &
- "produce correct results");
-
- Test_Block:
- declare
-
- use type Wide_Maps.Wide_Character_Set;
-
- MidPoint_Letter : constant := 13;
- Last_Letter : constant := 26;
-
- Vowels : constant Wide_Maps.Wide_Character_Sequence :=
- Equiv("aeiou");
- Quasi_Vowel : constant Wide_Character := Equiv('y');
-
- Alphabet : Wide_Maps.Wide_Character_Sequence(1..Last_Letter);
- Half_Alphabet : Wide_Maps.Wide_Character_Sequence(1..MidPoint_Letter);
- Inverse_Alphabet : Wide_Maps.Wide_Character_Sequence(1..Last_Letter);
-
- Alphabet_Set,
- Consonant_Set,
- Vowel_Set,
- Full_Vowel_Set,
- First_Half_Set,
- Second_Half_Set : Wide_Maps.Wide_Character_Set := Wide_Maps.Null_Set;
-
- begin
-
- -- Load the alphabet string for use in creating sets.
-
- for i in 0..MidPoint_Letter-1 loop
- Half_Alphabet(i+1) :=
- Wide_Character'Val(Wide_Character'Pos(Equiv('a')) + i);
- end loop;
-
- for i in 0..Last_Letter-1 loop
- Alphabet(i+1) :=
- Wide_Character'Val(Wide_Character'Pos(Equiv('a')) + i);
- end loop;
-
-
- -- Initialize a series of Wide_Character_Set objects.
-
- Alphabet_Set := Wide_Maps.To_Set(Alphabet);
- Vowel_Set := Wide_Maps.To_Set(Vowels);
- Full_Vowel_Set := Vowel_Set OR Wide_Maps.To_Set(Quasi_Vowel);
- Consonant_Set := Vowel_Set XOR Alphabet_Set;
-
- First_Half_Set := Wide_Maps.To_Set(Half_Alphabet);
- Second_Half_Set := Alphabet_Set XOR First_Half_Set;
-
-
- -- Evaluation of Set objects, operators, and functions.
-
- if Alphabet_Set /= (Vowel_Set OR Consonant_Set) then
- Report.Failed("Incorrect set combinations using OR operator");
- end if;
-
-
- for i in Vowels'First .. Vowels'Last loop
- if not Wide_Maps.Is_In(Vowels(i), Vowel_Set) or
- not Wide_Maps.Is_In(Vowels(i), Alphabet_Set) or
- Wide_Maps.Is_In(Vowels(i), Consonant_Set)
- then
- Report.Failed("Incorrect function Is_In use with set " &
- "combinations - " & Integer'Image(i));
- end if;
- end loop;
-
-
- if Wide_Maps.Is_Subset(Vowel_Set, First_Half_Set) or
- Wide_Maps."<="(Vowel_Set, Second_Half_Set) or
- not Wide_Maps.Is_Subset(Vowel_Set, Alphabet_Set)
- then
- Report.Failed
- ("Incorrect set evaluation using Is_Subset function");
- end if;
-
-
- if not (Full_Vowel_Set = Wide_Maps.To_Set(Equiv("aeiouy"))) then
- Report.Failed("Incorrect result for ""="" set operator");
- end if;
-
-
- if not ((Vowel_Set AND First_Half_Set) OR
- (Full_Vowel_Set AND Second_Half_Set)) = Full_Vowel_Set then
- Report.Failed
- ("Incorrect result for AND, OR, or ""="" set operators");
- end if;
-
-
- if (Alphabet_Set AND Wide_Maps.Null_Set) /= Wide_Maps.Null_Set or
- (Alphabet_Set OR Wide_Maps.Null_Set) /= Alphabet_Set
- then
- Report.Failed("Incorrect result for AND or OR set operators");
- end if;
-
-
- Vowel_Set := Full_Vowel_Set;
- Vowel_Set := Vowel_Set AND (NOT Wide_Maps.To_Set(Quasi_Vowel));
-
- if not (Vowels = Wide_Maps.To_Sequence(Vowel_Set)) then
- Report.Failed("Incorrect Set to Sequence translation");
- end if;
-
-
- for i in 0..Last_Letter-1 loop
- Inverse_Alphabet(i+1) := Alphabet(Last_Letter-i);
- end loop;
-
-
- -- Wide_Character_Mapping
-
- declare
- Inverse_Map : Wide_Maps.Wide_Character_Mapping :=
- Wide_Maps.To_Mapping(Alphabet, Inverse_Alphabet);
- begin
- if Wide_Maps.Value(Wide_Maps.Identity, Equiv('b')) /=
- Wide_Maps.Value(Inverse_Map, Equiv('y'))
- then
- Report.Failed("Incorrect Inverse mapping");
- end if;
- end;
-
-
- -- Check that Translation_Error is raised when a character is
- -- repeated in the parameter "From" string.
- declare
- Bad_Map : Wide_Maps.Wide_Character_Mapping;
- begin
- Bad_Map := Wide_Maps.To_Mapping(From => Equiv("aa"),
- To => Equiv("yz"));
- Report.Failed("Exception not raised with repeated character");
- exception
- when Translation_Error => null; -- OK
- when others =>
- Report.Failed("Incorrect exception raised in To_Mapping with " &
- "a repeated character");
- end;
-
-
- -- Check that Translation_Error is raised when the parameters of the
- -- function To_Mapping are of unequal lengths.
- declare
- Bad_Map : Wide_Maps.Wide_Character_Mapping;
- begin
- Bad_Map := Wide_Maps.To_Mapping(Equiv("abc"), Equiv("yz"));
- Report.Failed
- ("Exception not raised with unequal parameter lengths");
- exception
- when Translation_Error => null; -- OK
- when others =>
- Report.Failed("Incorrect exception raised in To_Mapping with " &
- "unequal parameter lengths");
- end;
-
-
- -- Check that the access-to-subprogram type is defined and available.
- -- This provides for one Wide_Character mapping capability only.
- -- The actual mapping functionality will be tested in conjunction with
- -- the tests of subprograms defined for Wide_String handling.
-
- declare
-
- X_Map_Ptr : Wide_Maps.Wide_Character_Mapping_Function :=
- X_Map'Access;
-
- begin
- if X_Map_Ptr(Equiv('A')) /= -- both return 'X'
- X_Map_Ptr.all(Equiv('Q'))
- then
- Report.Failed
- ("Incorrect result using access-to-subprogram values");
- end if;
- end;
-
-
- exception
- when others => Report.Failed ("Exception raised in Test_Block");
- end Test_Block;
-
-
- Report.Result;
-
-end CXA4012;
diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxa4013.a b/gcc/testsuite/ada/acats/tests/cxa/cxa4013.a
deleted file mode 100644
index 0f93e9dc8d1..00000000000
--- a/gcc/testsuite/ada/acats/tests/cxa/cxa4013.a
+++ /dev/null
@@ -1,203 +0,0 @@
--- CXA4013.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that the subprograms defined in package Ada.Strings.Wide_Fixed
--- are available, and that they produce correct results. Specifically,
--- check the subprograms Index, "*" (Wide_String constructor function),
--- Count, Trim, and Replace_Slice.
---
--- TEST DESCRIPTION:
--- This test demonstrates how certain Wide_Fixed string functions
--- are used to eliminate specific substrings from portions of text.
--- A procedure is defined that will take as parameters a source
--- Wide_String along with a substring that is to be completely removed
--- from the source string. The source Wide_String is parsed using the
--- Index function, and any substring slices are replaced in the source
--- Wide_String by a series of X's (based on the length of the substring.)
--- Three lines of text are provided to this procedure, and the resulting
--- substitutions are compared with expected results to validate the
--- string processing.
--- A global accumulator is updated with the number of occurrences of the
--- substring in the source string.
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
---
---!
-
-with Ada.Strings;
-with Ada.Strings.Wide_Fixed;
-with Ada.Strings.Wide_Maps;
-with Report;
-
-procedure CXA4013 is
-
-begin
-
- Report.Test ("CXA4013", "Check that the subprograms defined in package " &
- "Ada.Strings.Wide_Fixed are available, and that " &
- "they produce correct results");
-
- Test_Block:
- declare
-
- TC_Total : Natural := 0;
- Number_Of_Lines : constant := 3;
- WC : Wide_Character :=
- Wide_Character'Val(Character'Pos('X') +
- Character'Pos(Character'Last) +
- 1 );
-
- subtype WS is Wide_String (1..25);
-
- type Restricted_Words_Array_Type is
- array (1..10) of Wide_String (1..10);
-
- Restricted_Words : Restricted_Words_Array_Type :=
- (" platoon", " marines ", " Marines ",
- "north ", "south ", " east",
- " beach ", " airport", "airfield ",
- " road ");
-
- type Page_Of_Text_Type is array (1..Number_Of_Lines) of WS;
-
- Text_Page : Page_Of_Text_Type := ("The platoon of Marines ",
- "moved south on the south ",
- "road to the airfield. ");
-
- TC_Revised_Line_1 : constant Wide_String := "The XXXXXXX of XXXXXXX ";
- TC_Revised_Line_2 : constant Wide_String := "moved XXXXX on the XXXXX ";
- TC_Revised_Line_3 : constant Wide_String := "XXXX to the XXXXXXXX. ";
-
-
- function Equivalent (Left : WS; Right : Wide_String)
- return Boolean is
- begin
- for i in WS'range loop
- if Left(i) /= Right(i) then
- if Left(i) /= WC or Right(i) /= 'X' then
- return False;
- end if;
- end if;
- end loop;
- return True;
- end Equivalent;
-
- ---
-
- procedure Censor (Source_String : in out Wide_String;
- Pattern_String : in Wide_String) is
-
- use Ada.Strings.Wide_Fixed; -- allows infix notation of "*" below.
-
- -- Create a replacement string that is the same length as the
- -- pattern string being removed. Use the infix notation of the
- -- wide string constructor function.
-
- Replacement : constant Wide_String :=
- Pattern_String'Length * WC; -- "*"
-
- Going : Ada.Strings.Direction := Ada.Strings.Forward;
- Start_Pos,
- Index : Natural := Source_String'First;
-
- begin -- Censor
-
- -- Accumulate count of total replacement operations.
-
- TC_Total := TC_Total +
- Ada.Strings.Wide_Fixed.Count -- Count
- (Source => Source_String,
- Pattern => Pattern_String,
- Mapping => Ada.Strings.Wide_Maps.Identity);
- loop
-
- Index := Ada.Strings.Wide_Fixed.Index -- Index
- (Source_String(Start_Pos..Source_String'Last),
- Pattern_String,
- Going,
- Ada.Strings.Wide_Maps.Identity);
-
- exit when Index = 0; -- No matches, exit loop.
-
- -- if a match was found, modify the substring.
- Ada.Strings.Wide_Fixed.Replace_Slice -- Replace_Slice
- (Source_String,
- Index,
- Index + Pattern_String'Length - 1,
- Replacement);
- Start_Pos := Index + Pattern_String'Length;
-
- end loop;
-
- end Censor;
-
-
- begin
-
- -- Invoke Censor subprogram to cleanse text.
- -- Loop through each line of text, and check for the presence of each
- -- restricted word.
- -- Use the Trim function to eliminate leading or trailing blanks from
- -- the restricted word parameters.
-
- for Line in 1..Number_Of_Lines loop
- for Word in Restricted_Words'Range loop
- Censor (Text_Page(Line), -- Trim
- Ada.Strings.Wide_Fixed.Trim(Restricted_Words(Word),
- Ada.Strings.Both));
- end loop;
- end loop;
-
-
- -- Validate results.
-
- if TC_Total /= 6 then
- Report.Failed ("Incorrect number of substitutions performed");
- end if;
-
- if not Equivalent (Text_Page(1), TC_Revised_Line_1) then
- Report.Failed ("Incorrect substitutions on Line 1");
- end if;
-
- if not Equivalent (Text_Page(2), TC_Revised_Line_2) then
- Report.Failed ("Incorrect substitutions on Line 2");
- end if;
-
- if not Equivalent (Text_Page(3), TC_Revised_Line_3) then
- Report.Failed ("Incorrect substitutions on Line 3");
- end if;
-
-
- exception
- when others => Report.Failed ("Exception raised in Test_Block");
- end Test_Block;
-
-
- Report.Result;
-
-end CXA4013;
diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxa4014.a b/gcc/testsuite/ada/acats/tests/cxa/cxa4014.a
deleted file mode 100644
index 6e26a0330d5..00000000000
--- a/gcc/testsuite/ada/acats/tests/cxa/cxa4014.a
+++ /dev/null
@@ -1,359 +0,0 @@
--- CXA4014.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that the subprograms defined in package Ada.Strings.Wide_Fixed
--- are available, and that they produce correct results. Specifically,
--- check the subprograms Find_Token, Head, Index, Index_Non_Blank, Move,
--- Overwrite, and Replace_Slice, Tail, and Translate.
--- Use the access-to-subprogram mapping version of Translate (function
--- and procedure).
---
--- TEST DESCRIPTION:
--- This test demonstrates how certain wide fixed string operations could
--- be used in wide string information processing. A procedure is defined
--- that will extract portions of a 50 character string that correspond to
--- certain data items (i.e., name, address, state, zip code). These
--- parsed items will then be added to the appropriate fields of data
--- base elements. These data base elements are then compared for
--- accuracy against a similar set of predefined data base
--- elements.
--- A variety of wide fixed string processing subprograms are used in this
--- test. Each parsing operation attempts to use a different combination
--- of the available subprograms to accomplish the same goal, therefore
--- continuity of approach to wide string parsing is not seen in this
--- test.
--- However, a wide variety of possible approaches are demonstrated, while
--- exercising a large number of the total predefined subprograms of
--- package Ada.Strings.Wide_Fixed.
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 02 Nov 95 SAIC Update and repair for ACVC 2.0.1.
---
---!
-
-package CXA40140 is
-
- UnderScore : Wide_Character := '_';
- Blank : Wide_Character := ' ';
-
- -- Function providing a mapping to a blank Wide_Character.
- function US_to_Blank_Map (From : Wide_Character) return Wide_Character;
-
-end CXA40140;
-
-package body CXA40140 is
-
- function US_to_Blank_Map (From : Wide_Character) return Wide_Character is
- begin
- if From = UnderScore then
- return Blank;
- else
- return From;
- end if;
- end US_to_Blank_Map;
-
-end CXA40140;
-
-
-with CXA40140;
-with Ada.Strings.Wide_Fixed;
-with Ada.Strings.Wide_Maps;
-with Report;
-
-procedure CXA4014 is
- use CXA40140;
-begin
-
- Report.Test ("CXA4014", "Check that the subprograms defined in package " &
- "Ada.Strings.Wide_Fixed are available, and that " &
- "they produce correct results");
-
- Test_Block:
- declare
-
- Number_Of_Info_Strings : constant Natural := 3;
- DB_Size : constant Natural := Number_Of_Info_Strings;
- Count : Natural := 0;
- Finished_Processing : Boolean := False;
- Blank_Wide_String : constant Wide_String := " ";
-
- subtype Info_Wide_String_Type is Wide_String (1..50);
- type Info_Wide_String_Storage_Type is
- array (1..Number_Of_Info_Strings) of Info_Wide_String_Type;
-
-
- subtype Name_Type is Wide_String (1..10);
- subtype Street_Number_Type is Wide_String (1..5);
- subtype Street_Name_Type is Wide_String (1..10);
- subtype City_Type is Wide_String (1..10);
- subtype State_Type is Wide_String (1..2);
- subtype Zip_Code_Type is Wide_String (1..5);
-
- type Data_Base_Element_Type is
- record
- Name : Name_Type := (others => ' ');
- Street_Number : Street_Number_Type := (others => ' ');
- Street_Name : Street_Name_Type := (others => ' ');
- City : City_Type := (others => ' ');
- State : State_Type := (others => ' ');
- Zip_Code : Zip_Code_Type := (others => ' ');
- end record;
-
- type Data_Base_Type is array (1..DB_Size) of Data_Base_Element_Type;
-
- Data_Base : Data_Base_Type;
-
- ---
-
- Info_String_1 : Info_Wide_String_Type :=
- "Joe_Jones 123 Sixth_St San_Diego CA 98765";
-
- Info_String_2 : Info_Wide_String_Type :=
- "Sam_Smith 56789 S._Seventh Carlsbad CA 92177";
-
- Info_String_3 : Info_Wide_String_Type :=
- "Jane_Brown 1219 Info_Lane Tuscon AZ 85643";
-
-
- Info_Strings : Info_Wide_String_Storage_Type :=
- (1 => Info_String_1,
- 2 => Info_String_2,
- 3 => Info_String_3);
-
-
-
- TC_DB_Element_1 : Data_Base_Element_Type :=
- ("Joe Jones ", "123 ", "Sixth St ", "San Diego ", "CA", "98765");
-
- TC_DB_Element_2 : Data_Base_Element_Type :=
- ("Sam Smith ", "56789", "S. Seventh", "Carlsbad ", "CA", "92177");
-
- TC_DB_Element_3 : Data_Base_Element_Type :=
- ("Jane Brown", "1219 ", "Info Lane ", "Tuscon ", "AZ", "85643");
-
- TC_Data_Base : Data_Base_Type := (TC_DB_Element_1,
- TC_DB_Element_2,
- TC_DB_Element_3);
-
- ---
-
-
- procedure Store_Information
- (Info_String : in Info_Wide_String_Type;
- DB_Record : in out Data_Base_Element_Type) is
-
- package AS renames Ada.Strings;
- use type AS.Wide_Maps.Wide_Character_Set;
-
- Start,
- Stop : Natural := 0;
-
- Numeric_Set : constant AS.Wide_Maps.Wide_Character_Set :=
- AS.Wide_Maps.To_Set("0123456789");
-
- Cal : constant
- AS.Wide_Maps.Wide_Character_Sequence := "CA";
- California_Set : constant AS.Wide_Maps.Wide_Character_Set :=
- AS.Wide_Maps.To_Set(Cal);
- Arizona_Set : constant AS.Wide_Maps.Wide_Character_Set :=
- AS.Wide_Maps.To_Set("AZ");
- Nevada_Set : constant AS.Wide_Maps.Wide_Character_Set :=
- AS.Wide_Maps.To_Set("NV");
-
- Blank_Ftn_Ptr : AS.Wide_Maps.Wide_Character_Mapping_Function :=
- US_to_Blank_Map'Access;
-
- begin
-
- -- Find the starting position of the name field (first non-blank),
- -- then, from that position, find the end of the name field (first
- -- blank).
-
- Start := AS.Wide_Fixed.Index_Non_Blank(Info_String);
- Stop := AS.Wide_Fixed.Index (Info_String(Start..Info_String'Length),
- AS.Wide_Maps.To_Set(Blank),
- AS.Inside,
- AS.Forward) - 1 ;
-
- -- Store the name field in the data base element field for "Name".
-
- DB_Record.Name := AS.Wide_Fixed.Head(Info_String(1..Stop),
- DB_Record.Name'Length);
-
- -- Replace any underscore characters in the name field
- -- that were used to separate first/middle/last names.
- -- Use the overloaded version of Translate that takes an
- -- access-to-subprogram value.
-
- AS.Wide_Fixed.Translate (DB_Record.Name, Blank_Ftn_Ptr);
-
-
- -- Continue the extraction process; now find the position of
- -- the street number in the string.
-
- Start := Stop + 1;
-
- AS.Wide_Fixed.Find_Token(Info_String(Start..Info_String'Length),
- Numeric_Set,
- AS.Inside,
- Start,
- Stop);
-
- -- Store the street number field in the appropriate data base
- -- element.
- -- No modification of the default parameters of procedure Move
- -- is required.
-
- AS.Wide_Fixed.Move(Source => Info_String(Start..Stop),
- Target => DB_Record.Street_Number);
-
-
- -- Continue the extraction process; find the street name in the
- -- info string. Skip blanks to the start of the street name, then
- -- search for the index of the next blank character in the string.
-
- Start := AS.Wide_Fixed.Index_Non_Blank
- (Info_String(Stop+1..Info_String'Length));
-
- Stop :=
- AS.Wide_Fixed.Index(Info_String(Start..Info_String'Length),
- Blank_Wide_String) - 1;
-
- -- Store the street name in the appropriate data base element field.
-
- AS.Wide_Fixed.Overwrite(DB_Record.Street_Name,
- 1,
- Info_String(Start..Stop));
-
- -- Replace any underscore characters in the street name field
- -- that were used as word separation with blanks. Again, use the
- -- access-to-subprogram value to provide the mapping.
-
- DB_Record.Street_Name :=
- AS.Wide_Fixed.Translate(DB_Record.Street_Name,
- Blank_Ftn_Ptr);
-
-
- -- Continue the extraction; remove the city name from the string.
-
- Start := AS.Wide_Fixed.Index_Non_Blank
- (Info_String(Stop+1..Info_String'Length));
-
- Stop :=
- AS.Wide_Fixed.Index(Info_String(Start..Info_String'Length),
- Blank_Wide_String) - 1;
-
- -- Store the city name field in the appropriate data base element.
-
- AS.Wide_Fixed.Replace_Slice(DB_Record.City,
- 1,
- DB_Record.City'Length,
- Info_String(Start..Stop));
-
- -- Replace any underscore characters in the city name field
- -- that were used as word separation.
-
- AS.Wide_Fixed.Translate (DB_Record.City,
- Blank_Ftn_Ptr);
-
-
- -- Continue the extraction; remove the state identifier from the
- -- info string.
-
- Start := Stop + 1;
-
- AS.Wide_Fixed.Find_Token(Info_String(Start..Info_String'Length),
- AS.Wide_Maps."OR"(California_Set,
- AS.Wide_Maps."OR"(Nevada_Set,
- Arizona_Set)),
- AS.Inside,
- Start,
- Stop);
-
- -- Store the state indicator into the data base element.
-
- AS.Wide_Fixed.Move(Source => Info_String(Start..Stop),
- Target => DB_Record.State,
- Drop => Ada.Strings.Right,
- Justify => Ada.Strings.Left,
- Pad => AS.Wide_Space);
-
-
- -- Continue the extraction process; remove the final data item in
- -- the info string, the zip code, and place it into the
- -- corresponding data base element.
-
- DB_Record.Zip_Code :=
- AS.Wide_Fixed.Tail(Info_String, DB_Record.Zip_Code'Length);
-
- exception
- when AS.Length_Error =>
- Report.Failed ("Length_Error raised in procedure");
- when AS.Pattern_Error =>
- Report.Failed ("Pattern_Error raised in procedure");
- when AS.Translation_Error =>
- Report.Failed ("Translation_Error raised in procedure");
- when others =>
- Report.Failed ("Exception raised in procedure");
- end Store_Information;
-
-
- begin
-
- -- Loop thru the information strings, extract the name and address
- -- information, place this info into elements of the data base.
-
- while not Finished_Processing loop
-
- Count := Count + 1;
-
- Store_Information (Info_Strings(Count), Data_Base(Count));
-
- Finished_Processing := (Count = Number_Of_Info_Strings);
-
- end loop;
-
-
- -- Verify that the string processing was successful.
-
- for i in 1..DB_Size loop
- if Data_Base(i) /= TC_Data_Base(i) then
- Report.Failed
- ("Data processing error on record " & Integer'Image(i));
- end if;
- end loop;
-
-
- exception
- when others => Report.Failed ("Exception raised in Test_Block");
- end Test_Block;
-
-
- Report.Result;
-
-end CXA4014;
diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxa4015.a b/gcc/testsuite/ada/acats/tests/cxa/cxa4015.a
deleted file mode 100644
index 83fad3af866..00000000000
--- a/gcc/testsuite/ada/acats/tests/cxa/cxa4015.a
+++ /dev/null
@@ -1,580 +0,0 @@
--- CXA4015.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that the subprograms defined in package Ada.Strings.Wide_Fixed
--- are available, and that they produce correct results. Specifically,
--- check the subprograms Count, Find_Token, Index, Index_Non_Blank, and
--- Move.
---
--- TEST DESCRIPTION:
--- This test, when combined with tests CXA4013,14,16 will provide
--- coverage of the functionality found in Ada.Strings.Wide_Fixed.
--- This test contains many small, specific test cases, situations that
--- although common in user environments, are often difficult to generate
--- in large numbers in a application-based test.
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 02 Nov 95 SAIC Corrected various accesssibility problems and
--- expected result strings for ACVC 2.0.1.
---
---!
-
-package CXA40150 is
-
- -- Wide Character mapping function defined for use with specific
- -- versions of functions Index and Count.
-
- function AK_to_ZQ_Mapping (From : Wide_Character) return Wide_Character;
-
-end CXA40150;
-
-package body CXA40150 is
-
- function AK_to_ZQ_Mapping (From : Wide_Character)
- return Wide_Character is
- begin
- if From = 'a' then
- return 'z';
- elsif From = 'k' then
- return 'q';
- else
- return From;
- end if;
- end AK_to_ZQ_Mapping;
-
-end CXA40150;
-
-
-with CXA40150;
-with Report;
-with Ada.Strings;
-with Ada.Strings.Wide_Fixed;
-with Ada.Strings.Wide_Maps;
-
-procedure CXA4015 is
-begin
-
- Report.Test("CXA4015", "Check that the subprograms defined in " &
- "package Ada.Strings.Wide_Fixed are available, " &
- "and that they produce correct results");
-
-
- Test_Block:
- declare
-
- use CXA40150;
-
- package ASF renames Ada.Strings.Wide_Fixed;
- package Maps renames Ada.Strings.Wide_Maps;
-
- Result_String : Wide_String(1..10) :=
- (others => Ada.Strings.Wide_Space);
-
- Source_String1 : Wide_String(1..5) := "abcde"; -- odd len Wide_String
- Source_String2 : Wide_String(1..6) := "abcdef"; -- even len Wide_String
- Source_String3 : Wide_String(1..12) := "abcdefghijkl";
- Source_String4 : Wide_String(1..12) := "abcdefghij "; -- last 2 ch pad
- Source_String5 : Wide_String(1..12) := " cdefghijkl"; -- first 2 ch pad
- Source_String6 : Wide_String(1..12) := "abcdefabcdef";
-
- Location : Natural := 0;
- Slice_Start : Positive;
- Slice_End,
- Slice_Count : Natural := 0;
-
- CD_Set : Maps.Wide_Character_Set := Maps.To_Set("cd");
- ABCD_Set : Maps.Wide_Character_Set := Maps.To_Set("abcd");
- A_to_F_Set : Maps.Wide_Character_Set := Maps.To_Set("abcdef");
-
- CD_to_XY_Map : Maps.Wide_Character_Mapping :=
- Maps.To_Mapping(From => "cd", To => "xy");
-
-
- -- Access-to-Subprogram object defined for use with specific versions of
- -- functions Index and Count.
-
- Map_Ptr : Maps.Wide_Character_Mapping_Function :=
- AK_to_ZQ_Mapping'Access;
-
-
- begin
-
-
- -- Procedure Move
- -- Evaluate the Procedure Move with various combinations of
- -- parameters.
-
- -- Justify = Left (default case)
-
- ASF.Move(Source => Source_String1, -- "abcde"
- Target => Result_String);
-
- if Result_String /= "abcde " then
- Report.Failed("Incorrect result from Move with Justify = Left");
- end if;
-
- -- Justify = Right
-
- ASF.Move(Source => Source_String2, -- "abcdef"
- Target => Result_String,
- Drop => Ada.Strings.Error,
- Justify => Ada.Strings.Right);
-
- if Result_String /= " abcdef" then
- Report.Failed("Incorrect result from Move with Justify = Right");
- end if;
-
- -- Justify = Center (two cases, odd and even pad lengths)
-
- ASF.Move(Source_String1, -- "abcde"
- Result_String,
- Ada.Strings.Error,
- Ada.Strings.Center,
- 'x'); -- non-default padding.
-
- if Result_String /= "xxabcdexxx" then -- Unequal padding added right
- Report.Failed("Incorrect result from Move with Justify = Center-1");
- end if;
-
- ASF.Move(Source_String2, -- "abcdef"
- Result_String,
- Ada.Strings.Error,
- Ada.Strings.Center);
-
- if Result_String /= " abcdef " then -- Equal padding added on L/R.
- Report.Failed("Incorrect result from Move with Justify = Center-2");
- end if;
-
- -- When the source Wide_String is longer than the target Wide_String,
- -- several cases can be examined, with the results depending on the
- -- value of the Drop parameter.
-
- -- Drop = Left
-
- ASF.Move(Source => Source_String3, -- "abcdefghijkl"
- Target => Result_String,
- Drop => Ada.Strings.Left);
-
- if Result_String /= "cdefghijkl" then
- Report.Failed("Incorrect result from Move with Drop = Left");
- end if;
-
- -- Drop = Right
-
- ASF.Move(Source_String3, Result_String, Ada.Strings.Right);
-
- if Result_String /= "abcdefghij" then
- Report.Failed("Incorrect result from Move with Drop = Right");
- end if;
-
- -- Drop = Error
- -- The effect in this case depends on the value of the justify
- -- parameter, and on whether any characters in Source other than
- -- Pad would fail to be copied.
-
- -- Drop = Error, Justify = Left, right overflow characters are pad.
-
- ASF.Move(Source => Source_String4, -- "abcdefghij "
- Target => Result_String,
- Drop => Ada.Strings.Error,
- Justify => Ada.Strings.Left);
-
- if not(Result_String = "abcdefghij") then -- leftmost 10 characters
- Report.Failed("Incorrect result from Move with Drop = Error - 1");
- end if;
-
- -- Drop = Error, Justify = Right, left overflow characters are pad.
-
- ASF.Move(Source_String5, -- " cdefghijkl"
- Result_String,
- Ada.Strings.Error,
- Ada.Strings.Right);
-
- if Result_String /= "cdefghijkl" then -- rightmost 10 characters
- Report.Failed("Incorrect result from Move with Drop = Error - 2");
- end if;
-
- -- In other cases of Drop=Error, Length_Error is propagated, such as:
-
- begin
-
- ASF.Move(Source_String3, -- 12 characters, no Pad.
- Result_String, -- 10 characters
- Ada.Strings.Error,
- Ada.Strings.Left);
-
- Report.Failed("Length_Error not raised by Move - 1");
-
- exception
- when Ada.Strings.Length_Error => null; -- OK
- when others =>
- Report.Failed("Incorrect exception raised by Move - 1");
- end;
-
-
-
- -- Function Index
- -- (Other usage examples of this function found in CXA4013-14.)
- -- Check when the pattern is not found in the source.
-
- if ASF.Index("abcdef", "gh") /= 0 or
- ASF.Index("abcde", "abcdef") /= 0 or -- pattern > source
- ASF.Index("xyz",
- "abcde",
- Ada.Strings.Backward) /= 0 or
- ASF.Index("", "ab") /= 0 or -- null source Wide_String.
- ASF.Index("abcde", " ") /= 0 -- blank pattern.
- then
- Report.Failed("Incorrect result from Index, no pattern match");
- end if;
-
- -- Check that Pattern_Error is raised when the pattern is the
- -- null Wide_String.
- begin
- Location := ASF.Index(Source_String6, -- "abcdefabcdef"
- "", -- null pattern Wide_String.
- Ada.Strings.Forward);
- Report.Failed("Pattern_Error not raised by Index");
- exception
- when Ada.Strings.Pattern_Error => null; -- OK, expected exception.
- when others =>
- Report.Failed("Incorrect exception raised by Index, null pattern");
- end;
-
- -- Use the search direction "backward" to locate the particular
- -- pattern within the source Wide_String.
-
- Location := ASF.Index(Source_String6, -- "abcdefabcdef"
- "de", -- slice 4..5, 10..11
- Ada.Strings.Backward); -- search from right end.
-
- if Location /= 10 then
- Report.Failed("Incorrect result from Index going Backward");
- end if;
-
-
-
- -- Function Index
- -- Use the version of Index that takes a Wide_Character_Mapping_Function
- -- parameter.
- -- Use the search directions Forward and Backward to locate the
- -- particular pattern wide string within the source wide string.
-
- Location := ASF.Index("akzqefakzqef",
- "qzq", -- slice 8..10
- Ada.Strings.Backward,
- Map_Ptr); -- perform 'a' to 'z', 'k' to 'q'
- -- translation.
- if Location /= 8 then
- Report.Failed
- ("Incorrect result from Index w/map ptr going Backward");
- end if;
-
- Location := ASF.Index("ddkkddakcdakdefcadckdfzaaqd",
- "zq", -- slice 7..8
- Ada.Strings.Forward,
- Map_Ptr); -- perform 'a' to 'z', 'k' to 'q'
- -- translation.
- if Location /= 7 then
- Report.Failed
- ("Incorrect result from Index w/map ptr going Forward");
- end if;
-
-
- if ASF.Index("aakkzq", "zq", Ada.Strings.Forward, Map_Ptr) /= 2 or
- ASF.Index("qzedka", "qz", Ada.Strings.Backward, Map_Ptr) /= 5 or
- ASF.Index("zazaza", "zzzz", Ada.Strings.Backward, Map_Ptr) /= 3 or
- ASF.Index("kka", "qqz", Ada.Strings.Forward, Map_Ptr) /= 1
- then
- Report.Failed("Incorrect result from Index w/map ptr");
- end if;
-
-
- -- Check when the pattern wide string is not found in the source.
-
- if ASF.Index("akzqef", "kzq", Ada.Strings.Forward, Map_Ptr) /= 0 or
- ASF.Index("abcde", "abcdef", Ada.Strings.Backward, Map_Ptr) /= 0 or
- ASF.Index("xyz", "akzde", Ada.Strings.Backward, Map_Ptr) /= 0 or
- ASF.Index("", "zq", Ada.Strings.Forward, Map_Ptr) /= 0 or
- ASF.Index("akcde", " ", Ada.Strings.Backward, Map_Ptr) /= 0
- then
- Report.Failed
- ("Incorrect result from Index w/map ptr, no pattern match");
- end if;
-
- -- Check that Pattern_Error is raised when the pattern is a
- -- null Wide_String.
- begin
- Location := ASF.Index("akzqefakqzef",
- "", -- null pattern Wide_String.
- Ada.Strings.Forward,
- Map_Ptr);
- Report.Failed("Pattern_Error not raised by Index w/map ptr");
- exception
- when Ada.Strings.Pattern_Error => null; -- OK, expected exception.
- when others =>
- Report.Failed
- ("Incorrect exception raised by Index w/map ptr, null pattern");
- end;
-
-
-
- -- Function Index
- -- Using the version of Index testing wide character set membership,
- -- check combinations of forward/backward, inside/outside parameter
- -- configurations.
-
- if ASF.Index(Source => Source_String1, -- "abcde"
- Set => CD_Set,
- Test => Ada.Strings.Inside,
- Going => Ada.Strings.Forward) /= 3 or -- 'c' at pos 3.
- ASF.Index(Source_String6, -- "abcdefabcdef"
- CD_Set,
- Ada.Strings.Outside,
- Ada.Strings.Backward) /= 12 or -- 'f' at position 12
- ASF.Index(Source_String6, -- "abcdefabcdef"
- CD_Set,
- Ada.Strings.Inside,
- Ada.Strings.Backward) /= 10 or -- 'd' at position 10
- ASF.Index("cdcdcdcdacdcdcdcd",
- CD_Set,
- Ada.Strings.Outside,
- Ada.Strings.Forward) /= 9 -- 'a' at position 9
- then
- Report.Failed("Incorrect result from function Index for sets - 1");
- end if;
-
- -- Additional interesting uses/combinations using Index for sets.
-
- if ASF.Index("cd", -- same size, str-set
- CD_Set,
- Ada.Strings.Inside,
- Ada.Strings.Forward) /= 1 or -- 'c' at position 1
- ASF.Index("abcd", -- same size, str-set,
- Maps.To_Set("efgh"), -- different contents.
- Ada.Strings.Outside,
- Ada.Strings.Forward) /= 1 or
- ASF.Index("abccd", -- set > Wide_String
- Maps.To_Set("acegik"),
- Ada.Strings.Inside,
- Ada.Strings.Backward) /= 4 or -- 'c' at position 4
- ASF.Index("abcde",
- Maps.Null_Set) /= 0 or
- ASF.Index("", -- Null string.
- CD_Set) /= 0 or
- ASF.Index("abc ab", -- blank included
- Maps.To_Set("e "), -- in Wide_String and
- Ada.Strings.Inside, -- set.
- Ada.Strings.Backward) /= 4 -- blank in Wide_Str.
- then
- Report.Failed("Incorrect result from function Index for sets - 2");
- end if;
-
-
-
- -- Function Index_Non_Blank.
- -- (Other usage examples of this function found in CXA4013-14.)
-
-
- if ASF.Index_Non_Blank(Source => Source_String4, -- "abcdefghij "
- Going => Ada.Strings.Backward) /= 10 or
- ASF.Index_Non_Blank("abc def ghi jkl ",
- Ada.Strings.Backward) /= 15 or
- ASF.Index_Non_Blank(" abcdef") /= 3 or
- ASF.Index_Non_Blank(" ") /= 0
- then
- Report.Failed("Incorrect result from Index_Non_Blank");
- end if;
-
-
-
- -- Function Count
- -- (Other usage examples of this function found in CXA4013-14.)
-
- if ASF.Count("abababa", "aba") /= 2 or
- ASF.Count("abababa", "ab" ) /= 3 or
- ASF.Count("babababa", "ab") /= 3 or
- ASF.Count("abaabaaba", "aba") /= 3 or
- ASF.Count("xxxxxxxxxxxxxxxxxxxy", "xy") /= 1 or
- ASF.Count("xxxxxxxxxxxxxxxxxxxx", "x") /= 20
- then
- Report.Failed("Incorrect result from Function Count");
- end if;
-
- -- Determine the number of slices of Source that when mapped to a
- -- non-identity map, match the pattern Wide_String.
-
- Slice_Count := ASF.Count(Source_String6, -- "abcdefabcdef"
- "xy",
- CD_to_XY_Map); -- maps 'c' to 'x', 'd' to 'y'
-
- if Slice_Count /= 2 then -- two slices "xy" in "mapped" Source_String6
- Report.Failed("Incorrect result from Count with non-identity map");
- end if;
-
- -- If the pattern supplied to Function Count is the null Wide_String,
- -- then Pattern_Error is propagated.
- declare
- The_Null_Wide_String : constant Wide_String := "";
- begin
- Slice_Count := ASF.Count(Source_String6, The_Null_Wide_String);
- Report.Failed("Pattern_Error not raised by Function Count");
- exception
- when Ada.Strings.Pattern_Error => null; -- OK
- when others =>
- Report.Failed("Incorrect exception from Count with null pattern");
- end;
-
-
-
-
- -- Function Count
- -- Use the version of Count that takes a Wide_Character_Mapping_Function
- -- value as the basis of its source mapping.
-
- if ASF.Count("akakaka", "zqz", Map_Ptr) /= 2 or
- ASF.Count("akakaka", "qz", Map_Ptr) /= 3 or
- ASF.Count("kakakaka", "q", Map_Ptr) /= 4 or
- ASF.Count("zzqaakzaqzzk", "zzq", Map_Ptr) /= 4 or
- ASF.Count(" ", "z", Map_Ptr) /= 0 or
- ASF.Count("", "qz", Map_Ptr) /= 0 or
- ASF.Count("abbababab", "zq", Map_Ptr) /= 0 or
- ASF.Count("aaaaaaaaaaaaaaaaaakk", "zqq", Map_Ptr) /= 1 or
- ASF.Count("azaazaazzzaaaaazzzza", "z", Map_Ptr) /= 20
- then
- Report.Failed("Incorrect result from Function Count w/map ptr");
- end if;
-
- -- If the pattern supplied to Function Count is a null Wide_String,
- -- then Pattern_Error is propagated.
- declare
- The_Null_Wide_String : constant Wide_String := "";
- begin
- Slice_Count := ASF.Count(Source_String6,
- The_Null_Wide_String,
- Map_Ptr);
- Report.Failed
- ("Pattern_Error not raised by Function Count w/map ptr");
- exception
- when Ada.Strings.Pattern_Error => null; -- OK
- when others =>
- Report.Failed
- ("Incorrect exception from Count w/map ptr, null pattern");
- end;
-
-
-
-
- -- Function Count returning the number of characters in a particular
- -- set that are found in source Wide_String.
-
- if ASF.Count(Source_String6, CD_Set) /= 4 or -- 2 'c' and 'd' chars.
- ASF.Count("cddaccdaccdd", CD_Set) /= 10
- then
- Report.Failed("Incorrect result from Count with set");
- end if;
-
-
-
- -- Function Find_Token.
- -- (Other usage examples of this function found in CXA4013-14.)
-
- ASF.Find_Token(Source => Source_String6, -- First slice with no
- Set => ABCD_Set, -- 'a', 'b', 'c', or 'd'
- Test => Ada.Strings.Outside, -- is "ef" at 5..6.
- First => Slice_Start,
- Last => Slice_End);
-
- if Slice_Start /= 5 or Slice_End /= 6 then
- Report.Failed("Incorrect result from Find_Token - 1");
- end if;
-
- -- If no appropriate slice is contained by the source Wide_String,
- -- then the value returned in Last is zero, and the value in First is
- -- Source'First.
-
- ASF.Find_Token(Source_String6, -- "abcdefabcdef"
- A_to_F_Set, -- Set of characters 'a' thru 'f'.
- Ada.Strings.Outside, -- No characters outside this set.
- Slice_Start,
- Slice_End);
-
- if Slice_Start /= Source_String6'First or Slice_End /= 0 then
- Report.Failed("Incorrect result from Find_Token - 2");
- end if;
-
- -- Additional testing of Find_Token.
-
- ASF.Find_Token("eabcdabcddcab",
- ABCD_Set,
- Ada.Strings.Inside,
- Slice_Start,
- Slice_End);
-
- if Slice_Start /= 2 or Slice_End /= 13 then
- Report.Failed("Incorrect result from Find_Token - 3");
- end if;
-
- ASF.Find_Token("efghijklabcdabcd",
- ABCD_Set,
- Ada.Strings.Outside,
- Slice_Start,
- Slice_End);
-
- if Slice_Start /= 1 or Slice_End /= 8 then
- Report.Failed("Incorrect result from Find_Token - 4");
- end if;
-
- ASF.Find_Token("abcdefgabcdabcd",
- ABCD_Set,
- Ada.Strings.Outside,
- Slice_Start,
- Slice_End);
-
- if Slice_Start /= 5 or Slice_End /= 7 then
- Report.Failed("Incorrect result from Find_Token - 5");
- end if;
-
- ASF.Find_Token("abcdcbabcdcba",
- ABCD_Set,
- Ada.Strings.Inside,
- Slice_Start,
- Slice_End);
-
- if Slice_Start /= 1 or Slice_End /= 13 then
- Report.Failed("Incorrect result from Find_Token - 6");
- end if;
-
-
- exception
- when others => Report.Failed("Exception raised in Test_Block");
- end Test_Block;
-
- Report.Result;
-
-end CXA4015;
diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxa4016.a b/gcc/testsuite/ada/acats/tests/cxa/cxa4016.a
deleted file mode 100644
index 00dcdcdbd00..00000000000
--- a/gcc/testsuite/ada/acats/tests/cxa/cxa4016.a
+++ /dev/null
@@ -1,685 +0,0 @@
--- CXA4016.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that the subprograms defined in package Ada.Strings.Wide_Fixed
--- are available, and that they produce correct results. Specifically,
--- check the subprograms Delete, Head, Insert, Overwrite, Replace_Slice,
--- Tail, Trim, and "*".
---
--- TEST DESCRIPTION:
--- This test, when combined with tests CXA4013-15 will provide
--- coverage of the functionality found in package Ada.Strings.Wide_Fixed.
--- This test contains many small, specific test cases, situations that
--- although common in user environments, are often difficult to generate
--- in large numbers in a application-based test. They represent
--- individual usage paradigms in-the-small.
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 10 Apr 94 SAIC Modified comments in a subtest failure message.
--- 06 Nov 95 SAIC Corrected subtest results for ACVC 2.0.1
--- 14 Mar 01 RLB Added checks that the lower bound is 1, similar
--- to CXA4005. These changes were made to test
--- Defect Report 8652/0049, as reflected in
--- Technical Corrigendum 1.
---
---!
-
-with Report;
-with Ada.Strings;
-with Ada.Strings.Wide_Fixed;
-with Ada.Strings.Wide_Maps;
-
-procedure CXA4016 is
-
- type TC_Name_Holder is access String;
- Name : TC_Name_Holder;
-
- function TC_Check (S : Wide_String) return Wide_String is
- begin
- if S'First /= 1 then
- Report.Failed ("Lower bound of result of function " & Name.all &
- " is" & Integer'Image (S'First));
- end if;
- return S;
- end TC_Check;
-
- procedure TC_Set_Name (N : String) is
- begin
- Name := new String'(N);
- end TC_Set_Name;
-
-begin
-
- Report.Test("CXA4016", "Check that the subprograms defined in " &
- "package Ada.Strings.Wide_Fixed are available, " &
- "and that they produce correct results");
-
- Test_Block:
- declare
-
- package ASW renames Ada.Strings.Wide_Fixed;
- package Wide_Maps renames Ada.Strings.Wide_Maps;
-
- Result_String,
- Delete_String,
- Insert_String,
- Trim_String,
- Overwrite_String : Wide_String(1..10) :=
- (others => Ada.Strings.Wide_Space);
- Replace_String : Wide_String(10..30) :=
- (others => Ada.Strings.Wide_Space);
-
- Source_String1 : Wide_String(1..5) := "abcde"; -- odd len wd str
- Source_String2 : Wide_String(1..6) := "abcdef"; -- even len wd str
- Source_String3 : Wide_String(1..12) := "abcdefghijkl";
- Source_String4 : Wide_String(1..12) := "abcdefghij "; -- last two ch pad
- Source_String5 : Wide_String(1..12) := " cdefghijkl"; -- first two ch pad
- Source_String6 : Wide_String(1..12) := "abcdefabcdef";
-
- Location : Natural := 0;
- Slice_Start : Positive;
- Slice_End,
- Slice_Count : Natural := 0;
-
- CD_Set : Wide_Maps.Wide_Character_Set :=
- Wide_Maps.To_Set("cd");
- X_Set : Wide_Maps.Wide_Character_Set :=
- Wide_Maps.To_Set('x');
- ABCD_Set : Wide_Maps.Wide_Character_Set :=
- Wide_Maps.To_Set("abcd");
- A_to_F_Set : Wide_Maps.Wide_Character_Set :=
- Wide_Maps.To_Set("abcdef");
-
- CD_to_XY_Map : Wide_Maps.Wide_Character_Mapping :=
- Wide_Maps.To_Mapping(From => "cd", To => "xy");
-
- begin
-
- -- Procedure Replace_Slice
- -- The functionality of this procedure is similar to procedure Move,
- -- and is tested here in the same manner, evaluated with various
- -- combinations of parameters.
-
- -- Index_Error propagation when Low > Source'Last + 1
-
- begin
- ASW.Replace_Slice(Result_String,
- Result_String'Last + 2, -- should raise exception
- Result_String'Last,
- "xxxxxxx");
- Report.Failed("Index_Error not raised by Replace_Slice - 1");
- exception
- when Ada.Strings.Index_Error => null; -- OK, expected exception.
- when others =>
- Report.Failed("Incorrect exception from Replace_Slice - 1");
- end;
-
- -- Index_Error propagation when High < Source'First - 1
-
- begin
- ASW.Replace_Slice(Replace_String(20..30),
- Replace_String'First,
- Replace_String'First - 2, -- should raise exception
- "xxxxxxx");
- Report.Failed("Index_Error not raised by Replace_Slice - 2");
- exception
- when Ada.Strings.Index_Error => null; -- OK, expected exception.
- when others =>
- Report.Failed("Incorrect exception from Replace_Slice - 2");
- end;
-
- -- Justify = Left (default case)
-
- Result_String := "XXXXXXXXXX";
-
- ASW.Replace_Slice(Source => Result_String,
- Low => 1,
- High => 10,
- By => Source_String1); -- "abcde"
-
- if Result_String /= "abcde " then
- Report.Failed("Incorrect result from Replace_Slice - Justify = Left");
- end if;
-
- -- Justify = Right
-
- ASW.Replace_Slice(Source => Result_String,
- Low => 1,
- High => Result_String'Last,
- By => Source_String2, -- "abcdef"
- Drop => Ada.Strings.Error,
- Justify => Ada.Strings.Right);
-
- if Result_String /= " abcdef" then
- Report.Failed("Incorrect result from Replace_Slice - Justify=Right");
- end if;
-
- -- Justify = Center (two cases, odd and even pad lengths)
-
- ASW.Replace_Slice(Result_String,
- 1,
- Result_String'Last,
- Source_String1, -- "abcde"
- Ada.Strings.Error,
- Ada.Strings.Center,
- 'x'); -- non-default padding.
-
- if Result_String /= "xxabcdexxx" then -- Unequal padding added right
- Report.Failed("Incorrect result, Replace_Slice - Justify=Center - 1");
- end if;
-
- ASW.Replace_Slice(Result_String,
- 1,
- Result_String'Last,
- Source_String2, -- "abcdef"
- Ada.Strings.Error,
- Ada.Strings.Center);
-
- if Result_String /= " abcdef " then -- Equal padding added on L/R.
- Report.Failed("Incorrect result from Replace_Slice with " &
- "Justify = Center - 2");
- end if;
-
- -- When the source string is longer than the target string, several
- -- cases can be examined, with the results depending on the value of
- -- the Drop parameter.
-
- -- Drop = Left
-
- ASW.Replace_Slice(Result_String,
- 1,
- Result_String'Last,
- Source_String3, -- "abcdefghijkl"
- Drop => Ada.Strings.Left);
-
- if Result_String /= "cdefghijkl" then
- Report.Failed("Incorrect result from Replace_Slice - Drop=Left");
- end if;
-
- -- Drop = Right
-
- ASW.Replace_Slice(Result_String,
- 1,
- Result_String'Last,
- Source_String3, -- "abcdefghijkl"
- Ada.Strings.Right);
-
- if Result_String /= "abcdefghij" then
- Report.Failed("Incorrect result, Replace_Slice with Drop=Right");
- end if;
-
- -- Drop = Error
-
- -- The effect in this case depends on the value of the justify
- -- parameter, and on whether any characters in Source other than
- -- Pad would fail to be copied.
-
- -- Drop = Error, Justify = Left, right overflow characters are pad.
-
- ASW.Replace_Slice(Result_String,
- 1,
- Result_String'Last,
- Source_String4, -- "abcdefghij "
- Drop => Ada.Strings.Error,
- Justify => Ada.Strings.Left);
-
- if not(Result_String = "abcdefghij") then -- leftmost 10 characters
- Report.Failed("Incorrect result, Replace_Slice - Drop = Error - 1");
- end if;
-
- -- Drop = Error, Justify = Right, left overflow characters are pad.
-
- ASW.Replace_Slice(Source => Result_String,
- Low => 1,
- High => Result_String'Last,
- By => Source_String5, -- " cdefghijkl"
- Drop => Ada.Strings.Error,
- Justify => Ada.Strings.Right);
-
- if Result_String /= "cdefghijkl" then -- rightmost 10 characters
- Report.Failed("Incorrect result, Replace_Slice - Drop = Error - 2");
- end if;
-
- -- In other cases of Drop=Error, Length_Error is propagated, such as:
-
- begin
-
- ASW.Replace_Slice(Source => Result_String,
- Low => 1,
- High => Result_String'Last,
- By => Source_String3, -- "abcdefghijkl"
- Drop => Ada.Strings.Error);
-
- Report.Failed("Length_Error not raised by Replace_Slice - 1");
-
- exception
- when Ada.Strings.Length_Error => null; -- OK
- when others =>
- Report.Failed("Incorrect exception from Replace_Slice - 3");
- end;
-
-
- -- Function Replace_Slice
-
- TC_Set_Name ("Replace_Slice");
-
- if TC_Check (ASW.Replace_Slice("abcde", 3, 3, "x"))
- /= "abxde" or -- High = Low
- TC_Check (ASW.Replace_Slice("abc", 2, 3, "xyz")) /= "axyz" or
- TC_Check (ASW.Replace_Slice("abcd", 4, 1, "xy"))
- /= "abcxyd" or -- High < Low
- TC_Check (ASW.Replace_Slice("abc", 2, 3, "x")) /= "ax" or
- TC_Check (ASW.Replace_Slice("a", 1, 1, "z")) /= "z"
- then
- Report.Failed("Incorrect result from Function Replace_Slice - 1");
- end if;
-
- if TC_Check (ASW.Replace_Slice("abcde", 5, 5, "z"))
- /= "abcdz" or -- By length 1
- TC_Check (ASW.Replace_Slice("abc", 1, 3, "xyz"))
- /= "xyz" or -- High > Low
- TC_Check (ASW.Replace_Slice("abc", 3, 2, "xy"))
- /= "abxyc" or -- insert
- TC_Check (ASW.Replace_Slice("a", 1, 1, "xyz")) /= "xyz"
- then
- Report.Failed("Incorrect result from Function Replace_Slice - 2");
- end if;
-
-
-
- -- Function Insert.
-
- TC_Set_Name ("Insert");
-
- declare
- New_String : constant Wide_String :=
- TC_Check (
- ASW.Insert(Source => Source_String1(2..5), -- "bcde"
- Before => 2,
- New_Item => Source_String2)); -- "abcdef"
- begin
- if New_String /= "abcdefbcde" then
- Report.Failed("Incorrect result from Function Insert - 1");
- end if;
- end;
-
- if TC_Check (ASW.Insert("a", 1, "z")) /= "za" or
- TC_Check (ASW.Insert("abc", 3, "")) /= "abc" or
- TC_Check (ASW.Insert("abc", 4, "z")) /= "abcz"
- then
- Report.Failed("Incorrect result from Function Insert - 2");
- end if;
-
- begin
- if TC_Check (ASW.Insert(Source => Source_String1(2..5), -- "bcde"
- Before => Report.Ident_Int(7),
- New_Item => Source_String2)) -- "abcdef"
- /= "babcdefcde" then
- Report.Failed("Index_Error not raised by Insert - 3A");
- else
- Report.Failed("Index_Error not raised by Insert - 3B");
- end if;
- exception
- when Ada.Strings.Index_Error => null; -- OK, expected exception.
- when others =>
- Report.Failed("Incorrect exception from Insert - 3");
- end;
-
-
- -- Procedure Insert
-
- -- Drop = Right
-
- ASW.Insert(Source => Insert_String,
- Before => 6,
- New_Item => Source_String2, -- "abcdef"
- Drop => Ada.Strings.Right);
-
- if Insert_String /= " abcde" then -- last char of New_Item dropped.
- Report.Failed("Incorrect result from Insert with Drop = Right");
- end if;
-
- -- Drop = Left
-
- ASW.Insert(Source => Insert_String, -- 10 char string
- Before => 2, -- 9 chars, 2..10 available
- New_Item => Source_String3, -- 12 characters long.
- Drop => Ada.Strings.Left); -- truncate from Left.
-
- if Insert_String /= "l abcde" then -- 10 chars, leading blank.
- Report.Failed("Incorrect result from Insert with Drop=Left");
- end if;
-
- -- Drop = Error
-
- begin
- ASW.Insert(Source => Result_String, -- 10 chars
- Before => Result_String'Last,
- New_Item => "abcdefghijk",
- Drop => Ada.Strings.Error);
- Report.Failed("Exception not raised by Procedure Insert");
- exception
- when Ada.Strings.Length_Error => null; -- OK, expected exception
- when others =>
- Report.Failed("Incorrect exception raised by Procedure Insert");
- end;
-
-
-
- -- Function Overwrite
-
- TC_Set_Name ("Overwrite");
-
- Overwrite_String := TC_Check (
- ASW.Overwrite(Result_String, -- 10 chars
- 1, -- starting at pos=1
- Source_String3(1..10)));
-
- if Overwrite_String /= Source_String3(1..10) then
- Report.Failed("Incorrect result from Function Overwrite - 1");
- end if;
-
-
- if TC_Check (ASW.Overwrite("abcdef", 4, "xyz")) /= "abcxyz" or
- TC_Check (ASW.Overwrite("a", 1, "xyz"))
- /= "xyz" or -- chars appended
- TC_Check (ASW.Overwrite("abc", 3, " "))
- /= "ab " or -- blanks appended
- TC_Check (ASW.Overwrite("abcde", 1, "z" )) /= "zbcde"
- then
- Report.Failed("Incorrect result from Function Overwrite - 2");
- end if;
-
-
-
- -- Procedure Overwrite, with truncation.
-
- ASW.Overwrite(Source => Overwrite_String, -- 10 characters.
- Position => 1,
- New_Item => Source_String3, -- 12 characters.
- Drop => Ada.Strings.Left);
-
- if Overwrite_String /= "cdefghijkl" then
- Report.Failed("Incorrect result from Overwrite with Drop=Left");
- end if;
-
- -- The default drop value is Right, used here.
-
- ASW.Overwrite(Source => Overwrite_String, -- 10 characters.
- Position => 1,
- New_Item => Source_String3); -- 12 characters.
-
- if Overwrite_String /= "abcdefghij" then
- Report.Failed("Incorrect result from Overwrite with Drop=Right");
- end if;
-
- -- Drop = Error
-
- begin
- ASW.Overwrite(Source => Overwrite_String, -- 10 characters.
- Position => 1,
- New_Item => Source_String3, -- 12 characters.
- Drop => Ada.Strings.Error);
- Report.Failed("Exception not raised by Procedure Overwrite");
- exception
- when Ada.Strings.Length_Error => null; -- OK, expected exception.
- when others =>
- Report.Failed
- ("Incorrect exception raised by Procedure Overwrite");
- end;
-
- Overwrite_String := "ababababab";
- ASW.Overwrite(Overwrite_String, Overwrite_String'Last, "z");
- ASW.Overwrite(Overwrite_String, Overwrite_String'First,"z");
- ASW.Overwrite(Overwrite_String, 5, "zz");
-
- if Overwrite_String /= "zbabzzabaz" then
- Report.Failed("Incorrect result from Procedure Overwrite");
- end if;
-
-
-
- -- Function Delete
-
- TC_Set_Name ("Delete");
-
- declare
- New_String1 : constant Wide_String := -- Returns a 4 char wide str.
- TC_Check (ASW.Delete(Source => Source_String3,
- From => 3,
- Through => 10));
- New_String2 : constant Wide_String := -- This returns Source.
- TC_Check (ASW.Delete(Source_String3, 10, 3));
- begin
- if New_String1 /= "abkl" or
- New_String2 /= Source_String3
- then
- Report.Failed("Incorrect result from Function Delete - 1");
- end if;
- end;
-
- if TC_Check (ASW.Delete("a", 1, 1))
- /= "" or -- Source length = 1
- TC_Check (ASW.Delete("abc", 1, 2))
- /= "c" or -- From = Source'First
- TC_Check (ASW.Delete("abc", 3, 3))
- /= "ab" or -- From = Source'Last
- TC_Check (ASW.Delete("abc", 3, 1))
- /= "abc" -- From > Through
- then
- Report.Failed("Incorrect result from Function Delete - 2");
- end if;
-
-
-
- -- Procedure Delete
-
- -- Justify = Left
-
- Delete_String := Source_String3(1..10); -- Initialize to "abcdefghij"
-
- ASW.Delete(Source => Delete_String,
- From => 6,
- Through => Delete_String'Last,
- Justify => Ada.Strings.Left,
- Pad => 'x'); -- pad with char 'x'
-
- if Delete_String /= "abcdexxxxx" then
- Report.Failed("Incorrect result from Delete - Justify = Left");
- end if;
-
- -- Justify = Right
-
- ASW.Delete(Source => Delete_String, -- Remove x"s from end and
- From => 6, -- shift right.
- Through => Delete_String'Last,
- Justify => Ada.Strings.Right,
- Pad => 'x'); -- pad with char 'x' on left.
-
- if Delete_String /= "xxxxxabcde" then
- Report.Failed("Incorrect result from Delete - Justify = Right");
- end if;
-
- -- Justify = Center
-
- ASW.Delete(Source => Delete_String,
- From => 1,
- Through => 5,
- Justify => Ada.Strings.Center,
- Pad => 'z');
-
- if Delete_String /= "zzabcdezzz" then -- extra pad char on right side.
- Report.Failed("Incorrect result from Delete - Justify = Center");
- end if;
-
-
-
- -- Function Trim
- -- Use non-identity character sets to perform the trim operation.
-
- TC_Set_Name ("Trim");
-
- Trim_String := "cdabcdefcd";
-
- -- Remove the "cd" from each end of the string. This will not effect
- -- the "cd" slice at 5..6.
-
- declare
- New_String : constant Wide_String :=
- TC_Check (ASW.Trim(Source => Trim_String,
- Left => CD_Set, Right => CD_Set));
- begin
- if New_String /= Source_String2 then -- string "abcdef"
- Report.Failed
- ("Incorrect result from Trim with wide character sets");
- end if;
- end;
-
- if TC_Check (ASW.Trim("abcdef", Wide_Maps.Null_Set, Wide_Maps.Null_Set))
- /= "abcdef" then
- Report.Failed("Incorrect result from Trim with Null sets");
- end if;
-
- if TC_Check (ASW.Trim("cdxx", CD_Set, X_Set)) /= "" then
- Report.Failed("Incorrect result from Trim, wide string removal");
- end if;
-
-
- -- Procedure Trim
-
- -- Justify = Right
-
- ASW.Trim(Source => Trim_String,
- Left => CD_Set,
- Right => CD_Set,
- Justify => Ada.Strings.Right,
- Pad => 'x');
-
- if Trim_String /= "xxxxabcdef" then
- Report.Failed("Incorrect result from Trim with Justify = Right");
- end if;
-
- -- Justify = Left
-
- ASW.Trim(Source => Trim_String,
- Left => X_Set,
- Right => Wide_Maps.Null_Set,
- Justify => Ada.Strings.Left,
- Pad => ' ');
-
- if Trim_String /= "abcdef " then -- Padded with 4 blanks on right.
- Report.Failed("Incorrect result from Trim with Justify = Left");
- end if;
-
- -- Justify = Center
-
- ASW.Trim(Source => Trim_String,
- Left => ABCD_Set,
- Right => CD_Set,
- Justify => Ada.Strings.Center,
- Pad => 'x');
-
- if Trim_String /= "xxef xx" then -- Padded with 4 pad chars on L/R
- Report.Failed("Incorrect result from Trim with Justify = Center");
- end if;
-
-
-
- -- Function Head, testing use of padding.
-
- TC_Set_Name ("Head");
-
- -- Use the wide characters of Source_String1 ("abcde") and pad the
- -- last five wide characters of Result_String with 'x' wide characters.
-
- Result_String := TC_CHeck (ASW.Head(Source_String1, 10, 'x'));
-
- if Result_String /= "abcdexxxxx" then
- Report.Failed("Incorrect result from Function Head with padding");
- end if;
-
- if TC_Check (ASW.Head(" ab ", 2)) /= " " or
- TC_Check (ASW.Head("a", 6, 'A')) /= "aAAAAA" or
- TC_Check (ASW.Head(ASW.Head("abc ", 7, 'x'), 10, 'X'))
- /= "abc xxXXX"
- then
- Report.Failed("Incorrect result from Function Head");
- end if;
-
-
-
- -- Function Tail, testing use of padding.
-
- TC_Set_Name ("Tail");
-
- -- Use the wide characters of Source_String1 ("abcde") and pad the
- -- first five wide characters of Result_String with 'x' wide characters.
-
- Result_String := TC_Check (ASW.Tail(Source_String1, 10, 'x'));
-
- if Result_String /= "xxxxxabcde" then
- Report.Failed("Incorrect result from Function Tail with padding");
- end if;
-
- if TC_Check (ASW.Tail("abcde ", 5))
- /= "cde " or -- blanks, back
- TC_Check (ASW.Tail(" abc ", 8, ' '))
- /= " abc " or -- blanks, front/back
- TC_Check (ASW.Tail("", 5, 'Z'))
- /= "ZZZZZ" or -- pad characters only
- TC_Check (ASW.Tail("abc", 0))
- /= "" or -- null result
- TC_Check (ASW.Tail(ASW.Tail(" abc ", 6, 'x'),
- 10,
- 'X')) /= "XXXXx abc "
- then
- Report.Failed("Incorrect result from Function Tail");
- end if;
-
-
-
- -- Function "*" - with (Natural, Wide_String) parameters
-
- TC_Set_Name ("""*""");
-
- if TC_Check (ASW."*"(3, Source_String1)) /= "abcdeabcdeabcde" or
- TC_Check (ASW."*"(2, Source_String2)) /= Source_String6 or
- TC_Check (ASW."*"(4, Source_String1(1..2))) /= "abababab" or
- TC_Check (ASW."*"(0, Source_String1)) /= ""
- then
- Report.Failed
- ("Incorrect result from Function ""*"" with wide strings");
- end if;
-
- exception
- when others => Report.Failed("Exception raised in Test_Block");
- end Test_Block;
-
- Report.Result;
-
-end CXA4016;
diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxa4017.a b/gcc/testsuite/ada/acats/tests/cxa/cxa4017.a
deleted file mode 100644
index 8d6886897ad..00000000000
--- a/gcc/testsuite/ada/acats/tests/cxa/cxa4017.a
+++ /dev/null
@@ -1,337 +0,0 @@
--- CXA4017.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that the subprograms defined in package Ada.Strings.Wide_Bounded
--- are available, and that they produce correct results. Specifically,
--- check the subprograms Append, Delete, Index, Insert , Length,
--- Overwrite, Replace_Slice, Slice, "&", To_Bounded_Wide_String,
--- To_Wide_String, Translate, and Trim.
---
--- TEST DESCRIPTION:
--- This test demonstrates the uses of a variety of the Wide_String
--- functions found in the package Ada.Strings.Wide_Bounded, simulating
--- the operations found in a text processing environment.
--- With bounded wide strings, the length of each "line" of text can vary
--- up to the instantiated maximum, allowing one to view a page of text as
--- a series of expandable lines. This provides flexibility in text
--- formatting of individual lines (wide strings).
--- Several subprograms are defined, all of which attempt to take
--- advantage of as many different bounded wide string utilities as
--- possible. Often, an operation that is being performed in a subprogram
--- using a certain bounded wide string utility could more efficiently be
--- performed using a different utility. However, in the interest of
--- including as broad coverage as possible, a mixture of utilities is
--- invoked in this test.
--- A simulated page of text is provided as a parameter to the test
--- defined subprograms, and the appropriate processing performed. The
--- processed page of text is then compared to a predefined "finished"
--- page, and test passage/failure is based on the results of this
--- comparison.
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 06 Nov 95 SAIC Corrected initialization error for ACVC 2.0.1.
---
---!
-
-with Ada.Strings;
-with Ada.Strings.Wide_Bounded;
-with Ada.Strings.Wide_Maps;
-with Report;
-
-procedure CXA4017 is
-
-begin
-
- Report.Test ("CXA4017", "Check that the subprograms defined in package " &
- "Ada.Strings.Wide_Bounded are available, and " &
- "that they produce correct results");
-
- Test_Block:
- declare
-
- Characters_Per_Line : constant Positive := 40;
- Lines_Per_Page : constant Natural := 4;
-
-
- package BS_40 is new
- Ada.Strings.Wide_Bounded.Generic_Bounded_Length(Characters_Per_Line);
-
- use type BS_40.Bounded_Wide_String;
-
- type Page_Type is array (1..Lines_Per_Page) of
- BS_40.Bounded_Wide_String;
-
- -- Note: Misspellings below are intentional.
-
- Line1 : BS_40.Bounded_Wide_String :=
- BS_40.To_Bounded_Wide_String
- ("ada is a progrraming language designed");
- Line2 : BS_40.Bounded_Wide_String :=
- BS_40.To_Bounded_Wide_String("to support the construction of long-");
- Line3 : BS_40.Bounded_Wide_String :=
- BS_40.To_Bounded_Wide_String("lived, highly reliabel software ");
- Line4 : BS_40.Bounded_Wide_String :=
- BS_40.To_Bounded_Wide_String("systems");
-
- Page : Page_Type := (1 => Line1, 2 => Line2, 3 => Line3, 4 => Line4);
-
- Finished_Page : Page_Type :=
- (BS_40.To_Bounded_Wide_String
- ("Ada is a programming language designed"),
- BS_40.To_Bounded_Wide_String("to support the construction of long-"),
- BS_40.To_Bounded_Wide_String
- ("lived, HIGHLY RELIABLE software systems."),
- BS_40.To_Bounded_Wide_String(""));
-
- ---
-
- procedure Compress (Page : in out Page_Type) is
- Clear_Line : Natural := Lines_Per_Page;
- begin
- -- If two consecutive lines on the page are together less than the
- -- maximum line length, then append those two lines, move up all
- -- lower lines on the page, and blank out the last line.
- -- This algorithm works one time through the page, does not perform
- -- repetitive compression, and is designed for use with this test
- -- program only.
- for i in 1..Lines_Per_Page - 1 loop
- if BS_40.Length(Page(i)) + BS_40.Length(Page(i+1)) <=
- BS_40.Max_Length
- then
- Page(i) := BS_40."&"(Page(i),
- Page(i+1)); -- "&" (wd bnd, wd bnd)
-
- for j in i+1..Lines_Per_Page - 1 loop
- Page(j) :=
- BS_40.To_Bounded_Wide_String
- (BS_40.Slice(Page(j+1),
- 1,
- BS_40.Length(Page(j+1))));
- Clear_Line := j + 1;
- end loop;
- Page(Clear_Line) := BS_40.Null_Bounded_Wide_String;
- end if;
- end loop;
- end Compress;
-
- ---
-
- procedure Format (Page : in out Page_Type) is
- Sm_Ada : BS_40.Bounded_Wide_String :=
- BS_40.To_Bounded_Wide_String("ada");
- Cap_Ada : constant Wide_String := "Ada";
- Char_Pos : Natural := 0;
- Finished : Boolean := False;
- Line : Natural := Page_Type'Last;
- begin
-
- -- Add a period to the end of the last line.
- while Line >= Page_Type'First and not Finished loop
- if Page(Line) /= BS_40.Null_Bounded_Wide_String and
- BS_40.Length(Page(Line)) <= BS_40.Max_Length
- then
- Page(Line) := BS_40.Append(Page(Line), '.');
- Finished := True;
- end if;
- Line := Line - 1;
- end loop;
-
- -- Replace all occurrences of "ada" with "Ada".
- for Line in Page_Type'First .. Page_Type'Last loop
- Finished := False;
- while not Finished loop
- Char_Pos :=
- BS_40.Index (Source => Page(Line),
- Pattern => BS_40.To_Wide_String(Sm_Ada),
- Going => Ada.Strings.Backward);
- -- A zero is returned by function Index if no occurrences of
- -- the pattern wide string are found.
- Finished := (Char_Pos = 0);
- if not Finished then
- BS_40.Replace_Slice
- (Source => Page(Line),
- Low => Char_Pos,
- High => Char_Pos + BS_40.Length(Sm_Ada) - 1,
- By => Cap_Ada);
- end if;
- end loop; -- while loop
- end loop; -- for loop
-
- end Format;
-
- ---
-
- procedure Spell_Check (Page : in out Page_Type) is
- type Spelling_Type is (Incorrect, Correct);
- type Word_Array_Type is array (Spelling_Type)
- of BS_40.Bounded_Wide_String;
- type Dictionary_Type is array (1..2) of Word_Array_Type;
-
- -- Note that the "words" in the dictionary will require various
- -- amounts of Trimming prior to their use in the bounded wide string
- -- functions.
- Dictionary : Dictionary_Type :=
- (1 => (BS_40.To_Bounded_Wide_String(" reliabel "),
- BS_40.To_Bounded_Wide_String(" reliable ")),
- 2 => (BS_40.To_Bounded_Wide_String(" progrraming "),
- BS_40.To_Bounded_Wide_String(" programming ")));
-
- Pos : Natural := Natural'First;
- Finished : Boolean := False;
-
- begin
-
- for Line in Page_Type'Range loop
-
- -- Search for the first incorrectly spelled word in the
- -- Dictionary, if it is found, replace it with the correctly
- -- spelled word, using the Overwrite function.
-
- while not Finished loop
- Pos :=
- BS_40.Index(Page(Line),
- BS_40.To_Wide_String
- (BS_40.Trim(Dictionary(1)(Incorrect),
- Ada.Strings.Both)),
- Ada.Strings.Forward);
- Finished := (Pos = 0);
- if not Finished then
- Page(Line) :=
- BS_40.Overwrite(Page(Line),
- Pos,
- BS_40.To_Wide_String
- (BS_40.Trim(Dictionary(1)(Correct),
- Ada.Strings.Both)));
- end if;
- end loop;
-
- Finished := False;
-
- -- Search for the second incorrectly spelled word in the
- -- Dictionary, if it is found, replace it with the correctly
- -- spelled word, using the Delete procedure and Insert function.
-
- while not Finished loop
- Pos :=
- BS_40.Index(Page(Line),
- BS_40.To_Wide_String(
- BS_40.Trim(Dictionary(2)(Incorrect),
- Ada.Strings.Both)),
- Ada.Strings.Forward);
-
- Finished := (Pos = 0);
-
- if not Finished then
- BS_40.Delete
- (Page(Line),
- Pos,
- Pos + BS_40.To_Wide_String
- (BS_40.Trim(Dictionary(2)(Incorrect),
- Ada.Strings.Both))'Length-1);
- Page(Line) :=
- BS_40.Insert(Page(Line),
- Pos,
- BS_40.To_Wide_String
- (BS_40.Trim(Dictionary(2)(Correct),
- Ada.Strings.Both)));
- end if;
- end loop;
-
- Finished := False;
-
- end loop;
- end Spell_Check;
-
- ---
-
- procedure Bold (Page : in out Page_Type) is
- Key_Word : constant Wide_String := "highly reliable";
- Bold_Mapping : constant
- Ada.Strings.Wide_Maps.Wide_Character_Mapping :=
- Ada.Strings.Wide_Maps.To_Mapping
- (From => " abcdefghijklmnopqrstuvwxyz",
- To => " ABCDEFGHIJKLMNOPQRSTUVWXYZ");
- Pos : Natural := Natural'First;
- Finished : Boolean := False;
- begin
- -- This procedure is designed to change the case of the phrase
- -- "highly reliable" into upper case (a type of "Bolding").
- -- All instances of the phrase on all lines of the page will be
- -- modified.
-
- for Line in Page_Type'First .. Page_Type'Last loop
- while not Finished loop
- Pos := BS_40.Index(Page(Line), Key_Word);
- Finished := (Pos = 0);
- if not Finished then
-
- BS_40.Overwrite
- (Page(Line),
- Pos,
- BS_40.To_Wide_String
- (BS_40.Translate
- (BS_40.To_Bounded_Wide_String
- (BS_40.Slice(Page(Line),
- Pos,
- Pos + Key_Word'Length - 1)),
- Bold_Mapping)));
-
- end if;
- end loop;
- Finished := False;
- end loop;
- end Bold;
-
-
- begin
-
- Compress(Page);
- Format(Page);
- Spell_Check(Page);
- Bold(Page);
-
- for i in 1..Lines_Per_Page loop
- if BS_40.To_Wide_String(Page(i)) /=
- BS_40.To_Wide_String(Finished_Page(i)) or
- BS_40.Length(Page(i)) /=
- BS_40.Length(Finished_Page(i))
- then
- Report.Failed("Incorrect modification of Page, Line " &
- Integer'Image(i));
- end if;
- end loop;
-
-
- exception
- when others => Report.Failed ("Exception raised in Test_Block");
- end Test_Block;
-
-
- Report.Result;
-
-end CXA4017;
diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxa4018.a b/gcc/testsuite/ada/acats/tests/cxa/cxa4018.a
deleted file mode 100644
index 98e0ded4a2c..00000000000
--- a/gcc/testsuite/ada/acats/tests/cxa/cxa4018.a
+++ /dev/null
@@ -1,379 +0,0 @@
--- CXA4018.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that the subprograms defined in package
--- Ada.Strings.Wide_Bounded are available, and that they produce
--- correct results. Specifically, check the subprograms Append,
--- Count, Element, Find_Token, Head, Index_Non_Blank, Replace_Element,
--- Replicate, Tail, To_Bounded_Wide_String, "&", ">", "<", ">=", "<=",
--- and "*".
---
--- TEST DESCRIPTION:
--- This test, when taken in conjunction with test CXA40[17,19,20], will
--- constitute a test of all the functionality contained in package
--- Ada.Strings.Wide_Bounded. This test uses a variety of the
--- subprograms defined in the wide bounded string package in ways typical
--- of common usage. Different combinations of available subprograms
--- are used to accomplish similar wide bounded string processing goals.
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 22 Dec 94 SAIC Changed obsolete constant to Strings.Wide_Space.
--- 06 Nov 95 SAIC Corrected evaluation string used in Head/Tail
--- subtests for ACVC 2.0.1.
---
---!
-
-with Ada.Strings;
-with Ada.Strings.Wide_Bounded;
-with Ada.Characters.Handling;
-with Ada.Strings.Wide_Maps;
-with Report;
-
-procedure CXA4018 is
-
- -- The following two functions are used to translate character and string
- -- values to "Wide" values. They will be applied to all the Wide_Bounded
- -- subprogram parameters to simulate the use of Wide_Characters and
- -- Wide_Strings in actual practice. Blanks are translated to Wide_Character
- -- blanks and all other characters are translated into Wide_Characters with
- -- position values 256 greater than their (narrow) character position
- -- values.
-
- function Translate (Ch : Character) return Wide_Character is
- C : Character := Ch;
- begin
- if Ch = ' ' then
- return Ada.Characters.Handling.To_Wide_Character(C);
- else
- return Wide_Character'Val(Character'Pos(Ch) +
- Character'Pos(Character'Last) + 1);
- end if;
- end Translate;
-
- function Translate (Str : String) return Wide_String is
- WS : Wide_String(Str'First..Str'Last);
- begin
- for i in Str'First..Str'Last loop
- WS(i) := Translate(Str(i));
- end loop;
- return WS;
- end Translate;
-
-
-begin
-
- Report.Test ("CXA4018", "Check that the subprograms defined in package " &
- "Ada.Strings.Wide_Bounded are available, and " &
- "that they produce correct results");
-
- Test_Block:
- declare
-
- package BS80 is new Ada.Strings.Wide_Bounded.Generic_Bounded_Length(80);
- use type BS80.Bounded_Wide_String;
-
- Part1 : constant Wide_String := Translate("Rum");
- Part2 : Wide_Character := Translate('p');
- Part3 : BS80.Bounded_Wide_String :=
- BS80.To_Bounded_Wide_String(Translate("el"));
- Part4 : Wide_Character := Translate('s');
- Part5 : BS80.Bounded_Wide_String :=
- BS80.To_Bounded_Wide_String(Translate("tilt"));
- Part6 : Wide_String(1..3) := Translate("ski");
-
- Full_Catenate_String,
- Full_Append_String,
- Constructed_String,
- Drop_String,
- Replicated_String,
- Token_String : BS80.Bounded_Wide_String;
-
- CharA : Wide_Character := Translate('A');
- CharB : Wide_Character := Translate('B');
- CharC : Wide_Character := Translate('C');
- CharD : Wide_Character := Translate('D');
- CharE : Wide_Character := Translate('E');
- CharF : Wide_Character := Translate('F');
-
- ABStr : Wide_String(1..15) := Translate("AAAAABBBBBBBBBB");
- StrB : Wide_String(1..2) := Translate("BB");
- StrE : Wide_String(1..2) := Translate("EE");
-
-
- begin
-
- -- Evaluation of the overloaded forms of the "&" operator.
-
- Full_Catenate_String :=
- BS80."&"(Part2, -- WChar & Bnd WStr
- BS80."&"(Part3, -- Bnd WStr & Bnd WStr
- BS80."&"(Part4, -- WChar & Bnd WStr
- BS80."&"(Part5, -- Bnd WStr & Bnd WStr
- BS80.To_Bounded_Wide_String
- (Part6)))));
-
- Full_Catenate_String :=
- BS80."&"(Part1, Full_Catenate_String); -- WStr & Bnd WStr
- Full_Catenate_String :=
- BS80."&"(Left => Full_Catenate_String,
- Right => Translate('n')); -- Bnd WStr & WChar
-
-
- -- Evaluation of the overloaded forms of function Append.
-
- Full_Append_String :=
- BS80.Append(Part2, -- WChar,Bnd WStr
- BS80.Append(Part3, -- Bnd WStr, Bnd WStr
- BS80.Append(Part4, -- WChar,Bnd WStr
- BS80.Append(BS80.To_Wide_String(Part5), -- WStr,Bnd WStr
- BS80.To_Bounded_Wide_String(Part6)))));
-
- Full_Append_String :=
- BS80.Append(BS80.To_Bounded_Wide_String(Part1), -- Bnd WStr, WStr
- BS80.To_Wide_String(Full_Append_String));
-
- Full_Append_String :=
- BS80.Append(Left => Full_Append_String,
- Right => Translate('n')); -- Bnd WStr, WChar
-
-
- -- Validate the resulting bounded wide strings.
-
- if BS80."<"(Full_Catenate_String, Full_Append_String) or
- BS80.">"(Full_Catenate_String, Full_Append_String) or
- not (Full_Catenate_String = Full_Append_String and
- BS80."<="(Full_Catenate_String, Full_Append_String) and
- BS80.">="(Full_Catenate_String, Full_Append_String))
- then
- Report.Failed
- ("Incorrect results from bounded wide string catenation" &
- " and comparison");
- end if;
-
-
- -- Evaluate the overloaded forms of the Constructor function "*" and
- -- the Replicate function.
-
- Constructed_String :=
- BS80."*"(2,CharA) & -- "AA"
- BS80."*"(2,StrB) & -- "AABBBB"
- BS80."*"(3, BS80."*"(2, CharC)) & -- "AABBBBCCCCCC"
- BS80.Replicate(3,
- BS80.Replicate(2, CharD)) & -- "AABBBBCCCCCCDDDDDD"
- BS80.Replicate(2, StrE) & -- "AABBBBCCCCCCDDDDDDEEEE"
- BS80.Replicate(2, CharF); -- "AABBBBCCCCCCDDDDDDEEEEFF"
-
-
- -- Use of Function Replicate that involves dropping wide characters.
- -- The attempt to replicate the 15 character wide string six times will
- -- exceed the 80 wide character bound of the wide string. Therefore,
- -- the result should be the catenation of 5 copies of the 15 character
- -- wide string, followed by 5 'A' wide characters (the first five wide
- -- characters of the 6th replication) with the remaining wide
- -- characters of the 6th replication dropped.
-
- Drop_String :=
- BS80.Replicate(Count => 6,
- Item => ABStr, -- "AAAAABBBBBBBBBB"
- Drop => Ada.Strings.Right);
-
- if BS80.Element(Drop_String, 1) /= Translate('A') or
- BS80.Element(Drop_String, 6) /= Translate('B') or
- BS80.Element(Drop_String, 76) /= Translate('A') or
- BS80.Element(Drop_String, 80) /= Translate('A')
- then
- Report.Failed("Incorrect result from Replicate with Drop");
- end if;
-
-
- -- Use function Index_Non_Blank in the evaluation of the
- -- Constructed_String.
-
- if BS80.Index_Non_Blank(Constructed_String, Ada.Strings.Forward) /=
- BS80.To_Wide_String(Constructed_String)'First or
- BS80.Index_Non_Blank(Constructed_String, Ada.Strings.Backward) /=
- BS80.Length(Constructed_String)
- then
- Report.Failed("Incorrect results from constructor functions");
- end if;
-
-
-
- declare
-
- -- Define wide character set objects for use with the Count function.
- -- Constructed_String = "AABBBBCCCCCCDDDDDDEEEEFF" from above.
-
- A_Set : Ada.Strings.Wide_Maps.Wide_Character_Set :=
- Ada.Strings.Wide_Maps.To_Set(BS80.Element(Constructed_String,
- 1));
- B_Set : Ada.Strings.Wide_Maps.Wide_Character_Set :=
- Ada.Strings.Wide_Maps.To_Set(BS80.Element(Constructed_String,
- 3));
- C_Set : Ada.Strings.Wide_Maps.Wide_Character_Set :=
- Ada.Strings.Wide_Maps.To_Set(BS80.Element(Constructed_String,
- 7));
- D_Set : Ada.Strings.Wide_Maps.Wide_Character_Set :=
- Ada.Strings.Wide_Maps.To_Set(BS80.Element(Constructed_String,
- 13));
- E_Set : Ada.Strings.Wide_Maps.Wide_Character_Set :=
- Ada.Strings.Wide_Maps.To_Set(BS80.Element(Constructed_String,
- 19));
- F_Set : Ada.Strings.Wide_Maps.Wide_Character_Set :=
- Ada.Strings.Wide_Maps.To_Set(BS80.Element(Constructed_String,
- 23));
- Start : Positive;
- Stop : Natural := 0;
-
- begin
-
- -- Evaluate the results from function Count by comparing the number
- -- of A's to the number of F's, B's to E's, and C's to D's in the
- -- Constructed_String.
- -- There should be an equal number of each of the wide characters that
- -- are being compared (i.e., 2 A's and F's, 4 B's and E's, etc)
-
- if BS80.Count(Constructed_String, A_Set) /=
- BS80.Count(Constructed_String, F_Set) or
- BS80.Count(Constructed_String, B_Set) /=
- BS80.Count(Constructed_String, E_Set) or
- not (BS80.Count(Constructed_String, C_Set) =
- BS80.Count(Constructed_String, D_Set))
- then
- Report.Failed("Incorrect result from function Count");
- end if;
-
-
- -- Evaluate the functions Head, Tail, and Find_Token.
- -- Create the Token_String from the Constructed_String above.
-
- Token_String :=
- BS80.Tail(BS80.Head(Constructed_String, 3), 2) & -- "AB" &
- BS80.Head(BS80.Tail(Constructed_String, 13), 2) & -- "CD" &
- BS80.Head(BS80.Tail(Constructed_String, 3), 2); -- "EF"
-
- if Token_String /=
- BS80.To_Bounded_Wide_String(Translate("ABCDEF")) then
- Report.Failed("Incorrect result from Catenation of Token_String");
- end if;
-
-
- -- Find the starting/ending position of the first A in the
- -- Token_String (both should be 1, only one A appears in string).
- -- The Function Head uses the default pad character to return a
- -- bounded wide string longer than its input parameter bounded
- -- wide string.
-
- BS80.Find_Token(BS80.Head(Token_String, 10), -- Default pad.
- A_Set,
- Ada.Strings.Inside,
- Start,
- Stop);
-
- if Start /= 1 and Stop /= 1 then
- Report.Failed("Incorrect result from Find_Token - 1");
- end if;
-
-
- -- Find the starting/ending position of the first non-AB slice in
- -- the "head" five wide characters of Token_String (slice CDE at
- -- positions 3-5)
-
- BS80.Find_Token(BS80.Head(Token_String, 5), -- "ABCDE"
- Ada.Strings.Wide_Maps."OR"(A_Set, B_Set), -- Set (AB)
- Ada.Strings.Outside,
- Start,
- Stop);
-
- if Start /= 3 and Stop /= 5 then
- Report.Failed("Incorrect result from Find_Token - 2");
- end if;
-
-
- -- Find the starting/ending position of the first CD slice in
- -- the "tail" eight wide characters (including two pad wide
- -- characters) of Token_String (slice CD at positions 5-6 of
- -- the tail portion specified)
-
- BS80.Find_Token(BS80.Tail(Token_String, 8,
- Ada.Strings.Wide_Space),
- Ada.Strings.Wide_Maps."OR"(C_Set, D_Set),
- Ada.Strings.Inside,
- Start,
- Stop);
-
- if Start /= 5 and Stop /= 6 then
- Report.Failed("Incorrect result from Find_Token - 3");
- end if;
-
-
- -- Evaluate the Replace_Element function.
-
- -- Token_String = "ABCDEF"
-
- BS80.Replace_Element(Token_String, 3, BS80.Element(Token_String,4));
-
- -- Token_String = "ABDDEF"
-
- BS80.Replace_Element(Source => Token_String,
- Index => 2,
- By => BS80.Element(Token_String, 5));
-
- -- Token_String = "AEDDEF"
-
- BS80.Replace_Element(Token_String,
- 1,
- BS80.Element(BS80.Tail(Token_String, 2), 2));
-
- -- Token_String = "FEDDEF"
- -- Evaluate this result.
-
- if BS80.Element(Token_String,
- BS80.To_Wide_String(Token_String)'First) /=
- BS80.Element(Token_String,
- BS80.To_Wide_String(Token_String)'Last) or
- BS80.Count(Token_String, D_Set) /=
- BS80.Count(Token_String, E_Set) or
- BS80.Index_Non_Blank(BS80.Head(Token_String,6)) /=
- BS80.Index_Non_Blank(BS80.Tail(Token_String,6)) or
- BS80.Head(Token_String, 1) /=
- BS80.Tail(Token_String, 1)
- then
- Report.Failed("Incorrect result from operations in combination");
- end if;
-
- end;
-
- exception
- when others => Report.Failed ("Exception raised in Test_Block");
- end Test_Block;
-
-
- Report.Result;
-
-end CXA4018;
diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxa4019.a b/gcc/testsuite/ada/acats/tests/cxa/cxa4019.a
deleted file mode 100644
index 943e3e73b88..00000000000
--- a/gcc/testsuite/ada/acats/tests/cxa/cxa4019.a
+++ /dev/null
@@ -1,1027 +0,0 @@
--- CXA4019.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that the subprograms defined in package Ada.Strings.Wide_Bounded
--- are available, and that they produce correct results, especially
--- under conditions where truncation of the result is required.
--- Specifically, check the subprograms Append, Count with non-Identity
--- maps, Index with non-Identity maps, Index with Set parameters,
--- Insert (function and procedure), Replace_Slice (function and
--- procedure), To_Bounded_Wide_String, and Translate (function and
--- procedure).
---
--- TEST DESCRIPTION:
--- This test, in conjunction with tests CXA4017, CXA4018, and CXA4020,
--- will provide coverage of the most common usages of the functionality
--- found in the Ada.Strings.Wide_Bounded package. It deals in large part
--- with truncation effects and options. This test contains many small,
--- specific test cases, situations that are often difficult to generate
--- in large numbers in an application-based test. These cases represent
--- specific usage paradigms in-the-small.
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 06 Nov 95 SAIC Corrected expected result string in subtest for
--- ACVC 2.0.1.
--- Moved function Dog_to_Cat_Mapping to library
--- level to correct accessibility problem in test.
--- 22 Aug 96 SAIC Corrected three subtests identified in reviewer
--- comments.
--- 17 Feb 97 PWB.CTA Corrected result strings for Translate and Insert
---
---!
-
-package CXA40190 is
-
- -- Wide Character mapping function defined for use with specific
- -- versions of functions Index and Count.
-
- function Dog_to_Cat_Mapping (From : Wide_Character)
- return Wide_Character;
-
-end CXA40190;
-
-package body CXA40190 is
-
- -- Translates "dog" to "cat".
- function Dog_to_Cat_Mapping (From : Wide_Character)
- return Wide_Character is
- begin
- if From = 'd' then
- return 'c';
- elsif From = 'o' then
- return 'a';
- elsif From = 'g' then
- return 't';
- else
- return From;
- end if;
- end Dog_to_Cat_Mapping;
-
-end CXA40190;
-
-
-with CXA40190;
-with Report;
-with Ada.Characters.Handling;
-with Ada.Strings.Wide_Bounded;
-with Ada.Strings.Wide_Maps;
-with Ada.Strings.Wide_Maps.Wide_Constants;
-
-procedure CXA4019 is
-
- -- The following two functions are used to translate character and string
- -- values to "Wide" values. They will be applied to all the Wide_Bounded
- -- subprogram parameters to simulate the use of Wide_Characters and
- -- Wide_Strings in actual practice.
-
- function Equiv (Ch : Character) return Wide_Character is
- C : Character := Ch;
- begin
- if Ch = ' ' then
- return Ada.Characters.Handling.To_Wide_Character(C);
- else
- return Wide_Character'Val(Character'Pos(Ch) +
- Character'Pos(Character'Last) + 1);
- end if;
- end Equiv;
-
-
- function Equiv (Str : String) return Wide_String is
- WS : Wide_String(Str'First..Str'Last);
- begin
- for i in Str'First..Str'Last loop
- WS(i) := Equiv(Str(i));
- end loop;
- return WS;
- end Equiv;
-
-begin
-
- Report.Test("CXA4019", "Check that the subprograms defined in " &
- "package Ada.Strings.Wide_Bounded are " &
- "available, and that they produce correct " &
- "results, especially under conditions where " &
- "truncation of the result is required");
-
- Test_Block:
- declare
-
- use CXA40190;
-
- package AS renames Ada.Strings;
- package ASB renames Ada.Strings.Wide_Bounded;
- package ASWC renames Ada.Strings.Wide_Maps.Wide_Constants;
- package Maps renames Ada.Strings.Wide_Maps;
-
- package B10 is new ASB.Generic_Bounded_Length(Max => 10);
- use type B10.Bounded_Wide_String;
-
- Result_String : B10.Bounded_Wide_String;
- Test_String : B10.Bounded_Wide_String;
- AtoE_Bnd_Str : B10.Bounded_Wide_String :=
- B10.To_Bounded_Wide_String(Equiv("abcde"));
- FtoJ_Bnd_Str : B10.Bounded_Wide_String :=
- B10.To_Bounded_Wide_String(Equiv("fghij"));
- AtoJ_Bnd_Str : B10.Bounded_Wide_String :=
- B10.To_Bounded_Wide_String(Equiv("abcdefghij"));
-
- Location : Natural := 0;
- Total_Count : Natural := 0;
-
- CD_Set : Maps.Wide_Character_Set := Maps.To_Set("cd");
- Wide_CD_Set : Maps.Wide_Character_Set := Maps.To_Set(Equiv("cd"));
-
- AB_to_YZ_Map : Maps.Wide_Character_Mapping :=
- Maps.To_Mapping(From => "ab", To => "yz");
-
- Wide_AB_to_YZ_Map : Maps.Wide_Character_Mapping :=
- Maps.To_Mapping(From => Equiv("ab"),
- To => Equiv("yz"));
-
- CD_to_XY_Map : Maps.Wide_Character_Mapping :=
- Maps.To_Mapping(From => "cd", To => "xy");
-
- Wide_CD_to_XY_Map : Maps.Wide_Character_Mapping :=
- Maps.To_Mapping(From => Equiv("cd"),
- To => Equiv("xy"));
-
-
- -- Access-to-Subprogram object defined for use with specific versions of
- -- functions Index, Count Translate, and procedure Translate.
-
- Map_Ptr : Maps.Wide_Character_Mapping_Function :=
- Dog_to_Cat_Mapping'Access;
-
-
-
- begin
-
- -- Function To_Bounded_Wide_String with Truncation
- -- Evaluate the function Append with parameters that will
- -- cause the truncation of the result.
-
- -- Drop = Error (default case, Length_Error will be raised)
-
- begin
- Test_String :=
- B10.To_Bounded_Wide_String
- (Equiv("Much too long for this bounded wide string"));
- Report.Failed("Length Error not raised by To_Bounded_Wide_String");
- exception
- when AS.Length_Error => null; -- Expected exception raised.
- when others =>
- Report.Failed
- ("Incorrect exception raised by To_Bounded_Wide_String");
- end;
-
- -- Drop = Left
-
- Test_String :=
- B10.To_Bounded_Wide_String(Source => Equiv("abcdefghijklmn"),
- Drop => Ada.Strings.Left);
-
- if Test_String /= B10.To_Bounded_Wide_String(Equiv("efghijklmn")) then
- Report.Failed
- ("Incorrect result from To_Bounded_Wide_String, Drop = Left");
- end if;
-
- -- Drop = Right
-
- Test_String :=
- B10.To_Bounded_Wide_String(Source => Equiv("abcdefghijklmn"),
- Drop => Ada.Strings.Right);
-
- if not(Test_String = AtoJ_Bnd_Str) then
- Report.Failed
- ("Incorrect result from To_Bounded_Wide_String, Drop = Right");
- end if;
-
-
-
-
- -- Function Append with Truncation
- -- Evaluate the function Append with parameters that will
- -- cause the truncation of the result.
-
- -- Drop = Error (default case, Length_Error will be raised)
-
- begin
- -- Append (Bnd Str, Bnd Str);
- Result_String :=
- B10.Append(B10.To_Bounded_Wide_String(Equiv("abcde")),
- B10.To_Bounded_Wide_String(Equiv("fghijk"))); -- 11 char
- Report.Failed("Length_Error not raised by Append - 1");
- exception
- when AS.Length_Error => null; -- OK, correct exception raised.
- when others =>
- Report.Failed("Incorrect exception raised by Append - 1");
- end;
-
- begin
- -- Append (Str, Bnd Str);
- Result_String :=
- B10.Append(B10.To_Wide_String(AtoE_Bnd_Str),
- B10.To_Bounded_Wide_String(Equiv("fghijk")),
- AS.Error);
- Report.Failed("Length_Error not raised by Append - 2");
- exception
- when AS.Length_Error => null; -- OK, correct exception raised.
- when others =>
- Report.Failed("Incorrect exception raised by Append - 2");
- end;
-
- begin
- -- Append (Bnd Str, Char);
- Result_String :=
- B10.Append(B10.To_Bounded_Wide_String("abcdefghij"), 'k');
- Report.Failed("Length_Error not raised by Append - 3");
- exception
- when AS.Length_Error => null; -- OK, correct exception raised.
- when others =>
- Report.Failed("Incorrect exception raised by Append - 3");
- end;
-
- -- Drop = Left
-
- -- Append (Bnd Str, Bnd Str)
- Result_String :=
- B10.Append(B10.To_Bounded_Wide_String(Equiv("abcdefgh")), -- 8 chs
- B10.To_Bounded_Wide_String(Equiv("ijklmn")), -- 6 chs
- Ada.Strings.Left);
-
- if Result_String /=
- B10.To_Bounded_Wide_String(Equiv("efghijklmn")) -- 10 chars
- then
- Report.Failed("Incorrect truncation performed by Append - 4");
- end if;
-
- -- Append (Bnd Str, Str)
- Result_String :=
- B10.Append(B10.To_Bounded_Wide_String("abcdefghij"),
- "xyz",
- Ada.Strings.Left);
-
- if Result_String /= B10.To_Bounded_Wide_String("defghijxyz") then
- Report.Failed("Incorrect truncation performed by Append - 5");
- end if;
-
- -- Append (Char, Bnd Str)
-
- Result_String :=
- B10.Append(Equiv('A'),
- B10.To_Bounded_Wide_String(Equiv("abcdefghij")),
- Ada.Strings.Left);
-
- if Result_String /= B10.To_Bounded_Wide_String(Equiv("abcdefghij"))
- then
- Report.Failed("Incorrect truncation performed by Append - 6");
- end if;
-
- -- Drop = Right
-
- -- Append (Bnd Str, Bnd Str)
- Result_String := B10.Append(FtoJ_Bnd_Str,
- AtoJ_Bnd_Str,
- Ada.Strings.Right);
-
- if Result_String /=
- B10.To_Bounded_Wide_String(Equiv("fghijabcde"))
- then
- Report.Failed("Incorrect truncation performed by Append - 7");
- end if;
-
- -- Append (Str, Bnd Str)
- Result_String := B10.Append(B10.To_Wide_String(AtoE_Bnd_Str),
- AtoJ_Bnd_Str,
- Ada.Strings.Right);
-
- if Result_String /=
- B10.To_Bounded_Wide_String(Equiv("abcdeabcde"))
- then
- Report.Failed("Incorrect truncation performed by Append - 8");
- end if;
-
- -- Append (Char, Bnd Str)
- Result_String := B10.Append(Equiv('A'), AtoJ_Bnd_Str, Ada.Strings.Right);
-
- if Result_String /= B10.To_Bounded_Wide_String(Equiv("Aabcdefghi")) then
- Report.Failed("Incorrect truncation performed by Append - 9");
- end if;
-
-
-
- -- Function Index with non-Identity map.
- -- Evaluate the function Index with a non-identity map
- -- parameter which will cause mapping of the source parameter
- -- prior to the evaluation of the index position search.
-
- Location :=
- B10.Index(Source => B10.To_Bounded_Wide_String("foxy fox 2"),
- Pattern => "FOX",
- Going => Ada.Strings.Backward,
- Mapping => ASWC.Upper_Case_Map);
-
- if Location /= 6 then
- Report.Failed("Incorrect result from Index, non-Identity map - 1");
- end if;
-
- Location :=
- B10.Index(B10.To_Bounded_Wide_String("THE QUICK "),
- "quick",
- Ada.Strings.Forward,
- Ada.Strings.Wide_Maps.Wide_Constants.Lower_Case_Map);
-
- if Location /= 5 then
- Report.Failed("Incorrect result from Index, non-Identity map - 2");
- end if;
-
- Location := B10.Index(Source => B10.To_Bounded_Wide_String("The the"),
- Pattern => "the",
- Going => Ada.Strings.Forward,
- Mapping => ASWC.Lower_Case_Map);
-
- if Location /= 1 then
- Report.Failed("Incorrect result from Index, non-Identity map - 3");
- end if;
-
-
-
- if B10.Index(B10.To_Bounded_Wide_String("abcd"), -- Pattern = Source
- "abcd") /= 1 or
- B10.Index(B10.To_Bounded_Wide_String("abc"), -- Pattern < Source
- "abcd") /= 0 or
- B10.Index(B10.Null_Bounded_Wide_String, -- Source = Null
- "abc") /= 0
- then
- Report.Failed("Incorrect result from Index with string patterns");
- end if;
-
-
-
- -- Function Index with access-to-subprogram mapping value.
- -- Evaluate the function Index with a wide character mapping function
- -- object that performs the mapping operation.
-
- Location := B10.Index(Source => B10.To_Bounded_Wide_String("My dog"),
- Pattern => "cat",
- Going => Ada.Strings.Forward,
- Mapping => Map_Ptr); -- change "dog" to "cat"
-
- if Location /= 4 then
- Report.Failed("Incorrect result from Index, w/map ptr - 1");
- end if;
-
- Location := B10.Index(B10.To_Bounded_Wide_String("cat or dog"),
- "cat",
- Ada.Strings.Backward,
- Map_Ptr);
-
- if Location /= 8 then
- Report.Failed("Incorrect result from Index, w/map ptr - 2");
- end if;
-
- if B10.Index(B10.To_Bounded_Wide_String("dog"), -- Pattern = Source
- "cat",
- Ada.Strings.Forward,
- Map_Ptr) /= 1 or
- B10.Index(B10.To_Bounded_Wide_String("dog"), -- Pattern < Source
- "cats",
- Ada.Strings.Backward,
- Map_Ptr) /= 0 or
- B10.Index(B10.Null_Bounded_Wide_String, -- Source = Null
- "cat",
- Ada.Strings.Forward,
- Map_Ptr) /= 0 or
- B10.Index(B10.To_Bounded_Wide_String("hot dog"),
- "dog",
- Ada.Strings.Backward,
- Map_Ptr) /= 0 or
- B10.Index(B10.To_Bounded_Wide_String(" cat dog "),
- " cat",
- Ada.Strings.Backward,
- Map_Ptr) /= 5 or
- B10.Index(B10.To_Bounded_Wide_String("dog CatDog"),
- "cat",
- Ada.Strings.Backward,
- Map_Ptr) /= 1 or
- B10.Index(B10.To_Bounded_Wide_String("CatandDog"),
- "cat",
- Ada.Strings.Forward,
- Map_Ptr) /= 0 or
- B10.Index(B10.To_Bounded_Wide_String("dddd"),
- "ccccc",
- Ada.Strings.Backward,
- Map_Ptr) /= 0
- then
- Report.Failed("Incorrect result from Index w/map ptr - 3");
- end if;
-
-
-
- -- Function Index (for Sets).
- -- This version of Index uses Sets as the basis of the search.
-
- -- Test = Inside, Going = Forward (Default case).
- Location :=
- B10.Index(Source => B10.To_Bounded_Wide_String(Equiv("abcdeabcde")),
- Set => Wide_CD_Set,
- Test => Ada.Strings.Inside,
- Going => Ada.Strings.Forward);
-
- if not (Location = 3) then -- position of first 'c' equivalent in source.
- Report.Failed("Incorrect result from Index using Sets - 1");
- end if;
-
- -- Test = Inside, Going = Backward.
- Location :=
- B10.Index(Source => B10."&"(AtoE_Bnd_Str, AtoE_Bnd_Str),
- Set => Wide_CD_Set,
- Test => Ada.Strings.Inside,
- Going => Ada.Strings.Backward);
-
- if not (Location = 9) then -- position of last 'd' in source.
- Report.Failed("Incorrect result from Index using Sets - 2");
- end if;
-
- -- Test = Outside, Going = Forward.
- Location := B10.Index(B10.To_Bounded_Wide_String("deddacd"),
- CD_Set,
- Test => Ada.Strings.Outside,
- Going => Ada.Strings.Forward);
-
- if Location /= 2 then -- position of 'e' in source.
- Report.Failed("Incorrect result from Index using Sets - 3");
- end if;
-
- -- Test = Outside, Going = Backward.
- Location := B10.Index(B10.To_Bounded_Wide_String(Equiv("deddacd")),
- Wide_CD_Set,
- Ada.Strings.Outside,
- Ada.Strings.Backward);
-
- if Location /= 5 then -- position of 'a', correct.
- Report.Failed("Incorrect result from Index using Sets - 4");
- end if;
-
- if B10.Index(B10.To_Bounded_Wide_String("cd"), -- Source = Set
- CD_Set) /= 1 or
- B10.Index(B10.To_Bounded_Wide_String("c"), -- Source < Set
- CD_Set) /= 1 or
- B10.Index(B10.Null_Bounded_Wide_String, -- Source = Null
- Wide_CD_Set) /= 0 or
- B10.Index(AtoE_Bnd_Str,
- Maps.To_Set('x')) /= 0 -- No match.
- then
- Report.Failed("Incorrect result from Index using Sets - 5");
- end if;
-
-
-
- -- Function Count with non-Identity mapping.
- -- Evaluate the function Count with a non-identity map
- -- parameter which will cause mapping of the source parameter
- -- prior to the evaluation of the number of matching patterns.
-
- Total_Count :=
- B10.Count(Source => B10.To_Bounded_Wide_String("THE THE TH"),
- Pattern => "th",
- Mapping => ASWC.Lower_Case_Map);
-
- if Total_Count /= 3 then
- Report.Failed
- ("Incorrect result from function Count, non-Identity map - 1");
- end if;
-
- -- And a few with identity maps as well.
-
- if B10.Count(B10.To_Bounded_Wide_String(Equiv("ABABABABAB")),
- Equiv("ABA"),
- Maps.Identity) /= 2 or
- B10.Count(B10.To_Bounded_Wide_String("ADCBADABCD"),
- "AB",
- Maps.To_Mapping("CD", "AB")) /= 5 or
- B10.Count(B10.To_Bounded_Wide_String(Equiv("aaaaaaaaaa")),
- Equiv("aaa")) /= 3 or
- B10.Count(B10.To_Bounded_Wide_String(Equiv("XX")),
- Equiv("XXX"),
- Maps.Identity) /= 0 or
- B10.Count(AtoE_Bnd_Str, -- Source = Pattern
- Equiv("abcde")) /= 1 or
- B10.Count(B10.Null_Bounded_Wide_String, -- Source = Null
- " ") /= 0
- then
- Report.Failed
- ("Incorrect result from function Count, w,w/o mapping");
- end if;
-
-
-
-
-
- -- Function Count with access-to-subprogram mapping.
- -- Evaluate the version function Count that uses an access-to-subprogram
- -- map parameter.
-
- Total_Count :=
- B10.Count(Source => B10.To_Bounded_Wide_String("dogdogdo"),
- Pattern => "ca",
- Mapping => Map_Ptr);
-
- if Total_Count /= 3 then
- Report.Failed
- ("Incorrect result from function Count, w/map ptr - 1");
- end if;
-
-
- if B10.Count(B10.To_Bounded_Wide_String("DdOoGgod"),
- "c",
- Map_Ptr) /= 2 or
- B10.Count(B10.To_Bounded_Wide_String("dododododo"),
- "do",
- Map_Ptr) /= 0 or
- B10.Count(B10.To_Bounded_Wide_String("Dog or dog"),
- "cat",
- Map_Ptr) /= 1 or
- B10.Count(B10.To_Bounded_Wide_String("dddddddddd"),
- "ccccc",
- Map_Ptr) /= 2 or
- B10.Count(B10.To_Bounded_Wide_String("do"), -- Source < Pattern
- "cat",
- Map_Ptr) /= 0 or
- B10.Count(B10.To_Bounded_Wide_String(" dog "), -- Source = Pattern
- " cat ",
- Map_Ptr) /= 1 or
- B10.Count(B10.Null_Bounded_Wide_String, -- Source = Null
- " ",
- Map_Ptr) /= 0
- then
- Report.Failed
- ("Incorrect result from function Count, w/map ptr - 2");
- end if;
-
-
-
-
- -- Procedure Translate
-
- -- Partial mapping of source.
-
- Test_String := B10.To_Bounded_Wide_String("abcdeabcab");
-
- B10.Translate(Source => Test_String, Mapping => AB_to_YZ_Map);
-
- if Test_String /= B10.To_Bounded_Wide_String("yzcdeyzcyz") then
- Report.Failed("Incorrect result from procedure Translate - 1");
- end if;
-
- -- Total mapping of source.
-
- Test_String := B10.To_Bounded_Wide_String("abbaaababb");
-
- B10.Translate(Source => Test_String, Mapping => ASWC.Upper_Case_Map);
-
- if Test_String /= B10.To_Bounded_Wide_String("ABBAAABABB") then
- Report.Failed("Incorrect result from procedure Translate - 2");
- end if;
-
- -- No mapping of source.
-
- Test_String := B10.To_Bounded_Wide_String(Equiv("xyzsypcc"));
-
- B10.Translate(Source => Test_String, Mapping => Wide_AB_to_YZ_Map);
-
- if Test_String /= B10.To_Bounded_Wide_String(Equiv("xyzsypcc")) then
- Report.Failed("Incorrect result from procedure Translate - 3");
- end if;
-
- -- Map > 2 characters, partial mapping.
-
- Test_String := B10.To_Bounded_Wide_String("opabcdelmn");
-
- B10.Translate(Test_String,
- Maps.To_Mapping("abcde", "lmnop"));
-
- if Test_String /= B10.To_Bounded_Wide_String("oplmnoplmn") then
- Report.Failed("Incorrect result from procedure Translate - 4");
- end if;
-
-
-
-
- -- Procedure Translate with access-to-subprogram mapping.
- -- Use the version of Procedure Translate that takes an
- -- access-to-subprogram parameter to perform the Source mapping.
-
- -- Partial mapping of source.
-
- Test_String := B10.To_Bounded_Wide_String("dogeatdog");
-
- B10.Translate(Source => Test_String, Mapping => Map_Ptr);
-
- if Test_String /= B10.To_Bounded_Wide_String("cateatcat") then
- Report.Failed
- ("Incorrect result from procedure Translate w/map ptr - 1");
- end if;
-
- Test_String := B10.To_Bounded_Wide_String("odogcatlmn");
-
- B10.Translate(Test_String, Map_Ptr);
-
- if Test_String /= B10.To_Bounded_Wide_String("acatcatlmn") then
- Report.Failed
- ("Incorrect result from procedure Translate w/map ptr - 2");
- end if;
-
-
- -- Total mapping of source.
-
- Test_String := B10.To_Bounded_Wide_String("gggooooddd");
-
- B10.Translate(Source => Test_String, Mapping => Map_Ptr);
-
- if Test_String /= B10.To_Bounded_Wide_String("tttaaaaccc") then
- Report.Failed
- ("Incorrect result from procedure Translate w/map ptr- 3");
- end if;
-
- -- No mapping of source.
-
- Test_String := B10.To_Bounded_Wide_String(" DOG cat ");
-
- B10.Translate(Source => Test_String, Mapping => Map_Ptr);
-
- if Test_String /= B10.To_Bounded_Wide_String(" DOG cat ") then
- Report.Failed
- ("Incorrect result from procedure Translate w/map ptr - 4");
- end if;
-
- Test_String := B10.Null_Bounded_Wide_String;
-
- B10.Translate(Source => Test_String, Mapping => Map_Ptr);
-
- if Test_String /= B10.To_Bounded_Wide_String("") then
- Report.Failed
- ("Incorrect result from procedure Translate w/map ptr - 5");
- end if;
-
-
-
-
- -- Function Translate with access-to-subprogram mapping.
- -- Use the version of Function Translate that takes an
- -- access-to-subprogram parameter to perform the Source mapping.
-
- -- Partial mapping of source.
-
- if B10.Translate(Source => B10.To_Bounded_Wide_String("cateatdog"),
- Mapping => Map_Ptr) /=
- B10.To_Bounded_Wide_String("cateatcat")
- then
- Report.Failed
- ("Incorrect result from function Translate w/map ptr - 1");
- end if;
-
- if B10.Translate(B10.To_Bounded_Wide_String("cadogtac"),
- Map_Ptr) /=
- B10.To_Bounded_Wide_String("cacattac")
- then
- Report.Failed
- ("Incorrect result from function Translate w/map ptr - 2");
- end if;
-
- -- Total mapping of source.
-
- if B10.Translate(Source => B10.To_Bounded_Wide_String("dogodggdo"),
- Mapping => Map_Ptr) /=
- B10.To_Bounded_Wide_String("catacttca")
- then
- Report.Failed
- ("Incorrect result from function Translate w/map ptr- 3");
- end if;
-
- -- No mapping of source.
-
- if B10.Translate(Source => B10.To_Bounded_Wide_String(" DOG cat "),
- Mapping => Map_Ptr) /=
- B10.To_Bounded_Wide_String(" DOG cat ")
- then
- Report.Failed
- ("Incorrect result from function Translate w/map ptr - 4");
- end if;
-
- if B10.Translate(B10.To_Bounded_Wide_String("d "), Map_Ptr) /=
- B10.To_Bounded_Wide_String("c ") or
- B10.Translate(B10.To_Bounded_Wide_String(" god"), Map_Ptr) /=
- B10.To_Bounded_Wide_String(" tac") or
- B10.Translate(B10.To_Bounded_Wide_String("d o g D og"), Map_Ptr) /=
- B10.To_Bounded_Wide_String("c a t D at") or
- B10.Translate(B10.To_Bounded_Wide_String(" "), Map_Ptr) /=
- B10.To_Bounded_Wide_String(" ") or
- B10.Translate(B10.To_Bounded_Wide_String("dddddddddd"), Map_Ptr) /=
- B10.To_Bounded_Wide_String("cccccccccc")
- then
- Report.Failed
- ("Incorrect result from function Translate w/map ptr - 5");
- end if;
-
- if B10.Translate(Source => B10.Null_Bounded_Wide_String,
- Mapping => Map_Ptr) /=
- B10.To_Bounded_Wide_String("")
- then
- Report.Failed
- ("Incorrect result from function Translate w/map ptr - 6");
- end if;
-
-
-
-
- -- Function Replace_Slice
- -- Evaluate function Replace_Slice with
- -- a variety of Truncation options.
-
- -- Drop = Error (Default)
-
- begin
- Test_String := AtoJ_Bnd_Str;
- Result_String :=
- B10.Replace_Slice(Source => Test_String,
- Low => 3,
- High => 5, -- 3-5, 3 chars.
- By => Equiv("xxxxxx")); -- more than 3.
- Report.Failed("Length_Error not raised by Function Replace_Slice");
- exception
- when AS.Length_Error => null; -- Correct exception raised.
- when others =>
- Report.Failed
- ("Incorrect exception raised by Function Replace_Slice");
- end;
-
- -- Drop = Left
-
- Result_String :=
- B10.Replace_Slice(Source => Test_String,
- Low => 7,
- High => 10, -- 7-10, 4 chars.
- By => Equiv("xxxxxx"), -- 6 chars.
- Drop => Ada.Strings.Left);
-
- if Result_String /=
- B10.To_Bounded_Wide_String(Equiv("cdefxxxxxx")) -- drop a,b
- then
- Report.Failed
- ("Incorrect result from Function Replace Slice, Drop = Left");
- end if;
-
- -- Drop = Right
-
- Result_String :=
- B10.Replace_Slice(Source => Test_String,
- Low => 2,
- High => 5, -- 2-5, 4 chars.
- By => Equiv("xxxxxx"), -- 6 chars.
- Drop => Ada.Strings.Right);
-
- if Result_String /=
- B10.To_Bounded_Wide_String(Equiv("axxxxxxfgh")) -- drop i,j
- then
- Report.Failed
- ("Incorrect result from Function Replace Slice, Drop = Right");
- end if;
-
- -- Low = High = Source'Last, "By" length = 1.
-
- if B10.Replace_Slice(AtoE_Bnd_Str,
- B10.To_Wide_String(AtoE_Bnd_Str)'Last,
- B10.To_Wide_String(AtoE_Bnd_Str)'Last,
- Equiv("X"),
- Ada.Strings.Error) /=
- B10.To_Bounded_Wide_String(Equiv("abcdX"))
- then
- Report.Failed("Incorrect result from Function Replace_Slice");
- end if;
-
- -- Index_Error raised when High < Source'First - 1.
- begin
- Test_String :=
- B10.Replace_Slice(AtoE_Bnd_Str,
- B10.To_Wide_String(AtoE_Bnd_Str)'First,
- B10.To_Wide_String(AtoE_Bnd_Str)'First - 2,
- Equiv("hijklm"));
- Report.Failed("Index_Error not raised by Function Replace_Slice");
- exception
- when AS.Index_Error => null; -- OK, expected exception
- when Constraint_Error => null; -- Also OK, since RM is not clear
- when others =>
- Report.Failed
- ("Incorrect exception raised by Function Replace_Slice");
- end;
-
-
-
- -- Procedure Replace_Slice
- -- Evaluate procedure Replace_Slice with
- -- a variety of Truncation options.
-
- -- Drop = Error (Default)
-
- begin
- Test_String := AtoJ_Bnd_Str;
- B10.Replace_Slice(Source => Test_String,
- Low => 3,
- High => 5, -- 3-5, 3 chars.
- By => Equiv("xxxxxx")); -- more than 3.
- Report.Failed("Length_Error not raised by Procedure Replace_Slice");
- exception
- when AS.Length_Error => null; -- Correct exception raised.
- when others =>
- Report.Failed
- ("Incorrect exception raised by Procedure Replace_Slice");
- end;
-
- -- Drop = Left
-
- Test_String := AtoJ_Bnd_Str;
- B10.Replace_Slice(Source => Test_String,
- Low => 7,
- High => 9, -- 7-9, 3 chars.
- By => Equiv("xxxxx"), -- 5 chars.
- Drop => Ada.Strings.Left);
-
- if Test_String /=
- B10.To_Bounded_Wide_String(Equiv("cdefxxxxxj")) -- drop a,b
- then
- Report.Failed
- ("Incorrect result from Procedure Replace Slice, Drop = Left");
- end if;
-
- -- Drop = Right
-
- Test_String := AtoJ_Bnd_Str;
- B10.Replace_Slice(Source => Test_String,
- Low => 1,
- High => 3, -- 1-3, 3chars.
- By => Equiv("xxxx"), -- 4 chars.
- Drop => Ada.Strings.Right);
-
- if Test_String /=
- B10.To_Bounded_Wide_String(Equiv("xxxxdefghi")) -- drop j
- then
- Report.Failed
- ("Incorrect result from Procedure Replace Slice, Drop = Right");
- end if;
-
- -- High = Source'First, Low > High (Insert before Low).
-
- Test_String := AtoE_Bnd_Str;
- B10.Replace_Slice(Source => Test_String,
- Low => B10.To_Wide_String(Test_String)'Last,
- High => B10.To_Wide_String(Test_String)'First,
- By => Equiv("XXXX"), -- 4 chars.
- Drop => Ada.Strings.Right);
-
- if Test_String /= B10.To_Bounded_Wide_String(Equiv("abcdXXXXe")) then
- Report.Failed
- ("Incorrect result from Procedure Replace Slice");
- end if;
-
-
-
-
- -- Function Insert with Truncation
- -- Drop = Error (Default).
-
- begin
- Result_String :=
- B10.Insert(Source => AtoJ_Bnd_Str, -- "abcdefghij"
- Before => 2,
- New_Item => Equiv("xyz"));
- Report.Failed("Length_Error not raised by Function Insert");
- exception
- when AS.Length_Error => null; -- Correct exception raised.
- when others =>
- Report.Failed("Incorrect exception raised by Function Insert");
- end;
-
- -- Drop = Left
-
- Result_String :=
- B10.Insert(Source => AtoJ_Bnd_Str, -- "abcdefghij"
- Before => 5,
- New_Item => Equiv("xyz"), -- 3 additional chars.
- Drop => Ada.Strings.Left);
-
- if B10.To_Wide_String(Result_String) /= Equiv("dxyzefghij") then
- Report.Failed("Incorrect result from Function Insert, Drop = Left");
- end if;
-
- -- Drop = Right
-
- Result_String :=
- B10.Insert(Source => B10.To_Bounded_Wide_String("abcdef"),
- Before => 2,
- New_Item => "vwxyz", -- 5 additional chars.
- Drop => Ada.Strings.Right);
-
- if B10.To_Wide_String(Result_String) /= "avwxyzbcde" then -- drop f.
- Report.Failed("Incorrect result from Function Insert, Drop = Right");
- end if;
-
- -- Additional cases.
-
- if B10.Insert(B10.To_Bounded_Wide_String("a"), 1, " B") /=
- B10.To_Bounded_Wide_String(" Ba") or
- B10.Insert(B10.Null_Bounded_Wide_String, 1, Equiv("abcde")) /=
- AtoE_Bnd_Str or
- B10.Insert(B10.To_Bounded_Wide_String("ab"), 2, "") /=
- B10.To_Bounded_Wide_String("ab")
- then
- Report.Failed("Incorrect result from Function Insert");
- end if;
-
-
-
- -- Procedure Insert
-
- -- Drop = Error (Default).
- begin
- Test_String := AtoJ_Bnd_Str;
- B10.Insert(Source => Test_String,
- Before => 9,
- New_Item => Equiv("wxyz"),
- Drop => Ada.Strings.Error);
- Report.Failed("Length_Error not raised by Procedure Insert");
- exception
- when AS.Length_Error => null; -- Correct exception raised.
- when others =>
- Report.Failed("Incorrect exception raised by Procedure Insert");
- end;
-
- -- Drop = Left
-
- Test_String := AtoJ_Bnd_Str;
- B10.Insert(Source => Test_String,
- Before => B10.Length(Test_String), -- before last char
- New_Item => Equiv("xyz"), -- 3 additional chars.
- Drop => Ada.Strings.Left);
-
- if B10.To_Wide_String(Test_String) /= Equiv("defghixyzj") then
- Report.Failed("Incorrect result from Procedure Insert, Drop = Left");
- end if;
-
- -- Drop = Right
-
- Test_String := AtoJ_Bnd_Str;
- B10.Insert(Source => Test_String,
- Before => 4,
- New_Item => Equiv("yz"), -- 2 additional chars.
- Drop => Ada.Strings.Right);
-
- if B10.To_Wide_String(Test_String) /= Equiv("abcyzdefgh") then
- Report.Failed
- ("Incorrect result from Procedure Insert, Drop = Right");
- end if;
-
- -- Before = Source'First, New_Item length = 1.
-
- Test_String := B10.To_Bounded_Wide_String(" abc ");
- B10.Insert(Test_String,
- B10.To_Wide_String(Test_String)'First,
- "Z");
-
- if Test_String /= B10.To_Bounded_Wide_String("Z abc ") then
- Report.Failed("Incorrect result from Procedure Insert");
- end if;
-
-
- exception
- when others => Report.Failed("Exception raised in Test_Block");
- end Test_Block;
-
- Report.Result;
-
-end CXA4019;
diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxa4020.a b/gcc/testsuite/ada/acats/tests/cxa/cxa4020.a
deleted file mode 100644
index 24036f17103..00000000000
--- a/gcc/testsuite/ada/acats/tests/cxa/cxa4020.a
+++ /dev/null
@@ -1,688 +0,0 @@
--- CXA4020.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that the subprograms defined in package Ada.Strings.Wide_Bounded
--- are available, and that they produce correct results, especially under
--- conditions where truncation of the result is required. Specifically,
--- check the subprograms Overwrite (function and procedure), Delete,
--- Function Trim (blanks), Trim (Set wide characters, function and
--- procedure), Head, Tail, and Replicate (wide characters and wide
--- strings).
---
--- TEST DESCRIPTION:
--- This test, in conjunction with tests CXA4017, CXA4018, CXA4019,
--- will provide coverage of the most common usages of the functionality
--- found in the Ada.Strings.Wide_Bounded package. It deals in large part
--- with truncation effects and options. This test contains many small,
--- specific test cases, situations that are often difficult to generate
--- in large numbers in an application-based test. These cases represent
--- specific usage paradigms in-the-small.
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 22 Dec 94 SAIC Changed obsolete constant to Strings.Wide_Space.
--- 13 Apr 95 SAIC Corrected certain subtest acceptance conditions.
---
---!
-
-with Report;
-with Ada.Characters.Handling;
-with Ada.Strings.Wide_Bounded;
-with Ada.Strings.Wide_Maps;
-
-procedure CXA4020 is
-
- -- The following two functions are used to translate character and string
- -- values to "Wide" values. They will be applied to all the Wide_Bounded
- -- subprogram parameters to simulate the use of Wide_Characters and
- -- Wide_Strings in actual practice. Blanks are translated to Wide_Character
- -- blanks and all other characters are translated into Wide_Characters with
- -- position values 256 greater than their (narrow) character position
- -- values.
-
- function Translate (Ch : Character) return Wide_Character is
- C : Character := Ch;
- begin
- if Ch = ' ' then
- return Ada.Characters.Handling.To_Wide_Character(C);
- else
- return Wide_Character'Val(Character'Pos(Ch) +
- Character'Pos(Character'Last) + 1);
- end if;
- end Translate;
-
-
- function Translate (Str : String) return Wide_String is
- WS : Wide_String(Str'First..Str'Last);
- begin
- for i in Str'First..Str'Last loop
- WS(i) := Translate(Str(i));
- end loop;
- return WS;
- end Translate;
-
-
-begin
-
- Report.Test("CXA4020", "Check that the subprograms defined in " &
- "package Ada.Strings.Wide_Bounded are " &
- "available, and that they produce correct " &
- "results, especially under conditions where " &
- "truncation of the result is required");
-
- Test_Block:
- declare
-
- package AS renames Ada.Strings;
- package ASW renames Ada.Strings.Wide_Bounded;
- package Maps renames Ada.Strings.Wide_Maps;
-
- package B10 is new ASW.Generic_Bounded_Length(Max => 10);
- use type B10.Bounded_Wide_String;
-
- Result_String : B10.Bounded_Wide_String;
- Test_String : B10.Bounded_Wide_String;
- AtoE_Bnd_Str : B10.Bounded_Wide_String :=
- B10.To_Bounded_Wide_String(Translate("abcde"));
- FtoJ_Bnd_Str : B10.Bounded_Wide_String :=
- B10.To_Bounded_Wide_String(Translate("fghij"));
- AtoJ_Bnd_Str : B10.Bounded_Wide_String :=
- B10.To_Bounded_Wide_String(Translate("abcdefghij"));
-
- Location : Natural := 0;
- Total_Count : Natural := 0;
-
- CD_Set : Maps.Wide_Character_Set := Maps.To_Set(Translate("cd"));
- XY_Set : Maps.Wide_Character_Set := Maps.To_Set(Translate("xy"));
-
-
- begin
-
- -- Function Overwrite with Truncation
- -- Drop = Error (Default).
-
- begin
- Test_String := AtoJ_Bnd_Str;
- Result_String :=
- B10.Overwrite(Source => Test_String, -- "abcdefghij"
- Position => 9,
- New_Item => Translate("xyz"),
- Drop => AS.Error);
- Report.Failed("Exception not raised by Function Overwrite");
- exception
- when AS.Length_Error => null; -- Expected exception raised.
- when others =>
- Report.Failed("Incorrect exception raised by Function Overwrite");
- end;
-
- -- Drop = Left
-
- Result_String :=
- B10.Overwrite(Source => Test_String, -- "abcdefghij"
- Position => B10.Length(Test_String), -- 10
- New_Item => Translate("xyz"),
- Drop => Ada.Strings.Left);
-
- if B10.To_Wide_String(Result_String) /=
- Translate("cdefghixyz") then -- drop a,b
- Report.Failed
- ("Incorrect result from Function Overwrite, Drop = Left");
- end if;
-
- -- Drop = Right
-
- Result_String := B10.Overwrite(Test_String, -- "abcdefghij"
- 3,
- Translate("xxxyyyzzz"),
- Ada.Strings.Right);
-
- if B10.To_Wide_String(Result_String) /=
- Translate("abxxxyyyzz")
- then
- Report.Failed
- ("Incorrect result from Function Overwrite, Drop = Right");
- end if;
-
- -- Additional cases of function Overwrite.
-
- if B10.Overwrite(B10.To_Bounded_Wide_String(Translate("a")),
- 1, -- Source length = 1
- Translate(" abc ")) /=
- B10.To_Bounded_Wide_String(Translate(" abc ")) or
- B10.Overwrite(B10.Null_Bounded_Wide_String, -- Null source
- 1,
- Translate("abcdefghij")) /=
- AtoJ_Bnd_Str or
- B10.Overwrite(AtoE_Bnd_Str,
- B10.To_Wide_String(AtoE_Bnd_Str)'First,
- Translate(" ")) /= -- New_Item = 1
- B10.To_Bounded_Wide_String(Translate(" bcde"))
- then
- Report.Failed("Incorrect result from Function Overwrite");
- end if;
-
-
-
- -- Procedure Overwrite
- -- Correct usage, no truncation.
-
- Test_String := AtoE_Bnd_Str; -- "abcde"
- B10.Overwrite(Test_String, 2, Translate("xyz"));
-
- if Test_String /= B10.To_Bounded_Wide_String(Translate("axyze")) then
- Report.Failed("Incorrect result from Procedure Overwrite - 1");
- end if;
-
- Test_String := B10.To_Bounded_Wide_String(Translate("abc"));
- B10.Overwrite(Test_String, 2, ""); -- New_Item is null string.
-
- if Test_String /= B10.To_Bounded_Wide_String(Translate("abc")) then
- Report.Failed("Incorrect result from Procedure Overwrite - 2");
- end if;
-
- -- Drop = Error (Default).
-
- begin
- Test_String := AtoJ_Bnd_Str;
- B10.Overwrite(Source => Test_String, -- "abcdefghij"
- Position => 8,
- New_Item => Translate("uvwxyz"));
- Report.Failed("Exception not raised by Procedure Overwrite");
- exception
- when AS.Length_Error => null; -- Expected exception raised.
- when others =>
- Report.Failed("Incorrect exception raised by Procedure Overwrite");
- end;
-
- -- Drop = Left
-
- Test_String := AtoJ_Bnd_Str;
- B10.Overwrite(Source => Test_String, -- "abcdefghij"
- Position => B10.Length(Test_String) - 2, -- 8
- New_Item => Translate("uvwxyz"),
- Drop => Ada.Strings.Left);
-
- if B10.To_Wide_String(Test_String) /=
- Translate("defguvwxyz")
- then
- Report.Failed
- ("Incorrect result from Procedure Overwrite, Drop = Left");
- end if;
-
- -- Drop = Right
-
- Test_String := AtoJ_Bnd_Str;
- B10.Overwrite(Test_String, -- "abcdefghij"
- 3,
- Translate("xxxyyyzzz"),
- Ada.Strings.Right);
-
- if B10.To_Wide_String(Test_String) /= Translate("abxxxyyyzz") then
- Report.Failed
- ("Incorrect result from Procedure Overwrite, Drop = Right");
- end if;
-
-
-
- -- Function Delete
-
- if B10.Delete(Source => AtoJ_Bnd_Str, -- "abcdefghij"
- From => 3,
- Through => 8) /=
- B10."&"(B10.Head(AtoJ_Bnd_Str, 2),
- B10.Tail(AtoJ_Bnd_Str, 2)) or
- B10.Delete(AtoJ_Bnd_Str, 6, B10.Length(AtoJ_Bnd_Str)) /=
- AtoE_Bnd_Str or
- B10.Delete(AtoJ_Bnd_Str, 1, 5) /=
- FtoJ_Bnd_Str
- then
- Report.Failed("Incorrect result from Function Delete - 1");
- end if;
-
- if B10.Delete(B10.To_Bounded_Wide_String(Translate("a")), 1, 1) /=
- B10.Null_Bounded_Wide_String or
- B10.Delete(AtoE_Bnd_Str,
- 5,
- B10.To_Wide_String(AtoE_Bnd_Str)'First) /=
- AtoE_Bnd_Str or
- B10.Delete(AtoE_Bnd_Str,
- B10.To_Wide_String(AtoE_Bnd_Str)'Last,
- B10.To_Wide_String(AtoE_Bnd_Str)'Last) /=
- B10.To_Bounded_Wide_String(Translate("abcd"))
- then
- Report.Failed("Incorrect result from Function Delete - 2");
- end if;
-
-
-
- -- Function Trim
-
- declare
-
- Text : B10.Bounded_Wide_String :=
- B10.To_Bounded_Wide_String(Translate("Text"));
- type Bnd_Array_Type is array (1..5) of B10.Bounded_Wide_String;
- Bnd_Array : Bnd_Array_Type :=
- (B10.To_Bounded_Wide_String(Translate(" Text")),
- B10.To_Bounded_Wide_String(Translate("Text ")),
- B10.To_Bounded_Wide_String(Translate(" Text ")),
- B10.To_Bounded_Wide_String(Translate("Text Text")),
- B10.To_Bounded_Wide_String(Translate(" Text Text")));
-
- begin
-
- for i in Bnd_Array_Type'Range loop
- case i is
- when 4 =>
- if B10.Trim(Bnd_Array(i), AS.Both) /=
- Bnd_Array(i) then -- no change
- Report.Failed("Incorrect result from Function Trim - 4");
- end if;
- when 5 =>
- if B10.Trim(Bnd_Array(i), AS.Both) /=
- B10."&"(Text, B10."&"(Translate(' '), Text))
- then
- Report.Failed("Incorrect result from Function Trim - 5");
- end if;
- when others =>
- if B10.Trim(Bnd_Array(i), AS.Both) /= Text then
- Report.Failed("Incorrect result from Function Trim - " &
- Integer'Image(i));
- end if;
- end case;
- end loop;
-
- end;
-
-
-
- -- Function Trim using Sets
-
- -- Trim characters in sets from both sides of the bounded wide string.
- if B10.Trim(Source => B10.To_Bounded_Wide_String(Translate("ddabbaxx")),
- Left => CD_Set,
- Right => XY_Set) /=
- B10.To_Bounded_Wide_String(Translate("abba"))
- then
- Report.Failed
- ("Incorrect result from Fn Trim - Sets, Left & Right side - 1");
- end if;
-
- -- Ensure that the characters in the set provided as the actual to
- -- parameter Right are not trimmed from the left side of the bounded
- -- wide string; likewise for the opposite side. Only "cd" trimmed
- -- from left side, and only "xy" trimmed from right side.
-
- if B10.Trim(B10.To_Bounded_Wide_String(Translate("cdxyabcdxy")),
- CD_Set,
- XY_Set) /=
- B10.To_Bounded_Wide_String(Translate("xyabcd"))
- then
- Report.Failed
- ("Incorrect result from Fn Trim - Sets, Left & Right side - 2");
- end if;
-
- -- Ensure that characters contained in the sets are not trimmed from
- -- the "interior" of the bounded wide string, just the appropriate ends.
-
- if B10.Trim(B10.To_Bounded_Wide_String(Translate("cdabdxabxy")),
- CD_Set,
- XY_Set) /=
- B10.To_Bounded_Wide_String(Translate("abdxab"))
- then
- Report.Failed
- ("Incorrect result from Fn Trim - Sets, Left & Right side - 3");
- end if;
-
- -- Trim characters in set from right side only. No change to Left side.
-
- if B10.Trim(B10.To_Bounded_Wide_String(Translate("abxyzddcd")),
- XY_Set,
- CD_Set) /=
- B10.To_Bounded_Wide_String(Translate("abxyz"))
- then
- Report.Failed
- ("Incorrect result from Fn Trim - Sets, Right side");
- end if;
-
- -- Trim no characters on either side of the bounded string.
-
- Result_String := B10.Trim(AtoJ_Bnd_Str, CD_Set, XY_Set);
- if Result_String /= AtoJ_Bnd_Str then
- Report.Failed("Incorrect result from Fn Trim - Sets, Neither side");
- end if;
-
- if B10.Trim(AtoE_Bnd_Str, Maps.Null_Set, Maps.Null_Set) /=
- AtoE_Bnd_Str or
- B10.Trim(B10.To_Bounded_Wide_String(Translate("dcddcxyyxx")),
- CD_Set,
- XY_Set) /=
- B10.Null_Bounded_Wide_String
- then
- Report.Failed("Incorrect result from Function Trim");
- end if;
-
-
-
- -- Procedure Trim using Sets
-
- -- Trim characters in sets from both sides of the bounded wide string.
-
- Test_String := B10.To_Bounded_Wide_String(Translate("dcabbayx"));
- B10.Trim(Source => Test_String,
- Left => CD_Set,
- Right => XY_Set);
-
- if Test_String /= B10.To_Bounded_Wide_String(Translate("abba")) then
- Report.Failed
- ("Incorrect result from Proc Trim - Sets, Left & Right side - 1");
- end if;
-
- -- Ensure that the characters in the set provided as the actual to
- -- parameter Right are not trimmed from the left side of the bounded
- -- wide string; likewise for the opposite side. Only "cd" trimmed
- -- from left side, and only "xy" trimmed from right side.
-
- Test_String := B10.To_Bounded_Wide_String(Translate("cdxyabcdxy"));
- B10.Trim(Test_String, CD_Set, XY_Set);
-
- if Test_String /= B10.To_Bounded_Wide_String(Translate("xyabcd")) then
- Report.Failed
- ("Incorrect result from Proc Trim - Sets, Left & Right side - 2");
- end if;
-
- -- Ensure that characters contained in the sets are not trimmed from
- -- the "interior" of the bounded wide string, just the appropriate ends.
-
- Test_String := B10.To_Bounded_Wide_String(Translate("cdabdxabxy"));
- B10.Trim(Test_String, CD_Set, XY_Set);
-
- if not
- (Test_String = B10.To_Bounded_Wide_String(Translate("abdxab"))) then
- Report.Failed
- ("Incorrect result from Proc Trim - Sets, Left & Right side - 3");
- end if;
-
- -- Trim characters in set from Left side only. No change to Right side.
-
- Test_String := B10.To_Bounded_Wide_String(Translate("cccdabxyz"));
- B10.Trim(Test_String, CD_Set, XY_Set);
-
- if Test_String /= B10.To_Bounded_Wide_String(Translate("abxyz")) then
- Report.Failed
- ("Incorrect result from Proc Trim for Sets, Left side only");
- end if;
-
- -- Trim no characters on either side of the bounded wide string.
-
- Test_String := AtoJ_Bnd_Str;
- B10.Trim(Test_String, CD_Set, CD_Set);
-
- if Test_String /= AtoJ_Bnd_Str then
- Report.Failed("Incorrect result from Proc Trim-Sets, Neither side");
- end if;
-
-
-
- -- Function Head with Truncation
- -- Drop = Error (Default).
-
- begin
- Result_String := B10.Head(Source => AtoJ_Bnd_Str, -- max length
- Count => B10.Length(AtoJ_Bnd_Str) + 1,
- Pad => Translate('X'));
- Report.Failed("Length_Error not raised by Function Head");
- exception
- when AS.Length_Error => null; -- Expected exception raised.
- when others =>
- Report.Failed("Incorrect exception raised by Function Head");
- end;
-
- -- Drop = Left
-
- -- Pad characters (5) are appended to the right end of the bounded
- -- wide string (which is initially at its maximum length), then the
- -- first five characters of the intermediate result are dropped to
- -- conform to the maximum size limit of the bounded wide string (10).
-
- Result_String :=
- B10.Head(B10.To_Bounded_Wide_String(Translate("ABCDEFGHIJ")),
- 15,
- Translate('x'),
- Ada.Strings.Left);
-
- if Result_String /=
- B10.To_Bounded_Wide_String(Translate("FGHIJxxxxx"))
- then
- Report.Failed("Incorrect result from Function Head, Drop = Left");
- end if;
-
- -- Drop = Right
-
- -- Pad characters (6) are appended to the left end of the bounded
- -- wide string (which is initially at one less than its maximum length),
- -- then the last five characters of the intermediate result are dropped
- -- (which in this case are the pad characters) to conform to the
- -- maximum size limit of the bounded wide string (10).
-
- Result_String :=
- B10.Head(B10.To_Bounded_Wide_String(Translate("ABCDEFGHI")),
- 15,
- Translate('x'),
- Ada.Strings.Right);
-
- if Result_String /=
- B10.To_Bounded_Wide_String(Translate("ABCDEFGHIx"))
- then
- Report.Failed("Incorrect result from Function Head, Drop = Right");
- end if;
-
- -- Additional cases.
-
- if B10.Head(B10.Null_Bounded_Wide_String, 5, Translate('a')) /=
- B10.To_Bounded_Wide_String(Translate("aaaaa")) or
- B10.Head(AtoE_Bnd_Str,
- B10.Length(AtoE_Bnd_Str)) /=
- AtoE_Bnd_Str
- then
- Report.Failed("Incorrect result from Function Head");
- end if;
-
-
-
- -- Function Tail with Truncation
- -- Drop = Error (Default Case)
-
- begin
- Result_String := B10.Tail(Source => AtoJ_Bnd_Str, -- max length
- Count => B10.Length(AtoJ_Bnd_Str) + 1,
- Pad => Ada.Strings.Wide_Space,
- Drop => Ada.Strings.Error);
- Report.Failed("Length_Error not raised by Function Tail");
- exception
- when AS.Length_Error => null; -- Expected exception raised.
- when others =>
- Report.Failed("Incorrect exception raised by Function Tail");
- end;
-
- -- Drop = Left
-
- -- Pad characters (5) are appended to the left end of the bounded wide
- -- string (which is initially at two less than its maximum length),
- -- then the first three characters of the intermediate result (in this
- -- case, 3 pad characters) are dropped.
-
- Result_String :=
- B10.Tail(B10.To_Bounded_Wide_String(Translate("ABCDEFGH")),
- 13,
- Translate('x'),
- Ada.Strings.Left);
-
- if Result_String /=
- B10.To_Bounded_Wide_String(Translate("xxABCDEFGH"))
- then
- Report.Failed("Incorrect result from Function Tail, Drop = Left");
- end if;
-
- -- Drop = Right
-
- -- Pad characters (3) are appended to the left end of the bounded wide
- -- string (which is initially at its maximum length), then the last
- -- three characters of the intermediate result are dropped.
-
- Result_String :=
- B10.Tail(B10.To_Bounded_Wide_String(Translate("ABCDEFGHIJ")),
- 13,
- Translate('x'),
- Ada.Strings.Right);
-
- if Result_String /=
- B10.To_Bounded_Wide_String(Translate("xxxABCDEFG"))
- then
- Report.Failed("Incorrect result from Function Tail, Drop = Right");
- end if;
-
- -- Additional cases.
-
- if B10.Tail(B10.Null_Bounded_Wide_String, 3, Translate(' ')) /=
- B10.To_Bounded_Wide_String(Translate(" ")) or
- B10.Tail(AtoE_Bnd_Str,
- B10.To_Wide_String(AtoE_Bnd_Str)'First) /=
- B10.To_Bounded_Wide_String(Translate("e"))
- then
- Report.Failed("Incorrect result from Function Tail");
- end if;
-
-
-
- -- Function Replicate (#, Char) with Truncation
- -- Drop = Error (Default).
-
- begin
- Result_String := B10.Replicate(Count => B10.Max_Length + 5,
- Item => Translate('A'),
- Drop => AS.Error);
- Report.Failed
- ("Length_Error not raised by Replicate for characters");
- exception
- when AS.Length_Error => null; -- Expected exception raised.
- when others =>
- Report.Failed
- ("Incorrect exception raised by Replicate for characters");
- end;
-
- -- Drop = Left, Right
- -- Since this version of Replicate uses wide character parameters, the
- -- result after truncation from left or right will appear the same.
- -- The result will be a 10 character bounded wide string, composed of
- -- 10 "Item" wide characters.
-
- if B10.Replicate(Count => 20,
- Item => Translate('A'),
- Drop => Ada.Strings.Left) /=
- B10.Replicate(15, Translate('A'), Ada.Strings.Right)
- then
- Report.Failed("Incorrect result from Replicate for characters - 1");
- end if;
-
- -- Blank-filled, 10 character bounded wide strings.
-
- if B10.Replicate(B10.Max_Length + 1,
- Translate(' '),
- Drop => Ada.Strings.Left) /=
- B10.Replicate(B10.Max_Length, Ada.Strings.Wide_Space)
- then
- Report.Failed("Incorrect result from Replicate for characters - 2");
- end if;
-
- -- Additional cases.
-
- if B10.Replicate(0, Translate('a')) /= B10.Null_Bounded_Wide_String or
- B10.Replicate(1, Translate('a')) /=
- B10.To_Bounded_Wide_String(Translate("a"))
- then
- Report.Failed("Incorrect result from Replicate for characters - 3");
- end if;
-
-
-
- -- Function Replicate (#, String) with Truncation
- -- Drop = Error (Default).
-
- begin
- Result_String := B10.Replicate(Count => 5, -- result would be 15.
- Item => Translate("abc"));
- Report.Failed
- ("Length_Error not raised by Replicate for wide strings");
- exception
- when AS.Length_Error => null; -- Expected exception raised.
- when others =>
- Report.Failed
- ("Incorrect exception raised by Replicate for wide strings");
- end;
-
- -- Drop = Left
-
- Result_String := B10.Replicate(3, Translate("abcd"), Ada.Strings.Left);
-
- if Result_String /=
- B10.To_Bounded_Wide_String(Translate("cdabcdabcd"))
- then
- Report.Failed
- ("Incorrect result from Replicate for wide strings, Drop = Left");
- end if;
-
- -- Drop = Right
-
- Result_String := B10.Replicate(3, Translate("abcd"), Ada.Strings.Right);
-
- if Result_String /=
- B10.To_Bounded_Wide_String(Translate("abcdabcdab")) then
- Report.Failed
- ("Incorrect result from Replicate for wide strings, Drop = Right");
- end if;
-
- -- Additional cases.
-
- if B10.Replicate(5, Translate("X")) /=
- B10.To_Bounded_Wide_String(Translate("XXXXX")) or
- B10.Replicate(10, "") /=
- B10.Null_Bounded_Wide_String or
- B10.Replicate(0, Translate("ab")) /=
- B10.Null_Bounded_Wide_String
- then
- Report.Failed("Incorrect result from Replicate for wide strings");
- end if;
-
-
- exception
- when others => Report.Failed("Exception raised in Test_Block");
- end Test_Block;
-
- Report.Result;
-
-end CXA4020;
diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxa4021.a b/gcc/testsuite/ada/acats/tests/cxa/cxa4021.a
deleted file mode 100644
index 345a77c68d0..00000000000
--- a/gcc/testsuite/ada/acats/tests/cxa/cxa4021.a
+++ /dev/null
@@ -1,311 +0,0 @@
--- CXA4021.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that the subprograms defined in package
--- Ada.Strings.Wide_Unbounded are available, and that they produce
--- correct results. Specifically, check the subprograms Head, Index,
--- Index_Non_Blank, Insert, Length, Overwrite, Replace_Slice, Slice,
--- Tail, To_Wide_String, To_Unbounded_Wide_String, "*", "&",
--- and "=", "<=", ">=".
---
--- TEST DESCRIPTION:
--- This test demonstrates the uses of many of the subprograms defined
--- in package Ada.Strings.Wide_Unbounded for use with unbounded wide
--- strings.
--- The test attempts to simulate how unbounded wide strings could be used
--- to simulate paragraphs of text. Modifications could be easily be
--- performed using the provided subprograms (although in this test, the
--- main modification performed was the addition of more text to the
--- string). One would not have to worry about the formatting of the
--- paragraph until it was finished and correct in content. Then, once
--- all required editing is complete, the unbounded strings can be divided
--- up into the appropriate lengths based on particular formatting
--- requirements. The test then compares the formatted text product
--- with a predefined "finished product".
---
--- This test attempts to use a large number of the subprograms provided
--- by package Ada.Strings.Wide_Unbounded. Often, the processing involved
--- could have been performed more efficiently using a minimum number
--- of the subprograms, in conjunction with loops, etc. However, for
--- testing purposes, and in the interest of minimizing the number of
--- tests developed, subprogram variety and feature mixing was stressed.
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
---
---!
-
-with Report;
-with Ada.Characters.Handling;
-with Ada.Strings.Wide_Maps;
-with Ada.Strings.Wide_Unbounded;
-
-procedure CXA4021 is
-
- -- The following two functions are used to translate character and string
- -- values to "Wide" values. They will be applied to all the Wide_Bounded
- -- subprogram character and string parameters to simulate the use of non-
- -- character Wide_Characters and Wide_Strings in actual practice.
- -- Note: These functions do not actually return "equivalent" wide
- -- characters to their character inputs, just "non-character"
- -- wide characters.
-
- function Equiv (Ch : Character) return Wide_Character is
- C : Character := Ch;
- begin
- if Ch = ' ' then
- return Ada.Characters.Handling.To_Wide_Character(C);
- else
- return Wide_Character'Val(Character'Pos(Ch) +
- Character'Pos(Character'Last) + 1);
- end if;
- end Equiv;
-
-
- function Equiv (Str : String) return Wide_String is
- WS : Wide_String(Str'First..Str'Last);
- begin
- for i in Str'First..Str'Last loop
- WS(i) := Equiv(Str(i));
- end loop;
- return WS;
- end Equiv;
-
-begin
-
- Report.Test ("CXA4021", "Check that the subprograms defined in " &
- "package Ada.Strings.Wide_Unbounded are " &
- "available, and that they produce correct " &
- "results");
-
- Test_Block:
- declare
-
- package ASW renames Ada.Strings.Wide_Unbounded;
- use type ASW.Unbounded_Wide_String;
- use Ada.Strings;
-
- Pamphlet_Paragraph_Count : constant := 2;
- Lines : constant := 4;
- Line_Length : constant := 40;
-
- type Document_Type is array (Positive range <>)
- of ASW.Unbounded_Wide_String;
-
- type Camera_Ready_Copy_Type is array (1..Lines)
- of Wide_String (1..Line_Length);
-
- Pamphlet : Document_Type (1..Pamphlet_Paragraph_Count);
-
- Camera_Ready_Copy : Camera_Ready_Copy_Type :=
- (others => (others => Ada.Strings.Wide_Space));
-
- TC_Finished_Product : Camera_Ready_Copy_Type :=
- ( 1 => Equiv("Ada is a programming language designed "),
- 2 => Equiv("to support long-lived, reliable software"),
- 3 => Equiv(" systems. "),
- 4 => Equiv("Go with Ada! "));
-
- -----
-
-
- procedure Enter_Text_Into_Document (Document : in out Document_Type) is
- begin
-
- -- Fill in both "paragraphs" of the document. Each unbounded wide
- -- string functions as an individual paragraph, containing an
- -- unspecified number of characters.
- -- Use a variety of different unbounded wide string subprograms to
- -- load the data.
-
- Document(1) :=
- ASW.To_Unbounded_Wide_String(Equiv("Ada is a language"));
-
- -- Insert the word "programming" prior to "language".
- Document(1) :=
- ASW.Insert(Document(1),
- ASW.Index(Document(1),
- Equiv("language")),
- ASW.To_Wide_String(Equiv("progra") & -- Wd Str &
- ASW."*"(2,Equiv('m')) & -- Wd Unbd &
- Equiv("ing "))); -- Wd Str
-
-
- -- Overwrite the word "language" with "language" + additional text.
- Document(1) :=
- ASW.Overwrite(Document(1),
- ASW.Index(Document(1),
- ASW.To_Wide_String(
- ASW.Tail(Document(1), 8, Equiv(' '))),
- Ada.Strings.Backward),
- Equiv("language designed to support long-lifed"));
-
-
- -- Replace the word "lifed" with "lived".
- Document(1) :=
- ASW.Replace_Slice(Document(1),
- ASW.Index(Document(1), Equiv("lifed")),
- ASW.Length(Document(1)),
- Equiv("lived"));
-
-
- -- Overwrite the word "lived" with "lived" + additional text.
- Document(1) :=
- ASW.Overwrite(Document(1),
- ASW.Index(Document(1),
- ASW.To_Wide_String
- (ASW.Tail(Document(1), 5, Equiv(' '))),
- Ada.Strings.Backward),
- Equiv("lived, reliable software systems."));
-
-
- -- Use several of the overloaded versions of "&" to form this
- -- unbounded wide string.
-
- Document(2) := Equiv('G') &
- ASW.To_Unbounded_Wide_String(Equiv("o ")) &
- ASW.To_Unbounded_Wide_String(Equiv("with")) &
- Equiv(' ') &
- Equiv("Ada!");
-
- end Enter_Text_Into_Document;
-
-
- -----
-
-
- procedure Create_Camera_Ready_Copy
- (Document : in Document_Type;
- Camera_Copy : out Camera_Ready_Copy_Type) is
- begin
- -- Break the unbounded wide strings into fixed lengths.
-
- -- Search the first unbounded wide string for portions of text that
- -- are less than or equal to the length of a wide string in the
- -- Camera_Ready_Copy_Type object.
-
- Camera_Copy(1) := -- Take characters 1-39,
- ASW.Slice(Document(1), -- and append a blank space.
- 1,
- ASW.Index(ASW.To_Unbounded_Wide_String
- (ASW.Slice(Document(1),
- 1,
- Line_Length)),
- Ada.Strings.Wide_Maps.To_Set(Equiv(' ')),
- Ada.Strings.Inside,
- Ada.Strings.Backward)) & Equiv(' ');
-
- Camera_Copy(2) := -- Take characters 40-79.
- ASW.Slice(Document(1),
- 40,
- (ASW.Index_Non_Blank -- Should return 79
- (ASW.To_Unbounded_Wide_String
- (ASW.Slice(Document(1), -- Slice (40..79)
- 40,
- 79)),
- Ada.Strings.Backward) + 39)); -- Increment since
- -- this slice starts
- -- at 40.
-
- Camera_Copy(3)(1..9) := ASW.Slice(Document(1), -- Characters 80-88
- 80,
- ASW.Length(Document(1)));
-
-
- -- Break the second unbounded wide string into the appropriate
- -- length. It is only twelve characters in length, so the entire
- -- unbounded wide string will be placed on one string of the output
- -- object.
-
- Camera_Copy(4)(1..ASW.Length(Document(2))) :=
- ASW.To_Wide_String(ASW.Head(Document(2),
- ASW.Length(Document(2))));
-
- end Create_Camera_Ready_Copy;
-
-
- -----
-
-
- function Valid_Proofread (Draft, Master : Camera_Ready_Copy_Type)
- return Boolean is
- begin
-
- -- Evaluate wide strings for equality, using the operators defined
- -- in package Ada.Strings.Wide_Unbounded. The less than/greater
- -- than or equal comparisons should evaluate to "equals => True".
-
- if ASW.To_Unbounded_Wide_String(Draft(1)) = -- "="(WUnb,WUnb)
- ASW.To_Unbounded_Wide_String(Master(1)) and
- ASW.To_Unbounded_Wide_String(Draft(2)) <= -- "<="(WUnb,WUnb)
- ASW.To_Unbounded_Wide_String(Master(2)) and
- ASW.To_Unbounded_Wide_String(Draft(3)) >= -- ">="(WUnb,WUnb)
- ASW.To_Unbounded_Wide_String(Master(3)) and
- ASW.To_Unbounded_Wide_String(Draft(4)) = -- "="(WUnb,WUnb)
- ASW.To_Unbounded_Wide_String(Master(4))
- then
- return True;
- else
- return False;
- end if;
-
- end Valid_Proofread;
-
-
- -----
-
-
- begin
-
- -- Enter text into the unbounded wide string paragraphs of the document.
-
- Enter_Text_Into_Document (Pamphlet);
-
-
- -- Reformat the unbounded wide strings into fixed wide string format.
-
- Create_Camera_Ready_Copy (Document => Pamphlet,
- Camera_Copy => Camera_Ready_Copy);
-
-
- -- Verify the conversion process.
-
- if not Valid_Proofread (Draft => Camera_Ready_Copy,
- Master => TC_Finished_Product)
- then
- Report.Failed ("Incorrect unbounded wide string processing result");
- end if;
-
-
- exception
- when others => Report.Failed ("Exception raised in Test_Block");
- end Test_Block;
-
-
- Report.Result;
-
-end CXA4021;
diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxa4022.a b/gcc/testsuite/ada/acats/tests/cxa/cxa4022.a
deleted file mode 100644
index 3c649a1a294..00000000000
--- a/gcc/testsuite/ada/acats/tests/cxa/cxa4022.a
+++ /dev/null
@@ -1,531 +0,0 @@
--- CXA4022.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that the subprograms defined in package
--- Ada.Strings.Wide_Unbounded are available, and that they produce
--- correct results. Specifically, check the subprograms Count, Element,
--- Index, Replace_Element, To_Unbounded_Wide_String, and "&", ">", "<".
---
--- TEST DESCRIPTION:
--- This test demonstrates the uses of many of the subprograms defined
--- in package Ada.Strings.Wide_Unbounded for use with unbounded wide
--- strings. The test simulates how unbounded wide strings
--- will be processed in a user environment, using the subprograms
--- provided in this package.
---
--- Taken in conjunction with tests CXA4021 and CXA4023, this test will
--- constitute a test of the functionality contained in package
--- Ada.Strings.Wide Unbounded. This test uses a variety
--- of the subprograms defined in the unbounded wide string package
--- in ways typical of common usage, with different combinations of
--- available subprograms being used to accomplish similar
--- unbounded wide string processing goals.
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 08 Nov 95 SAIC Corrected accessibility level, type visibility,
--- and subtest acceptance criteria problems for
--- ACVC 2.0.1
---
---!
-
-with Ada.Characters.Handling;
-with Ada.Strings;
-
-package CXA40220 is
-
- -- The following two functions are used to translate character and string
- -- values to "Wide" values. They will be applied to all the Wide_Bounded
- -- subprogram character and string parameters to simulate the use of non-
- -- character Wide_Characters and Wide_Strings in actual practice.
- -- Note: These functions do not actually return "equivalent" wide
- -- characters to their character inputs, just "non-character"
- -- wide characters.
-
- function Equiv (Ch : Character) return Wide_Character;
-
- function Equiv (Str : String) return Wide_String;
-
-
- -- Functions and access-to-subprogram value used to supply mapping
- -- capability to the appropriate versions of Count, Index, and
- -- Translate.
-
- function AB_to_US_Mapping_Function (From : Wide_Character)
- return Wide_Character;
-
- function AB_to_Blank_Mapping_Function (From : Wide_Character)
- return Wide_Character;
-
-end CXA40220;
-
-package body CXA40220 is
-
- function Equiv (Ch : Character) return Wide_Character is
- C : Character := Ch;
- begin
- if Ch = ' ' then
- return Ada.Characters.Handling.To_Wide_Character(C);
- else
- return Wide_Character'Val(Character'Pos(Ch) +
- Character'Pos(Character'Last) + 1);
- end if;
- end Equiv;
-
-
- function Equiv (Str : String) return Wide_String is
- WS : Wide_String(Str'First..Str'Last);
- begin
- for i in Str'First..Str'Last loop
- WS(i) := Equiv(Str(i));
- end loop;
- return WS;
- end Equiv;
-
-
- function AB_to_US_Mapping_Function (From : Wide_Character)
- return Wide_Character is
- UnderScore : constant Wide_Character := Equiv('_');
- begin
- if From = Equiv('a') or From = Equiv('b') then
- return UnderScore;
- else
- return From;
- end if;
- end AB_to_US_Mapping_Function;
-
-
- function AB_to_Blank_Mapping_Function (From : Wide_Character)
- return Wide_Character is
- begin
- if From = Equiv('a') or From = Equiv('b') then
- return Ada.Strings.Wide_Space;
- else
- return From;
- end if;
- end AB_to_Blank_Mapping_Function;
-
-end CXA40220;
-
-
-with CXA40220;
-with Report;
-with Ada.Characters.Handling;
-with Ada.Strings.Wide_Maps;
-with Ada.Strings.Wide_Unbounded;
-
-procedure CXA4022 is
-begin
-
- Report.Test ("CXA4022", "Check that the subprograms defined in " &
- "package Ada.Strings.Wide_Unbounded are " &
- "available, and that they produce correct " &
- "results");
-
- Test_Block:
- declare
-
- use CXA40220;
-
- package ASW renames Ada.Strings.Wide_Unbounded;
- use Ada.Strings;
- use type Wide_Maps.Wide_Character_Set;
- use type ASW.Unbounded_Wide_String;
-
- Test_String : ASW.Unbounded_Wide_String;
- AtoE_Str : ASW.Unbounded_Wide_String :=
- ASW.To_Unbounded_Wide_String(Equiv("abcde"));
-
- Complete_String : ASW.Unbounded_Wide_String :=
- ASW."&"(ASW.To_Unbounded_Wide_String(Equiv("Incomplete")),
- ASW."&"(Ada.Strings.Wide_Space,
- ASW.To_Unbounded_Wide_String(Equiv("String"))));
-
- Incomplete_String : ASW.Unbounded_Wide_String :=
- ASW.To_Unbounded_Wide_String
- (Equiv("ncomplete Strin"));
-
- Incorrect_Spelling : ASW.Unbounded_Wide_String :=
- ASW.To_Unbounded_Wide_String(Equiv("Guob Dai"));
-
- Magic_String : ASW.Unbounded_Wide_String :=
- ASW.To_Unbounded_Wide_String(Equiv("abracadabra"));
-
- Incantation : ASW.Unbounded_Wide_String := Magic_String;
-
-
- A_Small_G : Wide_Character := Equiv('g');
- A_Small_D : Wide_Character := Equiv('d');
-
- ABCD_Set : Wide_Maps.Wide_Character_Set :=
- Wide_Maps.To_Set(Equiv("abcd"));
- B_Set : Wide_Maps.Wide_Character_Set :=
- Wide_Maps.To_Set(Equiv('b'));
- CD_Set : Wide_Maps.Wide_Character_Set :=
- Wide_Maps.To_Set(Equiv("cd"));
-
- CD_to_XY_Map : Wide_Maps.Wide_Character_Mapping :=
- Wide_Maps.To_Mapping(From => Equiv("cd"),
- To => Equiv("xy"));
- AB_to_YZ_Map : Wide_Maps.Wide_Character_Mapping :=
- Wide_Maps.To_Mapping(Equiv("ab"), Equiv("yz"));
-
-
- Matching_Letters : Natural := 0;
- Location,
- Total_Count : Natural := 0;
-
-
- Map_Ptr : Wide_Maps.Wide_Character_Mapping_Function :=
- AB_to_US_Mapping_Function'Access;
-
-
- begin
-
-
- -- Function "&"
-
- -- Prepend an 'I' and append a 'g' to the wide string.
- Incomplete_String := ASW."&"(Equiv('I'),
- Incomplete_String); -- Ch & W Unb
- Incomplete_String := ASW."&"(Incomplete_String,
- A_Small_G); -- W Unb & Ch
-
- if ASW."<"(Incomplete_String, Complete_String) or
- ASW.">"(Incomplete_String, Complete_String) or
- Incomplete_String /= Complete_String
- then
- Report.Failed("Incorrect result from use of ""&"" operator");
- end if;
-
-
-
- -- Function Element
-
- -- Last element of the unbounded wide string should be a 'g'.
- if ASW.Element(Incomplete_String, ASW.Length(Incomplete_String)) /=
- A_Small_G
- then
- Report.Failed("Incorrect result from use of Function Element - 1");
- end if;
-
- if ASW.Element(Incomplete_String, 2) /=
- ASW.Element(ASW.Tail(Incomplete_String, 2), 1) or
- ASW.Element(ASW.Head(Incomplete_String, 4), 2) /=
- ASW.Element(ASW.To_Unbounded_Wide_String(Equiv("wnqz")), 2)
- then
- Report.Failed("Incorrect result from use of Function Element - 2");
- end if;
-
-
-
- -- Procedure Replace_Element
-
- -- The unbounded wide string Incorrect_Spelling starts as "Guob Dai",
- -- and is transformed by the following three procedure calls to
- -- "Good Day".
-
- ASW.Replace_Element(Incorrect_Spelling, 2, Equiv('o'));
-
- ASW.Replace_Element(Incorrect_Spelling,
- ASW.Index(Incorrect_Spelling, B_Set),
- A_Small_D);
-
- ASW.Replace_Element(Source => Incorrect_Spelling,
- Index => ASW.Length(Incorrect_Spelling),
- By => Equiv('y'));
-
- if Incorrect_Spelling /=
- ASW.To_Unbounded_Wide_String(Equiv("Good Day"))
- then
- Report.Failed("Incorrect result from Procedure Replace_Element");
- end if;
-
-
-
- -- Function Index with non-Identity map.
- -- Evaluate the function Index with a non-identity map
- -- parameter which will cause mapping of the source parameter
- -- prior to the evaluation of the index position search.
-
- Location := ASW.Index(Source => ASW.To_Unbounded_Wide_String
- (Equiv("abcdefghij")),
- Pattern => Equiv("xy"),
- Going => Ada.Strings.Forward,
- Mapping => CD_to_XY_Map); -- change "cd" to "xy"
-
- if Location /= 3 then
- Report.Failed("Incorrect result from Index, non-Identity map - 1");
- end if;
-
- Location := ASW.Index(ASW.To_Unbounded_Wide_String(Equiv("abcdabcdab")),
- Equiv("yz"),
- Ada.Strings.Backward,
- AB_to_YZ_Map); -- change all "ab" to "yz"
-
- if Location /= 9 then
- Report.Failed("Incorrect result from Index, non-Identity map - 2");
- end if;
-
- -- A couple with identity maps (default) as well.
-
- if ASW.Index(ASW.To_Unbounded_Wide_String(Equiv("abcd")), -- Pat = Src
- Equiv("abcd")) /= 1 or
- ASW.Index(ASW.To_Unbounded_Wide_String(Equiv("abc")), -- Pat < Src
- Equiv("abcd")) /= 0 or
- ASW.Index(ASW.Null_Unbounded_Wide_String, -- Src = Null
- Equiv("abc")) /= 0
- then
- Report.Failed
- ("Incorrect result from Index with wide string patterns");
- end if;
-
-
-
- -- Function Index (for Sets).
- -- This version of Index uses Sets as the basis of the search.
-
- -- Test = Inside, Going = Forward (Default case).
- Location :=
- ASW.Index(Source => ASW.To_Unbounded_Wide_String(Equiv("abcdeabcde")),
- Set => CD_Set); -- set containing 'c' and 'd'
-
- if not (Location = 3) then -- position of first 'c' in source.
- Report.Failed("Incorrect result from Index using Sets - 1");
- end if;
-
- -- Test = Inside, Going = Backward.
- Location :=
- ASW.Index(Source => ASW."&"(AtoE_Str, AtoE_Str),
- Set => CD_Set, -- set containing 'c' and 'd'
- Test => Ada.Strings.Inside,
- Going => Ada.Strings.Backward);
-
- if not (Location = 9) then -- position of last 'd' in source.
- Report.Failed("Incorrect result from Index using Sets - 2");
- end if;
-
- -- Test = Outside, Going = Forward, Backward
- if ASW.Index(ASW.To_Unbounded_Wide_String(Equiv("deddacd")),
- Wide_Maps.To_Set(Equiv("xydcgf")),
- Test => Ada.Strings.Outside,
- Going => Ada.Strings.Forward) /= 2 or
- ASW.Index(ASW.To_Unbounded_Wide_String(Equiv("deddacd")),
- Wide_Maps.To_Set(Equiv("xydcgf")),
- Test => Ada.Strings.Outside,
- Going => Ada.Strings.Backward) /= 5 or
- ASW.Index(ASW.To_Unbounded_Wide_String(Equiv("deddacd")),
- CD_Set,
- Ada.Strings.Outside,
- Ada.Strings.Backward) /= 5
- then
- Report.Failed("Incorrect result from Index using Sets - 3");
- end if;
-
- -- Default direction (forward) and mapping (identity).
-
- if ASW.Index(ASW.To_Unbounded_Wide_String(Equiv("cd")), -- Source = Set
- CD_Set) /= 1 or
- ASW.Index(ASW.To_Unbounded_Wide_String(Equiv("c")), -- Source < Set
- CD_Set) /= 1 or
- ASW.Index(ASW.Null_Unbounded_Wide_String, -- Source = Null
- CD_Set) /= 0 or
- ASW.Index(AtoE_Str,
- Wide_Maps.Null_Set) /= 0 or -- Null set
- ASW.Index(AtoE_Str,
- Wide_Maps.To_Set(Equiv('x'))) /= 0 -- No match.
- then
- Report.Failed("Incorrect result from Index using Sets - 4");
- end if;
-
-
-
- -- Function Index using access-to-subprogram mapping.
- -- Evaluate the function Index with an access value that supplies the
- -- mapping function for this version of Index.
-
- Map_Ptr := AB_to_US_Mapping_Function'Access;
-
- Location := ASW.Index(Source => ASW.To_Unbounded_Wide_String
- (Equiv("xAxabbxax xaax _cx")),
- Pattern => Equiv("_x"),
- Going => Ada.Strings.Forward,
- Mapping => Map_Ptr); -- change 'a'or 'b' to '_'
-
- if Location /= 6 then -- location of "bx" substring
- Report.Failed("Incorrect result from Index, access value map - 1");
- end if;
-
- Map_Ptr := AB_to_Blank_Mapping_Function'Access;
-
- Location := ASW.Index(ASW.To_Unbounded_Wide_String
- (Equiv("ccacdcbbcdacc")),
- Equiv("cd "),
- Ada.Strings.Backward,
- Map_Ptr); -- change 'a' or 'b' to ' '
-
- if Location /= 9 then
- Report.Failed("Incorrect result from Index, access value map - 2");
- end if;
-
- if ASW.Index(ASW.To_Unbounded_Wide_String(Equiv("abcd")),
- Equiv(" cd"),
- Ada.Strings.Forward,
- Map_Ptr) /= 1 or
- ASW.Index(ASW.To_Unbounded_Wide_String(Equiv("abc")),
- Equiv(" c "), -- No match
- Ada.Strings.Backward,
- Map_Ptr) /= 0
- then
- Report.Failed("Incorrect result from Index, access value map - 3");
- end if;
-
-
-
- -- Function Count
-
- -- Determine the number of characters in the unbounded wide string that
- -- are contained in the set.
-
- Matching_Letters := ASW.Count(Source => Magic_String,
- Set => ABCD_Set);
-
- if Matching_Letters /= 9 then
- Report.Failed
- ("Incorrect result from Function Count with Set parameter");
- end if;
-
- -- Determine the number of occurrences of the following pattern wide
- -- strings in the unbounded wide string Magic_String.
-
- if ASW.Count(Magic_String, Equiv("ab")) /=
- (ASW.Count(Magic_String, Equiv("ac")) +
- ASW.Count(Magic_String, Equiv("ad"))) or
- ASW.Count(Magic_String, Equiv("ab")) /= 2
- then
- Report.Failed
- ("Incorrect result from Function Count, wide string parameter");
- end if;
-
-
-
- -- Function Count with non-Identity mapping.
- -- Evaluate the function Count with a non-identity map
- -- parameter which will cause mapping of the source parameter
- -- prior to the evaluation of the number of matching patterns.
-
- Total_Count :=
- ASW.Count(ASW.To_Unbounded_Wide_String(Equiv("abbabbabbabba")),
- Pattern => Equiv("yz"),
- Mapping => AB_to_YZ_Map);
-
- if Total_Count /= 4 then
- Report.Failed
- ("Incorrect result from function Count, non-Identity map - 1");
- end if;
-
- if ASW.Count(ASW.To_Unbounded_Wide_String(Equiv("ADCBADABCD")),
- Equiv("AB"),
- Wide_Maps.To_Mapping(Equiv("CD"), Equiv("AB"))) /= 5 or
- ASW.Count(ASW.To_Unbounded_Wide_String(Equiv("dcccddcdccdddccccd")),
- Equiv("xxy"),
- CD_to_XY_Map) /= 3
- then
- Report.Failed
- ("Incorrect result from function Count, non-Identity map - 2");
- end if;
-
- -- And a few with identity Wide_Maps as well.
-
- if ASW.Count(ASW.To_Unbounded_Wide_String(Equiv("ABABABABAB")),
- Equiv("ABA"),
- Wide_Maps.Identity) /= 2 or
- ASW.Count(ASW.To_Unbounded_Wide_String(Equiv("aaaaaaaaaa")),
- Equiv("aaa")) /= 3 or
- ASW.Count(ASW.To_Unbounded_Wide_String(Equiv("XX")), -- Src < Pat
- Equiv("XXX"),
- Wide_Maps.Identity) /= 0 or
- ASW.Count(AtoE_Str, -- Source = Pattern
- Equiv("abcde")) /= 1 or
- ASW.Count(ASW.Null_Unbounded_Wide_String, -- Source = Null
- Equiv(" ")) /= 0
- then
- Report.Failed
- ("Incorrect result from function Count, w,w/o mapping");
- end if;
-
-
-
- -- Function Count using access-to-subprogram mapping.
- -- Evaluate the function Count with an access value specifying the
- -- mapping that is going to occur to Source.
-
- Map_Ptr := AB_to_US_Mapping_Function'Access;
-
- Total_Count :=
- ASW.Count(ASW.To_Unbounded_Wide_String(Equiv("abcbacbadbaAbbB")),
- Pattern => Equiv("__"),
- Mapping => Map_Ptr); -- change 'a' and 'b' to '_'
-
- if Total_Count /= 5 then
- Report.Failed
- ("Incorrect result from function Count, access value map - 1");
- end if;
-
- Map_Ptr := AB_to_Blank_Mapping_Function'Access;
-
- if ASW.Count(ASW.To_Unbounded_Wide_String(Equiv("cccaccBcbcaccacAc")),
- Equiv("c c"),
- Map_Ptr) /= 3 or
- ASW.Count(ASW.To_Unbounded_Wide_String
- (Equiv("aBBAAABaBBBBAaBABBABaBBbBB")),
- Equiv(" BB"),
- Map_Ptr) /= 4 or
- ASW.Count(ASW.To_Unbounded_Wide_String(Equiv("aaaaaaaaaa")),
- Equiv(" "),
- Map_Ptr) /= 3 or
- ASW.Count(ASW.To_Unbounded_Wide_String(Equiv("XX")), -- Src < Pat
- Equiv("XX "),
- Map_Ptr) /= 0 or
- ASW.Count(AtoE_Str, -- Source'Length = Pattern'Length
- Equiv(" cde"),
- Map_Ptr) /= 1
- then
- Report.Failed
- ("Incorrect result from function Count, access value map - 3");
- end if;
-
-
-
- exception
- when others => Report.Failed ("Exception raised in Test_Block");
- end Test_Block;
-
-
- Report.Result;
-
-end CXA4022;
diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxa4023.a b/gcc/testsuite/ada/acats/tests/cxa/cxa4023.a
deleted file mode 100644
index d0325fc88ec..00000000000
--- a/gcc/testsuite/ada/acats/tests/cxa/cxa4023.a
+++ /dev/null
@@ -1,585 +0,0 @@
--- CXA4023.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that the subprograms defined in package
--- Ada.Strings.Wide_Unbounded are available, and that they produce
--- correct results. Specifically, check the subprograms Delete,
--- Find_Token, Translate, Trim, and "*".
---
--- TEST DESCRIPTION:
--- This test demonstrates the uses of many of the subprograms defined
--- in package Ada.Strings.Wide_Unbounded for use with unbounded wide
--- strings. The test simulates how unbounded wide strings
--- will be processed in a user environment, using the subprograms
--- provided in this package.
---
--- This test, when taken in conjunction with tests CXA4021-22, will
--- constitute a test of the functionality contained in package
--- Ada.Strings.Wide_Unbounded. This test uses a variety
--- of the subprograms defined in the unbounded wide string package
--- in ways typical of common usage, with different combinations of
--- available subprograms being used to accomplish similar
--- unbounded wide string processing goals.
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 08 Nov 95 SAIC Corrected accessibility level and type
--- visibility problems for ACVC 2.0.1.
---
---!
-
-with Ada.Characters.Handling;
-with Ada.Strings;
-
-package CXA40230 is
-
- -- The following two functions are used to translate character and string
- -- values to non-character "Wide" values. They will be applied to all the
- -- Wide_Bounded subprogram character and string parameters to simulate the
- -- use of Wide_Characters and Wide_Strings in actual practice.
- -- Note: These functions do not actually return "equivalent" wide
- -- characters to their character inputs, just "non-character"
- -- wide characters.
-
- function Equiv (Ch : Character) return Wide_Character;
-
- function Equiv (Str : String) return Wide_String;
-
- -- Functions and access-to-subprogram object used to supply mapping
- -- capability to the appropriate versions of Translate.
-
- function AB_to_US_Mapping_Function (From : Wide_Character)
- return Wide_Character;
-
- function AB_to_Blank_Mapping_Function (From : Wide_Character)
- return Wide_Character;
-
-end CXA40230;
-
-
-package body CXA40230 is
-
- function Equiv (Ch : Character) return Wide_Character is
- C : Character := Ch;
- begin
- if Ch = ' ' then
- return Ada.Characters.Handling.To_Wide_Character(C);
- else
- return Wide_Character'Val(Character'Pos(Ch) +
- Character'Pos(Character'Last) + 1);
- end if;
- end Equiv;
-
-
- function Equiv (Str : String) return Wide_String is
- WS : Wide_String(Str'First..Str'Last);
- begin
- for i in Str'First..Str'Last loop
- WS(i) := Equiv(Str(i));
- end loop;
- return WS;
- end Equiv;
-
-
- function AB_to_US_Mapping_Function (From : Wide_Character)
- return Wide_Character is
- UnderScore : constant Wide_Character := Equiv('_');
- begin
- if From = Equiv('a') or From = Equiv('b') then
- return UnderScore;
- else
- return From;
- end if;
- end AB_to_US_Mapping_Function;
-
-
- function AB_to_Blank_Mapping_Function (From : Wide_Character)
- return Wide_Character is
- begin
- if From = Equiv('a') or From = Equiv('b') then
- return Ada.Strings.Wide_Space;
- else
- return From;
- end if;
- end AB_to_Blank_Mapping_Function;
-
-end CXA40230;
-
-
-with CXA40230;
-with Report;
-with Ada.Characters.Handling;
-with Ada.Strings.Wide_Maps;
-with Ada.Strings.Wide_Unbounded;
-
-procedure CXA4023 is
-begin
-
- Report.Test ("CXA4023", "Check that the subprograms defined in " &
- "package Ada.Strings.Wide_Unbounded are " &
- "available, and that they produce correct " &
- "results");
-
- Test_Block:
- declare
-
- use CXA40230;
-
- package ASW renames Ada.Strings.Wide_Unbounded;
- use Ada.Strings;
- use type Wide_Maps.Wide_Character_Set;
- use type ASW.Unbounded_Wide_String;
-
- Test_String : ASW.Unbounded_Wide_String;
- AtoE_Str : ASW.Unbounded_Wide_String :=
- ASW.To_Unbounded_Wide_String(Equiv("abcde"));
-
- Cad_String : ASW.Unbounded_Wide_String :=
- ASW.To_Unbounded_Wide_String(Equiv("cad"));
-
- Magic_String : ASW.Unbounded_Wide_String :=
- ASW.To_Unbounded_Wide_String(Equiv("abracadabra"));
-
- Incantation : ASW.Unbounded_Wide_String := Magic_String;
-
-
- A_Small_G : Wide_Character := Equiv('g');
-
- ABCD_Set : Wide_Maps.Wide_Character_Set :=
- Wide_Maps.To_Set(Equiv("abcd"));
- B_Set : Wide_Maps.Wide_Character_Set :=
- Wide_Maps.To_Set(Equiv('b'));
- AB_Set : Wide_Maps.Wide_Character_Set :=
- Wide_Maps."OR"(Wide_Maps.To_Set(Equiv('a')), B_Set);
-
-
- AB_to_YZ_Map : Wide_Maps.Wide_Character_Mapping :=
- Wide_Maps.To_Mapping(From => Equiv("ab"),
- To => Equiv("yz"));
- Code_Map : Wide_Maps.Wide_Character_Mapping :=
- Wide_Maps.To_Mapping(Equiv("abcd"), Equiv("wxyz"));
- Reverse_Code_Map : Wide_Maps.Wide_Character_Mapping :=
- Wide_Maps.To_Mapping(Equiv("wxyz"), Equiv("abcd"));
- Non_Existent_Map : Wide_Maps.Wide_Character_Mapping :=
- Wide_Maps.To_Mapping(Equiv("jkl"), Equiv("mno"));
-
-
- Token_Start : Positive;
- Token_End : Natural := 0;
-
- Map_Ptr : Wide_Maps.Wide_Character_Mapping_Function :=
- AB_to_US_Mapping_Function'Access;
-
-
- begin
-
- -- Find_Token
-
- ASW.Find_Token(Magic_String, -- Find location of first "ab" equiv.
- AB_Set, -- Should be (1..2).
- Ada.Strings.Inside,
- Token_Start,
- Token_End);
-
- if Natural(Token_Start) /= ASW.To_Wide_String(Magic_String)'First or
- Token_End /= ASW.Index(Magic_String, B_Set) or
- Token_End /= 2
- then
- Report.Failed("Incorrect result from Procedure Find_Token - 1");
- end if;
-
-
- ASW.Find_Token(Source => Magic_String, -- Find location of char 'r'equiv
- Set => ABCD_Set, -- in wide str, should be (3..3)
- Test => Ada.Strings.Outside,
- First => Token_Start,
- Last => Token_End);
-
- if Natural(Token_Start) /= 3 or Token_End /= 3 then
- Report.Failed("Incorrect result from Procedure Find_Token - 2");
- end if;
-
-
- ASW.Find_Token(Magic_String, -- No 'g' "equivalent in
- Wide_Maps.To_Set(A_Small_G), -- the wide str, so the
- Ada.Strings.Inside, -- result params should be
- First => Token_Start, -- First = Source'First and
- Last => Token_End); -- Last = 0.
-
-
- if Token_Start /= ASW.To_Wide_String(Magic_String)'First or
- Token_End /= 0
- then
- Report.Failed("Incorrect result from Procedure Find_Token - 3");
- end if;
-
-
- ASW.Find_Token(ASW.To_Unbounded_Wide_String(Equiv("abpqpqrttrcpqr")),
- Wide_Maps.To_Set(Equiv("trpq")),
- Ada.Strings.Inside,
- Token_Start,
- Token_End);
-
- if Token_Start /= 3 or
- Token_End /= 10
- then
- Report.Failed("Incorrect result from Procedure Find_Token - 4");
- end if;
-
- ASW.Find_Token(ASW.To_Unbounded_Wide_String(Equiv("abpqpqrttrcpqr")),
- Wide_Maps.To_Set(Equiv("abpq")),
- Ada.Strings.Outside,
- Token_Start,
- Token_End);
-
- if Token_Start /= 7 or
- Token_End /= 11
- then
- Report.Failed("Incorrect result from Procedure Find_Token - 5");
- end if;
-
-
-
- -- Translate
-
- -- Use a mapping ("abcd" -> "wxyz") to transform the contents of
- -- the unbounded wide string.
- -- Magic_String = "abracadabra"
-
- Incantation := ASW.Translate(Magic_String, Code_Map);
-
- if Incantation /=
- ASW.To_Unbounded_Wide_String(Equiv("wxrwywzwxrw"))
- then
- Report.Failed("Incorrect result from Function Translate - 1");
- end if;
-
- -- (Note: See below for additional testing of Function Translate)
-
- -- Use the inverse mapping of the one above to return the "translated"
- -- unbounded wide string to its original form.
-
- ASW.Translate(Incantation, Reverse_Code_Map);
-
- -- The map contained in the following call to Translate contains three
- -- elements, and these elements are not found in the unbounded wide
- -- string, so this call to Translate should have no effect on it.
-
- if Incantation /= ASW.Translate(Magic_String, Non_Existent_Map) then
- Report.Failed("Incorrect result from Procedure Translate - 1");
- end if;
-
- -- Partial mapping of source.
-
- Test_String := ASW.To_Unbounded_Wide_String(Equiv("abcdeabcab"));
-
- ASW.Translate(Source => Test_String, Mapping => AB_to_YZ_Map);
-
- if Test_String /= ASW.To_Unbounded_Wide_String(Equiv("yzcdeyzcyz")) then
- Report.Failed("Incorrect result from Procedure Translate - 2");
- end if;
-
- -- Total mapping of source.
-
- Test_String := ASW.To_Unbounded_Wide_String(Equiv("abbaaababb"));
-
- ASW.Translate(Source => Test_String, Mapping => AB_to_YZ_Map);
-
- if Test_String /= ASW.To_Unbounded_Wide_String(Equiv("yzzyyyzyzz")) then
- Report.Failed("Incorrect result from Procedure Translate - 3");
- end if;
-
- -- No mapping of source.
-
- Test_String := ASW.To_Unbounded_Wide_String(Equiv("xyzsypcc"));
-
- ASW.Translate(Source => Test_String, Mapping => AB_to_YZ_Map);
-
- if Test_String /= ASW.To_Unbounded_Wide_String(Equiv("xyzsypcc")) then
- Report.Failed("Incorrect result from Procedure Translate - 4");
- end if;
-
- -- Map > 2 characters, partial mapping.
-
- Test_String := ASW.To_Unbounded_Wide_String(Equiv("opabcdelmn"));
-
- ASW.Translate(Test_String,
- Wide_Maps.To_Mapping(Equiv("abcde"), Equiv("lmnop")));
-
- if Test_String /= ASW.To_Unbounded_Wide_String(Equiv("oplmnoplmn")) then
- Report.Failed("Incorrect result from Procedure Translate - 5");
- end if;
-
-
-
- -- Various degrees of mapping of source (full, partial, none) used
- -- with Function Translate.
-
- if ASW.Translate(
- ASW.To_Unbounded_Wide_String(Equiv("abcdeabcabbbaaacaa")),
- AB_to_YZ_Map) /=
- ASW.To_Unbounded_Wide_String(Equiv("yzcdeyzcyzzzyyycyy")) or
-
- ASW.Translate(
- ASW.To_Unbounded_Wide_String(Equiv("abbaaababbaaaaba")),
- AB_to_YZ_Map) /=
- ASW.To_Unbounded_Wide_String(Equiv("yzzyyyzyzzyyyyzy")) or
-
- ASW.Translate(ASW.To_Unbounded_Wide_String(Equiv("cABcABBAc")),
- Mapping => AB_to_YZ_Map) /=
- ASW.To_Unbounded_Wide_String(Equiv("cABcABBAc")) or
-
- ASW.Translate(ASW.To_Unbounded_Wide_String("opabcdelmnddeaccabec"),
- Wide_Maps.To_Mapping("abcde", "lmnop")) /=
- ASW.To_Unbounded_Wide_String("oplmnoplmnooplnnlmpn")
- then
- Report.Failed("Incorrect result from Function Translate - 2");
- end if;
-
-
-
- -- Procedure Translate using access-to-subprogram mapping.
- -- Partial mapping of source.
-
- Map_Ptr := AB_to_Blank_Mapping_Function'Access;
-
- Test_String := ASW.To_Unbounded_Wide_String(Equiv("abABaABbaBAbba"));
-
- ASW.Translate(Source => Test_String, -- change equivalent of 'a' and
- Mapping => Map_Ptr); -- 'b' to ' '
-
- if Test_String /=
- ASW.To_Unbounded_Wide_String(Equiv(" AB AB BA "))
- then
- Report.Failed
- ("Incorrect result from Proc Translate, w/ access value map - 1");
- end if;
-
- -- Total mapping of source to blanks.
-
- Test_String := ASW.To_Unbounded_Wide_String(Equiv("abbbab"));
-
- ASW.Translate(Source => Test_String,
- Mapping => Map_Ptr);
-
- if Test_String /=
- ASW.To_Unbounded_Wide_String(Equiv(" "))
- then
- Report.Failed
- ("Incorrect result from Proc Translate, w/ access value map - 2");
- end if;
-
- -- No mapping of source.
-
- Map_Ptr := AB_to_US_Mapping_Function'Access;
-
- Test_String := ASW.To_Unbounded_Wide_String(Equiv("xyzsypcc"));
-
- ASW.Translate(Source => Test_String,
- Mapping => Map_Ptr);
-
- if Test_String /=
- ASW.To_Unbounded_Wide_String(Equiv("xyzsypcc")) -- no change
- then
- Report.Failed
- ("Incorrect result from Proc Translate, w/ access value map - 3");
- end if;
-
-
- -- Function Translate using access-to-subprogram mapping value.
-
- Map_Ptr := AB_to_Blank_Mapping_Function'Access;
-
- Test_String := ASW.To_Unbounded_Wide_String(Equiv("abAbBBAabbacD"));
-
- if ASW.Translate(ASW.Translate(Test_String, Map_Ptr), Map_Ptr) /=
- ASW.To_Unbounded_Wide_String(Equiv(" A BBA cD"))
- then
- Report.Failed
- ("Incorrect result from Function Translate, access value map - 1");
- end if;
-
- if ASW.Translate(Source => ASW.To_Unbounded_Wide_String(Equiv("a")),
- Mapping => Map_Ptr) /=
- ASW.To_Unbounded_Wide_String(Equiv(" ")) or
- ASW.Translate(ASW.To_Unbounded_Wide_String
- (Equiv(" aa Aa A AAaaa a aA")),
- Map_Ptr) /=
- ASW.To_Unbounded_Wide_String(Equiv(" A A AA A")) or
- ASW.Translate(Source => ASW.To_Unbounded_Wide_String(Equiv("a ")),
- Mapping => Map_Ptr) /=
- ASW.To_Unbounded_Wide_String(Equiv(" ")) or
- ASW.Translate(Source => ASW.To_Unbounded_Wide_String(Equiv("xyz")),
- Mapping => Map_Ptr) /=
- ASW.To_Unbounded_Wide_String(Equiv("xyz"))
- then
- Report.Failed
- ("Incorrect result from Function Translate, access value map - 2");
- end if;
-
-
-
- -- Trim
-
- Trim_Block:
- declare
-
- XYZ_Set : Wide_Maps.Wide_Character_Set :=
- Wide_Maps.To_Set(Equiv("xyz"));
- PQR_Set : Wide_Maps.Wide_Character_Set :=
- Wide_Maps.To_Set(Equiv("pqr"));
-
- Pad : constant ASW.Unbounded_Wide_String :=
- ASW.To_Unbounded_Wide_String(Equiv("Pad"));
-
- The_New_Ada : constant ASW.Unbounded_Wide_String :=
- ASW.To_Unbounded_Wide_String(Equiv("Ada9X"));
-
- Space_Array : array (1..4) of ASW.Unbounded_Wide_String :=
- (ASW.To_Unbounded_Wide_String(Equiv(" Pad ")),
- ASW.To_Unbounded_Wide_String(Equiv("Pad ")),
- ASW.To_Unbounded_Wide_String(Equiv(" Pad")),
- Pad);
-
- String_Array : array (1..5) of ASW.Unbounded_Wide_String :=
- (ASW.To_Unbounded_Wide_String(Equiv("xyzxAda9Xpqr")),
- ASW.To_Unbounded_Wide_String(Equiv("Ada9Xqqrp")),
- ASW.To_Unbounded_Wide_String(Equiv("zxyxAda9Xqpqr")),
- ASW.To_Unbounded_Wide_String(Equiv("xxxyAda9X")),
- The_New_Ada);
-
- begin
-
- -- Examine the version of Trim that removes blanks from
- -- the left and/or right of a wide string.
-
- for i in 1..4 loop
- if ASW.Trim(Space_Array(i), Ada.Strings.Both) /= Pad then
- Report.Failed("Incorrect result from Trim for spaces - " &
- Integer'Image(i));
- end if;
- end loop;
-
- -- Examine the version of Trim that removes set characters from
- -- the left and right of a wide string.
-
- for i in 1..5 loop
- if ASW.Trim(String_Array(i),
- Left => XYZ_Set,
- Right => PQR_Set) /= The_New_Ada then
- Report.Failed
- ("Incorrect result from Trim for set characters - " &
- Integer'Image(i));
- end if;
- end loop;
-
- -- No trimming.
-
- if ASW.Trim(
- ASW.To_Unbounded_Wide_String(Equiv("prqqprAda9Xyzzxyzzyz")),
- XYZ_Set,
- PQR_Set) /=
- ASW.To_Unbounded_Wide_String(Equiv("prqqprAda9Xyzzxyzzyz"))
- then
- Report.Failed
- ("Incorrect result from Trim for set, no trimming");
- end if;
-
- end Trim_Block;
-
-
-
- -- Delete
-
- -- Use the Delete function to remove the first four and last four
- -- characters from the wide string.
-
- if ASW.Delete(Source => ASW.Delete(Magic_String,
- 8,
- ASW.Length(Magic_String)),
- From => ASW.To_Wide_String(Magic_String)'First,
- Through => 4) /=
- Cad_String
- then
- Report.Failed("Incorrect results from Function Delete");
- end if;
-
-
-
- -- Constructors ("*")
-
- Constructor_Block:
- declare
-
- SOS : ASW.Unbounded_Wide_String;
-
- Dot : constant ASW.Unbounded_Wide_String :=
- ASW.To_Unbounded_Wide_String(Equiv("Dot_"));
- Dash : constant Wide_String := Equiv("Dash_");
-
- Distress : ASW.Unbounded_Wide_String :=
- ASW."&"(ASW.To_Unbounded_Wide_String
- (Equiv("Dot_Dot_Dot_")),
- ASW."&"(ASW.To_Unbounded_Wide_String
- (Equiv("Dash_Dash_Dash_")),
- ASW.To_Unbounded_Wide_String
- (Equiv("Dot_Dot_Dot"))));
-
- Repeat : constant Natural := 3;
- Separator : constant Wide_Character := Equiv('_');
-
- Separator_Set : Wide_Maps.Wide_Character_Set :=
- Wide_Maps.To_Set(Separator);
-
- begin
-
- -- Use the following constructor forms to construct the wide string
- -- "Dot_Dot_Dot_Dash_Dash_Dash_Dot_Dot_Dot". Note that the
- -- trailing underscore in the wide string is removed in the call to
- -- Trim in the If statement condition.
-
- SOS := ASW."*"(Repeat, Dot); -- "*"(#, W Unb Str)
-
- SOS := ASW."&"(SOS,
- ASW."&"(ASW."*"(Repeat, Dash), -- "*"(#, W Str)
- ASW."*"(Repeat, Dot))); -- "*"(#, W Unb Str)
-
- if ASW.Trim(SOS, Wide_Maps.Null_Set, Separator_Set) /= Distress then
- Report.Failed("Incorrect results from Function ""*""");
- end if;
-
- end Constructor_Block;
-
-
- exception
- when others => Report.Failed ("Exception raised in Test_Block");
- end Test_Block;
-
-
- Report.Result;
-
-end CXA4023;
diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxa4024.a b/gcc/testsuite/ada/acats/tests/cxa/cxa4024.a
deleted file mode 100644
index 1b0af9ce978..00000000000
--- a/gcc/testsuite/ada/acats/tests/cxa/cxa4024.a
+++ /dev/null
@@ -1,350 +0,0 @@
--- CXA4024.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that the function "-", To_Ranges, To_Domain, and To_Range are
--- available in the package Ada.Strings.Maps, and that they produce
--- correct results based on the Character_Set/Character_Mapping input
--- provided.
---
--- TEST DESCRIPTION:
--- This test examines the operation of four functions from within the
--- Ada.Strings.Maps package. A variety of Character_Sequence,
--- Character_Set, and Character_Mapping objects are created and
--- initialized for use with these functions. In each subtest of
--- function operation, specific inputs are provided to the functions as
--- input parameters, and the results are evaluated against expected
--- values. Wherever appropriate, additional characteristics of the
--- function results are verified against the prescribed result
--- characteristics.
---
---
--- CHANGE HISTORY:
--- 03 Feb 95 SAIC Initial prerelease version
--- 10 Mar 95 SAIC Incorporated reviewer comments.
--- 15 Apr 96 SAIC Incorporated reviewer comments for ACVC 2.1.
--- 05 Oct 96 SAIC Incorporated reviewer comments for ACVC 2.1.
---
---!
-
-with Ada.Strings.Maps;
-with Ada.Strings.Maps.Constants;
-with Ada.Characters.Latin_1;
-with Report;
-
-procedure CXA4024 is
-
-begin
-
- Report.Test ("CXA4024", "Check that the function ""-"", To_Ranges, " &
- "To_Domain, and To_Range are available in " &
- "the package Ada.Strings.Maps, and that " &
- "they produce correct results");
-
- Test_Block:
- declare
-
- use Ada.Strings, Ada.Strings.Maps;
- use type Maps.Character_Set; -- To allow logical set operator
- -- infix notation.
- package ACL1 renames Ada.Characters.Latin_1;
-
- MidPoint_Letter : constant := 13;
- Last_Letter : constant := 26;
-
- Vowels : constant Maps.Character_Sequence := "aeiou";
- Quasi_Vowel : constant Character := 'y';
-
- Alphabet : Maps.Character_Sequence (1..Last_Letter);
- Half_Alphabet : Maps.Character_Sequence (1..MidPoint_Letter);
-
- Alphabet_Set,
- Consonant_Set,
- Vowel_Set,
- First_Half_Set,
- Second_Half_Set : Maps.Character_Set;
-
-
- begin
-
- -- Load the alphabet strings for use in creating sets.
- for i in 0..12 loop
- Half_Alphabet(i+1) := Character'Val(Character'Pos('a') + i);
- end loop;
-
- for i in 0..25 loop
- Alphabet(i+1) := Character'Val(Character'Pos('a') + i);
- end loop;
-
- -- Initialize a series of Character_Set objects.
-
- Alphabet_Set := Maps.To_Set(Alphabet);
- Vowel_Set := Maps.To_Set(Vowels);
- Consonant_Set := Vowel_Set XOR Alphabet_Set;
- First_Half_Set := Maps.To_Set(Half_Alphabet);
- Second_Half_Set := Alphabet_Set XOR First_Half_Set;
-
-
-
- -- Evaluation of Set operator "-".
-
- if Consonant_Set /= "-"(Alphabet_Set, Vowel_Set) or
- Vowel_Set /= (Alphabet_Set - Consonant_Set) or
- Alphabet_Set /= Alphabet_Set - Maps.Null_Set or
- First_Half_Set /= "-"(Alphabet_Set, Second_Half_Set) or
- (Alphabet_Set - Vowel_Set) /= "AND"(Alphabet_Set, "NOT"(Vowel_Set))
- then
- Report.Failed("Incorrect result from ""-"" operator for sets");
- end if;
-
-
-
- -- Evaluation of Function "To_Ranges".
-
- declare
-
- use type Maps.Character_Range;
- use type Maps.Character_Ranges;
-
- Set_A_to_C : Maps.Character_Set := Maps.To_Set("ABC");
- Set_J : Maps.Character_Set := Maps.To_Set("J");
- Set_M_to_P : Maps.Character_Set := Maps.To_Set("MNOP");
- Set_X_to_Z : Maps.Character_Set := Maps.To_Set("XYZ");
- Set_Of_Five : Maps.Character_Set := Set_A_to_C OR -- Union of the
- Set_M_to_P OR -- five sets.
- Set_X_to_Z OR
- Set_J OR
- Maps.Null_Set;
-
- TC_Range_A_to_C : Maps.Character_Range := (Low => 'A', High => 'C');
- TC_Range_J : Maps.Character_Range := ('J', 'J');
- TC_Range_M_to_P : Maps.Character_Range := ('M', 'P');
- TC_Range_X_to_Z : Maps.Character_Range := (Low => 'X', High => 'Z');
-
- TC_Ranges : Maps.Character_Ranges (1..4) :=
- (1 => TC_Range_A_to_C,
- 2 => TC_Range_J,
- 3 => TC_Range_M_to_P,
- 4 => TC_Range_X_to_Z);
-
- begin
-
- -- Based on input of a set containing four separate "spans" of
- -- character sequences, Function To_Ranges is required to produce
- -- the shortest array of contiguous ranges of Character values in
- -- the input set, in increasing order of Low.
-
- declare
-
- -- This Character_Ranges constant should consist of array
- -- components, each component being a Character_Range from Low
- -- to High containing the appropriate characters.
-
- Ranges_Result : constant Maps.Character_Ranges :=
- Maps.To_Ranges(Set => Set_Of_Five);
- begin
-
- -- Check the structure and components of the Character_Ranges
- -- constant.
-
- if Ranges_Result(1) /= TC_Range_A_to_C or
- Ranges_Result(1).Low /= TC_Ranges(1).Low or
- Ranges_Result(2) /= TC_Range_J or
- Ranges_Result(2).High /= TC_Ranges(2).High or
- Ranges_Result(3) /= TC_Range_M_to_P or
- Ranges_Result(3).Low /= TC_Ranges(3).Low or
- Ranges_Result(3).High /= TC_Ranges(3).High or
- Ranges_Result(4) /= TC_Range_X_To_Z or
- Ranges_Result(4).Low /= TC_Ranges(4).Low or
- Ranges_Result(4).High /= TC_Ranges(4).High
- then
- Report.Failed ("Incorrect structure or components in " &
- "Character_Ranges constant");
- end if;
-
- exception
- when others =>
- Report.Failed("Exception raised using the Function To_Ranges " &
- "to initialize a Character_Ranges constant");
- end;
- end;
-
-
-
- -- Evaluation of Functions To_Domain and To_Range.
-
- declare
-
- Null_Sequence : constant Maps.Character_Sequence := "";
-
- TC_Upper_Case_Sequence : constant Maps.Character_Sequence :=
- "ZYXWVUTSRQPONMABCDEFGHIJKL";
- TC_Lower_Case_Sequence : constant Maps.Character_Sequence :=
- "zyxwvutsrqponmabcdefghijkl";
- TC_Unordered_Sequence : Maps.Character_Sequence(1..6) :=
- "BxACzy";
-
- TC_Upper_to_Lower_Map : Maps.Character_Mapping :=
- Maps.To_Mapping(TC_Upper_Case_Sequence,
- TC_Lower_Case_Sequence);
-
- TC_Lower_to_Upper_Map : Maps.Character_Mapping :=
- Maps.To_Mapping(TC_Lower_Case_Sequence,
- TC_Upper_Case_Sequence);
-
- TC_Unordered_Map : Maps.Character_Mapping :=
- Maps.To_Mapping(TC_Unordered_Sequence,
- "ikglja");
- begin
-
- declare
-
- TC_Domain_1 : constant Maps.Character_Sequence :=
- Maps.To_Domain(TC_Upper_to_Lower_Map);
-
- TC_Domain_2 : constant Maps.Character_Sequence :=
- Maps.To_Domain(TC_Lower_to_Upper_Map);
-
- TC_Domain_3 : Maps.Character_Sequence(1..6);
-
- TC_Range_1 : constant Maps.Character_Sequence :=
- Maps.To_Range(TC_Upper_to_Lower_Map);
-
- TC_Range_2 : constant Maps.Character_Sequence :=
- Maps.To_Range(TC_Lower_to_Upper_Map);
-
- TC_Range_3 : Maps.Character_Sequence(1..6);
-
- begin
-
- -- Function To_Domain returns the shortest Character_Sequence
- -- value such that each character not in the result maps to
- -- itself, and all characters in the result are in ascending
- -- order.
-
- TC_Domain_3 := Maps.To_Domain(TC_Unordered_Map);
-
- -- Check contents of result of To_Domain, must be in ascending
- -- order.
-
- if TC_Domain_1 /= "ABCDEFGHIJKLMNOPQRSTUVWXYZ" then
- Report.Failed("Incorrect result from To_Domain with " &
- "TC_Upper_to_Lower_Map as input");
- end if;
-
- if TC_Domain_2 /= "abcdefghijklmnopqrstuvwxyz" then
- Report.Failed("Incorrect result from To_Domain with " &
- "TC_Lower_to_Upper_Map as input");
- end if;
-
- if TC_Domain_3 /= "ABCxyz" then
- Report.Failed("Incorrect result from To_Domain with " &
- "an unordered mapping as input");
- end if;
-
-
- -- The lower bound on the returned Character_Sequence value
- -- from To_Domain must be 1.
-
- if TC_Domain_1'First /= 1 or
- TC_Domain_2'First /= 1 or
- TC_Domain_3'First /= 1
- then
- Report.Failed("Incorrect lower bound returned from To_Domain");
- end if;
-
-
- -- Check contents of result of To_Range.
-
- TC_Range_3 := Maps.To_Range(TC_Unordered_Map);
-
- if TC_Range_1 /= "abcdefghijklmnopqrstuvwxyz" then
- Report.Failed("Incorrect result from To_Range with " &
- "TC_Upper_to_Lower_Map as input");
- end if;
-
- if TC_Range_2 /= "ABCDEFGHIJKLMNOPQRSTUVWXYZ" then
- Report.Failed("Incorrect result from To_Range with " &
- "TC_Lower_to_Upper_Map as input");
- end if;
-
- if TC_Range_3 /= "gilkaj" then
- Report.Failed("Incorrect result from To_Range with " &
- "an unordered mapping as input");
- end if;
-
-
- -- The lower bound on the returned Character_Sequence value
- -- must be 1.
-
- if TC_Range_1'First /= 1 or
- TC_Range_2'First /= 1 or
- TC_Range_3'First /= 1
- then
- Report.Failed("Incorrect lower bound returned from To_Range");
- end if;
-
-
- -- The upper bound on the returned Character_Sequence value
- -- must be Map'Length.
-
- if TC_Range_1'Last /= TC_Lower_Case_Sequence'Length or
- TC_Range_2'Last /= TC_Upper_Case_Sequence'Length or
- TC_Range_3'Last /= TC_Unordered_Sequence'Length
- then
- Report.Failed("Incorrect upper bound returned from To_Range");
- end if;
-
- end;
-
- -- Both function To_Domain and To_Range return the null string
- -- when provided the Identity character map as an input parameter.
-
- if Maps.To_Domain(Maps.Identity) /= Null_Sequence then
- Report.Failed("Function To_Domain did not return the null " &
- "string when provided the Identity map as " &
- "input");
- end if;
-
- if Maps.To_Range(Maps.Identity) /= Null_Sequence then
- Report.Failed("Function To_Range did not return the null " &
- "string when provided the Identity map as " &
- "input");
- end if;
-
- exception
- when others =>
- Report.Failed("Exception raised during the evaluation of " &
- "Function To_Domain and To_Range");
- end;
-
- exception
- when others => Report.Failed ("Exception raised in Test_Block");
- end Test_Block;
-
-
- Report.Result;
-
-end CXA4024;
diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxa4025.a b/gcc/testsuite/ada/acats/tests/cxa/cxa4025.a
deleted file mode 100644
index 1665f7a46e8..00000000000
--- a/gcc/testsuite/ada/acats/tests/cxa/cxa4025.a
+++ /dev/null
@@ -1,376 +0,0 @@
--- CXA4025.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that the functionality found in packages Ada.Strings.Wide_Maps,
--- Ada.Strings.Wide_Fixed, and Ada.Strings.Wide_Maps.Wide_Constants
--- is available and produces correct results.
---
--- TEST DESCRIPTION:
--- This test validates the subprograms found in the various Wide_Map
--- and Wide_String packages. It is based on the tests CXA4024 and
--- CXA4026, which are tests for the complementary "non-wide" packages.
---
--- The functions found in CXA4025_0 provide mapping capability, when
--- used in conjunction with Wide_Character_Mapping_Function objects.
---
---
--- CHANGE HISTORY:
--- 23 Jun 95 SAIC Initial prerelease version.
--- 15 Apr 96 SAIC Incorporated reviewer comments for ACVC 2.1.
---
---!
-
-package CXA4025_0 is
- -- Functions used to supply mapping capability.
- function Map_To_Lower_Case (From : Wide_Character) return Wide_Character;
- function Map_To_Upper_Case (From : Wide_Character) return Wide_Character;
-end CXA4025_0;
-
-with Ada.Characters.Handling;
-package body CXA4025_0 is
- -- Function Map_To_Lower_Case will return the lower case form of
- -- Wide_Characters in the range 'A'..'Z' only, and return the input
- -- wide_character otherwise.
-
- function Map_To_Lower_Case (From : Wide_Character)
- return Wide_Character is
- begin
- return Ada.Characters.Handling.To_Wide_Character(
- Ada.Characters.Handling.To_Lower(
- Ada.Characters.Handling.To_Character(From)));
- end Map_To_Lower_Case;
-
- -- Function Map_To_Upper_Case will return the upper case form of
- -- Wide_Characters in the range 'a'..'z', or whose position is in one
- -- of the ranges 223..246 or 248..255, provided the wide_character has
- -- an upper case form.
-
- function Map_To_Upper_Case (From : Wide_Character)
- return Wide_Character is
- begin
- return Ada.Characters.Handling.To_Wide_Character(
- Ada.Characters.Handling.To_Upper(
- Ada.Characters.Handling.To_Character(From)));
- end Map_To_Upper_Case;
-
-end CXA4025_0;
-
-
-with CXA4025_0;
-with Report;
-with Ada.Characters.Handling;
-with Ada.Characters.Latin_1;
-with Ada.Exceptions;
-with Ada.Strings;
-with Ada.Strings.Wide_Maps;
-with Ada.Strings.Wide_Maps.Wide_Constants;
-with Ada.Strings.Wide_Fixed;
-
-procedure CXA4025 is
-begin
- Report.Test ("CXA4025",
- "Check that subprograms defined in packages " &
- "Ada.Strings.Wide_Maps and Ada.Strings.Wide_Fixed " &
- "produce correct results");
-
- Test_Block:
- declare
-
- package ACL1 renames Ada.Characters.Latin_1;
-
- use Ada.Characters, Ada.Strings;
- use Ada.Exceptions;
- use type Wide_Maps.Wide_Character_Set;
-
- subtype LC_Characters is Wide_Character range 'a'..'z';
-
- Last_Letter : constant := 26;
- Vowels : constant Wide_Maps.Wide_Character_Sequence := "aeiou";
- TC_String : constant Wide_String := "A Standard String";
-
- Alphabet : Wide_Maps.Wide_Character_Sequence (1..Last_Letter);
- Alphabet_Set,
- Consonant_Set,
- Vowel_Set : Wide_Maps.Wide_Character_Set;
-
- String_20 : Wide_String(1..20) := "ABCDEFGHIJKLMNOPQRST";
- String_40 : Wide_String(1..40) := "abcdefghijklmnopqrst" &
- String_20;
- String_80 : Wide_String(1..80) := String_40 & String_40;
- TC_String_5 : Wide_String(1..5) := "ABCDE";
-
- -- The following strings are used in examination of the Translation
- -- subprograms.
- New_Character_String : Wide_String(1..12) :=
- Handling.To_Wide_String(
- ACL1.LC_A_Grave & ACL1.LC_A_Ring & ACL1.LC_AE_Diphthong &
- ACL1.LC_C_Cedilla & ACL1.LC_E_Acute & ACL1.LC_I_Circumflex &
- ACL1.LC_Icelandic_Eth & ACL1.LC_N_Tilde &
- ACL1.LC_O_Oblique_Stroke & ACL1.LC_Icelandic_Thorn &
- ACL1.LC_German_Sharp_S & ACL1.LC_Y_Diaeresis);
-
- -- Note that there is no upper case version of the last two
- -- characters from above.
-
- TC_New_Character_String : Wide_String(1..12) :=
- Handling.To_Wide_String(
- ACL1.UC_A_Grave & ACL1.UC_A_Ring & ACL1.UC_AE_Diphthong &
- ACL1.UC_C_Cedilla & ACL1.UC_E_Acute & ACL1.UC_I_Circumflex &
- ACL1.UC_Icelandic_Eth & ACL1.UC_N_Tilde &
- ACL1.UC_O_Oblique_Stroke & ACL1.UC_Icelandic_Thorn &
- ACL1.LC_German_Sharp_S & ACL1.LC_Y_Diaeresis);
-
- -- Access objects that will be provided as parameters to the
- -- subprograms.
- Map_To_Lower_Case_Ptr : Wide_Maps.Wide_Character_Mapping_Function :=
- CXA4025_0.Map_To_Lower_Case'Access;
- Map_To_Upper_Case_Ptr : Wide_Maps.Wide_Character_Mapping_Function :=
- CXA4025_0.Map_To_Upper_Case'Access;
-
- begin
-
- --
- -- Testing of functionality found in Package Ada.Strings.Wide_Maps.
- --
-
- -- Load the alphabet strings for use in creating sets.
- for i in 0..25 loop
- Alphabet(i+1) := Wide_Character'Val(Wide_Character'Pos('a')+i);
- end loop;
-
- -- Initialize a series of Character_Set objects.
- Alphabet_Set := Wide_Maps.To_Set(Alphabet);
- Vowel_Set := Wide_Maps.To_Set(Vowels);
- Consonant_Set := Vowel_Set XOR Alphabet_Set;
-
- -- Evaluation of Set operator "-".
- if
- (Alphabet_Set - Consonant_Set) /=
- "AND"(Alphabet_Set, "NOT"(Consonant_Set)) or
- (Alphabet_Set - Vowel_Set) /= "AND"(Alphabet_Set, "NOT"(Vowel_Set))
- then
- Report.Failed("Incorrect result from ""-"" operator for sets");
- end if;
-
- -- Evaluation of Functions To_Domain and To_Range.
- declare
- Null_Sequence : constant Wide_Maps.Wide_Character_Sequence := "";
- TC_UC_Sequence : constant Wide_Maps.Wide_Character_Sequence :=
- "ZYXWVUTSRQPONMABCDEFGHIJKL";
- TC_LC_Sequence : constant Wide_Maps.Wide_Character_Sequence :=
- "zyxwvutsrqponmabcdefghijkl";
- TC_Upper_to_Lower_Map : Wide_Maps.Wide_Character_Mapping :=
- Wide_Maps.To_Mapping(TC_UC_Sequence,
- TC_LC_Sequence);
- TC_Lower_to_Upper_Map : Wide_Maps.Wide_Character_Mapping :=
- Wide_Maps.To_Mapping(TC_LC_Sequence,
- TC_UC_Sequence);
- begin
- declare
- TC_Domain : constant Wide_Maps.Wide_Character_Sequence :=
- Wide_Maps.To_Domain(TC_Upper_to_Lower_Map);
- TC_Range : constant Wide_Maps.Wide_Character_Sequence :=
- Wide_Maps.To_Range(TC_Lower_to_Upper_Map);
- begin
- -- Function To_Domain returns the shortest Wide_Character_Sequence
- -- value such that each wide character not in the result maps to
- -- itself, and all wide characters in the result are in ascending
- -- order.
- if TC_Domain /= "ABCDEFGHIJKLMNOPQRSTUVWXYZ" then
- Report.Failed("Incorrect result from To_Domain with " &
- "TC_Upper_to_Lower_Map as input");
- end if;
-
- -- The lower bound on the returned Wide_Character_Sequence value
- -- from To_Domain must be 1.
- if TC_Domain'First /= 1 then
- Report.Failed("Incorrect lower bound returned from To_Domain");
- end if;
-
- -- Check contents of result of To_Range.
- if TC_Range /= "ABCDEFGHIJKLMNOPQRSTUVWXYZ" then
- Report.Failed("Incorrect result from To_Range with " &
- "TC_Lower_to_Upper_Map as input");
- end if;
-
- -- The lower bound on the returned Character_Sequence value
- -- must be 1.
- if TC_Range'First /= 1 then
- Report.Failed("Incorrect lower bound returned from To_Range");
- end if;
-
- if TC_Range'Last /= TC_LC_Sequence'Length then
- Report.Failed("Incorrect upper bound returned from To_Range");
- end if;
- end;
-
- -- Both function To_Domain and To_Range return the null string
- -- when provided the Identity character map as an input parameter.
- if Wide_Maps.To_Domain(Wide_Maps.Identity) /= Null_Sequence or
- Wide_Maps.To_Range(Wide_Maps.Identity) /= Null_Sequence
- then
- Report.Failed("Null sequence not returned from To_Domain or " &
- "To_Range when provided the Identity map as input");
- end if;
- exception
- when others =>
- Report.Failed("Exception raised during the evaluation of " &
- "Function To_Domain and To_Range");
- end;
-
- -- Testing of functionality found in Package Ada.Strings.Wide_Fixed.
- --
- -- Function Index, Forward direction search.
-
- if Wide_Fixed.Index("CoMpLeTeLy MiXeD CaSe StRiNg",
- "MIXED CASE STRING",
- Ada.Strings.Forward,
- Map_To_Upper_Case_Ptr) /= 12 or
- Wide_Fixed.Index("STRING WITH NO MATCHING PATTERNS",
- "WITH",
- Ada.Strings.Forward,
- Map_To_Lower_Case_Ptr) /= 0
- then
- Report.Failed("Incorrect results from Function Index, going " &
- "in Forward direction, using a Character Mapping " &
- "Function parameter");
- end if;
-
- -- Function Index, Backward direction search.
- if Wide_Fixed.Index("Case of a Mixed Case String",
- "case",
- Ada.Strings.Backward,
- Map_To_Lower_Case_Ptr) /= 17 or
- Wide_Fixed.Index("WOULD MATCH BUT FOR THE CASE",
- "WOULD MATCH BUT FOR THE CASE",
- Ada.Strings.Backward,
- Map_To_Lower_Case_Ptr) /= 0
- then
- Report.Failed("Incorrect results from Function Index, going " &
- "in Backward direction, using a Character Mapping " &
- "Function parameter");
- end if;
-
- -- Function Count.
- if Wide_Fixed.Count("ABABABA", "ABA", Map_To_Upper_Case_Ptr) /= 2 or
- Wide_Fixed.Count("", "match", Map_To_Lower_Case_Ptr) /= 0
- then
- Report.Failed("Incorrect results from Function Count, using " &
- "a Character Mapping Function parameter");
- end if;
-
- -- Function Translate.
- if Wide_Fixed.Translate(Source => "A Sample Mixed Case String",
- Mapping => Map_To_Lower_Case_Ptr) /=
- "a sample mixed case string" or
- Wide_Fixed.Translate(New_Character_String,
- Map_To_Upper_Case_Ptr) /=
- TC_New_Character_String
- then
- Report.Failed("Incorrect results from Function Translate, using " &
- "a Wide_Character Mapping Function parameter");
- end if;
-
- -- Procedure Translate.
- declare
- use Ada.Strings.Wide_Fixed;
- Str : Wide_String(1..19) := "A Mixed Case String";
- begin
- Translate(Source => Str, Mapping => Map_To_Lower_Case_Ptr);
- if Str /= "a mixed case string" then
- Report.Failed("Incorrect result from Procedure Translate - 1");
- end if;
-
- Translate(New_Character_String, Map_To_Upper_Case_Ptr);
- if New_Character_String /= TC_New_Character_String then
- Report.Failed("Incorrect result from Procedure Translate - 2");
- end if;
- end;
-
- -- Procedure Trim.
- declare
- use Ada.Strings.Wide_Fixed;
- Trim_String : Wide_String(1..30) := " A string of characters ";
- begin
- Trim(Trim_String, Ada.Strings.Left, Ada.Strings.Right, 'x');
- if Trim_String /= "xxxxA string of characters " then
- Report.Failed("Incorrect result from Procedure Trim, trim " &
- "side = left, justify = right, pad = x");
- end if;
-
- Trim(Trim_String, Ada.Strings.Right, Ada.Strings.Center);
- if Trim_String /= " xxxxA string of characters " then
- Report.Failed("Incorrect result from Procedure Trim, trim " &
- "side = right, justify = center, default pad");
- end if;
- end;
-
- -- Procedure Head.
- declare
- Fixed_String : Wide_String(1..20) := "A sample test string";
- begin
- Wide_Fixed.Head(Source => Fixed_String, Count => 14,
- Justify => Ada.Strings.Center, Pad => '$');
- if Fixed_String /= "$$$A sample test $$$" then
- Report.Failed("Incorrect result from Procedure Head, " &
- "justify = center, pad = $");
- end if;
-
- Wide_Fixed.Head(Fixed_String, 11, Ada.Strings.Right);
- if Fixed_String /= " $$$A sample" then
- Report.Failed("Incorrect result from Procedure Head, " &
- "justify = right, default pad");
- end if;
- end;
-
- -- Procedure Tail.
- declare
- use Ada.Strings.Wide_Fixed;
- Tail_String : Wide_String(1..20) := "ABCDEFGHIJKLMNOPQRST";
- begin
- -- Default left justify.
- Tail(Source => Tail_String, Count => 10, Pad => '-');
- if Tail_String /= "KLMNOPQRST----------" then
- Report.Failed("Incorrect result from Procedure Tail, " &
- "default justify, pad = -");
- end if;
-
- Tail(Tail_String, 6, Ada.Strings.Center, 'a');
- if Tail_String /= "aaaaaaa------aaaaaaa" then
- Report.Failed("Incorrect result from Procedure Tail, " &
- "justify = center, pad = a");
- end if;
- end;
-
- exception
- when The_Error : others =>
- Report.Failed ("The following exception was raised in the " &
- "Test_Block: " & Exception_Name(The_Error));
- end Test_Block;
-
- Report.Result;
-
-end CXA4025;
diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxa4026.a b/gcc/testsuite/ada/acats/tests/cxa/cxa4026.a
deleted file mode 100644
index 766979ad057..00000000000
--- a/gcc/testsuite/ada/acats/tests/cxa/cxa4026.a
+++ /dev/null
@@ -1,526 +0,0 @@
--- CXA4026.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that Ada.Strings.Fixed procedures Head, Tail, and Trim, as well
--- as the versions of subprograms Translate (procedure and function),
--- Index, and Count, available in the package which use a
--- Maps.Character_Mapping_Function input parameter, produce correct
--- results.
---
--- TEST DESCRIPTION:
--- This test examines the operation of several subprograms contained in
--- the Ada.Strings.Fixed package.
--- This includes procedure versions of Head, Tail, and Trim, as well as
--- four subprograms that use a Character_Mapping_Function as a parameter
--- to provide the mapping capability.
---
--- Two functions are defined to provide the mapping. Access values
--- are defined to refer to these functions. One of the functions will
--- map upper case characters in the range 'A'..'Z' to their lower case
--- counterparts, while the other function will map lower case characters
--- ('a'..'z', or a character whose position is in one of the ranges
--- 223..246 or 248..255, provided the character has an upper case form)
--- to their upper case form.
---
--- Function Index uses the mapping function access value to map the input
--- string prior to searching for the appropriate index value to return.
--- Function Count uses the mapping function access value to map the input
--- string prior to counting the occurrences of the pattern string.
--- Both the Procedure and Function version of Translate use the mapping
--- function access value to perform the translation.
---
--- Results of all subprograms are compared with expected results.
---
---
--- CHANGE HISTORY:
--- 10 Feb 95 SAIC Initial prerelease version
--- 21 Apr 95 SAIC Modified definition of string variable Str_2.
---
---!
-
-
-package CXA4026_0 is
-
- -- Function Map_To_Lower_Case will return the lower case form of
- -- Characters in the range 'A'..'Z' only, and return the input
- -- character otherwise.
-
- function Map_To_Lower_Case (From : Character) return Character;
-
-
- -- Function Map_To_Upper_Case will return the upper case form of
- -- Characters in the range 'a'..'z', or whose position is in one
- -- of the ranges 223..246 or 248..255, provided the character has
- -- an upper case form.
-
- function Map_To_Upper_Case (From : Character) return Character;
-
-end CXA4026_0;
-
-
-with Ada.Characters.Handling;
-package body CXA4026_0 is
-
- function Map_To_Lower_Case (From : Character) return Character is
- begin
- if From in 'A'..'Z' then
- return Character'Val(Character'Pos(From) -
- (Character'Pos('A') - Character'Pos('a')));
- else
- return From;
- end if;
- end Map_To_Lower_Case;
-
- function Map_To_Upper_Case (From : Character) return Character is
- begin
- return Ada.Characters.Handling.To_Upper(From);
- end Map_To_Upper_Case;
-
-end CXA4026_0;
-
-
-with CXA4026_0;
-with Ada.Strings.Fixed;
-with Ada.Strings.Maps;
-with Ada.Characters.Handling;
-with Ada.Characters.Latin_1;
-with Report;
-
-procedure CXA4026 is
-
-begin
-
- Report.Test ("CXA4026", "Check that procedures Trim, Head, and Tail, " &
- "as well as the versions of subprograms " &
- "Translate, Index, and Count, which use the " &
- "Character_Mapping_Function input parameter," &
- "produce correct results");
-
- Test_Block:
- declare
-
- use Ada.Strings, CXA4026_0;
-
- -- The following strings are used in examination of the Translation
- -- subprograms.
-
- New_Character_String : String(1..10) :=
- Ada.Characters.Latin_1.LC_A_Grave &
- Ada.Characters.Latin_1.LC_A_Ring &
- Ada.Characters.Latin_1.LC_AE_Diphthong &
- Ada.Characters.Latin_1.LC_C_Cedilla &
- Ada.Characters.Latin_1.LC_E_Acute &
- Ada.Characters.Latin_1.LC_I_Circumflex &
- Ada.Characters.Latin_1.LC_Icelandic_Eth &
- Ada.Characters.Latin_1.LC_N_Tilde &
- Ada.Characters.Latin_1.LC_O_Oblique_Stroke &
- Ada.Characters.Latin_1.LC_Icelandic_Thorn;
-
-
- TC_New_Character_String : String(1..10) :=
- Ada.Characters.Latin_1.UC_A_Grave &
- Ada.Characters.Latin_1.UC_A_Ring &
- Ada.Characters.Latin_1.UC_AE_Diphthong &
- Ada.Characters.Latin_1.UC_C_Cedilla &
- Ada.Characters.Latin_1.UC_E_Acute &
- Ada.Characters.Latin_1.UC_I_Circumflex &
- Ada.Characters.Latin_1.UC_Icelandic_Eth &
- Ada.Characters.Latin_1.UC_N_Tilde &
- Ada.Characters.Latin_1.UC_O_Oblique_Stroke &
- Ada.Characters.Latin_1.UC_Icelandic_Thorn;
-
-
- -- Functions used to supply mapping capability.
-
-
- -- Access objects that will be provided as parameters to the
- -- subprograms.
-
- Map_To_Lower_Case_Ptr : Maps.Character_Mapping_Function :=
- Map_To_Lower_Case'Access;
-
- Map_To_Upper_Case_Ptr : Maps.Character_Mapping_Function :=
- Map_To_Upper_Case'Access;
-
-
- begin
-
- -- Function Index, Forward direction search.
- -- Note: Several of the following cases use the default value
- -- Forward for the Going parameter.
-
- if Fixed.Index(Source => "The library package Strings.Fixed",
- Pattern => "fix",
- Going => Ada.Strings.Forward,
- Mapping => Map_To_Lower_Case_Ptr) /= 29 or
- Fixed.Index("THE RAIN IN SPAIN FALLS MAINLY ON THE PLAIN",
- "ain",
- Mapping => Map_To_Lower_Case_Ptr) /= 6 or
- Fixed.Index("maximum number",
- "um",
- Ada.Strings.Forward,
- Map_To_Lower_Case_Ptr) /= 6 or
- Fixed.Index("CoMpLeTeLy MiXeD CaSe StRiNg",
- "MIXED CASE STRING",
- Ada.Strings.Forward,
- Map_To_Upper_Case_Ptr) /= 12 or
- Fixed.Index("STRING WITH NO MATCHING PATTERNS",
- "WITH",
- Ada.Strings.Forward,
- Map_To_Lower_Case_Ptr) /= 0 or
- Fixed.Index("THIS STRING IS IN UPPER CASE",
- "IS",
- Ada.Strings.Forward,
- Map_To_Upper_Case_Ptr) /= 3 or
- Fixed.Index("", -- Null string.
- "is",
- Mapping => Map_To_Lower_Case_Ptr) /= 0 or
- Fixed.Index("AAABBBaaabbb",
- "aabb",
- Mapping => Map_To_Lower_Case_Ptr) /= 2
- then
- Report.Failed("Incorrect results from Function Index, going " &
- "in Forward direction, using a Character Mapping " &
- "Function parameter");
- end if;
-
-
-
- -- Function Index, Backward direction search.
-
- if Fixed.Index("Case of a Mixed Case String",
- "case",
- Ada.Strings.Backward,
- Map_To_Lower_Case_Ptr) /= 17 or
- Fixed.Index("Case of a Mixed Case String",
- "CASE",
- Ada.Strings.Backward,
- Map_To_Upper_Case_Ptr) /= 17 or
- Fixed.Index("rain, Rain, and more RAIN",
- "rain",
- Ada.Strings.Backward,
- Map_To_Lower_Case_Ptr) /= 22 or
- Fixed.Index("RIGHT place, right time",
- "RIGHT",
- Ada.Strings.Backward,
- Map_To_Upper_Case_Ptr) /= 14 or
- Fixed.Index("WOULD MATCH BUT FOR THE CASE",
- "WOULD MATCH BUT FOR THE CASE",
- Ada.Strings.Backward,
- Map_To_Lower_Case_Ptr) /= 0
- then
- Report.Failed("Incorrect results from Function Index, going " &
- "in Backward direction, using a Character Mapping " &
- "Function parameter");
- end if;
-
-
-
- -- Function Index, Pattern_Error if Pattern = Null_String
-
- declare
- use Ada.Strings.Fixed;
- Null_Pattern_String : constant String := "";
- TC_Natural : Natural := 1000;
- begin
- TC_Natural := Index("A Valid String",
- Null_Pattern_String,
- Ada.Strings.Forward,
- Map_To_Lower_Case_Ptr);
- Report.Failed("Pattern_Error not raised by Function Index when " &
- "given a null pattern string");
- exception
- when Pattern_Error => null; -- OK, expected exception.
- when others =>
- Report.Failed("Incorrect exception raised by Function Index " &
- "using a Character Mapping Function parameter " &
- "when given a null pattern string");
- end;
-
-
-
- -- Function Count.
-
- if Fixed.Count(Source => "ABABABA",
- Pattern => "aba",
- Mapping => Map_To_Lower_Case_Ptr) /= 2 or
- Fixed.Count("ABABABA", "ABA", Map_To_Lower_Case_Ptr) /= 0 or
- Fixed.Count("This IS a MISmatched issue",
- "is",
- Map_To_Lower_Case_Ptr) /= 4 or
- Fixed.Count("ABABABA", "ABA", Map_To_Upper_Case_Ptr) /= 2 or
- Fixed.Count("This IS a MISmatched issue",
- "is",
- Map_To_Upper_Case_Ptr) /= 0 or
- Fixed.Count("She sells sea shells by the sea shore",
- "s",
- Map_To_Lower_Case_Ptr) /= 8 or
- Fixed.Count("", -- Null string.
- "match",
- Map_To_Upper_Case_Ptr) /= 0
- then
- Report.Failed("Incorrect results from Function Count, using " &
- "a Character Mapping Function parameter");
- end if;
-
-
-
- -- Function Count, Pattern_Error if Pattern = Null_String
-
- declare
- use Ada.Strings.Fixed;
- Null_Pattern_String : constant String := "";
- TC_Natural : Natural := 1000;
- begin
- TC_Natural := Count("A Valid String",
- Null_Pattern_String,
- Map_To_Lower_Case_Ptr);
- Report.Failed("Pattern_Error not raised by Function Count using " &
- "a Character Mapping Function parameter when " &
- "given a null pattern string");
- exception
- when Pattern_Error => null; -- OK, expected exception.
- when others =>
- Report.Failed("Incorrect exception raised by Function Count " &
- "using a Character Mapping Function parameter " &
- "when given a null pattern string");
- end;
-
-
-
- -- Function Translate.
-
- if Fixed.Translate(Source => "A Sample Mixed Case String",
- Mapping => Map_To_Lower_Case_Ptr) /=
- "a sample mixed case string" or
-
- Fixed.Translate("ALL LOWER CASE",
- Map_To_Lower_Case_Ptr) /=
- "all lower case" or
-
- Fixed.Translate("end with lower case",
- Map_To_Lower_Case_Ptr) /=
- "end with lower case" or
-
- Fixed.Translate("", Map_To_Lower_Case_Ptr) /=
- "" or
-
- Fixed.Translate("start with lower case",
- Map_To_Upper_Case_Ptr) /=
- "START WITH LOWER CASE" or
-
- Fixed.Translate("ALL UPPER CASE STRING",
- Map_To_Upper_Case_Ptr) /=
- "ALL UPPER CASE STRING" or
-
- Fixed.Translate("LoTs Of MiXeD CaSe ChArAcTeRs",
- Map_To_Upper_Case_Ptr) /=
- "LOTS OF MIXED CASE CHARACTERS" or
-
- Fixed.Translate("", Map_To_Upper_Case_Ptr) /=
- "" or
-
- Fixed.Translate(New_Character_String,
- Map_To_Upper_Case_Ptr) /=
- TC_New_Character_String
- then
- Report.Failed("Incorrect results from Function Translate, using " &
- "a Character Mapping Function parameter");
- end if;
-
-
-
- -- Procedure Translate.
-
- declare
-
- use Ada.Strings.Fixed;
-
- Str_1 : String(1..24) := "AN ALL UPPER CASE STRING";
- Str_2 : String(1..19) := "A Mixed Case String";
- Str_3 : String(1..32) := "a string with lower case letters";
- TC_Str_1 : constant String := Str_1;
- TC_Str_3 : constant String := Str_3;
-
- begin
-
- Translate(Source => Str_1, Mapping => Map_To_Lower_Case_Ptr);
-
- if Str_1 /= "an all upper case string" then
- Report.Failed("Incorrect result from Procedure Translate - 1");
- end if;
-
- Translate(Source => Str_1, Mapping => Map_To_Upper_Case_Ptr);
-
- if Str_1 /= TC_Str_1 then
- Report.Failed("Incorrect result from Procedure Translate - 2");
- end if;
-
- Translate(Source => Str_2, Mapping => Map_To_Lower_Case_Ptr);
-
- if Str_2 /= "a mixed case string" then
- Report.Failed("Incorrect result from Procedure Translate - 3");
- end if;
-
- Translate(Source => Str_2, Mapping => Map_To_Upper_Case_Ptr);
-
- if Str_2 /= "A MIXED CASE STRING" then
- Report.Failed("Incorrect result from Procedure Translate - 4");
- end if;
-
- Translate(Source => Str_3, Mapping => Map_To_Lower_Case_Ptr);
-
- if Str_3 /= TC_Str_3 then
- Report.Failed("Incorrect result from Procedure Translate - 5");
- end if;
-
- Translate(Source => Str_3, Mapping => Map_To_Upper_Case_Ptr);
-
- if Str_3 /= "A STRING WITH LOWER CASE LETTERS" then
- Report.Failed("Incorrect result from Procedure Translate - 6");
- end if;
-
- Translate(New_Character_String, Map_To_Upper_Case_Ptr);
-
- if New_Character_String /= TC_New_Character_String then
- Report.Failed("Incorrect result from Procedure Translate - 6");
- end if;
-
- end;
-
-
- -- Procedure Trim.
-
- declare
- Use Ada.Strings.Fixed;
- Trim_String : String(1..30) := " A string of characters ";
- begin
-
- Trim(Source => Trim_String,
- Side => Ada.Strings.Left,
- Justify => Ada.Strings.Right,
- Pad => 'x');
-
- if Trim_String /= "xxxxA string of characters " then
- Report.Failed("Incorrect result from Procedure Trim, trim " &
- "side = left, justify = right, pad = x");
- end if;
-
- Trim(Trim_String, Ada.Strings.Right, Ada.Strings.Center);
-
- if Trim_String /= " xxxxA string of characters " then
- Report.Failed("Incorrect result from Procedure Trim, trim " &
- "side = right, justify = center, default pad");
- end if;
-
- Trim(Trim_String, Ada.Strings.Both, Pad => '*');
-
- if Trim_String /= "xxxxA string of characters****" then
- Report.Failed("Incorrect result from Procedure Trim, trim " &
- "side = both, default justify, pad = *");
- end if;
-
- end;
-
-
- -- Procedure Head.
-
- declare
- Fixed_String : String(1..20) := "A sample test string";
- begin
-
- Fixed.Head(Source => Fixed_String,
- Count => 14,
- Justify => Ada.Strings.Center,
- Pad => '$');
-
- if Fixed_String /= "$$$A sample test $$$" then
- Report.Failed("Incorrect result from Procedure Head, " &
- "justify = center, pad = $");
- end if;
-
- Fixed.Head(Fixed_String, 11, Ada.Strings.Right);
-
- if Fixed_String /= " $$$A sample" then
- Report.Failed("Incorrect result from Procedure Head, " &
- "justify = right, default pad");
- end if;
-
- Fixed.Head(Fixed_String, 9, Pad => '*');
-
- if Fixed_String /= " ***********" then
- Report.Failed("Incorrect result from Procedure Head, " &
- "default justify, pad = *");
- end if;
-
- end;
-
-
- -- Procedure Tail.
-
- declare
- Use Ada.Strings.Fixed;
- Tail_String : String(1..20) := "ABCDEFGHIJKLMNOPQRST";
- begin
-
- Tail(Source => Tail_String, Count => 10, Pad => '-');
-
- if Tail_String /= "KLMNOPQRST----------" then
- Report.Failed("Incorrect result from Procedure Tail, " &
- "default justify, pad = -");
- end if;
-
- Tail(Tail_String, 6, Justify => Ada.Strings.Center, Pad => 'a');
-
- if Tail_String /= "aaaaaaa------aaaaaaa" then
- Report.Failed("Incorrect result from Procedure Tail, " &
- "justify = center, pad = a");
- end if;
-
- Tail(Tail_String, 1, Ada.Strings.Right);
-
- if Tail_String /= " a" then
- Report.Failed("Incorrect result from Procedure Tail, " &
- "justify = right, default pad");
- end if;
-
- Tail(Tail_String, 19, Ada.Strings.Right, 'A');
-
- if Tail_String /= "A a" then
- Report.Failed("Incorrect result from Procedure Tail, " &
- "justify = right, pad = A");
- end if;
-
- end;
-
- exception
- when others => Report.Failed ("Exception raised in Test_Block");
- end Test_Block;
-
-
- Report.Result;
-
-end CXA4026;
diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxa4027.a b/gcc/testsuite/ada/acats/tests/cxa/cxa4027.a
deleted file mode 100644
index 05c66d4cc9f..00000000000
--- a/gcc/testsuite/ada/acats/tests/cxa/cxa4027.a
+++ /dev/null
@@ -1,342 +0,0 @@
--- CXA4027.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that versions of Ada.Strings.Bounded subprograms Translate,
--- (procedure and function), Index, and Count, which use the
--- Maps.Character_Mapping_Function input parameter, produce correct
--- results.
---
--- TEST DESCRIPTION:
--- This test examines the operation of several subprograms from within
--- the Ada.Strings.Bounded package that use the
--- Character_Mapping_Function mapping parameter to provide a mapping
--- capability.
---
--- Two functions are defined to provide the mapping. Access values
--- are defined to refer to these functions. One of the functions will
--- map upper case characters in the range 'A'..'Z' to their lower case
--- counterparts, while the other function will map lower case characters
--- ('a'..'z', or a character whose position is in one of the ranges
--- 223..246 or 248..255, provided the character has an upper case form)
--- to their upper case form.
---
--- Function Index uses the mapping function access value to map the input
--- string prior to searching for the appropriate index value to return.
--- Function Count uses the mapping function access value to map the input
--- string prior to counting the occurrences of the pattern string.
--- Both the Procedure and Function version of Translate use the mapping
--- function access value to perform the translation.
---
---
--- CHANGE HISTORY:
--- 16 FEB 95 SAIC Initial prerelease version
--- 17 Jul 95 SAIC Incorporated reviewer comments. Replaced two
--- internally declared functions with two library
--- level functions to eliminate accessibility
--- problems.
---
---!
-
-
--- Function CXA4027_0 will return the lower case form of
--- the character input if it is in upper case, and return the input
--- character otherwise.
-
-with Ada.Characters.Handling;
-function CXA4027_0 (From : Character) return Character;
-
-function CXA4027_0 (From : Character) return Character is
-begin
- return Ada.Characters.Handling.To_Lower(From);
-end CXA4027_0;
-
-
-
--- Function CXA4027_1 will return the upper case form of
--- Characters in the range 'a'..'z', or whose position is in one
--- of the ranges 223..246 or 248..255, provided the character has
--- an upper case form.
-
-with Ada.Characters.Handling;
-function CXA4027_1 (From : Character) return Character;
-
-function CXA4027_1 (From : Character) return Character is
-begin
- return Ada.Characters.Handling.To_Upper(From);
-end CXA4027_1;
-
-
-with CXA4027_0, CXA4027_1;
-with Ada.Strings.Bounded;
-with Ada.Strings.Maps;
-with Ada.Characters.Handling;
-with Report;
-
-procedure CXA4027 is
-begin
-
- Report.Test ("CXA4027", "Check that Ada.Strings.Bounded subprograms " &
- "Translate, Index, and Count, which use the " &
- "Character_Mapping_Function input parameter, " &
- "produce correct results");
-
- Test_Block:
- declare
-
- use Ada.Strings;
-
- -- Functions used to supply mapping capability.
-
- function Map_To_Lower_Case (From : Character) return Character
- renames CXA4027_0;
-
- function Map_To_Upper_Case (From : Character) return Character
- renames CXA4027_1;
-
- Map_To_Lower_Case_Ptr : Maps.Character_Mapping_Function :=
- Map_To_Lower_Case'Access;
-
- Map_To_Upper_Case_Ptr : Maps.Character_Mapping_Function :=
- Map_To_Upper_Case'Access;
-
-
- -- Instantiations of Bounded String generic package.
-
- package BS1 is new Ada.Strings.Bounded.Generic_Bounded_Length(1);
- package BS20 is new Ada.Strings.Bounded.Generic_Bounded_Length(20);
- package BS40 is new Ada.Strings.Bounded.Generic_Bounded_Length(40);
- package BS80 is new Ada.Strings.Bounded.Generic_Bounded_Length(80);
-
- use type BS1.Bounded_String, BS20.Bounded_String,
- BS40.Bounded_String, BS80.Bounded_String;
-
- String_1 : String(1..1) := "A";
- String_20 : String(1..20) := "ABCDEFGHIJKLMNOPQRST";
- String_40 : String(1..40) := "abcdefghijklmnopqrst" & String_20;
- String_80 : String(1..80) := String_40 & String_40;
-
- BString_1 : BS1.Bounded_String := BS1.Null_Bounded_String;
- BString_20 : BS20.Bounded_String := BS20.Null_Bounded_String;
- BString_40 : BS40.Bounded_String := BS40.Null_Bounded_String;
- BString_80 : BS80.Bounded_String := BS80.Null_Bounded_String;
-
-
- begin
-
- -- Function Index.
-
- if BS40.Index(BS40.To_Bounded_String("Package Strings.Bounded"),
- Pattern => "s.b",
- Going => Ada.Strings.Forward,
- Mapping => Map_To_Lower_Case_Ptr) /= 15 or
- BS80.Index(BS80.To_Bounded_String("STRING TRANSLATIONS SUBPROGRAMS"),
- "tr",
- Mapping => Map_To_Lower_Case_Ptr) /= 2 or
- BS20.Index(BS20.To_Bounded_String("maximum number"),
- "um",
- Ada.Strings.Backward,
- Map_To_Lower_Case_Ptr) /= 10 or
- BS80.Index(BS80.To_Bounded_String("CoMpLeTeLy MiXeD CaSe StRiNg"),
- "MIXED CASE STRING",
- Ada.Strings.Forward,
- Map_To_Upper_Case_Ptr) /= 12 or
- BS40.Index(BS40.To_Bounded_String("STRING WITH NO MATCHING PATTERN"),
- "WITH",
- Ada.Strings.Backward,
- Map_To_Lower_Case_Ptr) /= 0 or
- BS80.Index(BS80.To_Bounded_String("THIS STRING IS IN UPPER CASE"),
- "I",
- Ada.Strings.Backward,
- Map_To_Upper_Case_Ptr) /= 16 or
- BS1.Index(BS1.Null_Bounded_String,
- "i",
- Mapping => Map_To_Lower_Case_Ptr) /= 0 or
- BS40.Index(BS40.To_Bounded_String("AAABBBaaabbb"),
- "aabb",
- Mapping => Map_To_Lower_Case_Ptr) /= 2 or
- BS80.Index(BS80.To_Bounded_String("WOULD MATCH BUT FOR THE CASE"),
- "WOULD MATCH BUT FOR THE CASE",
- Ada.Strings.Backward,
- Map_To_Lower_Case_Ptr) /= 0
- then
- Report.Failed("Incorrect results from Function Index, using a " &
- "Character Mapping Function parameter");
- end if;
-
-
- -- Function Index, Pattern_Error if Pattern = Null_String
-
- declare
- use BS20;
- TC_Natural : Natural := 1000;
- begin
- TC_Natural := Index(To_Bounded_String("A Valid String"),
- "",
- Ada.Strings.Forward,
- Map_To_Lower_Case_Ptr);
- Report.Failed("Pattern_Error not raised by Function Index when " &
- "given a null pattern string");
- exception
- when Pattern_Error => null; -- OK, expected exception.
- when others =>
- Report.Failed("Incorrect exception raised by Function Index " &
- "using a Character_Mapping_Function parameter " &
- "when given a null pattern string");
- end;
-
-
- -- Function Count.
-
- if BS20.Count(BS20.To_Bounded_String("ABABABA"),
- Pattern => "aba",
- Mapping => Map_To_Lower_Case_Ptr) /= 2 or
- BS20.Count(BS20.To_Bounded_String("ABABABA"),
- "ABA",
- Map_To_Lower_Case_Ptr) /= 0 or
- BS40.Count(BS40.To_Bounded_String("This IS a MISmatched issue"),
- "is",
- Map_To_Lower_Case_Ptr) /= 4 or
- BS80.Count(BS80.To_Bounded_String("ABABABA"),
- "ABA",
- Map_To_Upper_Case_Ptr) /= 2 or
- BS40.Count(BS40.To_Bounded_String("This IS a MISmatched issue"),
- "is",
- Map_To_Upper_Case_Ptr) /= 0 or
- BS80.Count(BS80.To_Bounded_String
- ("Peter Piper and his Pickled Peppers"),
- "p",
- Map_To_Lower_Case_Ptr) /= 7 or
- BS20.Count(BS20.To_Bounded_String("She sells sea shells"),
- "s",
- Map_To_Upper_Case_Ptr) /= 0 or
- BS80.Count(BS80.To_Bounded_String("No matches what-so-ever"),
- "matches",
- Map_To_Upper_Case_Ptr) /= 0
- then
- Report.Failed("Incorrect results from Function Count, using " &
- "a Character_Mapping_Function parameter");
- end if;
-
-
- -- Function Count, Pattern_Error if Pattern = Null_String
-
- declare
- use BS80;
- TC_Natural : Natural := 1000;
- begin
- TC_Natural := Count(To_Bounded_String("A Valid String"),
- "",
- Map_To_Lower_Case_Ptr);
- Report.Failed("Pattern_Error not raised by Function Count using " &
- "a Character_Mapping_Function parameter when " &
- "given a null pattern string");
- exception
- when Pattern_Error => null; -- OK, expected exception.
- when others =>
- Report.Failed("Incorrect exception raised by Function Count " &
- "using a Character_Mapping_Function parameter " &
- "when given a null pattern string");
- end;
-
-
- -- Function Translate.
-
- if BS40.Translate(BS40.To_Bounded_String("A Mixed Case String"),
- Mapping => Map_To_Lower_Case_Ptr) /=
- BS40.To_Bounded_String("a mixed case string") or
-
- BS20."/="(BS20.Translate(BS20.To_Bounded_String("ALL LOWER CASE"),
- Map_To_Lower_Case_Ptr),
- "all lower case") or
-
- BS20."/="("end with lower case",
- BS20.Translate(
- BS20.To_Bounded_String("end with lower case"),
- Map_To_Lower_Case_Ptr)) or
-
- BS1.Translate(BS1.Null_Bounded_String,
- Map_To_Lower_Case_Ptr) /=
- BS1.Null_Bounded_String or
-
- BS80."/="(BS80.Translate(BS80.To_Bounded_String
- ("start with lower case, end with upper case"),
- Map_To_Upper_Case_Ptr),
- "START WITH LOWER CASE, END WITH UPPER CASE") or
-
- BS40.Translate(BS40.To_Bounded_String("ALL UPPER CASE STRING"),
- Map_To_Upper_Case_Ptr) /=
- BS40.To_Bounded_String("ALL UPPER CASE STRING") or
-
- BS80."/="(BS80.Translate(BS80.To_Bounded_String
- ("LoTs Of MiXeD CaSe ChArAcTeRs In ThE StRiNg"),
- Map_To_Upper_Case_Ptr),
- "LOTS OF MIXED CASE CHARACTERS IN THE STRING")
-
- then
- Report.Failed("Incorrect results from Function Translate, using " &
- "a Character_Mapping_Function parameter");
- end if;
-
-
- -- Procedure Translate.
-
- BString_1 := BS1.To_Bounded_String("A");
-
- BS1.Translate(Source => BString_1, Mapping => Map_To_Lower_Case_Ptr);
-
- if not BS1."="(BString_1, "a") then -- "=" for Bounded_String, String
- Report.Failed("Incorrect result from Procedure Translate - 1");
- end if;
-
- BString_20 := BS20.To_Bounded_String(String_20);
- BS20.Translate(BString_20, Mapping => Map_To_Lower_Case_Ptr);
-
- if BString_20 /= BS20.To_Bounded_String("abcdefghijklmnopqrst") then
- Report.Failed("Incorrect result from Procedure Translate - 2");
- end if;
-
- BString_40 := BS40.To_Bounded_String("String needing highlighting");
- BS40.Translate(BString_40, Map_To_Upper_Case_Ptr);
-
- if not (BString_40 = "STRING NEEDING HIGHLIGHTING") then
- Report.Failed("Incorrect result from Procedure Translate - 3");
- end if;
-
- BString_80 := BS80.Null_Bounded_String;
- BS80.Translate(BString_80, Map_To_Upper_Case_Ptr);
-
- if not (BString_80 = BS80.Null_Bounded_String) then
- Report.Failed("Incorrect result from Procedure Translate - 4");
- end if;
-
-
- exception
- when others => Report.Failed ("Exception raised in Test_Block");
- end Test_Block;
-
- Report.Result;
-
-end CXA4027;
diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxa4028.a b/gcc/testsuite/ada/acats/tests/cxa/cxa4028.a
deleted file mode 100644
index bc6cac14c5e..00000000000
--- a/gcc/testsuite/ada/acats/tests/cxa/cxa4028.a
+++ /dev/null
@@ -1,331 +0,0 @@
--- CXA4028.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that Ada.Strings.Bounded procedures Append, Head, Tail, and
--- Trim, and relational operator functions "=", ">", ">=", "<", "<="
--- with parameter combinations of type String and Bounded_String,
--- produce correct results.
---
--- TEST DESCRIPTION:
--- This test examines the operation of several subprograms from within
--- the Ada.Strings.Bounded package. Four different instantiations of
--- Ada.Strings.Bounded.Generic_Bounded_Length provide packages defined
--- to manipulate bounded strings of lengths 1, 20, 40, and 80.
--- Examples of the above mentioned procedures and relational operators
--- from each of these instantiations are tested, with results compared
--- against expected output.
---
--- Testing of the function versions of many of the subprograms tested
--- here is performed in tests CXA4006-CXA4009.
---
---
--- CHANGE HISTORY:
--- 16 Feb 95 SAIC Initial prerelease version
--- 10 Mar 95 SAIC Incorporated reviewer comments.
--- 15 Apr 96 SAIC Incorporated reviewer comments for ACVC 2.1.
---
---!
-
-with Ada.Exceptions;
-with Ada.Strings.Bounded;
-with Report;
-
-procedure CXA4028 is
-
-begin
-
- Report.Test ("CXA4028", "Check that Ada.Strings.Bounded procedures " &
- "Append, Head, Tail, and Trim, and relational " &
- "operator functions =, >, >=, <, <= with " &
- "parameter combinations of type String and " &
- "Bounded_String, produce correct results");
-
- Test_Block:
- declare
-
- use Ada.Exceptions;
- use Ada.Strings;
-
- -- Instantiations of Bounded String generic package.
-
- package BS1 is new Ada.Strings.Bounded.Generic_Bounded_Length(1);
- package BS20 is new Ada.Strings.Bounded.Generic_Bounded_Length(20);
- package BS40 is new Ada.Strings.Bounded.Generic_Bounded_Length(40);
- package BS80 is new Ada.Strings.Bounded.Generic_Bounded_Length(80);
-
- use type BS1.Bounded_String, BS20.Bounded_String,
- BS40.Bounded_String, BS80.Bounded_String;
-
- String_1 : String(1..1) := "A";
- String_20 : String(1..20) := "ABCDEFGHIJKLMNOPQRST";
- String_40 : String(1..40) := "abcdefghijklmnopqrst" & String_20;
- String_80 : String(1..80) := String_40 & String_40;
-
- BString_1 : BS1.Bounded_String := BS1.Null_Bounded_String;
- BString_20 : BS20.Bounded_String := BS20.Null_Bounded_String;
- BString_40 : BS40.Bounded_String := BS40.Null_Bounded_String;
- BString_80 : BS80.Bounded_String := BS80.Null_Bounded_String;
-
- begin
-
- -- Procedure Append.
-
- declare
- use BS1, BS20;
- begin
- Append(Source => BString_1, New_Item => To_Bounded_String("A"));
- Append(BString_1, "B", Ada.Strings.Left);
- Append(BString_1, 'C', Drop => Ada.Strings.Right); -- Drop appended
- -- character.
- if BString_1 /= To_Bounded_String("B") then
- Report.Failed("Incorrect results from BS1 versions of " &
- "procedure Append");
- end if;
-
- Append(BString_20, 'T'); -- Character.
- Append(BString_20, "his string"); -- String.
- Append(BString_20,
- To_Bounded_String(" is complete."), -- Bounded string.
- Drop => Ada.Strings.Right); -- Drop 4 characters.
-
- if BString_20 /= To_Bounded_String("This string is compl") then
- Report.Failed("Incorrect results from BS20 versions of " &
- "procedure Append");
- end if;
- end;
-
-
- -- Operator "=".
-
- BString_40 := BS40.To_Bounded_String(String_40);
- BString_80 := BS80.To_Bounded_String(
- BS40.To_String(BString_40) &
- BS40.To_String(BString_40));
-
- if not (BString_40 = String_40 and -- (Bounded_String, String)
- BS80."="(String_80, BString_80)) -- (String, Bounded_String)
- then
- Report.Failed("Incorrect results from function ""="" with " &
- "string - bounded string parameter combinations");
- end if;
-
-
- -- Operator "<".
-
- BString_1 := BS1.To_Bounded_String("cat", -- string "c" only.
- Drop => Ada.Strings.Right);
- BString_20 := BS20.To_Bounded_String("Santa Claus");
-
- if BString_1 < "C" or -- (Bounded_String, String)
- BS1."<"(BString_1,"c") or -- (Bounded_String, String)
- "x" < BString_1 or -- (String, Bounded_String)
- BString_20 < "Santa " or -- (Bounded_String, String)
- "Santa and his Elves" < BString_20 -- (String, Bounded_String)
- then
- Report.Failed("Incorrect results from function ""<"" with " &
- "string - bounded string parameter combinations");
- end if;
-
-
- -- Operator "<=".
-
- BString_20 := BS20.To_Bounded_String("Sample string");
-
- if BString_20 <= "Sample strin" or -- (Bounded_String, String)
- "sample string" <= BString_20 or -- (String, Bounded_String)
- not("Sample string" <= BString_20) -- (String, Bounded_String)
- then
- Report.Failed("Incorrect results from function ""<="" with " &
- "string - bounded string parameter combinations");
- end if;
-
-
- -- Operator ">".
-
- BString_40 := BS40.To_Bounded_String("A MUCH LONGER SAMPLE STRING.");
-
- if BString_40 > "A much longer sample string" or -- (Bnd_Str, Str)
- String_20 > BS40.To_Bounded_String(String_40) or -- (Str, Bnd_Str)
- BS40.To_Bounded_String("ABCDEFGH") > "abcdefgh" -- (Str, Bnd_Str)
- then
- Report.Failed("Incorrect results from function "">"" with " &
- "string - bounded string parameter combinations");
- end if;
-
-
- -- Operator ">=".
-
- BString_80 := BS80.To_Bounded_String(String_80);
-
- if not (BString_80 >= String_80 and
- BS80.To_Bounded_String("Programming") >= "PROGRAMMING" and
- "test" >= BS80.To_Bounded_String("tess"))
- then
- Report.Failed("Incorrect results from function "">="" with " &
- "string - bounded string parameter combinations");
- end if;
-
-
- -- Procedure Trim
-
- BString_20 := BS20.To_Bounded_String(" Left Spaces ");
- BS20.Trim(Source => BString_20,
- Side => Ada.Strings.Left);
-
- if "Left Spaces " /= BString_20 then
- Report.Failed("Incorrect results from Procedure Trim with " &
- "Side = Left");
- end if;
-
- BString_40 := BS40.To_Bounded_String(" Right Spaces ");
- BS40.Trim(BString_40, Side => Ada.Strings.Right);
-
- if BString_40 /= " Right Spaces" then
- Report.Failed("Incorrect results from Procedure Trim with " &
- "Side = Right");
- end if;
-
- BString_20 := BS20.To_Bounded_String(" Both Sides ");
- BS20.Trim(BString_20, Ada.Strings.Both);
-
- if BString_20 /= BS20.To_Bounded_String("Both Sides") then
- Report.Failed("Incorrect results from Procedure Trim with " &
- "Side = Both");
- end if;
-
- BString_80 := BS80.To_Bounded_String("Centered Spaces");
- BS80.Trim(BString_80, Ada.Strings.Both);
-
- if BString_80 /= BS80.To_Bounded_String("Centered Spaces") then
- Report.Failed("Incorrect results from Procedure Trim with " &
- "no blank spaces on the ends of the string");
- end if;
-
-
- -- Procedure Head
-
- BString_40 := BS40.To_Bounded_String("Test String");
- BS40.Head(Source => BString_40,
- Count => 4); -- Count < Source'Length
-
- if BString_40 /= BS40.To_Bounded_String("Test") then
- Report.Failed("Incorrect results from Procedure Head with " &
- "the Count parameter less than Source'Length");
- end if;
-
- BString_1 := BS1.To_Bounded_String("X");
- BS1.Head(BString_1, BS1.Length(BString_1)); -- Count = Source'Length
-
- if BString_1 /= "X" then
- Report.Failed("Incorrect results from Procedure Head with " &
- "the Count parameter equal to Source'Length");
- end if;
-
- BString_20 := BS20.To_Bounded_String("Sample string");
- BS20.Head(BString_20,
- Count => BS20.Max_Length, -- Count > Source'Length
- Pad => '*');
-
- if BString_20 /= BS20.To_Bounded_String("Sample string*******") then
- Report.Failed("Incorrect results from Procedure Head with " &
- "the Count parameter greater than Source'Length");
- end if;
-
- BString_20 := BS20.To_Bounded_String("Twenty Characters 20");
- BS20.Head(BString_20, 22, Pad => '*', Drop => Ada.Strings.Left);
-
- if BString_20 /= "enty Characters 20**" then
- Report.Failed("Incorrect results from Procedure Head with " &
- "the Count parameter greater than Source'Length, " &
- "and the Drop parameter = Left");
- end if;
-
- BString_20 := BS20.To_Bounded_String("Short String");
- BS20.Head(BString_20, 23, '-', Ada.Strings.Right);
-
- if ("Short String--------") /= BString_20 then
- Report.Failed("Incorrect results from Procedure Head with " &
- "the Count parameter greater than Source'Length, " &
- "and the Drop parameter = Right");
- end if;
-
-
- -- Procedure Tail
-
- BString_40 := BS40.To_Bounded_String("Test String");
- BS40.Tail(Source => BString_40,
- Count => 6); -- Count < Source'Length
-
- if BString_40 /= BS40.To_Bounded_String("String") then
- Report.Failed("Incorrect results from Procedure Tail with " &
- "the Count parameter less than Source'Length");
- end if;
-
- BString_1 := BS1.To_Bounded_String("X");
- BS1.Tail(BString_1, BS1.Length(BString_1)); -- Count = Source'Length
-
- if BString_1 /= "X" then
- Report.Failed("Incorrect results from Procedure Tail with " &
- "the Count parameter equal to Source'Length");
- end if;
-
- BString_20 := BS20.To_Bounded_String("Sample string");
- BS20.Tail(BString_20,
- Count => BS20.Max_Length, -- Count > Source'Length
- Pad => '*');
-
- if BString_20 /= BS20.To_Bounded_String("*******Sample string") then
- Report.Failed("Incorrect results from Procedure Tail with " &
- "the Count parameter greater than Source'Length");
- end if;
-
- BString_20 := BS20.To_Bounded_String("Twenty Characters"); -- Len = 17
- BS20.Tail(BString_20, 22, Pad => '*', Drop => Ada.Strings.Left);
-
- if BString_20 /= "***Twenty Characters" then
- Report.Failed("Incorrect results from Procedure Tail with " &
- "the Count parameter greater than Source'Length, " &
- "and the Drop parameter = Left");
- end if;
-
- BString_20 := BS20.To_Bounded_String("Maximum Length Chars");
- BS20.Tail(BString_20, 23, '-', Ada.Strings.Right);
-
- if ("---Maximum Length Ch") /= BString_20 then
- Report.Failed("Incorrect results from Procedure Tail with " &
- "the Count parameter greater than Source'Length, " &
- "and the Drop parameter = Right");
- end if;
-
- exception
- when The_Error : others =>
- Report.Failed ("The following exception was raised in the " &
- "Test_Block: " & Exception_Name(The_Error));
- end Test_Block;
-
- Report.Result;
-
-end CXA4028;
diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxa4029.a b/gcc/testsuite/ada/acats/tests/cxa/cxa4029.a
deleted file mode 100644
index 7140674544a..00000000000
--- a/gcc/testsuite/ada/acats/tests/cxa/cxa4029.a
+++ /dev/null
@@ -1,333 +0,0 @@
--- CXA4029.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that the functionality found in packages Ada.Strings.Wide_Maps,
--- Ada.Strings.Wide_Bounded, and Ada.Strings.Wide_Maps.Wide_Constants
--- is available and produces correct results.
---
--- TEST DESCRIPTION:
--- This test tests the subprograms found in the
--- Ada.Strings.Wide_Bounded package. It is based on the tests
--- CXA4027-28, which are tests for the complementary "non-wide"
--- packages.
---
--- The functions found in CXA4029_0 provide mapping capability, when
--- used in conjunction with Wide_Character_Mapping_Function objects.
---
---
--- CHANGE HISTORY:
--- 23 Jun 95 SAIC Initial prerelease version.
--- 18 Apr 96 SAIC Incorporated reviewer comments for ACVC 2.1.
---
---!
-
-package CXA4029_0 is
- -- Functions used to supply mapping capability.
- function Map_To_Lower_Case (From : Wide_Character) return Wide_Character;
- function Map_To_Upper_Case (From : Wide_Character) return Wide_Character;
-end CXA4029_0;
-
-with Ada.Characters.Handling;
-package body CXA4029_0 is
- -- Function Map_To_Lower_Case will return the lower case form of
- -- Wide_Characters in the range 'A'..'Z' only, and return the input
- -- wide_character otherwise.
-
- function Map_To_Lower_Case (From : Wide_Character)
- return Wide_Character is
- begin
- return Ada.Characters.Handling.To_Wide_Character(
- Ada.Characters.Handling.To_Lower(
- Ada.Characters.Handling.To_Character(From)));
- end Map_To_Lower_Case;
-
- -- Function Map_To_Upper_Case will return the upper case form of
- -- Wide_Characters in the range 'a'..'z', or whose position is in one
- -- of the ranges 223..246 or 248..255, provided the wide_character has
- -- an upper case form.
-
- function Map_To_Upper_Case (From : Wide_Character)
- return Wide_Character is
- begin
- return Ada.Characters.Handling.To_Wide_Character(
- Ada.Characters.Handling.To_Upper(
- Ada.Characters.Handling.To_Character(From)));
- end Map_To_Upper_Case;
-
-end CXA4029_0;
-
-
-with CXA4029_0;
-with Report;
-with Ada.Characters.Handling;
-with Ada.Characters.Latin_1;
-with Ada.Strings;
-with Ada.Strings.Wide_Maps;
-with Ada.Strings.Wide_Maps.Wide_Constants;
-with Ada.Strings.Wide_Fixed;
-with Ada.Strings.Wide_Bounded;
-
-procedure CXA4029 is
-begin
- Report.Test ("CXA4029",
- "Check that subprograms defined in package " &
- "Ada.Strings.Wide_Bounded produce correct results");
-
- Test_Block:
- declare
-
- package ACL1 renames Ada.Characters.Latin_1;
- package BS1 is new Ada.Strings.Wide_Bounded.Generic_Bounded_Length(1);
- package BS20 is new Ada.Strings.Wide_Bounded.Generic_Bounded_Length(20);
- package BS40 is new Ada.Strings.Wide_Bounded.Generic_Bounded_Length(40);
- package BS80 is new Ada.Strings.Wide_Bounded.Generic_Bounded_Length(80);
-
- subtype LC_Characters is Wide_Character range 'a'..'z';
-
- use Ada.Characters, Ada.Strings;
- use type Wide_Maps.Wide_Character_Set;
- use type BS1.Bounded_Wide_String, BS20.Bounded_Wide_String,
- BS40.Bounded_Wide_String, BS80.Bounded_Wide_String;
-
- TC_String : constant Wide_String := "A Standard String";
-
- BString_1 : BS1.Bounded_Wide_String :=
- BS1.Null_Bounded_Wide_String;
- BString_20 : BS20.Bounded_Wide_String :=
- BS20.Null_Bounded_Wide_String;
- BString_40 : BS40.Bounded_Wide_String :=
- BS40.Null_Bounded_Wide_String;
- BString_80 : BS80.Bounded_Wide_String :=
- BS80.Null_Bounded_Wide_String;
- String_20 : Wide_String(1..20) := "ABCDEFGHIJKLMNOPQRST";
- String_40 : Wide_String(1..40) := "abcdefghijklmnopqrst" &
- String_20;
- String_80 : Wide_String(1..80) := String_40 & String_40;
- TC_String_5 : Wide_String(1..5) := "ABCDE";
-
- -- The following strings are used in examination of the Translation
- -- subprograms.
- New_Character_String : Wide_String(1..10) :=
- Handling.To_Wide_String(
- ACL1.LC_A_Grave & ACL1.LC_A_Ring & ACL1.LC_AE_Diphthong &
- ACL1.LC_C_Cedilla & ACL1.LC_E_Acute & ACL1.LC_I_Circumflex &
- ACL1.LC_Icelandic_Eth & ACL1.LC_N_Tilde &
- ACL1.LC_O_Oblique_Stroke & ACL1.LC_Icelandic_Thorn);
-
- TC_New_Character_String : Wide_String(1..10) :=
- Handling.To_Wide_String(
- ACL1.UC_A_Grave & ACL1.UC_A_Ring & ACL1.UC_AE_Diphthong &
- ACL1.UC_C_Cedilla & ACL1.UC_E_Acute & ACL1.UC_I_Circumflex &
- ACL1.UC_Icelandic_Eth & ACL1.UC_N_Tilde &
- ACL1.UC_O_Oblique_Stroke & ACL1.UC_Icelandic_Thorn);
-
- -- Access objects that will be provided as parameters to the
- -- subprograms.
- Map_To_Lower_Case_Ptr : Wide_Maps.Wide_Character_Mapping_Function :=
- CXA4029_0.Map_To_Lower_Case'Access;
- Map_To_Upper_Case_Ptr : Wide_Maps.Wide_Character_Mapping_Function :=
- CXA4029_0.Map_To_Upper_Case'Access;
-
- begin
-
- -- Testing of functionality found in Package Ada.Strings.Wide_Bounded.
- --
- -- Function Index.
-
- if BS80.Index(BS80.To_Bounded_Wide_String("CoMpLeTeLy MiXeD CaSe"),
- "MIXED CASE",
- Ada.Strings.Forward,
- Map_To_Upper_Case_Ptr) /= 12 or
- BS1.Index(BS1.Null_Bounded_Wide_String,
- "i",
- Mapping => Map_To_Lower_Case_Ptr) /= 0
- then
- Report.Failed("Incorrect results from BND Function Index, going " &
- "in Forward direction, using a Character Mapping " &
- "Function parameter");
- end if;
-
- -- Function Count.
- if BS40.Count(BS40.To_Bounded_Wide_String("This IS a MISmatched issue"),
- "is",
- Map_To_Lower_Case_Ptr) /= 4 or
- BS80.Count(BS80.To_Bounded_Wide_String("ABABABA"),
- "ABA",
- Map_To_Upper_Case_Ptr) /= 2
- then
- Report.Failed("Incorrect results from BND Function Count, using " &
- "a Character_Mapping_Function parameter");
- end if;
-
- -- Function Translate.
- if BS40.Translate(BS40.To_Bounded_Wide_String("A Mixed Case String"),
- Mapping => Map_To_Lower_Case_Ptr) /=
- BS40.To_Bounded_Wide_String("a mixed case string") or
- BS20."/="("end with lower case",
- BS20.Translate(
- BS20.To_Bounded_Wide_String("end with lower case"),
- Map_To_Lower_Case_Ptr))
- then
- Report.Failed("Incorrect results from BND Function Translate, " &
- "using a Character_Mapping_Function parameter");
- end if;
-
- -- Procedure Translate.
- BString_20 := BS20.To_Bounded_Wide_String(String_20);
- BS20.Translate(BString_20, Mapping => Map_To_Lower_Case_Ptr);
- if BString_20 /= BS20.To_Bounded_Wide_String("abcdefghijklmnopqrst")
- then
- Report.Failed("Incorrect result from BND Procedure Translate - 1");
- end if;
-
- BString_80 := BS80.Null_Bounded_Wide_String;
- BS80.Translate(BString_80, Map_To_Upper_Case_Ptr);
- if not (BString_80 = BS80.Null_Bounded_Wide_String) then
- Report.Failed("Incorrect result from BND Procedure Translate - 2");
- end if;
-
- -- Procedure Append.
- declare
- use BS20;
- begin
- BString_20 := BS20.Null_Bounded_Wide_String;
- Append(BString_20, 'T');
- Append(BString_20, "his string");
- Append(BString_20,
- To_Bounded_Wide_String(" is complete."),
- Drop => Ada.Strings.Right); -- Drop 4 characters.
- if BString_20 /= To_Bounded_Wide_String("This string is compl") then
- Report.Failed("Incorrect results from BS20 versions of " &
- "procedure Append");
- end if;
- exception
- when others => Report.Failed("Exception raised in block checking " &
- "BND Procedure Append");
- end;
-
- -- Operator "=".
- BString_40 := BS40.To_Bounded_Wide_String(String_40);
- BString_80 := BS80.To_Bounded_Wide_String(
- BS40.To_Wide_String(BString_40) &
- BS40.To_Wide_String(BString_40));
- if not (BString_40 = String_40 and
- BS80."="(String_80, BString_80)) then
- Report.Failed("Incorrect results from BND Function ""="" with " &
- "string - bounded string parameter combinations");
- end if;
-
- -- Operator "<".
- BString_1 := BS1.To_Bounded_Wide_String("cat",
- Drop => Ada.Strings.Right);
- BString_20 := BS20.To_Bounded_Wide_String("Santa Claus");
- if BString_1 < "C" or
- BS1."<"(BString_1,"c") or
- BS1."<"("x", BString_1) or
- BS20."<"(BString_20,"Santa ") or
- BS20."<"("Santa and his Elves", BString_20)
- then
- Report.Failed("Incorrect results from BND Function ""<"" with " &
- "string - bounded string parameter combinations");
- end if;
-
- -- Operator "<=".
- BString_20 := BS20.To_Bounded_Wide_String("Sample string");
- if BS20."<="(BString_20,"Sample strin") or
- not(BS20."<="("Sample string",BString_20))
- then
- Report.Failed("Incorrect results from BND Function ""<="" with " &
- "string - bounded string parameter combinations");
- end if;
-
- -- Operator ">".
- BString_40 := BS40.To_Bounded_Wide_String(
- "A MUCH LONGER SAMPLE STRING.");
- if BString_40 > "A much longer sample string" or
- BS40.To_Bounded_Wide_String("ABCDEFGH") > "abcdefgh"
- then
- Report.Failed("Incorrect results from BND Function "">"" with " &
- "string - bounded string parameter combinations");
- end if;
-
- -- Operator ">=".
- BString_80 := BS80.To_Bounded_Wide_String(String_80);
- if not (BString_80 >= String_80 and
- BS80.To_Bounded_Wide_String("Programming") >= "PROGRAMMING" and
- BS80.">="("test", BS80.To_Bounded_Wide_String("tess")))
- then
- Report.Failed("Incorrect results from BND Function "">="" with " &
- "string - bounded string parameter combinations");
- end if;
-
- -- Procedure Trim
- BString_20 := BS20.To_Bounded_Wide_String(" Both Sides ");
- BS20.Trim(BString_20, Ada.Strings.Both);
- if BString_20 /= BS20.To_Bounded_Wide_String("Both Sides") then
- Report.Failed("Incorrect results from BND Procedure Trim with " &
- "Side = Both");
- end if;
-
- -- Procedure Head
- BString_40 := BS40.To_Bounded_Wide_String("Test String");
- BS40.Head(Source => BString_40,
- Count => 4); -- Count < Source'Length
- if BString_40 /= BS40.To_Bounded_Wide_String("Test") then
- Report.Failed("Incorrect results from BND Procedure Head with " &
- "the Count parameter less than Source'Length");
- end if;
-
- BString_20 := BS20.To_Bounded_Wide_String("Short String");
- BS20.Head(BString_20, 23, '-', Ada.Strings.Right);
- if BS20.To_Bounded_Wide_String("Short String--------") /= BString_20 then
- Report.Failed("Incorrect results from BND Procedure Head with " &
- "the Count parameter greater than Source'Length, " &
- "and the Drop parameter = Right");
- end if;
-
- -- Procedure Tail
- BString_40 := BS40.To_Bounded_Wide_String("Test String");
- BS40.Tail(Source => BString_40,
- Count => 6);
- if BString_40 /= BS40.To_Bounded_Wide_String("String") then
- Report.Failed("Incorrect results from BND Procedure Tail with " &
- "the Count parameter less than Source'Length");
- end if;
-
- BString_20 := BS20.To_Bounded_Wide_String("Maximum Length Chars");
- BS20.Tail(BString_20, 23, '-', Ada.Strings.Right);
- if BS20.To_Bounded_Wide_String("---Maximum Length Ch") /= BString_20 then
- Report.Failed("Incorrect results from BND Procedure Tail with " &
- "the Count parameter greater than Source'Length, " &
- "and the Drop parameter = Right");
- end if;
-
- exception
- when others => Report.Failed ("Exception raised in Test_Block");
- end Test_Block;
-
- Report.Result;
-
-end CXA4029;
diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxa4030.a b/gcc/testsuite/ada/acats/tests/cxa/cxa4030.a
deleted file mode 100644
index 475d0089921..00000000000
--- a/gcc/testsuite/ada/acats/tests/cxa/cxa4030.a
+++ /dev/null
@@ -1,414 +0,0 @@
--- CXA4030.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that Ada.Strings.Unbounded versions of subprograms Translate
--- (procedure and function), Index, and Count, which use a
--- Maps.Character_Mapping_Function input parameter, produce correct
--- results.
---
--- TEST DESCRIPTION:
--- This test examines the operation of the four subprograms contained
--- in the Ada.Strings.Unbounded package that use a
--- Character_Mapping_Function parameter to provide the mapping
--- capability.
--- Two Character_Mapping_Function objects are defined that reference
--- subprograms contained in the Ada.Characters.Handling package;
--- To_Lower will return the lower-case form of the character provided
--- as the input parameter, To_Upper will return the upper-case form
--- of the character input parameter (provided there is an upper-case
--- form).
--- In several instances in this test, the character handling functions
--- are referenced directly in the parameter list of the subprograms
--- under test, demonstrating another form of expected common usage.
---
--- Results of all subprograms are compared with expected results.
---
--- This test, when taken in conjunction with tests CXA4010, CXA4011,
--- CXA4031, and CXA4032 will constitute a test of all the functionality
--- contained in package Ada.Strings.Unbounded. This test uses a variety
--- of the subprograms defined in the unbounded string package in ways
--- typical of common usage.
---
---
--- CHANGE HISTORY:
--- 21 Feb 95 SAIC Initial prerelease version
--- 21 Apr 95 SAIC Modified header commentary.
---
---!
-
-with Ada.Strings.Unbounded;
-with Ada.Strings.Maps;
-with Ada.Characters.Handling;
-with Ada.Characters.Latin_1;
-with Report;
-
-procedure CXA4030 is
-
-begin
-
- Report.Test ("CXA4030", "Check that Ada.Strings.Unbounded versions " &
- "of subprograms Translate (procedure and " &
- "function), Index, and Count, which use a " &
- "Maps.Character_Mapping_Function input " &
- "parameter, produce correct results");
-
- Test_Block:
- declare
-
- package Unb renames Ada.Strings.Unbounded;
- use type Unb.Unbounded_String;
- use Ada.Strings;
- use Ada.Characters;
-
-
- -- The following strings are used in examination of the Translation
- -- subprograms.
-
- New_Character_String : Unb.Unbounded_String :=
- Unb.To_Unbounded_String(
- Latin_1.LC_A_Grave &
- Latin_1.LC_A_Ring &
- Latin_1.LC_AE_Diphthong &
- Latin_1.LC_C_Cedilla &
- Latin_1.LC_E_Acute &
- Latin_1.LC_I_Circumflex &
- Latin_1.LC_Icelandic_Eth &
- Latin_1.LC_N_Tilde &
- Latin_1.LC_O_Oblique_Stroke &
- Latin_1.LC_Icelandic_Thorn);
-
-
- TC_New_Character_String : Unb.Unbounded_String :=
- Unb.To_Unbounded_String(
- Latin_1.UC_A_Grave &
- Latin_1.UC_A_Ring &
- Latin_1.UC_AE_Diphthong &
- Latin_1.UC_C_Cedilla &
- Latin_1.UC_E_Acute &
- Latin_1.UC_I_Circumflex &
- Latin_1.UC_Icelandic_Eth &
- Latin_1.UC_N_Tilde &
- Latin_1.UC_O_Oblique_Stroke &
- Latin_1.UC_Icelandic_Thorn);
-
-
- -- In this test, access objects are defined to refer to two functions
- -- from the Ada.Characters.Handling package. These access objects
- -- will be provided as parameters to the subprograms under test.
- -- Note: There will be several examples in this test of these character
- -- handling functions being referenced directly within the
- -- parameter list of the subprograms under test.
-
- Map_To_Lower_Case_Ptr : Maps.Character_Mapping_Function :=
- Handling.To_Lower'Access;
-
- Map_To_Upper_Case_Ptr : Maps.Character_Mapping_Function :=
- Handling.To_Upper'Access;
-
- begin
-
- -- Function Index, Forward direction search.
- -- Note: Several of the following cases use the default value
- -- Forward for the Going parameter.
-
- if Unb.Index(Source => Unb.To_Unbounded_String(
- "The library package Strings.Unbounded"),
- Pattern => "unb",
- Going => Ada.Strings.Forward,
- Mapping => Map_To_Lower_Case_Ptr) /= 29 or
-
- Unb.Index(Unb.To_Unbounded_String(
- "THE RAIN IN SPAIN FALLS MAINLY ON THE PLAIN"),
- "ain",
- Mapping => Map_To_Lower_Case_Ptr) /= 6 or
-
- Unb.Index(Unb.To_Unbounded_String("maximum number"),
- "um",
- Ada.Strings.Forward,
- Handling.To_Lower'Access) /= 6 or
-
- Unb.Index(Unb.To_Unbounded_String("CoMpLeTeLy MiXeD CaSe StRiNg"),
- "MIXED CASE STRING",
- Ada.Strings.Forward,
- Map_To_Upper_Case_Ptr) /= 12 or
-
- Unb.Index(Unb.To_Unbounded_String(
- "STRING WITH NO MATCHING PATTERNS"),
- "WITH",
- Mapping => Map_To_Lower_Case_Ptr) /= 0 or
-
- Unb.Index(Unb.To_Unbounded_String("THIS STRING IS IN UPPER CASE"),
- "IS",
- Ada.Strings.Forward,
- Handling.To_Upper'Access) /= 3 or
-
- Unb.Index(Unb.Null_Unbounded_String,
- "is",
- Mapping => Map_To_Lower_Case_Ptr) /= 0 or
-
- Unb.Index(Unb.To_Unbounded_String("AAABBBaaabbb"),
- "aabb",
- Mapping => Handling.To_Lower'Access) /= 2
- then
- Report.Failed("Incorrect results from Function Index, going " &
- "in Forward direction, using a Character Mapping " &
- "Function parameter");
- end if;
-
-
-
- -- Function Index, Backward direction search.
-
- if Unb.Index(Unb.To_Unbounded_String("Case of a Mixed Case String"),
- "case",
- Ada.Strings.Backward,
- Map_To_Lower_Case_Ptr) /= 17 or
-
- Unb.Index(Unb.To_Unbounded_String("Case of a Mixed Case String"),
- "CASE",
- Ada.Strings.Backward,
- Mapping => Map_To_Upper_Case_Ptr) /= 17 or
-
- Unb.Index(Unb.To_Unbounded_String("rain, Rain, and more RAIN"),
- "rain",
- Ada.Strings.Backward,
- Handling.To_Lower'Access) /= 22 or
-
- Unb.Index(Unb.To_Unbounded_String("RIGHT place, right time"),
- "RIGHT",
- Ada.Strings.Backward,
- Handling.To_Upper'Access) /= 14 or
-
- Unb.Index(Unb.To_Unbounded_String("WOULD MATCH BUT FOR THE CASE"),
- "WOULD MATCH BUT FOR THE CASE",
- Going => Ada.Strings.Backward,
- Mapping => Map_To_Lower_Case_Ptr) /= 0
- then
- Report.Failed("Incorrect results from Function Index, going " &
- "in Backward direction, using a Character Mapping " &
- "Function parameter");
- end if;
-
-
-
- -- Function Index, Pattern_Error if Pattern = Null_String
-
- declare
- use Unbounded;
- Null_String : constant String := "";
- TC_Natural : Natural := 1000;
- begin
- TC_Natural := Index(To_Unbounded_String("A Valid Unbounded String"),
- Null_String,
- Going => Ada.Strings.Forward,
- Mapping => Handling.To_Lower'Access);
- Report.Failed("Pattern_Error not raised by Function Index when " &
- "given a null pattern string");
- exception
- when Pattern_Error => null; -- OK, expected exception.
- when others =>
- Report.Failed("Incorrect exception raised by Function Index " &
- "using a Character Mapping Function parameter " &
- "when given a null pattern string");
- end;
-
-
-
- -- Function Count.
-
- if Unb.Count(Source => Unb.To_Unbounded_String("ABABABA"),
- Pattern => "aba",
- Mapping => Map_To_Lower_Case_Ptr) /= 2 or
-
- Unb.Count(Unb.To_Unbounded_String("ABABABA"),
- "ABA",
- Mapping => Map_To_Lower_Case_Ptr) /= 0 or
-
- Unb.Count(Unb.To_Unbounded_String("This IS a MISmatched issue"),
- "is",
- Handling.To_Lower'Access) /= 4 or
-
- Unb.Count(Unb.To_Unbounded_String("ABABABA"),
- "ABA",
- Map_To_Upper_Case_Ptr) /= 2 or
-
- Unb.Count(Unb.To_Unbounded_String("This IS a MISmatched issue"),
- "is",
- Mapping => Map_To_Upper_Case_Ptr) /= 0 or
-
- Unb.Count(Unb.To_Unbounded_String(
- "She sells sea shells by the sea shore"),
- "s",
- Handling.To_Lower'Access) /= 8 or
-
- Unb.Count(Unb.Null_Unbounded_String,
- "match",
- Map_To_Upper_Case_Ptr) /= 0
- then
- Report.Failed("Incorrect results from Function Count, using " &
- "a Character Mapping Function parameter");
- end if;
-
-
-
- -- Function Count, Pattern_Error if Pattern = Null_String
-
- declare
- use Ada.Strings.Unbounded;
- Null_Pattern_String : constant String := "";
- TC_Natural : Natural := 1000;
- begin
- TC_Natural := Count(To_Unbounded_String("A Valid String"),
- Null_Pattern_String,
- Map_To_Lower_Case_Ptr);
- Report.Failed("Pattern_Error not raised by Function Count using " &
- "a Character Mapping Function parameter when " &
- "given a null pattern string");
- exception
- when Pattern_Error => null; -- OK, expected exception.
- when others =>
- Report.Failed("Incorrect exception raised by Function Count " &
- "using a Character Mapping Function parameter " &
- "when given a null pattern string");
- end;
-
-
-
- -- Function Translate.
-
- if Unb.Translate(Source => Unb.To_Unbounded_String(
- "A Sample Mixed Case String"),
- Mapping => Map_To_Lower_Case_Ptr) /=
- Unb.To_Unbounded_String("a sample mixed case string") or
-
- Unb.Translate(Unb.To_Unbounded_String("ALL LOWER CASE"),
- Handling.To_Lower'Access) /=
- Unb.To_Unbounded_String("all lower case") or
-
- Unb.Translate(Unb.To_Unbounded_String("end with lower case"),
- Map_To_Lower_Case_Ptr) /=
- Unb.To_Unbounded_String("end with lower case") or
-
- Unb.Translate(Unb.Null_Unbounded_String,
- Handling.To_Lower'Access) /=
- Unb.Null_Unbounded_String or
-
- Unb.Translate(Unb.To_Unbounded_String("start with lower case"),
- Map_To_Upper_Case_Ptr) /=
- Unb.To_Unbounded_String("START WITH LOWER CASE") or
-
- Unb.Translate(Unb.To_Unbounded_String("ALL UPPER CASE STRING"),
- Handling.To_Upper'Access) /=
- Unb.To_Unbounded_String("ALL UPPER CASE STRING") or
-
- Unb.Translate(Unb.To_Unbounded_String(
- "LoTs Of MiXeD CaSe ChArAcTeRs"),
- Map_To_Upper_Case_Ptr) /=
- Unb.To_Unbounded_String("LOTS OF MIXED CASE CHARACTERS") or
-
- Unb.Translate(New_Character_String,
- Handling.To_Upper'Access) /=
- TC_New_Character_String
-
- then
- Report.Failed("Incorrect results from Function Translate, using " &
- "a Character Mapping Function parameter");
- end if;
-
-
-
- -- Procedure Translate.
-
- declare
-
- use Ada.Strings.Unbounded;
- use Ada.Characters.Handling;
-
- Str_1 : Unbounded_String :=
- To_Unbounded_String("AN ALL UPPER CASE STRING");
- Str_2 : Unbounded_String :=
- To_Unbounded_String("A Mixed Case String");
- Str_3 : Unbounded_String :=
- To_Unbounded_String("a string with lower case letters");
- TC_Str_1 : constant Unbounded_String := Str_1;
- TC_Str_3 : constant Unbounded_String := Str_3;
-
- begin
-
- Translate(Source => Str_1, Mapping => Map_To_Lower_Case_Ptr);
-
- if Str_1 /= To_Unbounded_String("an all upper case string") then
- Report.Failed("Incorrect result from Procedure Translate - 1");
- end if;
-
- Translate(Source => Str_1, Mapping => Map_To_Upper_Case_Ptr);
-
- if Str_1 /= TC_Str_1 then
- Report.Failed("Incorrect result from Procedure Translate - 2");
- end if;
-
- Translate(Str_2, Mapping => Map_To_Lower_Case_Ptr);
-
- if Str_2 /= To_Unbounded_String("a mixed case string") then
- Report.Failed("Incorrect result from Procedure Translate - 3");
- end if;
-
- Translate(Str_2, Mapping => To_Upper'Access);
-
- if Str_2 /= To_Unbounded_String("A MIXED CASE STRING") then
- Report.Failed("Incorrect result from Procedure Translate - 4");
- end if;
-
- Translate(Str_3, To_Lower'Access);
-
- if Str_3 /= TC_Str_3 then
- Report.Failed("Incorrect result from Procedure Translate - 5");
- end if;
-
- Translate(Str_3, To_Upper'Access);
-
- if Str_3 /=
- To_Unbounded_String("A STRING WITH LOWER CASE LETTERS")
- then
- Report.Failed("Incorrect result from Procedure Translate - 6");
- end if;
-
- Translate(New_Character_String, Map_To_Upper_Case_Ptr);
-
- if New_Character_String /= TC_New_Character_String then
- Report.Failed("Incorrect result from Procedure Translate - 6");
- end if;
-
- end;
-
-
- exception
- when others => Report.Failed ("Exception raised in Test_Block");
- end Test_Block;
-
- Report.Result;
-
-end CXA4030;
diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxa4031.a b/gcc/testsuite/ada/acats/tests/cxa/cxa4031.a
deleted file mode 100644
index 91bc68ce6e7..00000000000
--- a/gcc/testsuite/ada/acats/tests/cxa/cxa4031.a
+++ /dev/null
@@ -1,291 +0,0 @@
--- CXA4031.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that the subprograms defined in package Ada.Strings.Unbounded
--- are available, and that they produce correct results. Specifically,
--- check the functions To_Unbounded_String (version with Length
--- parameter), "=", "<", "<=", ">", ">=" (all with String-Unbounded
--- String parameter mix), as well as three versions of Procedure Append.
---
--- TEST DESCRIPTION:
--- This test demonstrates the uses of many of the subprograms defined
--- in package Ada.Strings.Unbounded for use with unbounded strings.
--- The test simulates how unbounded strings could be processed in a
--- user environment, using the subprograms provided in this package.
---
--- This test, when taken in conjunction with tests CXA4010, CXA4011,
--- CXA4030, and CXA4032 will constitute a test of all the functionality
--- contained in package Ada.Strings.Unbounded. This test uses a variety
--- of the subprograms defined in the unbounded string package in ways
--- typical of common usage.
---
---
--- CHANGE HISTORY:
--- 27 Feb 95 SAIC Initial prerelease version.
--- 18 Apr 96 SAIC Incorporated reviewer comments for ACVC 2.1.
---
---!
-
-with Report;
-with Ada.Exceptions;
-with Ada.Strings.Maps;
-with Ada.Strings.Unbounded;
-
-procedure CXA4031 is
-begin
-
- Report.Test ("CXA4031", "Check that the subprograms defined in " &
- "package Ada.Strings.Unbounded are available, " &
- "and that they produce correct results");
-
- Test_Block:
- declare
-
- package Unb renames Ada.Strings.Unbounded;
- use Unb;
- use Ada.Exceptions;
-
- subtype LC_Characters is Character range 'a'..'z';
-
- Null_String : constant String := "";
- TC_String : constant String := "A Standard String";
-
- TC_Unb_String,
- TC_New_Unb_String : Unb.Unbounded_String := Unb.Null_Unbounded_String;
-
- begin
-
- -- Function To_Unbounded_String (version with Length parameter)
- -- returns an unbounded string that represents an uninitialized String
- -- whose length is Length.
- -- Note: Unbounded_String length can vary conceptually between 0 and
- -- Natural'Last.
-
- if Unb.Length(Unb.To_Unbounded_String(Length => 10)) /= 10 or
- Unb.Length(Unb.To_Unbounded_String(1)) /= 1 or
- Unb.Length(Unb.To_Unbounded_String(0)) /= 0 or
- Unb.Length(Unb."&"(Unb.To_Unbounded_String(Length => 10),
- Unb."&"(Unb.To_Unbounded_String(1),
- Unb.To_Unbounded_String(0) ))) /= 10+1+0
- then
- Report.Failed
- ("Incorrect results from Function To_Unbounded_String with " &
- "Length parameter");
- end if;
-
-
- -- Procedure Append (Unbounded - Unbounded)
- -- Note: For each of the Append procedures, the resulting string
- -- represented by the Source parameter is given by the
- -- concatenation of the original value of Source and the value
- -- of New_Item.
-
- TC_Unb_String := Unb.To_Unbounded_String("Sample string of length L");
- TC_New_Unb_String := Unb.To_Unbounded_String(" and then some");
-
- Unb.Append(Source => TC_Unb_String, New_Item => TC_New_Unb_String);
-
- if TC_Unb_String /=
- Unb.To_Unbounded_String("Sample string of length L and then some")
- then
- Report.Failed("Incorrect results from Procedure Append with " &
- "unbounded string parameters - 1");
- end if;
-
-
- TC_Unb_String := Unb.To_Unbounded_String("Sample string of length L");
- TC_New_Unb_String := Unb.Null_Unbounded_String;
-
- Unb.Append(TC_Unb_String, TC_New_Unb_String);
-
- if TC_Unb_String /=
- Unb.To_Unbounded_String("Sample string of length L")
- then
- Report.Failed("Incorrect results from Procedure Append with " &
- "unbounded string parameters - 2");
- end if;
-
-
- TC_Unb_String := Unb.Null_Unbounded_String;
-
- Unb.Append(TC_Unb_String,
- Unb.To_Unbounded_String("New Unbounded String"));
-
- if TC_Unb_String /=
- Unb.To_Unbounded_String("New Unbounded String")
- then
- Report.Failed("Incorrect results from Procedure Append with " &
- "unbounded string parameters - 3");
- end if;
-
-
- -- Procedure Append (Unbounded - String)
-
- TC_Unb_String := Unb.To_Unbounded_String("An Unbounded String and ");
-
- Unb.Append(Source => TC_Unb_String, New_Item => TC_String);
-
- if TC_Unb_String /=
- Unb.To_Unbounded_String("An Unbounded String and A Standard String")
- then
- Report.Failed("Incorrect results from Procedure Append with " &
- "an unbounded string parameter and a string " &
- "parameter - 1");
- end if;
-
-
- TC_Unb_String := Unb.To_Unbounded_String("An Unbounded String");
-
- Unb.Append(TC_Unb_String, New_Item => Null_String);
-
- if TC_Unb_String /=
- Unb.To_Unbounded_String("An Unbounded String")
- then
- Report.Failed("Incorrect results from Procedure Append with " &
- "an unbounded string parameter and a string " &
- "parameter - 2");
- end if;
-
-
- TC_Unb_String := Unb.Null_Unbounded_String;
-
- Unb.Append(TC_Unb_String, TC_String);
-
- if TC_Unb_String /= Unb.To_Unbounded_String("A Standard String") then
- Report.Failed("Incorrect results from Procedure Append with " &
- "an unbounded string parameter and a string " &
- "parameter - 3");
- end if;
-
-
- -- Procedure Append (Unbounded - Character)
-
- TC_Unb_String := Unb.To_Unbounded_String("Lower Case = ");
-
- for i in LC_Characters'Range loop
- Unb.Append(Source => TC_Unb_String, New_Item => LC_Characters(i));
- end loop;
-
- if TC_Unb_String /=
- Unb.To_Unbounded_String("Lower Case = abcdefghijklmnopqrstuvwxyz")
- then
- Report.Failed("Incorrect results from Procedure Append with " &
- "an unbounded string parameter and a character " &
- "parameter - 1");
- end if;
-
-
- TC_Unb_String := Unb.Null_Unbounded_String;
-
- Unb.Append(TC_Unb_String, New_Item => 'a');
-
- if TC_Unb_String /= Unb.To_Unbounded_String("a") then
- Report.Failed("Incorrect results from Procedure Append with " &
- "an unbounded string parameter and a character " &
- "parameter - 2");
- end if;
-
-
- -- Function "="
-
- TC_Unb_String := Unb.To_Unbounded_String(TC_String);
-
- if not (TC_Unb_String = TC_String) or -- (Unb_Str, Str)
- not Unb."="("A Standard String", TC_Unb_String) or -- (Str, Unb_Str)
- not ((Unb.Null_Unbounded_String = "") and -- (Unb_Str, Str)
- ("Test String" = -- (Str, Unb_Str)
- Unb.To_Unbounded_String("Test String")))
- then
- Report.Failed("Incorrect results from function ""="" with " &
- "string - unbounded string parameter combinations");
- end if;
-
-
- -- Function "<"
-
- if not ("Extra Space" < Unb.To_Unbounded_String("Extra Space ") and
- Unb.To_Unbounded_String("tess") < "test" and
- Unb.To_Unbounded_String("best") < "test") or
- Unb.Null_Unbounded_String < Null_String or
- " leading blank" < Unb.To_Unbounded_String(" leading blank") or
- "ending blank " < Unb.To_Unbounded_String("ending blank ")
- then
- Report.Failed("Incorrect results from function ""<"" with " &
- "string - unbounded string parameter combinations");
- end if;
-
-
- -- Function "<="
-
- TC_Unb_String := Unb.To_Unbounded_String("Sample string");
-
- if TC_Unb_String <= "Sample strin" or -- (Unb_Str, Str)
- "sample string" <= TC_Unb_String or -- (Str, Unb_Str)
- not(Unb.Null_Unbounded_String <= "") or -- (Unb_Str, Str)
- not("Sample string" <= TC_Unb_String) -- (Str, Unb_Str)
- then
- Report.Failed("Incorrect results from function ""<="" with " &
- "string - unbounded string parameter combinations");
- end if;
-
-
- -- Function ">"
-
- TC_Unb_String := Unb.To_Unbounded_String("A MUCH LONGER STRING");
-
- if not ("A much longer string" > TC_Unb_String and
- Unb.To_Unbounded_String(TC_String) > "A Standard Strin" and
- "abcdefgh" > Unb.To_Unbounded_String("ABCDEFGH")) or
- Unb.Null_Unbounded_String > Null_String
- then
- Report.Failed("Incorrect results from function "">"" with " &
- "string - unbounded string parameter combinations");
- end if;
-
-
- -- Function ">="
-
- TC_Unb_String := Unb.To_Unbounded_String(TC_String);
-
- if not (TC_Unb_String >= TC_String and
- Null_String >= Unb.Null_Unbounded_String and
- "test" >= Unb.To_Unbounded_String("tess") and
- Unb.To_Unbounded_String("Programming") >= "PROGRAMMING")
- then
- Report.Failed("Incorrect results from function "">="" with " &
- "string - unbounded string parameter combinations");
- end if;
-
-
- exception
- when The_Error : others =>
- Report.Failed ("The following exception was raised in the " &
- "Test_Block: " & Exception_Name(The_Error));
- end Test_Block;
-
- Report.Result;
-
-end CXA4031;
diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxa4032.a b/gcc/testsuite/ada/acats/tests/cxa/cxa4032.a
deleted file mode 100644
index 031d01c6cb7..00000000000
--- a/gcc/testsuite/ada/acats/tests/cxa/cxa4032.a
+++ /dev/null
@@ -1,457 +0,0 @@
--- CXA4032.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that procedures defined in package Ada.Strings.Unbounded
--- are available, and that they produce correct results. Specifically,
--- check the procedures Replace_Slice, Insert, Overwrite, Delete,
--- Trim (2 versions), Head, and Tail.
---
--- TEST DESCRIPTION:
--- This test demonstrates the uses of many of the procedures defined
--- in package Ada.Strings.Unbounded for use with unbounded strings.
--- The test simulates how unbounded strings could be processed in a
--- user environment, using the procedures provided in this package.
---
--- This test, when taken in conjunction with tests CXA4010, CXA4011,
--- CXA4030, and CXA4031 will constitute a test of all the functionality
--- contained in package Ada.Strings.Unbounded. This test uses a variety
--- of the procedures defined in the unbounded string package in ways
--- typical of common usage.
---
---
--- CHANGE HISTORY:
--- 02 Mar 95 SAIC Initial prerelease version.
---
---!
-
-with Report;
-with Ada.Strings;
-with Ada.Strings.Maps;
-with Ada.Strings.Maps.Constants;
-with Ada.Strings.Unbounded;
-
-procedure CXA4032 is
-begin
-
- Report.Test ("CXA4032", "Check that the subprograms defined in " &
- "package Ada.Strings.Unbounded are available, " &
- "and that they produce correct results");
-
- Test_Block:
- declare
-
- package Unb renames Ada.Strings.Unbounded;
- use Unb;
- use Ada.Strings;
-
- TC_Null_String : constant String := "";
- TC_String_5 : String(1..5) := "ABCDE";
-
- TC_Unb_String : Unb.Unbounded_String :=
- Unb.To_Unbounded_String("Test String");
-
- begin
-
- -- Procedure Replace_Slice
-
- begin -- Low > Source'Last+1
- Unb.Replace_Slice(Source => TC_Unb_String,
- Low => Unb.Length(TC_Unb_String) + 2,
- High => Unb.Length(TC_Unb_String),
- By => TC_String_5);
- Report.Failed("Index_Error not raised by Replace_Slice when Low " &
- "> Source'Last+1");
- exception
- when Index_Error => null; -- OK, expected exception.
- when others =>
- Report.Failed("Unexpected exception raised by Replace_Slice" &
- "when Low > Source'Last+1");
- end;
-
- -- High >= Low
-
- TC_Unb_String := Unb.To_Unbounded_String("Test String");
-
- Unb.Replace_Slice(TC_Unb_String, 5, 5, TC_String_5);
-
- if TC_Unb_String /= Unb.To_Unbounded_String("TestABCDEString") then
- Report.Failed("Incorrect results from Replace_Slice - 1");
- end if;
-
- Unb.Replace_Slice(TC_Unb_String, 1, 4, TC_String_5);
-
- if TC_Unb_String /= Unb.To_Unbounded_String("ABCDEABCDEString") then
- Report.Failed("Incorrect results from Replace_Slice - 2");
- end if;
-
- Unb.Replace_Slice(TC_Unb_String,
- 11,
- Unb.Length(TC_Unb_String),
- TC_Null_String);
-
- if TC_Unb_String /= Unb.To_Unbounded_String("ABCDEABCDE") then
- Report.Failed("Incorrect results from Replace_Slice - 3");
- end if;
-
- -- High < Low
-
- Unb.Replace_Slice(TC_Unb_String, Low => 4, High => 1, By => "xxx");
-
- if TC_Unb_String /= Unb.To_Unbounded_String("ABCxxxDEABCDE") then
- Report.Failed("Incorrect results from Replace_Slice - 4");
- end if;
-
- Unb.Replace_Slice(TC_Unb_String, Low => 1, High => 0, By => "yyy");
-
- if TC_Unb_String /= Unb.To_Unbounded_String("yyyABCxxxDEABCDE") then
- Report.Failed("Incorrect results from Replace_Slice - 5");
- end if;
-
- Unb.Replace_Slice(TC_Unb_String,
- Unb.Length(TC_Unb_String) + 1,
- Unb.Length(TC_Unb_String),
- By => "zzz");
-
- if TC_Unb_String /= Unb.To_Unbounded_String("yyyABCxxxDEABCDEzzz") then
- Report.Failed("Incorrect results from Replace_Slice - 6");
- end if;
-
-
- -- Procedure Insert
-
- TC_Unb_String := Unb.To_Unbounded_String("Test String");
-
- begin -- Before not in Source'First..Source'Last + 1
- Unb.Insert(Source => TC_Unb_String,
- Before => Unb.Length(TC_Unb_String) + 2,
- New_Item => TC_String_5);
- Report.Failed("Index_Error not raised by Insert when Before " &
- "not in the range Source'First..Source'Last+1");
- exception
- when Index_Error => null; -- OK, expected exception.
- when others =>
- Report.Failed
- ("Unexpected exception raised by Insert when Before not in " &
- "the range Source'First..Source'Last+1");
- end;
-
- Unb.Insert(TC_Unb_String, 1, "**");
-
- if TC_Unb_String /= Unb.To_Unbounded_String("**Test String") then
- Report.Failed("Incorrect results from Insert - 1");
- end if;
-
- Unb.Insert(TC_Unb_String, Unb.Length(TC_Unb_String)+1, "**");
-
- if TC_Unb_String /= Unb.To_Unbounded_String("**Test String**") then
- Report.Failed("Incorrect results from Insert - 2");
- end if;
-
- Unb.Insert(TC_Unb_String, 8, "---");
-
- if TC_Unb_String /= Unb.To_Unbounded_String("**Test ---String**") then
- Report.Failed("Incorrect results from Insert - 3");
- end if;
-
- Unb.Insert(TC_Unb_String, 3, TC_Null_String);
-
- if TC_Unb_String /= Unb.To_Unbounded_String("**Test ---String**") then
- Report.Failed("Incorrect results from Insert - 4");
- end if;
-
-
- -- Procedure Overwrite
-
- begin -- Position not in Source'First..Source'Last + 1
- Unb.Overwrite(Source => TC_Unb_String,
- Position => Unb.Length(TC_Unb_String) + 2,
- New_Item => TC_String_5);
- Report.Failed("Index_Error not raised by Overwrite when Position " &
- "not in the range Source'First..Source'Last+1");
- exception
- when Index_Error => null; -- OK, expected exception.
- when others =>
- Report.Failed
- ("Unexpected exception raised by Overwrite when Position not " &
- "in the range Source'First..Source'Last+1");
- end;
-
- TC_Unb_String := Unb.To_Unbounded_String("Test String");
-
- Unb.Overwrite(Source => TC_Unb_String,
- Position => 1,
- New_Item => "XXXX");
-
- if TC_Unb_String /= Unb.To_Unbounded_String("XXXX String") then
- Report.Failed("Incorrect results from Overwrite - 1");
- end if;
-
- Unb.Overwrite(TC_Unb_String, Unb.Length(TC_Unb_String)+1, "**");
-
- if TC_Unb_String /= Unb.To_Unbounded_String("XXXX String**") then
- Report.Failed("Incorrect results from Overwrite - 2");
- end if;
-
- Unb.Overwrite(TC_Unb_String, 3, TC_Null_String);
-
- if TC_Unb_String /= Unb.To_Unbounded_String("XXXX String**") then
- Report.Failed("Incorrect results from Overwrite - 3");
- end if;
-
- Unb.Overwrite(TC_Unb_String, 1, "abcdefghijklmn");
-
- if TC_Unb_String /= Unb.To_Unbounded_String("abcdefghijklmn") then
- Report.Failed("Incorrect results from Overwrite - 4");
- end if;
-
-
- -- Procedure Delete
-
- TC_Unb_String := Unb.To_Unbounded_String("Test String");
-
- -- From > Through (No change to Source)
-
- Unb.Delete(Source => TC_Unb_String,
- From => Unb.Length(TC_Unb_String),
- Through => Unb.Length(TC_Unb_String)-1);
-
- if TC_Unb_String /= Unb.To_Unbounded_String("Test String") then
- Report.Failed("Incorrect results from Delete - 1");
- end if;
-
- Unb.Delete(TC_Unb_String, 1, 0);
-
- if TC_Unb_String /= Unb.To_Unbounded_String("Test String") then
- Report.Failed("Incorrect results from Delete - 2");
- end if;
-
- -- From <= Through
-
- Unb.Delete(TC_Unb_String, 1, 5);
-
- if TC_Unb_String /= Unb.To_Unbounded_String("String") then
- Report.Failed("Incorrect results from Delete - 3");
- end if;
-
- Unb.Delete(TC_Unb_String, 3, 3);
-
- if TC_Unb_String /= Unb.To_Unbounded_String("Sting") then
- Report.Failed("Incorrect results from Delete - 4");
- end if;
-
-
- -- Procedure Trim
-
- TC_Unb_String := Unb.To_Unbounded_String("No Spaces");
-
- Unb.Trim(Source => TC_Unb_String, Side => Ada.Strings.Both);
-
- if TC_Unb_String /= Unb.To_Unbounded_String("No Spaces") then
- Report.Failed("Incorrect results from Trim - 1");
- end if;
-
- TC_Unb_String := Unb.To_Unbounded_String(" Leading Spaces ");
-
- Unb.Trim(TC_Unb_String, Ada.Strings.Left);
-
- if TC_Unb_String /= Unb.To_Unbounded_String("Leading Spaces ") then
- Report.Failed("Incorrect results from Trim - 2");
- end if;
-
- TC_Unb_String := Unb.To_Unbounded_String(" Ending Spaces ");
-
- Unb.Trim(TC_Unb_String, Ada.Strings.Right);
-
- if TC_Unb_String /= Unb.To_Unbounded_String(" Ending Spaces") then
- Report.Failed("Incorrect results from Trim - 3");
- end if;
-
- TC_Unb_String :=
- Unb.To_Unbounded_String(" Spaces on both ends ");
-
- Unb.Trim(TC_Unb_String, Ada.Strings.Both);
-
- if TC_Unb_String /=
- Unb.To_Unbounded_String("Spaces on both ends")
- then
- Report.Failed("Incorrect results from Trim - 4");
- end if;
-
-
- -- Procedure Trim (with Character Set parameters)
-
- TC_Unb_String := Unb.To_Unbounded_String("lowerCASEletters");
-
- Unb.Trim(Source => TC_Unb_String,
- Left => Ada.Strings.Maps.Constants.Lower_Set,
- Right => Ada.Strings.Maps.Constants.Lower_Set);
-
- if TC_Unb_String /= Unb.To_Unbounded_String("CASE") then
- Report.Failed("Incorrect results from Trim with Sets - 1");
- end if;
-
- TC_Unb_String := Unb.To_Unbounded_String("lowerCASEletters");
-
- Unb.Trim(TC_Unb_String,
- Ada.Strings.Maps.Constants.Upper_Set,
- Ada.Strings.Maps.Constants.Upper_Set);
-
- if TC_Unb_String /= Unb.To_Unbounded_String("lowerCASEletters") then
- Report.Failed("Incorrect results from Trim with Sets - 2");
- end if;
-
- TC_Unb_String := Unb.To_Unbounded_String("012abcdefghGFEDCBA789ab");
-
- Unb.Trim(TC_Unb_String,
- Ada.Strings.Maps.Constants.Hexadecimal_Digit_Set,
- Ada.Strings.Maps.Constants.Hexadecimal_Digit_Set);
-
- if TC_Unb_String /= Unb.To_Unbounded_String("ghG") then
- Report.Failed("Incorrect results from Trim with Sets - 3");
- end if;
-
-
- -- Procedure Head
-
- -- Count <= Source'Length
-
- TC_Unb_String := Unb.To_Unbounded_String("Test String");
-
- Unb.Head(Source => TC_Unb_String,
- Count => 0,
- Pad => '*');
-
- if TC_Unb_String /= Unb.Null_Unbounded_String then
- Report.Failed("Incorrect results from Head - 1");
- end if;
-
- TC_Unb_String := Unb.To_Unbounded_String("Test String");
-
- Unb.Head(Source => TC_Unb_String,
- Count => 4,
- Pad => '*');
-
- if TC_Unb_String /= Unb.To_Unbounded_String("Test") then
- Report.Failed("Incorrect results from Head - 2");
- end if;
-
- TC_Unb_String := Unb.To_Unbounded_String("Test String");
-
- Unb.Head(Source => TC_Unb_String,
- Count => Unb.Length(TC_Unb_String),
- Pad => '*');
-
- if TC_Unb_String /= Unb.To_Unbounded_String("Test String") then
- Report.Failed("Incorrect results from Head - 3");
- end if;
-
- -- Count > Source'Length
-
- TC_Unb_String := Unb.To_Unbounded_String("Test String");
-
- Unb.Head(Source => TC_Unb_String,
- Count => Unb.Length(TC_Unb_String) + 4,
- Pad => '*');
-
- if TC_Unb_String /= Unb.To_Unbounded_String("Test String****") then
- Report.Failed("Incorrect results from Head - 4");
- end if;
-
- TC_Unb_String := Unb.Null_Unbounded_String;
-
- Unb.Head(Source => TC_Unb_String,
- Count => Unb.Length(TC_Unb_String) + 3,
- Pad => '*');
-
- if TC_Unb_String /= Unb.To_Unbounded_String("***") then
- Report.Failed("Incorrect results from Head - 5");
- end if;
-
-
- -- Procedure Tail
-
- -- Count <= Source'Length
-
- TC_Unb_String := Unb.To_Unbounded_String("Test String");
-
- Unb.Tail(Source => TC_Unb_String,
- Count => 0,
- Pad => '*');
-
- if TC_Unb_String /= Unb.Null_Unbounded_String then
- Report.Failed("Incorrect results from Tail - 1");
- end if;
-
- TC_Unb_String := Unb.To_Unbounded_String("Test String");
-
- Unb.Tail(Source => TC_Unb_String,
- Count => 6,
- Pad => '*');
-
- if TC_Unb_String /= Unb.To_Unbounded_String("String") then
- Report.Failed("Incorrect results from Tail - 2");
- end if;
-
- TC_Unb_String := Unb.To_Unbounded_String("Test String");
-
- Unb.Tail(Source => TC_Unb_String,
- Count => Unb.Length(TC_Unb_String),
- Pad => '*');
-
- if TC_Unb_String /= Unb.To_Unbounded_String("Test String") then
- Report.Failed("Incorrect results from Tail - 3");
- end if;
-
- -- Count > Source'Length
-
- TC_Unb_String := Unb.To_Unbounded_String("Test String");
-
- Unb.Tail(Source => TC_Unb_String,
- Count => Unb.Length(TC_Unb_String) + 5,
- Pad => 'x');
-
- if TC_Unb_String /= Unb.To_Unbounded_String("xxxxxTest String") then
- Report.Failed("Incorrect results from Tail - 4");
- end if;
-
- TC_Unb_String := Unb.Null_Unbounded_String;
-
- Unb.Tail(Source => TC_Unb_String,
- Count => Unb.Length(TC_Unb_String) + 3,
- Pad => 'X');
-
- if TC_Unb_String /= Unb.To_Unbounded_String("XXX") then
- Report.Failed("Incorrect results from Tail - 5");
- end if;
-
-
- exception
- when others => Report.Failed ("Exception raised in Test_Block");
- end Test_Block;
-
- Report.Result;
-
-end CXA4032;
diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxa4033.a b/gcc/testsuite/ada/acats/tests/cxa/cxa4033.a
deleted file mode 100644
index 8f39b4cff05..00000000000
--- a/gcc/testsuite/ada/acats/tests/cxa/cxa4033.a
+++ /dev/null
@@ -1,405 +0,0 @@
--- CXA4033.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that the functionality found in packages Ada.Strings.Wide_Maps,
--- Ada.Strings.Wide_Unbounded, and Ada.Strings.Wide_Maps.Wide_Constants
--- is available and produces correct results.
---
--- TEST DESCRIPTION:
--- This test tests the subprograms found in the
--- Ada.Strings.Wide_Unbounded package. It is based on the tests
--- CXA4030-32, which are tests for the complementary "non-wide"
--- packages.
---
--- The functions found in CXA4033_0 provide mapping capability, when
--- used in conjunction with Wide_Character_Mapping_Function objects.
---
---
--- CHANGE HISTORY:
--- 23 Jun 95 SAIC Initial prerelease version.
--- 24 Feb 97 PWB.CTA Removed attempt to create wide string of length
--- Natural'Last
---!
-
-package CXA4033_0 is
- -- Functions used to supply mapping capability.
- function Map_To_Lower_Case (From : Wide_Character) return Wide_Character;
- function Map_To_Upper_Case (From : Wide_Character) return Wide_Character;
-end CXA4033_0;
-
-with Ada.Characters.Handling;
-package body CXA4033_0 is
- -- Function Map_To_Lower_Case will return the lower case form of
- -- Wide_Characters in the range 'A'..'Z' only, and return the input
- -- wide_character otherwise.
-
- function Map_To_Lower_Case (From : Wide_Character)
- return Wide_Character is
- begin
- return Ada.Characters.Handling.To_Wide_Character(
- Ada.Characters.Handling.To_Lower(
- Ada.Characters.Handling.To_Character(From)));
- end Map_To_Lower_Case;
-
- -- Function Map_To_Upper_Case will return the upper case form of
- -- Wide_Characters in the range 'a'..'z', or whose position is in one
- -- of the ranges 223..246 or 248..255, provided the wide_character has
- -- an upper case form.
-
- function Map_To_Upper_Case (From : Wide_Character)
- return Wide_Character is
- begin
- return Ada.Characters.Handling.To_Wide_Character(
- Ada.Characters.Handling.To_Upper(
- Ada.Characters.Handling.To_Character(From)));
- end Map_To_Upper_Case;
-
-end CXA4033_0;
-
-
-with CXA4033_0;
-with Report;
-with Ada.Characters.Handling;
-with Ada.Characters.Latin_1;
-with Ada.Strings;
-with Ada.Strings.Wide_Maps;
-with Ada.Strings.Wide_Maps.Wide_Constants;
-with Ada.Strings.Wide_Fixed;
-with Ada.Strings.Wide_Unbounded;
-
-procedure CXA4033 is
-begin
- Report.Test ("CXA4033",
- "Check that subprograms defined in the package " &
- "Ada.Strings.Wide_Unbounded produce correct results");
-
- Test_Block:
- declare
-
- package ACL1 renames Ada.Characters.Latin_1;
- package Unb renames Ada.Strings.Wide_Unbounded;
-
- subtype LC_Characters is Wide_Character range 'a'..'z';
-
- use Ada.Characters, Ada.Strings, Unb;
- use type Wide_Maps.Wide_Character_Set;
-
- TC_String : constant Wide_String := "A Standard String";
-
- String_20 : Wide_String(1..20) := "ABCDEFGHIJKLMNOPQRST";
- String_40 : Wide_String(1..40) := "abcdefghijklmnopqrst" &
- String_20;
- String_80 : Wide_String(1..80) := String_40 & String_40;
- TC_String_5 : Wide_String(1..5) := "ABCDE";
- TC_Unb_String : Unbounded_Wide_String := Null_Unbounded_Wide_String;
-
- -- The following strings are used in examination of the Translation
- -- subprograms.
- New_Character_String : Wide_String(1..10) :=
- Handling.To_Wide_String(
- ACL1.LC_A_Grave & ACL1.LC_A_Ring & ACL1.LC_AE_Diphthong &
- ACL1.LC_C_Cedilla & ACL1.LC_E_Acute & ACL1.LC_I_Circumflex &
- ACL1.LC_Icelandic_Eth & ACL1.LC_N_Tilde &
- ACL1.LC_O_Oblique_Stroke & ACL1.LC_Icelandic_Thorn);
-
- TC_New_Character_String : Wide_String(1..10) :=
- Handling.To_Wide_String(
- ACL1.UC_A_Grave & ACL1.UC_A_Ring & ACL1.UC_AE_Diphthong &
- ACL1.UC_C_Cedilla & ACL1.UC_E_Acute & ACL1.UC_I_Circumflex &
- ACL1.UC_Icelandic_Eth & ACL1.UC_N_Tilde &
- ACL1.UC_O_Oblique_Stroke & ACL1.UC_Icelandic_Thorn);
-
- New_UB_Character_String : Unbounded_Wide_String :=
- To_Unbounded_Wide_String(New_Character_String);
-
- TC_New_UB_Character_String : Unbounded_Wide_String :=
- To_Unbounded_Wide_String(TC_New_Character_String);
-
- -- Access objects that will be provided as parameters to the
- -- subprograms.
- Map_To_Lower_Case_Ptr : Wide_Maps.Wide_Character_Mapping_Function :=
- CXA4033_0.Map_To_Lower_Case'Access;
- Map_To_Upper_Case_Ptr : Wide_Maps.Wide_Character_Mapping_Function :=
- CXA4033_0.Map_To_Upper_Case'Access;
-
- begin
-
- -- Testing functionality found in Package Ada.Strings.Wide_Unbounded.
- --
- -- Function Index.
-
- if Index(To_Unbounded_Wide_String("AAABBBaaabbb"),
- "aabb",
- Mapping => Map_To_Lower_Case_Ptr) /= 2 or
- Index(To_Unbounded_Wide_String("Case of a Mixed Case String"),
- "case",
- Ada.Strings.Backward,
- Map_To_Lower_Case_Ptr) /= 17
- then
- Report.Failed("Incorrect results from Function Index, " &
- "using a Wide Character Mapping Function parameter");
- end if;
-
- -- Function Count.
- if Count(Source => To_Unbounded_Wide_String("ABABABA"),
- Pattern => "aba",
- Mapping => Map_To_Lower_Case_Ptr) /= 2 or
- Count(Null_Unbounded_Wide_String, "mat", Map_To_Upper_Case_Ptr) /= 0
- then
- Report.Failed("Incorrect results from Function Count, using " &
- "a Character Mapping Function parameter");
- end if;
-
- -- Function Translate.
- if Translate(To_Unbounded_Wide_String("A Sample Mixed Case String"),
- Mapping => Map_To_Lower_Case_Ptr) /=
- To_Unbounded_Wide_String("a sample mixed case string") or
- Translate(New_UB_Character_String, Map_To_Upper_Case_Ptr) /=
- TC_New_UB_Character_String
- then
- Report.Failed("Incorrect results from Function Translate, " &
- "using a Character Mapping Function parameter");
- end if;
-
- -- Procedure Translate.
- declare
- use Ada.Characters.Handling;
- Str : Unbounded_Wide_String :=
- To_Unbounded_Wide_String("AN ALL UPPER CASE STRING");
- begin
- Translate(Source => Str, Mapping => Map_To_Lower_Case_Ptr);
- if Str /= To_Unbounded_Wide_String("an all upper case string") then
- Report.Failed("Incorrect result from Procedure Translate 1");
- end if;
-
- Translate(New_UB_Character_String, Map_To_Upper_Case_Ptr);
- if New_UB_Character_String /= TC_New_UB_Character_String then
- Report.Failed("Incorrect result from Procedure Translate 2");
- end if;
- end;
-
- -- Function To_Unbounded_Wide_String (version with Length parameter)
- if Length(To_Unbounded_Wide_String(Length => 10)) /= 10 or
- Length(To_Unbounded_Wide_String(0)) /= 0 or
- Length( To_Unbounded_Wide_String(10) &
- To_Unbounded_Wide_String(1) &
- To_Unbounded_Wide_String(0) ) /= 10 + 1 + 0
- then
- Report.Failed
- ("Incorrect results from Function To_Unbounded_Wide_String " &
- "with Length parameter");
- end if;
-
- -- Procedure Append (Wide_Unbounded - Wide_Unbounded)
- TC_Unb_String := Null_Unbounded_Wide_String;
- Append(TC_Unb_String, To_Unbounded_Wide_String("New Unbounded String"));
- if TC_Unb_String /= To_Unbounded_Wide_String("New Unbounded String")
- then
- Report.Failed("Incorrect results from Procedure Append with " &
- "unbounded wide string parameters");
- end if;
-
-
- -- Procedure Append (Wide_Unbounded - Wide_String)
- TC_Unb_String := To_Unbounded_Wide_String("An Unbounded String and ");
- Append(Source => TC_Unb_String, New_Item => TC_String);
- if TC_Unb_String /=
- To_Unbounded_Wide_String("An Unbounded String and A Standard String")
- then
- Report.Failed("Incorrect results from Procedure Append with " &
- "an unbounded wide string parameter and a wide " &
- "string parameter");
- end if;
-
- -- Procedure Append (Wide_Unbounded - Wide_Character)
- TC_Unb_String := To_Unbounded_Wide_String("Lower Case = ");
- for i in LC_Characters'Range loop
- Append(Source => TC_Unb_String, New_Item => LC_Characters(i));
- end loop;
- if TC_Unb_String /=
- Unb.To_Unbounded_Wide_String
- ("Lower Case = abcdefghijklmnopqrstuvwxyz")
- then
- Report.Failed("Incorrect results from Procedure Append with " &
- "an unbounded wide string parameter and a wide " &
- "character parameter");
- end if;
-
- -- Function "="
- TC_Unb_String := To_Unbounded_Wide_String(TC_String);
- if not (TC_Unb_String = TC_String) or
- not "="("A Standard String", TC_Unb_String) or
- not ((Null_Unbounded_Wide_String = "") and
- ("Test String" = To_Unbounded_Wide_String("Test String")))
- then
- Report.Failed("Incorrect results from Function ""="" with " &
- "wide_string - unbounded wide string parameters");
- end if;
-
- -- Function "<"
- if not ("Extra Space" < To_Unbounded_Wide_String("Extra Space ") and
- To_Unbounded_Wide_String("tess") < "test" and
- To_Unbounded_Wide_String("best") < "test")
- then
- Report.Failed("Incorrect results from Function ""<"" with " &
- "wide string - unbounded wide string parameters");
- end if;
-
- -- Function "<="
- TC_Unb_String := To_Unbounded_Wide_String("Sample string");
- if TC_Unb_String <= "Sample strin" or
- not("Sample string" <= TC_Unb_String)
- then
- Report.Failed("Incorrect results from Function ""<="" with " &
- "wide string - unbounded wide string parameters");
- end if;
-
- -- Function ">"
- TC_Unb_String := To_Unbounded_Wide_String("A MUCH LONGER STRING");
- if not ("A much longer string" > TC_Unb_String and
- To_Unbounded_Wide_String(TC_String) > "A Standard Strin" and
- "abcdefgh" > To_Unbounded_Wide_String("ABCDEFGH"))
- then
- Report.Failed("Incorrect results from Function "">"" with " &
- "wide string - unbounded wide string parameters");
- end if;
-
- -- Function ">="
- TC_Unb_String := To_Unbounded_Wide_String(TC_String);
- if not (TC_Unb_String >= TC_String and
- "test" >= To_Unbounded_Wide_String("tess") and
- To_Unbounded_Wide_String("Programming") >= "PROGRAMMING")
- then
- Report.Failed("Incorrect results from Function "">="" with " &
- "wide string - unbounded wide string parameters");
- end if;
-
- -- Procedure Replace_Slice
- TC_Unb_String := To_Unbounded_Wide_String("Test String");
- Replace_Slice(TC_Unb_String, 5, 5, TC_String_5);
- if TC_Unb_String /= To_Unbounded_Wide_String("TestABCDEString") then
- Report.Failed("Incorrect results from Replace_Slice - 1");
- end if;
-
- Replace_Slice(TC_Unb_String, 1, 4, TC_String_5);
- if TC_Unb_String /= To_Unbounded_Wide_String("ABCDEABCDEString") then
- Report.Failed("Incorrect results from Replace_Slice - 2");
- end if;
-
- -- Procedure Insert
- TC_Unb_String := To_Unbounded_Wide_String("Test String");
- Insert(TC_Unb_String, 1, "**");
- if TC_Unb_String /= To_Unbounded_Wide_String("**Test String") then
- Report.Failed("Incorrect results from Procedure Insert - 1");
- end if;
-
- Insert(TC_Unb_String, Length(TC_Unb_String)+1, "**");
- if TC_Unb_String /= To_Unbounded_Wide_String("**Test String**") then
- Report.Failed("Incorrect results from Procedure Insert - 2");
- end if;
-
- -- Procedure Overwrite
- TC_Unb_String := To_Unbounded_Wide_String("Test String");
- Overwrite(TC_Unb_String, 1, New_Item => "XXXX");
- if TC_Unb_String /= To_Unbounded_Wide_String("XXXX String") then
- Report.Failed("Incorrect results from Procedure Overwrite - 1");
- end if;
-
- Overwrite(TC_Unb_String, Length(TC_Unb_String)+1, "**");
- if TC_Unb_String /= To_Unbounded_Wide_String("XXXX String**") then
- Report.Failed("Incorrect results from Procedure Overwrite - 2");
- end if;
-
- -- Procedure Delete
- TC_Unb_String := To_Unbounded_Wide_String("Test String");
- Delete(TC_Unb_String, 1, 0);
- if TC_Unb_String /= To_Unbounded_Wide_String("Test String") then
- Report.Failed("Incorrect results from Procedure Delete - 1");
- end if;
-
- Delete(TC_Unb_String, 1, 5);
- if TC_Unb_String /= To_Unbounded_Wide_String("String") then
- Report.Failed("Incorrect results from Procedure Delete - 2");
- end if;
-
- -- Procedure Trim
- TC_Unb_String := To_Unbounded_Wide_String(" Leading Spaces ");
- Trim(TC_Unb_String, Ada.Strings.Left);
- if TC_Unb_String /= To_Unbounded_Wide_String("Leading Spaces ") then
- Report.Failed("Incorrect results from Procedure Trim - 1");
- end if;
-
- TC_Unb_String :=
- To_Unbounded_Wide_String(" Spaces on both ends ");
- Trim(TC_Unb_String, Ada.Strings.Both);
- if TC_Unb_String /=
- To_Unbounded_Wide_String("Spaces on both ends")
- then
- Report.Failed("Incorrect results from Procedure Trim - 2");
- end if;
-
- -- Procedure Trim (with Wide_Character_Set parameters)
- TC_Unb_String := To_Unbounded_Wide_String("012abcdefghGFEDCBA789ab");
- Trim(TC_Unb_String,
- Ada.Strings.Wide_Maps.Wide_Constants.Hexadecimal_Digit_Set,
- Ada.Strings.Wide_Maps.Wide_Constants.Hexadecimal_Digit_Set);
- if TC_Unb_String /= To_Unbounded_Wide_String("ghG") then
- Report.Failed("Incorrect results from Procedure Trim with Sets");
- end if;
-
- -- Procedure Head
- TC_Unb_String := To_Unbounded_Wide_String("Test String");
- Head(Source => TC_Unb_String, Count => 0, Pad => '*');
- if TC_Unb_String /= Null_Unbounded_Wide_String then
- Report.Failed("Incorrect results from Procedure Head - 1");
- end if;
-
- TC_Unb_String := To_Unbounded_Wide_String("Test String");
- Head(Source => TC_Unb_String, Count => 4, Pad => '*');
- if TC_Unb_String /= To_Unbounded_Wide_String("Test") then
- Report.Failed("Incorrect results from Procedure Head - 2");
- end if;
-
- -- Procedure Tail
- TC_Unb_String := To_Unbounded_Wide_String("Test String");
- Tail(Source => TC_Unb_String, Count => 0, Pad => '*');
- if TC_Unb_String /= Null_Unbounded_Wide_String then
- Report.Failed("Incorrect results from Procedure Tail - 1");
- end if;
-
- TC_Unb_String := To_Unbounded_Wide_String("Test String");
- Tail(TC_Unb_String, Length(TC_Unb_String) + 5, 'x');
- if TC_Unb_String /= To_Unbounded_Wide_String("xxxxxTest String") then
- Report.Failed("Incorrect results from Procedure Tail - 2");
- end if;
-
- exception
- when others => Report.Failed ("Exception raised in Test_Block");
- end Test_Block;
-
- Report.Result;
-
-end CXA4033;
diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxa4034.a b/gcc/testsuite/ada/acats/tests/cxa/cxa4034.a
deleted file mode 100644
index a1ed53de0f7..00000000000
--- a/gcc/testsuite/ada/acats/tests/cxa/cxa4034.a
+++ /dev/null
@@ -1,281 +0,0 @@
--- CXA4034.A
---
--- Grant of Unlimited Rights
---
--- The Ada Conformity Assessment Authority (ACAA) holds unlimited
--- rights in the software and documentation contained herein. Unlimited
--- rights are the same as those granted by the U.S. Government for older
--- parts of the Ada Conformity Assessment Test Suite, and are defined
--- in DFAR 252.227-7013(a)(19). By making this public release, the ACAA
--- intends to confer upon all recipients unlimited rights equal to those
--- held by the ACAA. These rights include rights to use, duplicate,
--- release or disclose the released technical data and computer software
--- in whole or in part, in any manner and for any purpose whatsoever, and
--- to have or permit others to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that Ada.Strings.Bounded.Slice raises Index_Error if
--- High > Length (Source) or Low > Length (Source) + 1.
--- (Defect Report 8652/0049).
---
--- Check that Ada.Strings.Wide_Bounded.Slice raises Index_Error if
--- High > Length (Source) or Low > Length (Source) + 1.
---
--- CHANGE HISTORY:
--- 12 FEB 2001 PHL Initial version
--- 14 MAR 2001 RLB Added Wide_Bounded subtest.
---
---!
-with Ada.Exceptions;
-use Ada.Exceptions;
-with Ada.Strings.Bounded;
-with Ada.Strings.Wide_Bounded;
-use Ada.Strings;
-with Report;
-use Report;
-procedure CXA4034 is
-
- package Bs is new Ada.Strings.Bounded.Generic_Bounded_Length (40);
-
- package WBs is new Ada.Strings.Wide_Bounded.Generic_Bounded_Length (32);
-
- Source : String (Ident_Int (1) .. Ident_Int (30));
-
- Wide_Source : Wide_String (Ident_Int (1) .. Ident_Int (24));
-
- X : Bs.Bounded_String;
-
- WX : WBs.Bounded_Wide_String;
-
-begin
- Test ("CXA4034",
- "Check that Slice raises Index_Error if either Low or High is " &
- "greater than the Length(Source) for Ada.Strings.Bounded and " &
- "Ada.Strings.Wide_Bounded");
-
- -- Fill Source with "ABC..."
- for I in Source'Range loop
- Source (I) := Ident_Char (Character'Val (I +
- Character'Pos ('A') - Source'First));
- end loop;
- -- and W with "ABC..."
- for I in Wide_Source'Range loop
- Wide_Source (I) := Ident_Wide_Char (Wide_Character'Val (I +
- Wide_Character'Pos ('A') - Wide_Source'First));
- end loop;
-
- X := Bs.To_Bounded_String (Source);
-
- begin
- declare
- S : constant String :=
- Bs.Slice (X, Low => Ident_Int (28), High => Ident_Int (41));
- begin
- Failed ("No exception raised by Slice - 1");
- if S = Source then
- Comment ("Don't optimize S");
- end if;
- end;
- exception
- when Index_Error =>
- null; -- Expected exception.
- when E: others =>
- Failed ("Exception raised - " & Exception_Name (E) &
- " - " & Exception_Message (E) & " - 1");
- end;
-
- begin
- declare
- S : constant String :=
- Bs.Slice (X, Low => Ident_Int (8), High => Ident_Int (31));
- begin
- Failed ("No exception raised by Slice - 2");
- if S = Source then
- Comment ("Don't optimize S");
- end if;
- end;
- exception
- when Index_Error =>
- null; -- Expected exception.
- when E: others =>
- Failed ("Exception raised - " & Exception_Name (E) &
- " - " & Exception_Message (E) & " - 2");
- end;
-
- begin
- declare
- S : constant String :=
- Bs.Slice (X, Low => Ident_Int (15), High => Ident_Int (30));
- begin
- if S /= Source(15..30) then
- Failed ("Wrong result - 3");
- end if;
- end;
- exception
- when E: others =>
- Failed ("Exception raised - " & Exception_Name (E) &
- " - " & Exception_Message (E) & " - 3");
- end;
-
- begin
- declare
- S : constant String :=
- Bs.Slice (X, Low => Ident_Int (42), High => Ident_Int (28));
- begin
- Failed ("No exception raised by Slice - 4");
- if S = Source then
- Comment ("Don't optimize S");
- end if;
- end;
- exception
- when Index_Error =>
- null; -- Expected exception.
- when E: others =>
- Failed ("Exception raised - " & Exception_Name (E) &
- " - " & Exception_Message (E) & " - 4");
- end;
-
- begin
- declare
- S : constant String :=
- Bs.Slice (X, Low => Ident_Int (31), High => Ident_Int (28));
- begin
- if S /= "" then
- Failed ("Wrong result - 5");
- end if;
- end;
- exception
- when E: others =>
- Failed ("Exception raised - " & Exception_Name (E) &
- " - " & Exception_Message (E) & " - 5");
- end;
-
- begin
- declare
- S : constant String :=
- Bs.Slice (X, Low => Ident_Int (30), High => Ident_Int (30));
- begin
- if S /= Source(30..30) then
- Failed ("Wrong result - 6");
- end if;
- end;
- exception
- when E: others =>
- Failed ("Exception raised - " & Exception_Name (E) &
- " - " & Exception_Message (E) & " - 6");
- end;
-
- WX := WBs.To_Bounded_Wide_String (Wide_Source);
-
- begin
- declare
- W : constant Wide_String :=
- WBs.Slice (WX, Low => Ident_Int (21), High => Ident_Int (33));
- begin
- Failed ("No exception raised by Slice - 7");
- if W = Wide_Source then
- Comment ("Don't optimize W");
- end if;
- end;
- exception
- when Index_Error =>
- null; -- Expected exception.
- when E: others =>
- Failed ("Exception raised - " & Exception_Name (E) &
- " - " & Exception_Message (E) & " - 7");
- end;
-
- begin
- declare
- W : constant Wide_String :=
- WBs.Slice (WX, Low => Ident_Int (8), High => Ident_Int (25));
- begin
- Failed ("No exception raised by Slice - 8");
- if W = Wide_Source then
- Comment ("Don't optimize W");
- end if;
- end;
- exception
- when Index_Error =>
- null; -- Expected exception.
- when E: others =>
- Failed ("Exception raised - " & Exception_Name (E) &
- " - " & Exception_Message (E) & " - 8");
- end;
-
- begin
- declare
- W : constant Wide_String :=
- WBs.Slice (WX, Low => Ident_Int (15), High => Ident_Int (24));
- begin
- if W /= Wide_Source(15..24) then
- Failed ("Wrong result - 8");
- end if;
- end;
- exception
- when E: others =>
- Failed ("Exception raised - " & Exception_Name (E) &
- " - " & Exception_Message (E) & " - 9");
- end;
-
- begin
- declare
- W : constant Wide_String :=
- WBs.Slice (WX, Low => Ident_Int (36), High => Ident_Int (20));
- begin
- Failed ("No exception raised by Slice - 10");
- if W = Wide_Source then
- Comment ("Don't optimize W");
- end if;
- end;
- exception
- when Index_Error =>
- null; -- Expected exception.
- when E: others =>
- Failed ("Exception raised - " & Exception_Name (E) &
- " - " & Exception_Message (E) & " - 10");
- end;
-
- begin
- declare
- W : constant Wide_String :=
- WBs.Slice (WX, Low => Ident_Int (25), High => Ident_Int (21));
- begin
- if W /= "" then
- Failed ("Wrong result - 11");
- end if;
- end;
- exception
- when E: others =>
- Failed ("Exception raised - " & Exception_Name (E) &
- " - " & Exception_Message (E) & " - 11");
- end;
-
- begin
- declare
- W : constant Wide_String :=
- WBs.Slice (WX, Low => Ident_Int (24), High => Ident_Int (24));
- begin
- if W /= Wide_Source(24..24) then
- Failed ("Wrong result - 12");
- end if;
- end;
- exception
- when E: others =>
- Failed ("Exception raised - " & Exception_Name (E) &
- " - " & Exception_Message (E) & " - 12");
- end;
-
- Result;
-end CXA4034;
-
diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxa5011.a b/gcc/testsuite/ada/acats/tests/cxa/cxa5011.a
deleted file mode 100644
index c9a007e524f..00000000000
--- a/gcc/testsuite/ada/acats/tests/cxa/cxa5011.a
+++ /dev/null
@@ -1,471 +0,0 @@
--- CXA5011.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that, for both Float_Random and Discrete_Random packages,
--- the following are true:
--- 1) two objects of type Generator are initialized to the same state.
--- 2) when the Function Reset is used to reset two generators
--- to different time-dependent states, the resulting random values
--- from each generator are different.
--- 3) when the Function Reset uses the same integer initiator
--- to reset two generators to the same state, the resulting random
--- values from each generator are identical.
--- 4) when the Function Reset uses different integer initiator
--- values to reset two generators, the resulting random numbers are
--- different.
---
--- TEST DESCRIPTION:
--- This test evaluates components of the Ada.Numerics.Float_Random and
--- Ada.Numerics.Discrete_Random packages.
--- This test checks to see that objects of type Generator are initialized
--- to the same state. In addition, the functionality of Function Reset is
--- validated.
--- For each of the objectives above, evaluation of the various generators
--- is performed using each of the following techniques. When the states of
--- two generators are to be compared, each state is saved, then
--- transformed to a bounded-string variable. The bounded-strings can
--- then be compared for equality. In this case, matching bounded-strings
--- are evidence that the states of two generators are the same.
--- In addition, two generators are compared by evaluating a series of
--- random numbers they produce. A matching series of random numbers
--- implies that the generators were in the same state prior to producing
--- the numbers.
---
---
--- CHANGE HISTORY:
--- 20 Apr 95 SAIC Initial prerelease version.
--- 07 Jul 95 SAIC Incorporated reviewer comments/suggestions.
--- 22 Apr 96 SAIC Incorporated reviewer comments for ACVC 2.1.
--- 17 Aug 96 SAIC Deleted Subtest #2.
--- 09 Feb 01 RLB Repaired to work on implementations with a 16-bit
--- Integer.
-
---!
-
-with Ada.Exceptions;
-with Ada.Numerics.Float_Random;
-with Ada.Numerics.Discrete_Random;
-with Ada.Strings.Bounded;
-with ImpDef;
-with Report;
-
-procedure CXA5011 is
-begin
-
- Report.Test ("CXA5011", "Check the effect of Function Reset on the " &
- "state of random number generators");
-
- Test_Block:
- declare
-
- use Ada.Exceptions;
- use Ada.Numerics;
- use Ada.Strings.Bounded;
-
- -- Declare an modular subtype, and use it to instantiate the discrete
- -- random number generator generic package.
-
- type Discrete_Range is mod 2**(Integer'Size-1);
- package Discrete_Package is new Discrete_Random(Discrete_Range);
-
- -- Declaration of random number generator objects.
-
- Discrete_Generator_1,
- Discrete_Generator_2 : Discrete_Package.Generator;
- Float_Generator_1,
- Float_Generator_2 : Float_Random.Generator;
-
- -- Declaration of bounded string packages instantiated with the
- -- value of Max_Image_Width constant from each random number generator
- -- package, and bounded string variables used to hold the image of
- -- random number generator states.
-
- package Discrete_String_Pack is
- new Generic_Bounded_Length(Discrete_Package.Max_Image_Width);
-
- package Float_String_Pack is
- new Generic_Bounded_Length(Float_Random.Max_Image_Width);
-
- use Discrete_String_Pack, Float_String_Pack;
-
- TC_Seed : Integer;
- TC_Max_Loop_Count : constant Natural := 1000;
- Allowed_Matches : constant Natural := 2;
- --
- -- In a sequence of TC_Max_Loop_Count random numbers that should
- -- not match, some may match by chance. Up to Allowed_Matches
- -- numbers may match before the test is considered to fail.
- --
-
-
- procedure Check_Float_State (Gen_1, Gen_2 : Float_Random.Generator;
- Sub_Test : Integer;
- States_Should_Match : Boolean) is
-
- use type Float_Random.State;
-
- State_1,
- State_2 : Float_Random.State;
-
- State_String_1,
- State_String_2 : Float_String_Pack.Bounded_String :=
- Float_String_Pack.Null_Bounded_String;
- begin
-
- Float_Random.Save(Gen => Gen_1, To_State => State_1);
- Float_Random.Save(Gen_2, State_2);
-
- State_String_1 :=
- Float_String_Pack.To_Bounded_String(Source =>
- Float_Random.Image(Of_State => State_1));
-
- State_String_2 :=
- Float_String_Pack.To_Bounded_String(Float_Random.Image(State_2));
-
- case States_Should_Match is
- when True =>
- if State_1 /= State_2 then
- Report.Failed("Subtest #" & Integer'Image(Sub_Test) &
- " State values from Float generators " &
- "are not the same");
- end if;
- if State_String_1 /= State_String_2 then
- Report.Failed("Subtest #" & Integer'Image(Sub_Test) &
- " State strings from Float generators " &
- "are not the same");
- end if;
- when False =>
- if State_1 = State_2 then
- Report.Failed("Subtest #" & Integer'Image(Sub_Test) &
- " State values from Float generators " &
- "are the same");
- end if;
- if State_String_1 = State_String_2 then
- Report.Failed("Subtest #" & Integer'Image(Sub_Test) &
- " State strings from Float generators " &
- "are the same");
- end if;
- end case;
- end Check_Float_State;
-
-
-
- procedure Check_Discrete_State (Gen_1,
- Gen_2 : Discrete_Package.Generator;
- Sub_Test : Integer;
- States_Should_Match : Boolean) is
-
- use type Discrete_Package.State;
-
- State_1, State_2 : Discrete_Package.State;
-
- State_String_1,
- State_String_2 : Discrete_String_Pack.Bounded_String :=
- Discrete_String_Pack.Null_Bounded_String;
- begin
-
- Discrete_Package.Save(Gen => Gen_1,
- To_State => State_1);
- Discrete_Package.Save(Gen_2, To_State => State_2);
-
- State_String_1 :=
- Discrete_String_Pack.To_Bounded_String(Source =>
- Discrete_Package.Image(Of_State => State_1));
-
- State_String_2 :=
- Discrete_String_Pack.To_Bounded_String(Source =>
- Discrete_Package.Image(Of_State => State_2));
-
- case States_Should_Match is
- when True =>
- if State_1 /= State_2 then
- Report.Failed("Subtest #" & Integer'Image(Sub_Test) &
- " State values from Discrete " &
- "generators are not the same");
- end if;
- if State_String_1 /= State_String_2 then
- Report.Failed("Subtest #" & Integer'Image(Sub_Test) &
- " State strings from Discrete " &
- "generators are not the same");
- end if;
- when False =>
- if State_1 = State_2 then
- Report.Failed("Subtest #" & Integer'Image(Sub_Test) &
- " State values from Discrete " &
- "generators are the same");
- end if;
- if State_String_1 = State_String_2 then
- Report.Failed("Subtest #" & Integer'Image(Sub_Test) &
- " State strings from Discrete " &
- "generators are the same");
- end if;
- end case;
- end Check_Discrete_State;
-
-
-
- procedure Check_Float_Values (Gen_1, Gen_2 : Float_Random.Generator;
- Sub_Test : Integer;
- Values_Should_Match : Boolean) is
- Matches : Natural := 0;
- Check_Failed : Boolean := False;
- begin
- case Values_Should_Match is
- when True =>
- for i in 1..TC_Max_Loop_Count loop
- if Float_Random.Random(Gen_1) /= Float_Random.Random(Gen_2)
- then
- Check_Failed := True;
- exit;
- end if;
- end loop;
- if Check_Failed then
- Report.Failed("Sub_Test # " & Integer'Image(Sub_Test) &
- " Random numbers from Float generators " &
- "Failed check");
- end if;
- when False =>
- for i in 1..TC_Max_Loop_Count loop
- if Float_Random.Random(Gen_1) = Float_Random.Random(Gen_2)
- then
- Matches := Matches + 1;
- end if;
- end loop;
- end case;
-
- if (Values_Should_Match and Check_Failed) or
- (not Values_Should_Match and Matches > Allowed_Matches)
- then
- Report.Failed("Sub_Test # " & Integer'Image(Sub_Test) &
- " Random numbers from Float generators " &
- "Failed check");
- end if;
-
- end Check_Float_Values;
-
-
-
- procedure Check_Discrete_Values (Gen_1,
- Gen_2 : Discrete_Package.Generator;
- Sub_Test : Integer;
- Values_Should_Match : Boolean) is
- Matches : Natural := 0;
- Check_Failed : Boolean := False;
- begin
- case Values_Should_Match is
- when True =>
- for i in 1..TC_Max_Loop_Count loop
- if Discrete_Package.Random(Gen_1) /=
- Discrete_Package.Random(Gen_2)
- then
- Check_Failed := True;
- exit;
- end if;
- end loop;
- when False =>
- for i in 1..TC_Max_Loop_Count loop
- if Discrete_Package.Random(Gen_1) =
- Discrete_Package.Random(Gen_2)
- then
- Matches := Matches + 1;
- end if;
- end loop;
- end case;
-
- if (Values_Should_Match and Check_Failed) or
- (not Values_Should_Match and Matches > Allowed_Matches)
- then
- Report.Failed("Sub_Test # " & Integer'Image(Sub_Test) &
- " Random numbers from Discrete generators " &
- "Failed check");
- end if;
-
- end Check_Discrete_Values;
-
-
-
- begin
-
- Sub_Test_1:
- -- Check that two objects of type Generator are initialized to the
- -- same state.
- begin
-
- -- Since the discrete and float random generators are in the initial
- -- state, using Procedure Save to save the states of the generator
- -- objects, and transforming these states into strings using
- -- Function Image, should yield identical strings.
-
- Check_Discrete_State (Discrete_Generator_1,
- Discrete_Generator_2,
- Sub_Test => 1,
- States_Should_Match => True);
-
- Check_Float_State (Float_Generator_1,
- Float_Generator_2,
- Sub_Test => 1,
- States_Should_Match => True);
-
- -- Since the two random generator objects are in their initial
- -- state, the values produced from each (upon calls to Random)
- -- should be identical.
-
- Check_Discrete_Values (Discrete_Generator_1,
- Discrete_Generator_2,
- Sub_Test => 1,
- Values_Should_Match => True);
-
- Check_Float_Values (Float_Generator_1,
- Float_Generator_2,
- Sub_Test => 1,
- Values_Should_Match => True);
-
- end Sub_Test_1;
-
-
-
- Sub_Test_3:
- -- Check that when the Function Reset uses the same integer
- -- initiator to reset two generators to the same state, the
- -- resulting random values and the state from each generator
- -- are identical.
- declare
- use Discrete_Package, Float_Random;
- begin
-
- -- Reset the generators to the same states, using the version of
- -- Function Reset with both generator parameter and initiator
- -- specified.
-
- TC_Seed := Integer(Random(Discrete_Generator_1));
- Reset(Gen => Discrete_Generator_1, Initiator => TC_Seed);
- Reset(Discrete_Generator_2, Initiator => TC_Seed);
- Reset(Float_Generator_1, TC_Seed);
- Reset(Float_Generator_2, TC_Seed);
-
- -- Since the random generators have been reset to identical states,
- -- bounded string images of these states should yield identical
- -- strings.
-
- Check_Discrete_State (Discrete_Generator_1,
- Discrete_Generator_2,
- Sub_Test => 3,
- States_Should_Match => True);
-
- Check_Float_State (Float_Generator_1,
- Float_Generator_2,
- Sub_Test => 3,
- States_Should_Match => True);
-
- -- Since the random generators have been reset to identical states,
- -- the values produced from each (upon calls to Random) should
- -- be identical.
-
- Check_Discrete_Values (Discrete_Generator_1,
- Discrete_Generator_2,
- Sub_Test => 3,
- Values_Should_Match => True);
-
- Check_Float_Values (Float_Generator_1,
- Float_Generator_2,
- Sub_Test => 3,
- Values_Should_Match => True);
-
- end Sub_Test_3;
-
-
-
- Sub_Test_4:
- -- Check that when the Function Reset uses different integer
- -- initiator values to reset two generators, the resulting random
- -- numbers and states are different.
- begin
-
- -- Reset the generators to different states.
-
- TC_Seed :=
- Integer(Discrete_Package.Random(Discrete_Generator_1));
-
- Discrete_Package.Reset(Gen => Discrete_Generator_1,
- Initiator => TC_Seed);
-
- -- Set the seed value to a different value for the second call
- -- to Reset.
- -- Note: A second call to Random could be made, as above, but that
- -- would not ensure that the resulting seed value was
- -- different from the first.
-
- if TC_Seed /= Integer'Last then
- TC_Seed := TC_Seed + 1;
- else
- TC_Seed := TC_Seed - 1;
- end if;
-
- Discrete_Package.Reset(Gen => Discrete_Generator_2,
- Initiator => TC_Seed);
-
- Float_Random.Reset(Float_Generator_1, 16#FF#); -- 255
- Float_Random.Reset(Float_Generator_2, 2#1110_0000#); -- 224
-
- -- Since the two float random generators are in different
- -- states, the bounded string images depicting their states should
- -- differ.
-
- Check_Discrete_State (Discrete_Generator_1,
- Discrete_Generator_2,
- Sub_Test => 4,
- States_Should_Match => False);
-
- Check_Float_State (Float_Generator_1,
- Float_Generator_2,
- Sub_Test => 4,
- States_Should_Match => False);
-
- -- Since the two discrete random generator objects were reset
- -- to different states, the values produced from each (upon calls
- -- to Random) should differ.
-
- Check_Discrete_Values (Discrete_Generator_1,
- Discrete_Generator_2,
- Sub_Test => 4,
- Values_Should_Match => False);
-
- Check_Float_Values (Float_Generator_1,
- Float_Generator_2,
- Sub_Test => 4,
- Values_Should_Match => False);
-
- end Sub_Test_4;
-
- exception
- when The_Error : others =>
- Report.Failed ("The following exception was raised in the " &
- "Test_Block: " & Exception_Name(The_Error));
- end Test_Block;
-
- Report.Result;
-
-end CXA5011;
diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxa5012.a b/gcc/testsuite/ada/acats/tests/cxa/cxa5012.a
deleted file mode 100644
index a286fa71ed0..00000000000
--- a/gcc/testsuite/ada/acats/tests/cxa/cxa5012.a
+++ /dev/null
@@ -1,536 +0,0 @@
--- CXA5012.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that, for both Float_Random and Discrete_Random packages,
--- the following are true:
--- 1) the procedures Save and Reset can be used to save the
--- specific state of a random number generator, and then restore
--- the specific state to the generator following some intermediate
--- generator activity.
--- 2) the Function Image can be used to obtain a string
--- representation of the state of a generator; and that the
--- Function Value will transform a string representation of the
--- state of a random number generator into the actual state object.
--- 3) a call to Function Value, with a string value that is
--- not the image of any generator state, is a bounded error. This
--- error either raises Constraint_Error or Program_Error, or is
--- accepted. (See Technical Corrigendum 1).
---
--- TEST DESCRIPTION:
--- This test evaluates components of the Ada.Numerics.Float_Random and
--- Ada.Numerics.Discrete_Random packages.
--- The first objective block of this test uses Procedure Save to
--- save the particular state of a random number generator. The random
--- number generator then generates a series of random numbers. The
--- saved state variable is then used to reset (using Procedure Reset)
--- the generator back to the state it was in at the point of the call
--- to Save. Random values are then generated from this restored
--- generator, and compared with expected values.
--- The second objective block of this test uses Function Image to
--- provide a string representation of a state code. This string is
--- then transformed back to a state code value, and used to reset a
--- random number generator to the saved state. Random values are
--- likewise generated from this restored generator, and compared with
--- expected values.
---
---
--- CHANGE HISTORY:
--- 25 Apr 95 SAIC Initial prerelease version.
--- 17 Jul 95 SAIC Incorporated reviewer comments.
--- 17 Dec 97 EDS Change subtype upper limit from 100_000 to 10_000.
--- 16 Sep 99 RLB Updated objective 3 for Technical Corrigendum 1
--- changes.
-
---!
-
-with Ada.Numerics.Float_Random;
-with Ada.Numerics.Discrete_Random;
-with Ada.Strings.Bounded;
-with ImpDef;
-with Report;
-
-procedure CXA5012 is
-
-begin
-
- Report.Test ("CXA5012", "Check the effect of Procedures Save and " &
- "Reset, and Functions Image and Value " &
- "from the Ada.Numerics.Discrete_Random " &
- "and Float_Random packages");
-
- Test_Block:
- declare
-
- use Ada.Numerics, Ada.Strings.Bounded;
-
- -- Declare an integer subtype and an enumeration subtype, and use them
- -- to instantiate the discrete random number generator generic package.
-
- subtype Discrete_Range is Integer range 1..10_000;
- type Suit_Of_Cards is (Ace, One, Two, Three, Four, Five, Six,
- Seven, Eight, Nine, Ten, Jack, Queen, King);
- package Discrete_Pack is new Discrete_Random(Discrete_Range);
- package Card_Pack is new Discrete_Random(Suit_Of_Cards);
-
- -- Declaration of random number generator objects.
-
- DGen_1, DGen_2 : Discrete_Pack.Generator;
- EGen_1, EGen_2 : Card_Pack.Generator;
- FGen_1, FGen_2 : Float_Random.Generator;
-
- -- Variables declared to hold random numbers over the inclusive range
- -- of their corresponding type.
-
- DVal_1, DVal_2 : Discrete_Range;
- EVal_1, EVal_2 : Suit_Of_Cards;
- FVal_1, FVal_2 : Float_Random.Uniformly_Distributed;
-
- -- Declaration of State variables used to hold the state of the
- -- random number generators.
-
- DState_1, DState_2 : Discrete_Pack.State;
- EState_1, EState_2 : Card_Pack.State;
- FState_1, FState_2 : Float_Random.State;
-
- -- Declaration of bounded string packages instantiated with the
- -- value of Max_Image_Width constant, and bounded string variables
- -- used to hold the image of random number generator states.
-
- package DString_Pack is
- new Generic_Bounded_Length(Discrete_Pack.Max_Image_Width);
- package EString_Pack is
- new Generic_Bounded_Length(Card_Pack.Max_Image_Width);
- package FString_Pack is
- new Generic_Bounded_Length(Float_Random.Max_Image_Width);
-
- use DString_Pack, EString_Pack, FString_Pack;
-
- DString_1, DString_2 : DString_Pack.Bounded_String :=
- DString_Pack.Null_Bounded_String;
- EString_1, EString_2 : EString_Pack.Bounded_String :=
- EString_Pack.Null_Bounded_String;
- FString_1, FString_2 : FString_Pack.Bounded_String :=
- FString_Pack.Null_Bounded_String;
-
- -- Test variables.
-
- TC_Count : Natural;
- TC_Discrete_Check_Failed,
- TC_Enum_Check_Failed,
- TC_Float_Check_Failed : Boolean := False;
- TC_Seed : Integer;
-
- begin
-
- Objective_1:
- -- Check that the procedures Save and Reset can be used to save the
- -- specific state of a random number generator, and then restore the
- -- specific state to the generator following some intermediate
- -- generator activity.
- declare
-
- First_Row : constant := 1;
- Second_Row : constant := 2;
- TC_Max_Values : constant := 100;
-
- TC_Discrete_Array : array (First_Row..Second_Row, 1..TC_Max_Values)
- of Discrete_Range;
- TC_Enum_Array : array (First_Row..Second_Row, 1..TC_Max_Values)
- of Suit_Of_Cards;
- TC_Float_Array : array (First_Row..Second_Row, 1..TC_Max_Values)
- of Float_Random.Uniformly_Distributed;
- begin
-
- -- The state of the random number generators are saved to state
- -- variables using the procedure Save.
-
- Discrete_Pack.Save(Gen => DGen_1, To_State => DState_1);
- Card_Pack.Save (Gen => EGen_1, To_State => EState_1);
- Float_Random.Save (Gen => FGen_1, To_State => FState_1);
-
- -- Random number generators are used to fill the first half of the
- -- first row of the arrays with randomly generated values.
-
- for i in 1..TC_Max_Values/2 loop
- TC_Discrete_Array(First_Row, i) := Discrete_Pack.Random(DGen_1);
- TC_Enum_Array(First_Row, i) := Card_Pack.Random(EGen_1);
- TC_Float_Array(First_Row, i) := Float_Random.Random(FGen_1);
- end loop;
-
- -- The random number generators are reset to the states saved in the
- -- state variables, using the procedure Reset.
-
- Discrete_Pack.Reset(Gen => DGen_1, From_State => DState_1);
- Card_Pack.Reset (Gen => EGen_1, From_State => EState_1);
- Float_Random.Reset (Gen => FGen_1, From_State => FState_1);
-
- -- The same random number generators are used to fill the first half
- -- of the second row of the arrays with randomly generated values.
-
- for i in 1..TC_Max_Values/2 loop
- TC_Discrete_Array(Second_Row, i) := Discrete_Pack.Random(DGen_1);
- TC_Enum_Array(Second_Row, i) := Card_Pack.Random(EGen_1);
- TC_Float_Array(Second_Row, i) := Float_Random.Random(FGen_1);
- end loop;
-
- -- Run the random number generators many times (not using results).
-
- for i in Discrete_Range'Range loop
- DVal_1 := Discrete_Pack.Random(DGen_1);
- EVal_1 := Card_Pack.Random(EGen_1);
- FVal_1 := Float_Random.Random(FGen_1);
- end loop;
-
- -- The states of the random number generators are saved to state
- -- variables using the procedure Save.
-
- Discrete_Pack.Save(Gen => DGen_1, To_State => DState_1);
- Card_Pack.Save(Gen => EGen_1, To_State => EState_1);
- Float_Random.Save (Gen => FGen_1, To_State => FState_1);
-
- -- The last half of the first row of the arrays are filled with
- -- values generated from the same random number generators.
-
- for i in (TC_Max_Values/2 + 1)..TC_Max_Values loop
- TC_Discrete_Array(First_Row, i) := Discrete_Pack.Random(DGen_1);
- TC_Enum_Array(First_Row, i) := Card_Pack.Random(EGen_1);
- TC_Float_Array(First_Row, i) := Float_Random.Random(FGen_1);
- end loop;
-
- -- The random number generators are reset to the states saved in the
- -- state variables, using the procedure Reset.
-
- Discrete_Pack.Reset(Gen => DGen_1, From_State => DState_1);
- Card_Pack.Reset(Gen => EGen_1, From_State => EState_1);
- Float_Random.Reset (Gen => FGen_1, From_State => FState_1);
-
- -- The last half of the second row of the arrays are filled with
- -- values generated from the same random number generator.
- -- These values should exactly mirror the values in the last half
- -- of the first row of the arrays that had been previously generated.
-
- for i in (TC_Max_Values/2 + 1)..TC_Max_Values loop
- TC_Discrete_Array(Second_Row, i) := Discrete_Pack.Random(DGen_1);
- TC_Enum_Array(Second_Row, i) := Card_Pack.Random(EGen_1);
- TC_Float_Array(Second_Row, i) := Float_Random.Random(FGen_1);
- end loop;
-
- -- Check that the values in the two rows of the arrays are identical.
-
- for i in 1..TC_Max_Values loop
- if TC_Discrete_Array(First_Row,i) /=
- TC_Discrete_Array(Second_Row,i)
- then
- TC_Discrete_Check_Failed := True;
- exit;
- end if;
- end loop;
-
- for i in 1..TC_Max_Values loop
- if TC_Enum_Array(First_Row,i) /= TC_Enum_Array(Second_Row,i) then
- TC_Enum_Check_Failed := True;
- exit;
- end if;
- end loop;
-
- for i in 1..TC_Max_Values loop
- if TC_Float_Array(First_Row,i) /= TC_Float_Array(Second_Row,i)
- then
- TC_Float_Check_Failed := True;
- exit;
- end if;
- end loop;
-
- if TC_Discrete_Check_Failed then
- Report.Failed("Discrete random values generated following use " &
- "of procedures Save and Reset were not the same");
- TC_Discrete_Check_Failed := False;
- end if;
-
- if TC_Enum_Check_Failed then
- Report.Failed("Enumeration random values generated following " &
- "use of procedures Save and Reset were not the " &
- "same");
- TC_Enum_Check_Failed := False;
- end if;
-
- if TC_Float_Check_Failed then
- Report.Failed("Float random values generated following use " &
- "of procedures Save and Reset were not the same");
- TC_Float_Check_Failed := False;
- end if;
-
- end Objective_1;
-
-
-
- Objective_2:
- -- Check that the Function Image can be used to obtain a string
- -- representation of the state of a generator.
- -- Check that the Function Value will transform a string
- -- representation of the state of a random number generator
- -- into the actual state object.
- begin
-
- -- Use two discrete and float random number generators to generate
- -- a series of values (so that the generators are no longer in their
- -- initial states, and they have generated the same number of
- -- random values).
-
- TC_Seed := Integer(Discrete_Pack.Random(DGen_1));
- Discrete_Pack.Reset(DGen_1, TC_Seed);
- Discrete_Pack.Reset(DGen_2, TC_Seed);
- Card_Pack.Reset (EGen_1, TC_Seed);
- Card_Pack.Reset (EGen_2, TC_Seed);
- Float_Random.Reset (FGen_1, TC_Seed);
- Float_Random.Reset (FGen_2, TC_Seed);
-
- for i in 1..1000 loop
- DVal_1 := Discrete_Pack.Random(DGen_1);
- DVal_2 := Discrete_Pack.Random(DGen_2);
- EVal_1 := Card_Pack.Random(EGen_1);
- EVal_2 := Card_Pack.Random(EGen_2);
- FVal_1 := Float_Random.Random(FGen_1);
- FVal_2 := Float_Random.Random(FGen_2);
- end loop;
-
- -- Use the Procedure Save to save the states of the generators
- -- to state variables.
-
- Discrete_Pack.Save(Gen => DGen_1, To_State => DState_1);
- Discrete_Pack.Save(DGen_2, To_State => DState_2);
- Card_Pack.Save (Gen => EGen_1, To_State => EState_1);
- Card_Pack.Save (EGen_2, To_State => EState_2);
- Float_Random.Save (FGen_1, To_State => FState_1);
- Float_Random.Save (FGen_2, FState_2);
-
- -- Use the Function Image to produce a representation of the state
- -- codes as (bounded) string objects.
-
- DString_1 := DString_Pack.To_Bounded_String(
- Discrete_Pack.Image(Of_State => DState_1));
- DString_2 := DString_Pack.To_Bounded_String(
- Discrete_Pack.Image(DState_2));
- EString_1 := EString_Pack.To_Bounded_String(
- Card_Pack.Image(Of_State => EState_1));
- EString_2 := EString_Pack.To_Bounded_String(
- Card_Pack.Image(EState_2));
- FString_1 := FString_Pack.To_Bounded_String(
- Float_Random.Image(Of_State => FState_1));
- FString_2 := FString_Pack.To_Bounded_String(
- Float_Random.Image(FState_2));
-
- -- Compare the bounded string objects for equality.
-
- if DString_1 /= DString_2 then
- Report.Failed("String values returned from Function Image " &
- "depict different states of Discrete generators");
- end if;
- if EString_1 /= EString_2 then
- Report.Failed("String values returned from Function Image " &
- "depict different states of Enumeration " &
- "generators");
- end if;
- if FString_1 /= FString_2 then
- Report.Failed("String values returned from Function Image " &
- "depict different states of Float generators");
- end if;
-
- -- The string representation of a state code is transformed back
- -- to a state code variable using the Function Value.
-
- DState_1 := Discrete_Pack.Value(Coded_State =>
- DString_Pack.To_String(DString_1));
- EState_1 := Card_Pack.Value(EString_Pack.To_String(EString_1));
- FState_1 := Float_Random.Value(FString_Pack.To_String(FString_1));
-
- -- One of the (pair of each type of ) generators is used to generate
- -- a series of random values, getting them "out of synch" with the
- -- specific generation sequence of the other generators.
-
- for i in 1..100 loop
- DVal_1 := Discrete_Pack.Random(DGen_1);
- EVal_1 := Card_Pack.Random(EGen_1);
- FVal_1 := Float_Random.Random (FGen_1);
- end loop;
-
- -- The "out of synch" generators are reset to the previous state they
- -- had when their states were saved, and they should now have the same
- -- states as the generators that did not generate the values above.
-
- Discrete_Pack.Reset(Gen => DGen_1, From_State => DState_1);
- Card_Pack.Reset (Gen => EGen_1, From_State => EState_1);
- Float_Random.Reset (Gen => FGen_1, From_State => FState_1);
-
- -- All generators should now be in the same state, so the
- -- random values they produce should be the same.
-
- for i in 1..1000 loop
- if Discrete_Pack.Random(DGen_1) /= Discrete_Pack.Random(DGen_2)
- then
- TC_Discrete_Check_Failed := True;
- exit;
- end if;
- end loop;
-
- for i in 1..1000 loop
- if Card_Pack.Random(EGen_1) /= Card_Pack.Random(EGen_2) then
- TC_Enum_Check_Failed := True;
- exit;
- end if;
- end loop;
-
- for i in 1..1000 loop
- if Float_Random.Random(FGen_1) /= Float_Random.Random(FGen_2)
- then
- TC_Float_Check_Failed := True;
- exit;
- end if;
- end loop;
-
- if TC_Discrete_Check_Failed then
- Report.Failed("Random values generated following use of " &
- "procedures Image and Value were not the same " &
- "for Discrete generator");
- end if;
- if TC_Enum_Check_Failed then
- Report.Failed("Random values generated following use of " &
- "procedures Image and Value were not the same " &
- "for Enumeration generator");
- end if;
- if TC_Float_Check_Failed then
- Report.Failed("Random values generated following use of " &
- "procedures Image and Value were not the same " &
- "for Float generator");
- end if;
-
- end Objective_2;
-
-
-
- Objective_3:
- -- Check that a call to Function Value, with a string value that is
- -- not the image of any generator state, is a bounded error. This
- -- error either raises Constraint_Error or Program_Error, or is
- -- accepted. (See Technical Corrigendum 1).
- declare
- Not_A_State : constant String := ImpDef.Non_State_String;
- begin
-
- begin
- DState_1 := Discrete_Pack.Value(Not_A_State);
- if Not_A_State /= "**NONE**" then
- Report.Failed("Exception not raised by Function " &
- "Ada.Numerics.Discrete_Random.Value when " &
- "provided a string input that does not " &
- "represent the state of a random number " &
- "generator");
- else
- Report.Comment("All strings represent states for Function " &
- "Ada.Numerics.Discrete_Random.Value");
- end if;
- Discrete_Pack.Reset(DGen_1, DState_1);
- exception
- when Constraint_Error => null; -- OK, expected exception.
- Report.Comment("Constraint_Error raised by Function " &
- "Ada.Numerics.Discrete_Random.Value when " &
- "provided a string input that does not " &
- "represent the state of a random number " &
- "generator");
- when Program_Error => -- OK, expected exception.
- Report.Comment("Program_Error raised by Function " &
- "Ada.Numerics.Discrete_Random.Value when " &
- "provided a string input that does not " &
- "represent the state of a random number " &
- "generator");
- when others =>
- Report.Failed("Unexpected exception raised by Function " &
- "Ada.Numerics.Discrete_Random.Value when " &
- "provided a string input that does not " &
- "represent the state of a random number " &
- "generator");
- end;
-
- begin
- EState_1 := Card_Pack.Value(Not_A_State);
- if Not_A_State /= "**NONE**" then
- Report.Failed("Exception not raised by Function " &
- "Ada.Numerics.Discrete_Random.Value when " &
- "provided a string input that does not " &
- "represent the state of an enumeration " &
- "random number generator");
- else
- Report.Comment("All strings represent states for Function " &
- "Ada.Numerics.Discrete_Random.Value");
- end if;
- Card_Pack.Reset(EGen_1, EState_1);
- exception
- when Constraint_Error => null; -- OK, expected exception.
- when Program_Error => null; -- OK, expected exception.
- when others =>
- Report.Failed("Unexpected exception raised by Function " &
- "Ada.Numerics.Discrete_Random.Value when " &
- "provided a string input that does not " &
- "represent the state of an enumeration " &
- "random number generator");
- end;
-
- begin
- FState_1 := Float_Random.Value(Not_A_State);
- if Not_A_State /= "**NONE**" then
- Report.Failed("Exception not raised by an " &
- "instantiated version of " &
- "Ada.Numerics.Float_Random.Value when " &
- "provided a string input that does not " &
- "represent the state of a random number " &
- "generator");
- else
- Report.Comment("All strings represent states for Function " &
- "Ada.Numerics.Float_Random.Value");
- end if;
- Float_Random.Reset(FGen_1, FState_1);
- exception
- when Constraint_Error => null; -- OK, expected exception.
- when Program_Error => null; -- OK, expected exception.
- when others =>
- Report.Failed("Unexpected exception raised by an " &
- "instantiated version of " &
- "Ada.Numerics.Float_Random.Value when " &
- "provided a string input that does not " &
- "represent the state of a random number " &
- "generator");
- end;
-
- end Objective_3;
-
-
- exception
- when others => Report.Failed ("Exception raised in Test_Block");
- end Test_Block;
-
- Report.Result;
-
-end CXA5012;
diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxa5015.a b/gcc/testsuite/ada/acats/tests/cxa/cxa5015.a
deleted file mode 100644
index e1035db271b..00000000000
--- a/gcc/testsuite/ada/acats/tests/cxa/cxa5015.a
+++ /dev/null
@@ -1,342 +0,0 @@
--- CXA5015.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that the following representation-oriented attributes are
--- available and that the produce correct results:
--- 'Denorm, 'Signed_Zeros, 'Exponent 'Fraction, 'Compose, 'Scaling,
--- 'Floor, 'Ceiling, 'Rounding, 'Unbiased_Rounding, 'Truncation,
--- 'Remainder, 'Adjacent, 'Copy_Sign, 'Leading_Part, 'Machine, and
--- 'Model_Small.
---
--- TEST DESCRIPTION:
--- This test checks whether certain attributes of floating point types
--- are available from an implementation. Where attribute correctness
--- can be verified in a straight forward manner, the appropriate checks
--- are included here. However, this test is not intended to ensure the
--- correctness of the results returned from all of the attributes
--- examined in this test; that process will occur in the tests of the
--- Numerics_Annex.
---
---
--- CHANGE HISTORY:
--- 26 Jun 95 SAIC Initial prerelease version.
--- 29 Apr 96 SAIC Incorporated reviewer comments for ACVC 2.1.
--- 01 DEC 97 EDS Fix value for checking the S'Adjacent attribute
---!
-
-with Report;
-
-procedure CXA5015 is
-
- subtype Float_Subtype is Float range -10.0..10.0;
- type Derived_Float_1 is digits 8;
- type Derived_Float_2 is new Derived_Float_1 range -10.0..10.0E10;
-
- use type Float, Float_Subtype, Derived_Float_1, Derived_Float_2;
-
- TC_Boolean : Boolean;
- TC_Float : Float;
- TC_SFloat : Float_Subtype;
- TC_DFloat_1 : Derived_Float_1;
- TC_DFloat_2 : Derived_Float_2;
- TC_Tolerance : Float := 0.001;
-
- function Not_Equal (Actual_Result, Expected_Result, Tolerance : Float)
- return Boolean is
- begin
- return abs(Actual_Result - Expected_Result) > Tolerance;
- end Not_Equal;
-
-
-begin
-
- Report.Test ("CXA5015", "Check that certain representation-oriented " &
- "attributes are available and that they " &
- "produce correct results");
-
- -- New Representation-Oriented Attributes.
- --
- -- Check the S'Denorm attribute.
-
- TC_Boolean := Float'Denorm;
- TC_Boolean := Float_Subtype'Denorm;
- TC_Boolean := Derived_Float_1'Denorm;
- TC_Boolean := Derived_Float_2'Denorm;
-
-
- -- Check the S'Signed_Zeroes attribute.
-
- TC_Boolean := Float'Signed_Zeros;
- TC_Boolean := Float_Subtype'Signed_Zeros;
- TC_Boolean := Derived_Float_1'Signed_Zeros;
- TC_Boolean := Derived_Float_2'Signed_Zeros;
-
-
- -- New Primitive Function Attributes.
- --
- -- Check the S'Exponent attribute.
-
- TC_Float := 0.5;
- TC_SFloat := 0.99;
- TC_DFloat_1 := 2.45;
- TC_DFloat_2 := 2.65;
-
- if Float'Exponent(TC_Float) > Float_Subtype'Exponent(TC_SFloat) or
- Float'Exponent(TC_Float) > 2
- then
- Report.Failed("Incorrect result from the 'Exponent attribute");
- end if;
-
-
- -- Check the S'Fraction attribute.
-
- if Not_Equal
- (Float'Fraction(TC_Float),
- TC_Float * Float(Float'Machine_Radix)**(-Float'Exponent(TC_Float)),
- TC_Tolerance)
- then
- Report.Failed("Incorrect result from the 'Fraction attribute - 1");
- end if;
-
- if Float'Fraction(TC_Float) <
- (1.0/Float(Float'Machine_Radix)) - TC_Tolerance or
- Float'Fraction(TC_Float) >= 1.0 - TC_Tolerance
- then
- Report.Failed("Incorrect result from the 'Fraction attribute - 2");
- end if;
-
-
- -- Check the S'Compose attribute.
-
- if Not_Equal
- (Float'Compose(TC_Float, 3),
- TC_Float * Float(Float'Machine_Radix)**(3-Float'Exponent(TC_Float)),
- TC_Tolerance)
- then
- Report.Failed("Incorrect result from the 'Compose attribute");
- end if;
-
-
- -- Check the S'Scaling attribute.
-
- if Not_Equal
- (Float'Scaling(TC_Float, 2),
- TC_Float * Float(Float'Machine_Radix)**2,
- TC_Tolerance)
- then
- Report.Failed("Incorrect result from the 'Scaling attribute");
- end if;
-
-
- -- Check the S'Floor attribute.
-
- TC_Float := 0.99;
- TC_SFloat := 1.00;
- TC_DFloat_1 := 2.50;
- TC_DFloat_2 := -2.50;
-
- if Float'Floor(TC_Float) /= 0.0 or
- Float_Subtype'Floor(TC_SFloat) /= 1.0 or
- Derived_Float_1'Floor(TC_DFloat_1) /= 2.0 or
- Derived_Float_2'Floor(TC_DFloat_2) /= -3.0
- then
- Report.Failed("Incorrect result from the 'Floor attribute");
- end if;
-
-
- -- Check the S'Ceiling attribute.
-
- TC_Float := 0.99;
- TC_SFloat := 1.00;
- TC_DFloat_1 := 2.50;
- TC_DFloat_2 := -2.99;
-
- if Float'Ceiling(TC_Float) /= 1.0 or
- Float_Subtype'Ceiling(TC_SFloat) /= 1.0 or
- Derived_Float_1'Ceiling(TC_DFloat_1) /= 3.0 or
- Derived_Float_2'Ceiling(TC_DFloat_2) /= -2.0
- then
- Report.Failed("Incorrect result from the 'Ceiling attribute");
- end if;
-
-
- -- Check the S'Rounding attribute.
-
- TC_Float := 0.49;
- TC_SFloat := 1.00;
- TC_DFloat_1 := 2.50;
- TC_DFloat_2 := -2.50;
-
- if Float'Rounding(TC_Float) /= 0.0 or
- Float_Subtype'Rounding(TC_SFloat) /= 1.0 or
- Derived_Float_1'Rounding(TC_DFloat_1) /= 3.0 or
- Derived_Float_2'Rounding(TC_DFloat_2) /= -3.0
- then
- Report.Failed("Incorrect result from the 'Rounding attribute");
- end if;
-
-
- -- Check the S'Unbiased_Rounding attribute.
-
- TC_Float := 0.50;
- TC_SFloat := 1.50;
- TC_DFloat_1 := 2.50;
- TC_DFloat_2 := -2.50;
-
- if Float'Unbiased_Rounding(TC_Float) /= 0.0 or
- Float_Subtype'Unbiased_Rounding(TC_SFloat) /= 2.0 or
- Derived_Float_1'Unbiased_Rounding(TC_DFloat_1) /= 2.0 or
- Derived_Float_2'Unbiased_Rounding(TC_DFloat_2) /= -2.0
- then
- Report.Failed("Incorrect result from the 'Unbiased_Rounding " &
- "attribute");
- end if;
-
-
- -- Check the S'Truncation attribute.
-
- TC_Float := -0.99;
- TC_SFloat := 1.50;
- TC_DFloat_1 := 2.99;
- TC_DFloat_2 := -2.50;
-
- if Float'Truncation(TC_Float) /= 0.0 or
- Float_Subtype'Truncation(TC_SFloat) /= 1.0 or
- Derived_Float_1'Truncation(TC_DFloat_1) /= 2.0 or
- Derived_Float_2'Truncation(TC_DFloat_2) /= -2.0
- then
- Report.Failed("Incorrect result from the 'Truncation attribute");
- end if;
-
-
- -- Check the S'Remainder attribute.
-
- TC_Float := 9.0;
- TC_SFloat := 7.5;
- TC_DFloat_1 := 5.0;
- TC_DFloat_2 := 8.0;
-
- if Float'Remainder(TC_Float, 2.0) /= 1.0 or
- Float_Subtype'Remainder(TC_SFloat, 3.0) /= 1.5 or
- Derived_Float_1'Remainder(TC_DFloat_1, 2.0) /= 1.0 or
- Derived_Float_2'Remainder(TC_DFloat_2, 4.0) /= 0.0
- then
- Report.Failed("Incorrect result from the 'Remainder attribute");
- end if;
-
-
- -- Check the S'Adjacent attribute.
-
- TC_Float := 4.0;
- TC_SFloat := -1.0;
-
- if Float'Adjacent(TC_Float, TC_Float) /= TC_Float or
- Float_Subtype'Adjacent(TC_SFloat, -1.0) /= TC_SFloat
- then
- Report.Failed("Incorrect result from the 'Adjacent attribute");
- end if;
-
-
- -- Check the S'Copy_Sign attribute.
-
- TC_Float := 0.0;
- TC_SFloat := -1.0;
- TC_DFloat_1 := 5.0;
- TC_DFloat_2 := -2.5;
-
- if Float'Copy_Sign(TC_Float, -2.0) /= 0.0 or
- Float_Subtype'Copy_Sign(TC_SFloat, 4.0) /= 1.0 or
- Derived_Float_1'Copy_Sign(TC_DFloat_1, -2.0) /= -5.0 or
- Derived_Float_2'Copy_Sign(TC_DFloat_2, -2.0) /= -2.5
- then
- Report.Failed("Incorrect result from the 'Copy_Sign attribute");
- end if;
-
-
- -- Check the S'Leading_Part attribute.
-
- TC_Float := 0.0;
- TC_SFloat := -1.0;
- TC_DFloat_1 := 5.88;
- TC_DFloat_2 := -2.52;
-
- -- Leading part obtained in the variables.
- TC_Float := Float'Leading_Part(TC_Float, 2);
- TC_SFloat := Float_Subtype'Leading_Part(TC_SFloat, 2);
- TC_DFloat_1 := Derived_Float_1'Leading_Part(TC_DFloat_1, 2);
- TC_DFloat_2 := Derived_Float_2'Leading_Part(TC_DFloat_2, 2);
-
- -- Checking for the leading part of the variables at this point should
- -- produce the same values.
- if Float'Leading_Part(TC_Float, 2) /= TC_Float or
- Float_Subtype'Leading_Part(TC_SFloat, 2) /= TC_SFloat or
- Derived_Float_1'Leading_Part(TC_DFloat_1, 2) /= TC_DFloat_1 or
- Derived_Float_2'Leading_Part(TC_DFloat_2, 2) /= TC_DFloat_2
- then
- Report.Failed("Incorrect result from the 'Leading_Part attribute");
- end if;
-
-
- -- Check the S'Machine attribute.
-
- TC_Float := 0.0;
- TC_SFloat := -1.0;
- TC_DFloat_1 := 5.88;
- TC_DFloat_2 := -2.52;
-
- -- Closest machine number obtained in the variables.
- TC_Float := Float'Machine(TC_Float);
- TC_SFloat := Float_Subtype'Machine(TC_SFloat);
- TC_DFloat_1 := Derived_Float_1'Machine(TC_DFloat_1);
- TC_DFloat_2 := Derived_Float_2'Machine(TC_DFloat_2);
-
- -- Checking for the closest machine number to each of the variables at
- -- this point should produce the same values.
- if Float'Machine(TC_Float) /= TC_Float or
- Float_Subtype'Machine(TC_SFloat) /= TC_SFloat or
- Derived_Float_1'Machine(TC_DFloat_1) /= TC_DFloat_1 or
- Derived_Float_2'Machine(TC_DFloat_2) /= TC_DFloat_2
- then
- Report.Failed("Incorrect result from the 'Machine attribute");
- end if;
-
-
- -- New Model-Oriented Attributes.
- --
- -- Check the S'Model_Small attribute.
-
- if Not_Equal
- (Float'Model_Small,
- Float(Float'Machine_Radix)**(Float'Model_Emin-1),
- TC_Tolerance)
- then
- Report.Failed("Incorrect result from the 'Model_Small attribute");
- end if;
-
-
- Report.Result;
-
-end CXA5015;
diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxa5a01.a b/gcc/testsuite/ada/acats/tests/cxa/cxa5a01.a
deleted file mode 100644
index 12db5e7e108..00000000000
--- a/gcc/testsuite/ada/acats/tests/cxa/cxa5a01.a
+++ /dev/null
@@ -1,338 +0,0 @@
--- CXA5A01.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that the functions Sin and Sinh provide correct results.
---
--- TEST DESCRIPTION:
--- This test examines both the version of Sin and Sinh resulting from
--- the instantiation of the Ada.Numerics.Generic_Elementary_Functions
--- with a type derived from type Float, as well as the preinstantiated
--- version of this package for type Float.
--- Prescribed results, as well as instances prescribed to raise
--- exceptions, are examined in the test cases. In addition,
--- certain evaluations are performed where the actual function result
--- is compared with the expected result (within an epsilon range of
--- accuracy).
---
--- TEST FILES:
--- The following files comprise this test:
---
--- FXA5A00.A (foundation code)
--- CXA5A01.A
---
---
--- CHANGE HISTORY:
--- 06 Mar 95 SAIC Initial prerelease version.
--- 13 Jun 95 SAIC Incorporated use of Dont_Optimize procedure, and
--- use of Result_Within_Range function overloaded for
--- FXA5A00.New_Float_Type.
--- 26 Jun 98 EDS Protected exception tests by first testing
--- for 'Machine_Overflows
---!
-
-with Ada.Numerics.Elementary_Functions;
-with Ada.Numerics.Generic_Elementary_Functions;
-with FXA5A00;
-with Report;
-
-procedure CXA5A01 is
-begin
-
- Report.Test ("CXA5A01", "Check that the functions Sin and Sinh provide " &
- "correct results");
-
- Test_Block:
- declare
-
- use Ada.Numerics;
- use FXA5A00;
-
- package GEF is new Ada.Numerics.Generic_Elementary_Functions(New_Float);
- package EF renames Ada.Numerics.Elementary_Functions;
-
- The_Result : Float;
- New_Float_Result : New_Float;
-
- procedure Dont_Optimize_Float is new Dont_Optimize(Float);
- procedure Dont_Optimize_New_Float is new Dont_Optimize(New_Float);
-
- begin
-
- -- Testing of Sin Function, both instantiated and pre-instantiated
- -- version.
-
- -- Check that no exception occurs on computing the Sin with very
- -- large (positive and negative) input values.
-
- begin
- New_Float_Result := GEF.Sin (New_Float(FXA5A00.Large));
- Dont_Optimize_New_Float(New_Float_Result, 1);
- exception
- when others =>
- Report.Failed("Unexpected exception on GEF.Sin with large " &
- "positive value");
- end;
-
- begin
- The_Result := EF.Sin (FXA5A00.Minus_Large);
- Dont_Optimize_Float(The_Result, 2);
- exception
- when others =>
- Report.Failed("Unexpected exception on GEF.Sin with large " &
- "negative value");
- end;
-
-
- -- Test of Sin for prescribed result at zero.
-
- if GEF.Sin (0.0) /= 0.0 or
- EF.Sin (0.0) /= 0.0
- then
- Report.Failed("Incorrect value returned from Sin(0.0)");
- end if;
-
-
- -- Test of Sin with expected result value between 0.0 and 1.0.
-
- if not (GEF.Sin (Ada.Numerics.Pi/4.0) < 1.0) or
- not ( EF.Sin (Ada.Numerics.Pi/4.0) < 1.0) or
- not FXA5A00.Result_Within_Range(GEF.Sin(0.35), 0.343, 0.001) or
- not FXA5A00.Result_Within_Range( EF.Sin(1.18), 0.924, 0.001)
- then
- Report.Failed("Incorrect value returned from Sin function when " &
- "the expected result is between 0.0 and 1.0");
- end if;
-
-
- -- Test of Sin with expected result value between -1.0 and 0.0.
-
- if not (GEF.Sin (-Ada.Numerics.Pi/4.0) > -1.0) or
- not ( EF.Sin (-Ada.Numerics.Pi/4.0) > -1.0) or
- not FXA5A00.Result_Within_Range(GEF.Sin(-0.24), -0.238, 0.001) or
- not FXA5A00.Result_Within_Range( EF.Sin(-1.00), -0.841, 0.001)
- then
- Report.Failed("Incorrect value returned from Sin function when " &
- "the expected result is between -1.0 and 0.0");
- end if;
-
-
- -- Testing of the Sin function with Cycle parameter.
-
- -- Check that Argument_Error is raised when the value of the Cycle
- -- parameter is zero.
-
- begin
- New_Float_Result := GEF.Sin (X => 1.0, Cycle => 0.0);
- Report.Failed("Argument_Error not raised by GEF.Sin function " &
- "when the Cycle parameter is zero");
- Dont_Optimize_New_Float(New_Float_Result, 3);
- exception
- when Ada.Numerics.Argument_Error => null; -- OK, expected exception.
- when others =>
- Report.Failed("Unexpected exception raised by GEF.Sin function " &
- "when the Cycle parameter is zero");
- end;
-
- begin
- The_Result := EF.Sin (X => 0.34, Cycle => 0.0);
- Report.Failed("Argument_Error not raised by EF.Sin function when " &
- "the Cycle parameter is zero");
- Dont_Optimize_Float(The_Result, 4);
- exception
- when Ada.Numerics.Argument_Error => null; -- OK, expected exception.
- when others =>
- Report.Failed("Unexpected exception raised by EF.Sin function " &
- "when the Cycle parameter is zero");
- end;
-
- -- Check that Argument_Error is raised when the value of the Cycle
- -- parameter is negative.
-
- begin
- New_Float_Result := GEF.Sin (X => 0.45, Cycle => -1.0);
- Report.Failed("Argument_Error not raised by GEF.Sin function " &
- "when the Cycle parameter is negative");
- Dont_Optimize_New_Float(New_Float_Result, 5);
- exception
- when Ada.Numerics.Argument_Error => null; -- OK, expected exception.
- when others =>
- Report.Failed("Unexpected exception raised by GEF.Sin function " &
- "when the Cycle parameter is negative");
- end;
-
- begin
- The_Result := EF.Sin (X => 0.10, Cycle => -4.0);
- Report.Failed("Argument_Error not raised by EF.Sin function when " &
- "the Cycle parameter is negative");
- Dont_Optimize_Float(The_Result, 6);
- exception
- when Ada.Numerics.Argument_Error => null; -- OK, expected exception.
- when others =>
- Report.Failed("Unexpected exception raised by EF.Sin function " &
- "when the Cycle parameter is negative");
- end;
-
-
- -- Check that no exception occurs on computing the Sin with very
- -- large (positive and negative) input values and Cycle parameter.
-
- begin
- New_Float_Result := GEF.Sin (New_Float(FXA5A00.Large), 360.0);
- Dont_Optimize_New_Float(New_Float_Result, 7);
- exception
- when others =>
- Report.Failed("Unexpected exception on GEF.Sin with large " &
- "positive value and Cycle parameter");
- end;
-
- begin
- The_Result := EF.Sin (FXA5A00.Minus_Large, 720.0);
- Dont_Optimize_Float(The_Result, 8);
- exception
- when others =>
- Report.Failed("Unexpected exception on EF.Sin with large " &
- "negative value and Cycle parameter");
- end;
-
-
- -- Test of Sin with Cycle parameter for prescribed result at zero.
-
- if GEF.Sin (0.0, 360.0) /= 0.0 or
- EF.Sin (0.0, 180.0) /= 0.0
- then
- Report.Failed("Incorrect value returned from Sin function with " &
- "cycle parameter for a zero input parameter value");
- end if;
-
-
- -- Tests of Sin function with Cycle parameter for prescribed results.
-
- if GEF.Sin(0.0, 360.0) /= 0.0 or
- EF.Sin(180.0, 360.0) /= 0.0 or
- GEF.Sin(90.0, 360.0) /= 1.0 or
- EF.Sin(450.0, 360.0) /= 1.0 or
- GEF.Sin(270.0, 360.0) /= -1.0 or
- EF.Sin(630.0, 360.0) /= -1.0
- then
- Report.Failed("Incorrect result from the Sin function with " &
- "various cycle values for prescribed results");
- end if;
-
-
- -- Testing of Sinh Function, both instantiated and pre-instantiated
- -- version.
-
- -- Test for Constraint_Error on parameter with large positive magnitude.
-
- begin
-
- if New_Float'Machine_Overflows then
- New_Float_Result := GEF.Sinh (New_Float(FXA5A00.Large));
- Report.Failed("Constraint_Error not raised when the GEF.Sinh " &
- "function is provided a parameter with a large " &
- "positive value");
- Dont_Optimize_New_Float(New_Float_Result, 9);
- end if;
-
- exception
- when Constraint_Error => null; -- OK, expected exception.
- when others =>
- Report.Failed("Constraint_Error not raised when the GEF.Sinh " &
- "function is provided a parameter with a large " &
- "positive value");
- end;
-
- -- Test for Constraint_Error on parameter with large negative magnitude.
-
- begin
-
- if Float'Machine_Overflows then
- The_Result := EF.Sinh (FXA5A00.Minus_Large);
- Report.Failed("Constraint_Error not raised when the EF.Sinh " &
- "function is provided a parameter with a " &
- "large negative value");
- Dont_Optimize_Float(The_Result, 10);
- end if;
-
- exception
- when Constraint_Error => null; -- OK, expected exception.
- when others =>
- Report.Failed("Constraint_Error not raised when the EF.Sinh " &
- "function is provided a parameter with a " &
- "large negative value");
- end;
-
-
- -- Test that no exception occurs when the Sinh function is provided a
- -- very small positive or negative value.
-
- begin
- New_Float_Result := GEF.Sinh (New_Float(FXA5A00.Small));
- Dont_Optimize_New_Float(New_Float_Result, 11);
- exception
- when others =>
- Report.Failed("Unexpected exception on GEF.Sinh with a very" &
- "small positive value");
- end;
-
- begin
- The_Result := EF.Sinh (-FXA5A00.Small);
- Dont_Optimize_Float(The_Result, 12);
- exception
- when others =>
- Report.Failed("Unexpected exception on EF.Sinh with a very" &
- "small negative value");
- end;
-
-
- -- Test for prescribed 0.0 result of Function Sinh with 0.0 parameter.
-
- if GEF.Sinh (0.0) /= 0.0 or
- EF.Sinh (0.0) /= 0.0
- then
- Report.Failed("Incorrect value returned from Sinh(0.0)");
- end if;
-
-
- -- Test of Sinh function with various input parameters.
-
- if not FXA5A00.Result_Within_Range(GEF.Sinh(0.01), 0.010, 0.001) or
- not FXA5A00.Result_Within_Range( EF.Sinh(0.61), 0.649, 0.001) or
- not FXA5A00.Result_Within_Range(GEF.Sinh(1.70), 2.65, 0.01) or
- not FXA5A00.Result_Within_Range( EF.Sinh(3.15), 11.65, 0.01)
- then
- Report.Failed("Incorrect result returned from Sinh function " &
- "with various input parameters");
- end if;
-
-
- exception
- when others => Report.Failed ("Exception raised in Test_Block");
- end Test_Block;
-
- Report.Result;
-
-end CXA5A01;
diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxa5a02.a b/gcc/testsuite/ada/acats/tests/cxa/cxa5a02.a
deleted file mode 100644
index 9e6c575dd2c..00000000000
--- a/gcc/testsuite/ada/acats/tests/cxa/cxa5a02.a
+++ /dev/null
@@ -1,328 +0,0 @@
--- CXA5A02.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that the functions Cos and Cosh provide correct results.
---
--- TEST DESCRIPTION:
--- This test examines both the version of Cos and Cosh resulting from
--- the instantiation of the Ada.Numerics.Generic_Elementary_Functions
--- with type derived from type Float, as well as the pre-instantiated
--- version of this package for type Float.
--- Prescribed results, including instances prescribed to raise
--- exceptions, are examined in the test cases. In addition,
--- certain evaluations are performed where the actual function result
--- is compared with the expected result (within an epsilon range of
--- accuracy).
---
--- TEST FILES:
--- The following files comprise this test:
---
--- FXA5A00.A (foundation code)
--- CXA5A02.A
---
---
--- CHANGE HISTORY:
--- 09 Mar 95 SAIC Initial prerelease version.
--- 03 Apr 95 SAIC Removed reference to derived type.
--- 13 Jun 95 SAIC Incorporated use of Dont_Optimize procedure, and
--- use of Result_Within_Range function overloaded for
--- FXA5A00.New_Float_Type.
--- 28 Feb 97 PWB.CTA Removed checks specifying Cycle => 2.0 * Pi
--- 26 Jun 98 EDS Protected exception checks by first testing
--- for 'Machine_Overflows. Removed code deleted
--- by comment.
--- CHANGE NOTE:
--- According to Ken Dritz, author of the Numerics Annex of the RM,
--- one should never specify the cycle 2.0*Pi for the trigonometric
--- functions. In particular, if the machine number for the first
--- argument is not an exact multiple of the machine number for the
--- explicit cycle, then the specified exact results cannot be
--- reasonably expected. The affected checks have been deleted.
---!
-
-with Ada.Numerics.Elementary_Functions;
-with Ada.Numerics.Generic_Elementary_Functions;
-with FXA5A00;
-with Report;
-
-procedure CXA5A02 is
-begin
-
- Report.Test ("CXA5A02", "Check that the functions Cos and Cosh provide " &
- "correct results");
-
- Test_Block:
- declare
-
- use Ada.Numerics;
- use FXA5A00;
-
- package GEF is new Ada.Numerics.Generic_Elementary_Functions(New_Float);
- package EF renames Ada.Numerics.Elementary_Functions;
-
- The_Result : Float;
- New_Float_Result : New_Float;
-
- procedure Dont_Optimize_Float is new Dont_Optimize(Float);
- procedure Dont_Optimize_New_Float is new Dont_Optimize(New_Float);
-
- begin
-
- -- Testing of Cos Function, both instantiated and pre-instantiated
- -- version.
-
- -- Check that no exception occurs on computing the Cos with very
- -- large (positive and negative) input values.
-
- begin
- New_Float_Result := GEF.Cos (New_Float(FXA5A00.Large));
- Dont_Optimize_New_Float(New_Float_Result, 1);
- exception
- when others =>
- Report.Failed("Unexpected exception on GEF.Cos with large " &
- "positive value");
- end;
-
- begin
- The_Result := EF.Cos (FXA5A00.Minus_Large);
- Dont_Optimize_Float(The_Result, 2);
- exception
- when others =>
- Report.Failed("Unexpected exception on GEF.Cos with large " &
- "negative value");
- end;
-
-
- -- Test of Cos for prescribed result at zero.
-
- if GEF.Cos (0.0) /= 1.0 or
- EF.Cos (0.0) /= 1.0
- then
- Report.Failed("Incorrect value returned from Cos(0.0)");
- end if;
-
-
- -- Test of Cos with expected result value between 1.0 and -1.0.
-
- if not (Result_Within_Range( EF.Cos(Ada.Numerics.Pi/3.0),
- 0.500,
- 0.001) and
- Result_Within_Range(GEF.Cos(0.6166), 0.816, 0.001) and
- Result_Within_Range(GEF.Cos(0.1949), 0.981, 0.001) and
- Result_Within_Range( EF.Cos(Ada.Numerics.Pi/2.0),
- 0.00,
- 0.001) and
- Result_Within_Range( EF.Cos(2.0*Ada.Numerics.Pi/3.0),
- -0.500,
- 0.001) and
- Result_Within_Range(GEF.Cos(New_Float(Ada.Numerics.Pi)),
- -1.00,
- 0.001))
- then
- Report.Failed("Incorrect value returned from Cos function when " &
- "the expected result is between 1.0 and -1.0");
- end if;
-
-
- -- Testing of the Cos function with Cycle parameter.
-
- -- Check that Argument_Error is raised when the value of the Cycle
- -- parameter is zero.
-
- begin
- New_Float_Result := GEF.Cos (X => 1.0, Cycle => 0.0);
- Report.Failed("Argument_Error not raised by GEF.Cos function " &
- "when the Cycle parameter is zero");
- Dont_Optimize_New_Float(New_Float_Result, 3);
- exception
- when Ada.Numerics.Argument_Error => null; -- OK, expected exception.
- when others =>
- Report.Failed("Unexpected exception raised by GEF.cos function " &
- "when the Cycle parameter is zero");
- end;
-
- begin
- The_Result := EF.Cos (X => 0.55, Cycle => 0.0);
- Report.Failed("Argument_Error not raised by EF.Cos function when " &
- "the Cycle parameter is zero");
- Dont_Optimize_Float(The_Result, 4);
- exception
- when Ada.Numerics.Argument_Error => null; -- OK, expected exception.
- when others =>
- Report.Failed("Unexpected exception raised by EF.Cos function " &
- "when the Cycle parameter is zero");
- end;
-
- -- Check that Argument_Error is raised when the value of the Cycle
- -- parameter is negative.
-
- begin
- New_Float_Result := GEF.Cos (X => 0.45, Cycle => -2.0*Pi);
- Report.Failed("Argument_Error not raised by GEF.Cos function " &
- "when the Cycle parameter is negative");
- Dont_Optimize_New_Float(New_Float_Result, 5);
- exception
- when Ada.Numerics.Argument_Error => null; -- OK, expected exception.
- when others =>
- Report.Failed("Unexpected exception raised by GEF.Cos function " &
- "when the Cycle parameter is negative");
- end;
-
- begin
- The_Result := EF.Cos (X => 0.10, Cycle => -Pi/2.0);
- Report.Failed("Argument_Error not raised by EF.Cos function when " &
- "the Cycle parameter is negative");
- Dont_Optimize_Float(The_Result, 6);
- exception
- when Ada.Numerics.Argument_Error => null; -- OK, expected exception.
- when others =>
- Report.Failed("Unexpected exception raised by EF.Cos function " &
- "when the Cycle parameter is negative");
- end;
-
- -- Test of Cos with Cycle parameter for prescribed result at zero.
-
- if GEF.Cos (0.0, 360.0) /= 1.0 or
- EF.Cos (0.0, 360.0) /= 1.0
- then
- Report.Failed("Incorrect value returned from Cos function with " &
- "cycle parameter for a zero input parameter value");
- end if;
-
-
- -- Tests of Cos function with specified Cycle, using various input
- -- parameter values for prescribed results.
-
- if GEF.Cos(0.0, 360.0) /= 1.0 or
- EF.Cos(360.0, 360.0) /= 1.0 or
- GEF.Cos(90.0, 360.0) /= 0.0 or
- EF.Cos(270.0, 360.0) /= 0.0 or
- GEF.Cos(180.0, 360.0) /= -1.0 or
- EF.Cos(540.0, 360.0) /= -1.0
- then
- Report.Failed("Incorrect result from the Cos function with " &
- "specified cycle for prescribed results");
- end if;
-
-
-
- -- Testing of Cosh Function, both instantiated and pre-instantiated
- -- version.
-
- -- Test for Constraint_Error on parameter with large positive magnitude.
-
- begin
-
- if New_Float'Machine_Overflows then
-
- New_Float_Result := GEF.Cosh (New_Float(FXA5A00.Large));
- Report.Failed("Constraint_Error not raised when the GEF.Cosh " &
- "function is provided a parameter with a large " &
- "positive value");
- Dont_Optimize_New_Float(New_Float_Result, 9);
- end if;
-
- exception
- when Constraint_Error => null; -- OK, expected exception.
- when others =>
- Report.Failed("Constraint_Error not raised when the GEF.Cosh " &
- "function is provided a parameter with a large " &
- "positive value");
- end;
-
- -- Test for Constraint_Error on parameter with large negative magnitude.
-
- begin
-
- if Float'Machine_Overflows then
- The_Result := EF.Cosh (FXA5A00.Minus_Large);
- Report.Failed("Constraint_Error not raised when the EF.Cosh " &
- "function is provided a parameter with a " &
- "large negative value");
- Dont_Optimize_Float(The_Result, 10);
- end if;
-
- exception
- when Constraint_Error => null; -- OK, expected exception.
- when others =>
- Report.Failed("Constraint_Error not raised when the EF.Cosh " &
- "function is provided a parameter with a " &
- "large negative value");
- end;
-
-
- -- Test that no exception occurs when the Cosh function is provided a
- -- very small positive or negative value.
-
- begin
- New_Float_Result := GEF.Cosh (New_Float(FXA5A00.Small));
- Dont_Optimize_New_Float(New_Float_Result, 11);
- exception
- when others =>
- Report.Failed("Unexpected exception on GEF.Cosh with a very" &
- "small positive value");
- end;
-
- begin
- The_Result := EF.Cosh (-FXA5A00.Small);
- Dont_Optimize_Float(The_Result, 12);
- exception
- when others =>
- Report.Failed("Unexpected exception on EF.Cosh with a very" &
- "small negative value");
- end;
-
-
- -- Test for prescribed 1.0 result of Function Cosh with 0.0 parameter.
-
- if GEF.Cosh (0.0) /= 1.0 or
- EF.Cosh (0.0) /= 1.0
- then
- Report.Failed("Incorrect value returned from Cosh(0.0)");
- end if;
-
-
- -- Test of Cosh function with various input parameters.
-
- if not FXA5A00.Result_Within_Range(GEF.Cosh(0.24), 1.029, 0.001) or
- not FXA5A00.Result_Within_Range( EF.Cosh(0.59), 1.179, 0.001) or
- not FXA5A00.Result_Within_Range(GEF.Cosh(1.06), 1.616, 0.001) or
- not FXA5A00.Result_Within_Range( EF.Cosh(1.50), 2.352, 0.001) or
- not FXA5A00.Result_Within_Range(GEF.Cosh(1.84), 3.228, 0.001) or
- not FXA5A00.Result_Within_Range( EF.Cosh(3.40), 14.99, 0.01)
- then
- Report.Failed("Incorrect result from Cosh function with " &
- "various input parameters");
- end if;
-
-
- exception
- when others => Report.Failed ("Exception raised in Test_Block");
- end Test_Block;
-
- Report.Result;
-
-end CXA5A02;
diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxa5a03.a b/gcc/testsuite/ada/acats/tests/cxa/cxa5a03.a
deleted file mode 100644
index d99ba9bdcf0..00000000000
--- a/gcc/testsuite/ada/acats/tests/cxa/cxa5a03.a
+++ /dev/null
@@ -1,426 +0,0 @@
--- CXA5A03.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that the functions Tan, Tanh, and Arctanh provide correct
--- results.
---
--- TEST DESCRIPTION:
--- This test examines both the version of Tan, Tanh, and Arctanh
--- the instantiation of the Ada.Numerics.Generic_Elementary_Functions
--- with a type derived from type Float, as well as the preinstantiated
--- version of this package for type Float.
--- Prescribed results, including instances prescribed to raise
--- exceptions, are examined in the test cases. In addition,
--- certain evaluations are performed where the actual function result
--- is compared with the expected result (within an epsilon range of
--- accuracy).
---
--- TEST FILES:
--- The following files comprise this test:
---
--- FXA5A00.A (foundation code)
--- CXA5A03.A
---
---
--- CHANGE HISTORY:
--- 14 Mar 95 SAIC Initial prerelease version.
--- 06 Apr 95 SAIC Corrected errors in context clause references
--- and usage of Cycle parameter.
--- 13 Jun 95 SAIC Incorporated use of Dont_Optimize procedure, and
--- use of Result_Within_Range function overloaded for
--- FXA5A00.New_Float_Type.
--- 29 Jun 98 EDS Protected exception tests by first testing
--- for 'Machine_Overflows
---
---!
-
-with Ada.Numerics.Elementary_Functions;
-with Ada.Numerics.Generic_Elementary_Functions;
-with FXA5A00;
-with Report;
-
-procedure CXA5A03 is
-begin
-
- Report.Test ("CXA5A03", "Check that the functions Tan, Tanh, and " &
- "Arctanh provide correct results");
-
- Test_Block:
- declare
-
- use Ada.Numerics;
- use FXA5A00;
-
- package GEF is new Ada.Numerics.Generic_Elementary_Functions(New_Float);
- package EF renames Ada.Numerics.Elementary_Functions;
-
- The_Result : Float;
- New_Float_Result : New_Float;
-
- procedure Dont_Optimize_Float is new Dont_Optimize(Float);
- procedure Dont_Optimize_New_Float is new Dont_Optimize(New_Float);
-
- begin
-
- -- Testing of Tan Function, both instantiated and pre-instantiated
- -- version.
-
- -- Check that no exception occurs on computing the Tan with very
- -- large (positive and negative) input values.
-
- begin
- New_Float_Result := GEF.Tan (New_Float(FXA5A00.Large));
- Dont_Optimize_New_Float(New_Float_Result, 1);
- exception
- when others =>
- Report.Failed("Unexpected exception on GEF.Tan with large " &
- "positive value");
- end;
-
- begin
- The_Result := EF.Tan (FXA5A00.Minus_Large);
- Dont_Optimize_Float(The_Result, 2);
- exception
- when others =>
- Report.Failed("Unexpected exception on EF.Tan with large " &
- "negative value");
- end;
-
-
- -- Check that no exception occurs on computing the Tan with very
- -- small (positive and negative) input values.
-
- begin
- New_Float_Result := GEF.Tan (New_Float(FXA5A00.Small));
- Dont_Optimize_New_Float(New_Float_Result, 3);
- exception
- when others =>
- Report.Failed("Unexpected exception on GEF.Tan with small " &
- "positive value");
- end;
-
- begin
- The_Result := EF.Tan (-FXA5A00.Small);
- Dont_Optimize_Float(The_Result, 4);
- exception
- when others =>
- Report.Failed("Unexpected exception on EF.Tan with small " &
- "negative value");
- end;
-
-
- -- Check prescribed result from Tan function. When the parameter X
- -- has the value zero, the Tan function yields a result of zero.
-
- if GEF.Tan(0.0) /= 0.0 or
- EF.Tan(0.0) /= 0.0
- then
- Report.Failed("Incorrect result from Tan function with zero " &
- "value input parameter");
- end if;
-
-
- -- Check the results of the Tan function with various input parameters.
-
- if not (Result_Within_Range(GEF.Tan(0.7854), 1.0, 0.001) and
- Result_Within_Range(GEF.Tan(0.8436), 1.124, 0.001) and
- Result_Within_Range( EF.Tan(Pi), 0.0, 0.001) and
- Result_Within_Range( EF.Tan(-Pi), 0.0, 0.001) and
- Result_Within_Range(GEF.Tan(0.5381), 0.597, 0.001) and
- Result_Within_Range( EF.Tan(0.1978), 0.200, 0.001))
- then
- Report.Failed("Incorrect result from Tan function with various " &
- "input parameters");
- end if;
-
-
- -- Testing of Tan function with cycle parameter.
-
- -- Check that Constraint_Error is raised by the Tan function with
- -- specified cycle, when the value of the parameter X is an odd
- -- multiple of the quarter cycle.
-
- if New_Float'Machine_Overflows = True then
- begin
- New_Float_Result := GEF.Tan(270.0, 360.0);
- Report.Failed("Constraint_Error not raised by GEF.Tan on odd " &
- "multiple of the quarter cycle");
- Dont_Optimize_New_Float(New_Float_Result, 5);
- exception
- when Constraint_Error => null; -- OK, expected exception.
- when others =>
- Report.Failed("Unexpected exception raised by GEF.Tan on odd " &
- "multiple of the quarter cycle");
- end;
- end if;
-
- -- Check that the exception Numerics.Argument_Error is raised, when
- -- the value of the parameter Cycle is zero or negative.
-
- begin
- New_Float_Result := GEF.Tan(X => 1.0, Cycle => -360.0);
- Report.Failed("Argument_Error not raised by GEF.Tan when Cycle " &
- "parameter has negative value");
- Dont_Optimize_New_Float(New_Float_Result, 6);
- exception
- when Argument_Error => null; -- OK, expected exception.
- when others =>
- Report.Failed("Unexpected exception raised by GEF.Tan when Cycle " &
- "parameter has negative value");
- end;
-
- begin
- The_Result := EF.Tan(1.0, Cycle => 0.0);
- Report.Failed("Argument_Error not raised by GEF.Tan when Cycle " &
- "parameter has a zero value");
- Dont_Optimize_Float(The_Result, 7);
- exception
- when Argument_Error => null; -- OK, expected exception.
- when others =>
- Report.Failed("Unexpected exception raised by EF.Tan when Cycle " &
- "parameter has a zero value");
- end;
-
-
- -- Check that no exception occurs on computing the Tan with very
- -- large (positive and negative) input values.
-
- begin
- New_Float_Result := GEF.Tan (New_Float(FXA5A00.Large), 360.0);
- Dont_Optimize_New_Float(New_Float_Result, 8);
- exception
- when others =>
- Report.Failed("Unexpected exception on GEF.Tan with large " &
- "positive value");
- end;
-
- begin
- The_Result := EF.Tan (FXA5A00.Minus_Large, Cycle => 360.0);
- Dont_Optimize_Float(The_Result, 9);
- exception
- when others =>
- Report.Failed("Unexpected exception on EF.Tan with large " &
- "negative value");
- end;
-
-
- -- Check prescribed result from Tan function with Cycle parameter.
-
- if GEF.Tan(0.0, 360.0) /= 0.0 or
- EF.Tan(0.0, Cycle => 360.0) /= 0.0
- then
- Report.Failed("Incorrect result from Tan function with cycle " &
- "parameter, using a zero value input parameter");
- end if;
-
-
- -- Check the Tan function, with specified Cycle parameter, with a
- -- variety of input parameters.
-
- if not Result_Within_Range(GEF.Tan(30.0, 360.0), 0.577, 0.001) or
- not Result_Within_Range( EF.Tan(57.0, 360.0), 1.540, 0.001) or
- not Result_Within_Range(GEF.Tan(115.0, 360.0), -2.145, 0.001) or
- not Result_Within_Range( EF.Tan(299.0, 360.0), -1.804, 0.001) or
- not Result_Within_Range(GEF.Tan(390.0, 360.0), 0.577, 0.001) or
- not Result_Within_Range( EF.Tan(520.0, 360.0), -0.364, 0.001)
- then
- Report.Failed("Incorrect result from the Tan function with " &
- "cycle parameter, with various input parameter " &
- "values");
- end if;
-
-
-
- -- Testing of Tanh Function, both instantiated and pre-instantiated
- -- version.
-
- -- Check that no exception occurs on computing the Tan with very
- -- large (positive and negative) input values.
-
- begin
- New_Float_Result := GEF.Tanh (New_Float(FXA5A00.Large));
- Dont_Optimize_New_Float(New_Float_Result, 10);
- exception
- when others =>
- Report.Failed("Unexpected exception on GEF.Tanh with large " &
- "positive value");
- end;
-
- begin
- The_Result := EF.Tanh (FXA5A00.Minus_Large);
- Dont_Optimize_Float(The_Result, 11);
- exception
- when others =>
- Report.Failed("Unexpected exception on EF.Tanh with large " &
- "negative value");
- end;
-
-
- -- Check for prescribed result of Tanh with zero value input parameter.
-
- if GEF.Tanh (0.0) /= 0.0 or
- EF.Tanh (0.0) /= 0.0
- then
- Report.Failed("Incorrect result from Tanh with zero parameter");
- end if;
-
-
- -- Check the results of the Tanh function with various input
- -- parameters.
-
- if not (FXA5A00.Result_Within_Range(GEF.Tanh(2.99), 0.995, 0.001) and
- FXA5A00.Result_Within_Range(GEF.Tanh(0.130), 0.129, 0.001) and
- FXA5A00.Result_Within_Range( EF.Tanh(Pi), 0.996, 0.001) and
- FXA5A00.Result_Within_Range( EF.Tanh(-Pi), -0.996, 0.001) and
- FXA5A00.Result_Within_Range(GEF.Tanh(0.60), 0.537, 0.001) and
- FXA5A00.Result_Within_Range( EF.Tanh(1.04), 0.778, 0.001) and
- FXA5A00.Result_Within_Range(GEF.Tanh(1.55), 0.914, 0.001) and
- FXA5A00.Result_Within_Range( EF.Tanh(-2.14), -0.973, 0.001))
- then
- Report.Failed("Incorrect result from Tanh function with various " &
- "input parameters");
- end if;
-
-
-
- -- Testing of Arctanh Function, both instantiated and pre-instantiated
- -- version.
-
- -- Check that Constraint_Error is raised by the Arctanh function
- -- when the absolute value of the parameter X is one.
-
- if New_Float'Machine_Overflows = True then
- begin
- New_Float_Result := GEF.Arctanh(X => 1.0);
- Report.Failed("Constraint_Error not raised by Function Arctanh " &
- "when provided a parameter value of 1.0");
- Dont_Optimize_New_Float(New_Float_Result, 12);
- exception
- when Constraint_Error => null; -- OK, expected exception.
- when others =>
- Report.Failed("Unexpected exception raised by Function Arctanh "
- & "when provided a parameter value of 1.0");
- end;
- end if;
-
- if Float'Machine_Overflows = True then
- begin
- The_Result := EF.Arctanh(-1.0);
- Report.Failed("Constraint_Error not raised by Function Arctanh " &
- "when provided a parameter value of -1.0");
- Dont_Optimize_Float(The_Result, 13);
- exception
- when Constraint_Error => null; -- OK, expected exception.
- when others =>
- Report.Failed("Unexpected exception raised by Function Arctanh "
- & "when provided a parameter value of -1.0");
- end;
- end if;
-
- -- Check that Function Arctanh raises Argument_Error when the absolute
- -- value of the parameter X exceeds one.
-
- begin
- New_Float_Result := GEF.Arctanh(New_Float(FXA5A00.One_Plus_Delta));
- Report.Failed("Argument_Error not raised by Function Arctanh " &
- "when provided a parameter value greater than 1.0");
- Dont_Optimize_New_Float(New_Float_Result, 14);
- exception
- when Argument_Error => null; -- OK, expected exception.
- when others =>
- Report.Failed("Unexpected exception raised by Function Arctanh " &
- "when provided a parameter value greater than 1.0");
- end;
-
-
- begin
- The_Result := EF.Arctanh(FXA5A00.Minus_One_Minus_Delta);
- Report.Failed("Argument_Error not raised by Function Arctanh " &
- "when provided a parameter value less than -1.0");
- Dont_Optimize_Float(The_Result, 15);
- exception
- when Argument_Error => null; -- OK, expected exception.
- when others =>
- Report.Failed("Unexpected exception raised by Function Arctanh " &
- "when provided a parameter value less than -1.0");
- end;
-
-
- begin
- New_Float_Result := GEF.Arctanh(New_Float(FXA5A00.Large));
- Report.Failed("Argument_Error not raised by Function Arctanh " &
- "when provided a large positive parameter value");
- Dont_Optimize_New_Float(New_Float_Result, 16);
- exception
- when Argument_Error => null; -- OK, expected exception.
- when others =>
- Report.Failed("Unexpected exception raised by Function Arctanh " &
- "when provided a large positive parameter value");
- end;
-
-
- begin
- The_Result := EF.Arctanh(FXA5A00.Minus_Large);
- Report.Failed("Argument_Error not raised by Function Arctanh " &
- "when provided a large negative parameter value");
- Dont_Optimize_Float(The_Result, 17);
- exception
- when Argument_Error => null; -- OK, expected exception.
- when others =>
- Report.Failed("Unexpected exception raised by Function Arctanh " &
- "when provided a large negative parameter value");
- end;
-
-
- -- Prescribed results for Function Arctanh with zero input value.
-
- if GEF.Arctanh(0.0) /= 0.0 or
- EF.Arctanh(0.0) /= 0.0
- then
- Report.Failed("Incorrect result from Function Arctanh with a " &
- "parameter value of zero");
- end if;
-
-
- -- Check the results of the Arctanh function with various input
- -- parameters.
-
- if not (Result_Within_Range(GEF.Arctanh(0.15), 0.151, 0.001) and
- Result_Within_Range( EF.Arctanh(0.44), 0.472, 0.001) and
- Result_Within_Range(GEF.Arctanh(0.81), 1.127, 0.001) and
- Result_Within_Range( EF.Arctanh(0.99), 2.647, 0.001))
- then
- Report.Failed("Incorrect result from Arctanh function with " &
- "various input parameters");
- end if;
-
- exception
- when others => Report.Failed ("Exception raised in Test_Block");
- end Test_Block;
-
- Report.Result;
-
-end CXA5A03;
diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxa5a04.a b/gcc/testsuite/ada/acats/tests/cxa/cxa5a04.a
deleted file mode 100644
index 9b590a23cb8..00000000000
--- a/gcc/testsuite/ada/acats/tests/cxa/cxa5a04.a
+++ /dev/null
@@ -1,434 +0,0 @@
--- CXA5A04.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that the functions Cot, Coth, and Arccoth provide correct
--- results.
---
--- TEST DESCRIPTION:
--- This test examines both the version of Cot, Coth, and Arccoth
--- the instantiation of the Ada.Numerics.Generic_Elementary_Functions
--- with a type derived from type Float, as well as the preinstantiated
--- version of this package for type Float.
--- Prescribed results, including instances prescribed to raise
--- exceptions, are examined in the test cases. In addition,
--- certain evaluations are performed where the actual function result
--- is compared with the expected result (within an epsilon range of
--- accuracy).
---
--- TEST FILES:
--- The following files comprise this test:
---
--- FXA5A00.A (foundation code)
--- CXA5A04.A
---
---
--- CHANGE HISTORY:
--- 15 Mar 95 SAIC Initial prerelease version.
--- 07 Apr 95 SAIC Corrected errors in context clause reference,
--- added trigonometric relationship checks.
--- 13 Jun 95 SAIC Incorporated use of Dont_Optimize procedure, and
--- use of Result_Within_Range function overloaded for
--- FXA5A00.New_Float_Type.
--- 18 Apr 96 SAIC Incorporated reviewer comments for ACVC 2.1.
--- 28 Feb 97 PWB.CTA Removed checks with explicit Cycle => 2.0*Pi
--- 29 Jun 98 EDS Protected exception tests by first testing
--- for 'Machine_Overflows
---
--- CHANGE NOTE:
--- According to Ken Dritz, author of the Numerics Annex of the RM,
--- one should never specify the cycle 2.0*Pi for the trigonometric
--- functions. In particular, if the machine number for the first
--- argument is not an exact multiple of the machine number for the
--- explicit cycle, then the specified exact results cannot be
--- reasonably expected. The affected checks in this test have been
--- marked as comments, with the additional notation "pwb-math".
--- Phil Brashear
---!
-
-with Ada.Exceptions;
-with Ada.Numerics.Elementary_Functions;
-with Ada.Numerics.Generic_Elementary_Functions;
-with FXA5A00;
-with Report;
-
-procedure CXA5A04 is
-begin
-
- Report.Test ("CXA5A04", "Check that the functions Cot, Coth, and " &
- "Arccoth provide correct results");
-
- Test_Block:
- declare
-
- use Ada.Exceptions;
- use Ada.Numerics;
- use FXA5A00;
-
- package GEF is new Ada.Numerics.Generic_Elementary_Functions(New_Float);
- package EF renames Ada.Numerics.Elementary_Functions;
-
- The_Result : Float;
- New_Float_Result : New_Float;
-
- procedure Dont_Optimize_Float is new Dont_Optimize(Float);
- procedure Dont_Optimize_New_Float is new Dont_Optimize(New_Float);
-
- begin
-
- -- Testing of Cot Function, both instantiated and pre-instantiated
- -- version.
-
- -- Check that Constraint_Error is raised with the Cot function is
- -- given a parameter input value of 0.0.
-
- if New_Float'Machine_Overflows = True then
- begin
- New_Float_Result := GEF.Cot (0.0);
- Report.Failed("Constraint_Error not raised by Function Cot " &
- "when provided a zero input parameter value");
- Dont_Optimize_New_Float(New_Float_Result, 1);
- exception
- when Constraint_Error => null; -- OK, expected exception.
- when others =>
- Report.Failed("Unexpected exception raised by Function Cot " &
- "when provided a zero input parameter value");
- end;
- end if;
-
- -- Check that no exception occurs on computing the Cot with very
- -- large (positive and negative) input values.
-
- begin
- New_Float_Result := GEF.Cot (New_Float(FXA5A00.Large));
- Dont_Optimize_New_Float(New_Float_Result, 2);
- exception
- when others =>
- Report.Failed("Unexpected exception on GEF.Cot with large " &
- "positive value");
- end;
-
- begin
- The_Result := EF.Cot (FXA5A00.Minus_Large);
- Dont_Optimize_Float(The_Result, 3);
- exception
- when others =>
- Report.Failed("Unexpected exception on EF.Cot with large " &
- "negative value");
- end;
-
-
- -- Check the results of the Cot function with various input parameters.
-
- if not (FXA5A00.Result_Within_Range(GEF.Cot(Pi/4.0), 1.0, 0.001) and
- FXA5A00.Result_Within_Range( EF.Cot(Pi/2.0), 0.0, 0.001) and
- FXA5A00.Result_Within_Range(GEF.Cot(3.0*Pi/4.0),-1.0, 0.001) and
- FXA5A00.Result_Within_Range( EF.Cot(3.0*Pi/2.0), 0.0, 0.001))
- then
- Report.Failed("Incorrect result from Cot function with various " &
- "input parameters");
- end if;
-
-
- -- Check the results of the Cot function against the results of
- -- various trigonometric relationships.
-
- if not FXA5A00.Result_Within_Range(GEF.Cot(New_Float(Pi/4.0)),
- 1.0/EF.Tan(Pi/4.0),
- 0.001) or
- not FXA5A00.Result_Within_Range(EF.Cot(Pi/4.0),
- EF.Cos(Pi/4.0)/EF.Sin(Pi/4.0),
- 0.001) or
- not FXA5A00.Result_Within_Range(EF.Cot(EF.Arccot(Pi/4.0)),
- Pi/4.0,
- 0.001)
- then
- Report.Failed("Incorrect result from Cot function with respect " &
- "to various trigonometric relationship expected " &
- "results");
- end if;
-
-
- -- Testing of Cot with Cycle parameter.
-
- -- Check that Argument_Error is raised by the Cot function when the
- -- value of the Cycle parameter is zero or negative.
-
- begin
- New_Float_Result := GEF.Cot (1.0, Cycle => 0.0);
- Report.Failed("Argument_Error not raised by the Cot Function " &
- "with a specified cycle value of 0.0");
- Dont_Optimize_New_Float(New_Float_Result, 4);
- exception
- when Argument_Error => null; -- OK, expected exception.
- when others =>
- Report.Failed
- ("Unexpected exception raised by the Cot Function with " &
- "a specified cycle value of 0.0");
- end;
-
- begin
- The_Result := EF.Cot (X => 1.0, Cycle => -360.0);
- Report.Failed("Argument_Error not raised by the Cot Function " &
- "with a specified cycle value of -360.0");
- Dont_Optimize_Float(The_Result, 5);
- exception
- when Argument_Error => null; -- OK, expected exception.
- when others =>
- Report.Failed
- ("Unexpected exception raised by the Cot Function with " &
- "a specified cycle value of -360.0");
- end;
-
-
- -- Check that Constraint_Error is raised by the Cot Function with
- -- specified cycle, when the value of the parameter X is 0.0.
-
- if New_Float'Machine_Overflows = True then
- begin
- New_Float_Result := GEF.Cot (0.0, 360.0);
- Report.Failed("Constraint_Error not raised by Function Cot " &
- "with specified cycle, when value of parameter " &
- "X is 0.0");
- Dont_Optimize_New_Float(New_Float_Result, 6);
- exception
- when Constraint_Error => null; -- OK, expected exception.
- when others =>
- Report.Failed("Unexpected exception raised by Function Cot " &
- "with specified cycle, when value of parameter " &
- "X is 0.0");
- end;
- end if;
-
- -- Check that Constraint_Error is raised by the Cot Function with
- -- specified cycle, when the value of the parameter X is a multiple
- -- of the half cycle.
-
- if New_Float'Machine_Overflows = True then
- begin
- New_Float_Result := GEF.Cot (180.0, 360.0);
- Report.Failed("Constraint_Error not raised by Function Cot " &
- "with specified cycle, when value of parameter " &
- "X is a multiple of the half cycle (180.0, 360.0)");
- Dont_Optimize_New_Float(New_Float_Result, 7);
- exception
- when Constraint_Error => null; -- OK, expected exception.
- when others =>
- Report.Failed("Unexpected exception raised by Function Cot " &
- "with specified cycle, when value of parameter " &
- "X is a multiple of the half cycle" &
- " (180.0, 360.0)");
- end;
- end if;
-
- if Float'Machine_Overflows = True then
- begin
- The_Result := EF.Cot (540.0, 360.0);
- Report.Failed("Constraint_Error not raised by Function Cot " &
- "with specified cycle, when value of parameter " &
- "X is a multiple of the half cycle (540.0, 360.0)");
- Dont_Optimize_Float(The_Result, 8);
- exception
- when Constraint_Error => null; -- OK, expected exception.
- when others =>
- Report.Failed("Unexpected exception raised by Function Cot " &
- "with specified cycle, when value of parameter " &
- "X is a multiple of the half cycle (540.0, 360.0)");
- end;
- end if;
-
---pwb-math -- Check that no exception occurs on computing the Cot with very
---pwb-math -- large (positive and negative) input values.
---pwb-math
---pwb-math begin
---pwb-math New_Float_Result := GEF.Cot (New_Float(FXA5A00.Large), 2.0*Pi);
---pwb-math Dont_Optimize_New_Float(New_Float_Result, 9);
---pwb-math exception
---pwb-math when others =>
---pwb-math Report.Failed("Unexpected exception on GEF.Cot with large " &
---pwb-math "positive value");
---pwb-math end;
---pwb-math
---pwb-math begin
---pwb-math The_Result := EF.Cot (FXA5A00.Minus_Large, Cycle => 2.0*Pi);
---pwb-math Dont_Optimize_Float(The_Result, 10);
---pwb-math exception
---pwb-math when others =>
---pwb-math Report.Failed("Unexpected exception on EF.Cot with large " &
---pwb-math "negative value");
---pwb-math end;
---pwb-math
---pwb-math
---pwb-math -- Check prescribed result from Cot function with Cycle parameter.
---pwb-math
---pwb-math if not FXA5A00.Result_Within_Range
---pwb-math (GEF.Cot(New_Float(FXA5A00.Half_Pi), 2.0*Pi), 0.0, 0.001) or
---pwb-math not FXA5A00.Result_Within_Range
---pwb-math (EF.Cot(3.0*Pi/2.0, Cycle => 2.0*Pi), 0.0, 0.001)
---pwb-math then
---pwb-math Report.Failed("Incorrect result from Cot function with cycle " &
---pwb-math "parameter, using a multiple of Pi/2 as the " &
---pwb-math "input parameter");
---pwb-math end if;
-
-
- -- Testing of Coth Function, both instantiated and pre-instantiated
- -- version.
-
- -- Check that no exception occurs on computing the Coth with very
- -- large (positive and negative) input values.
-
- begin
- The_Result := EF.Coth (FXA5A00.Large);
- if The_Result > 1.0 then
- Report.Failed("Result of Coth function with large positive " &
- "value greater than 1.0");
- end if;
- exception
- when others =>
- Report.Failed("Unexpected exception on EF.Coth with large " &
- "positive value");
- end;
-
- begin
- The_Result := EF.Coth (FXA5A00.Minus_Large);
- if The_Result < -1.0 then
- Report.Failed("Result of Coth function with large negative " &
- "value less than -1.0");
- end if;
- exception
- when others =>
- Report.Failed("Unexpected exception on EF.Coth with large " &
- "negative value");
- end;
-
-
- -- Check that Constraint_Error is raised by the Coth function, when
- -- the value of the parameter X is 0.0.
-
- if New_Float'Machine_Overflows = True then
- begin
- New_Float_Result := GEF.Coth (X => 0.0);
- Report.Failed("Constraint_Error not raised by the Coth function " &
- "when the value of parameter X is 0.0");
- Dont_Optimize_New_Float(New_Float_Result, 11);
- exception
- when Constraint_Error => null; -- OK, expected exception.
- when others =>
- Report.Failed("Unexpected exception raised by the Coth " &
- "function when the value of parameter X is 0.0");
- end;
- end if;
-
-
- -- Testing of Arccoth Function, both instantiated and pre-instantiated
- -- version.
-
- -- Check that Constraint_Error is raised by the Arccoth function
- -- when the absolute value of the parameter X is 1.0.
-
- if New_Float'Machine_Overflows = True then
- begin
- New_Float_Result := GEF.Arccoth (X => 1.0);
- Report.Failed("Constraint_Error not raised by the Arccoth " &
- "function when the value of parameter X is 1.0");
- Dont_Optimize_New_Float(New_Float_Result, 12);
- exception
- when Constraint_Error => null; -- OK, expected exception.
- when others =>
- Report.Failed("Unexpected exception raised by the Arccoth " &
- "function when the value of parameter X is 1.0");
- end;
- end if;
-
- if Float'Machine_Overflows = True then
- begin
- The_Result := EF.Arccoth (-1.0);
- Report.Failed("Constraint_Error not raised by the Arccoth " &
- "function when the value of parameter X is -1.0");
- Dont_Optimize_Float(The_Result, 13);
- exception
- when Constraint_Error => null; -- OK, expected exception.
- when others =>
- Report.Failed("Unexpected exception raised by the Arccoth " &
- "function when the value of parameter X is -1.0");
- end;
- end if;
-
- -- Check that Argument_Error is raised by the Arccoth function when
- -- the absolute value of the parameter X is less than 1.0.
-
- begin
- New_Float_Result := GEF.Arccoth (X => New_Float(One_Minus_Delta));
- Report.Failed("Argument_Error not raised by the Arccoth " &
- "function with parameter value less than 1.0");
- Dont_Optimize_New_Float(New_Float_Result, 14);
- exception
- when Argument_Error => null; -- OK, expected exception.
- when others =>
- Report.Failed("Unexpected exception raised by the Arccoth " &
- "function with parameter value less than 1.0");
- end;
-
- begin
- The_Result := EF.Arccoth (X => FXA5A00.Minus_One_Plus_Delta);
- Report.Failed("Argument_Error not raised by the Arccoth function " &
- "with parameter value between 0.0 and -1.0");
- Dont_Optimize_Float(The_Result, 15);
- exception
- when Argument_Error => null; -- OK, expected exception.
- when others =>
- Report.Failed("Unexpected exception raised by the Arccoth " &
- "function with parameter value between 0.0 " &
- "and -1.0");
- end;
-
-
- -- Check the results of the Arccoth function with various input
- -- parameters.
-
- if not (Result_Within_Range(GEF.Arccoth(1.01), 2.652, 0.01) and
- Result_Within_Range( EF.Arccoth(1.25), 1.099, 0.01) and
- Result_Within_Range(GEF.Arccoth(1.56), 0.760, 0.001) and
- Result_Within_Range( EF.Arccoth(1.97), 0.560, 0.001) and
- Result_Within_Range(GEF.Arccoth(2.40), 0.444, 0.001) and
- Result_Within_Range( EF.Arccoth(4.30), 0.237, 0.001) and
- Result_Within_Range(GEF.Arccoth(5.80), 0.174, 0.001) and
- Result_Within_Range( EF.Arccoth(7.00), 0.144, 0.001))
- then
- Report.Failed("Incorrect result from Arccoth function with various " &
- "input parameters");
- end if;
-
-
- exception
- when The_Error : others =>
- Report.Failed ("The following exception was raised in the " &
- "Test_Block: " & Exception_Name(The_Error));
- end Test_Block;
-
- Report.Result;
-
-end CXA5A04;
diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxa5a05.a b/gcc/testsuite/ada/acats/tests/cxa/cxa5a05.a
deleted file mode 100644
index b50da3a6ab5..00000000000
--- a/gcc/testsuite/ada/acats/tests/cxa/cxa5a05.a
+++ /dev/null
@@ -1,338 +0,0 @@
--- CXA5A05.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that the functions Arcsin and Arcsinh provide correct
--- results.
---
--- TEST DESCRIPTION:
--- This test examines both the version of Arcsin and Arcsinh
--- the instantiation of the Ada.Numerics.Generic_Elementary_Functions
--- with a type derived from type Float, as well as the preinstantiated
--- version of this package for type Float.
--- Prescribed results, including instances prescribed to raise
--- exceptions, are examined in the test cases. In addition,
--- certain evaluations are performed where the actual function result
--- is compared with the expected result (within an epsilon range of
--- accuracy).
---
--- TEST FILES:
--- The following files comprise this test:
---
--- FXA5A00.A (foundation code)
--- CXA5A05.A
---
---
--- CHANGE HISTORY:
--- 20 Mar 95 SAIC Initial prerelease version.
--- 06 Apr 95 SAIC Corrected errors in context clause reference and
--- use of Cycle parameter.
--- 13 Jun 95 SAIC Incorporated use of Dont_Optimize procedure, and
--- use of Result_Within_Range function overloaded for
--- FXA5A00.New_Float_Type.
--- 28 Feb 97 PWB.CTA Removed checks with explict Cycle => 2.0*Pi
---
--- CHANGE NOTE:
--- According to Ken Dritz, author of the Numerics Annex of the RM,
--- one should never specify the cycle 2.0*Pi for the trigonometric
--- functions. In particular, if the machine number for the first
--- argument is not an exact multiple of the machine number for the
--- explicit cycle, then the specified exact results cannot be
--- reasonably expected. The affected checks in this test have been
--- marked as comments, with the additional notation "pwb-math".
--- Phil Brashear
---!
-
-with Ada.Numerics.Elementary_Functions;
-with Ada.Numerics.Generic_Elementary_Functions;
-with FXA5A00;
-with Report;
-
-procedure CXA5A05 is
-begin
-
- Report.Test ("CXA5A05", "Check that the functions Arcsin and Arcsinh " &
- "provide correct results");
-
- Test_Block:
- declare
-
- use Ada.Numerics;
- use FXA5A00;
-
- package GEF is new Ada.Numerics.Generic_Elementary_Functions(New_Float);
- package EF renames Ada.Numerics.Elementary_Functions;
-
- The_Result : Float;
- New_Float_Result : New_Float;
-
- procedure Dont_Optimize_Float is new Dont_Optimize(Float);
- procedure Dont_Optimize_New_Float is new Dont_Optimize(New_Float);
-
- begin
-
- -- Testing of Function Arcsin, both instantiated and pre-instantiated
- -- versions.
-
- -- Check that Argument_Error is raised by the Arcsin function when
- -- the absolute value of the parameter X is greater than 1.0.
-
- begin
- New_Float_Result := GEF.Arcsin(New_Float(FXA5A00.One_Plus_Delta));
- Report.Failed("Argument_Error not raised by Arcsin function " &
- "when provided a parameter value larger than 1.0");
- Dont_Optimize_New_Float(New_Float_Result, 1);
- exception
- when Argument_Error => null; -- OK, expected exception.
- when others =>
- Report.Failed("Unexpected exception raised by Arcsin function " &
- "when provided a parameter value larger than 1.0");
- end;
-
- begin
- The_Result := EF.Arcsin(FXA5A00.Minus_Large);
- Report.Failed("Argument_Error not raised by Arcsin function " &
- "when provided a large negative parameter value");
- Dont_Optimize_Float(The_Result, 2);
- exception
- when Argument_Error => null; -- OK, expected exception.
- when others =>
- Report.Failed("Unexpected exception raised by Arcsin function " &
- "when provided a large negative parameter value");
- end;
-
-
- -- Check the prescribed result of function Arcsin with parameter 0.0.
-
- if GEF.Arcsin(X => 0.0) /= 0.0 or
- EF.Arcsin(0.0) /= 0.0
- then
- Report.Failed("Incorrect result from Function Arcsin when the " &
- "value of the parameter X is 0.0");
- end if;
-
-
- -- Check the results of the Arcsin function with various input
- -- parameters.
-
- if not Result_Within_Range(GEF.Arcsin(1.0), 1.571, 0.001) or
- not Result_Within_Range( EF.Arcsin(0.62), 0.669, 0.001) or
- not Result_Within_Range(GEF.Arcsin(0.01), 0.010, 0.001) or
- not Result_Within_Range( EF.Arcsin(-0.29), -0.294, 0.001) or
- not Result_Within_Range(GEF.Arcsin(-0.50), -0.524, 0.001) or
- not Result_Within_Range( EF.Arcsin(-1.0), -1.571, 0.001)
- then
- Report.Failed("Incorrect result from Function Arcsin with " &
- "various input parameters");
- end if;
-
-
- -- Testing of Function Arcsin with specified Cycle parameter.
-
---pwb-math -- Check that Argument_Error is raised by the Arcsin function with
---pwb-math -- specified cycle, whenever the absolute value of the parameter X
---pwb-math -- is greater than 1.0.
---pwb-math
---pwb-math begin
---pwb-math New_Float_Result := GEF.Arcsin(New_Float(FXA5A00.Large), 2.0*Pi);
---pwb-math Report.Failed("Argument_Error not raised by Function Arcsin " &
---pwb-math "with specified cycle, when provided a large " &
---pwb-math "positive input parameter");
---pwb-math Dont_Optimize_New_Float(New_Float_Result, 3);
---pwb-math exception
---pwb-math when Argument_Error => null; -- OK, expected exception.
---pwb-math when others =>
---pwb-math Report.Failed("Unexpected exception raised by Function Arcsin " &
---pwb-math "with specified cycle, when provided a large " &
---pwb-math "positive input parameter");
---pwb-math end;
---pwb-math
---pwb-math begin
---pwb-math The_Result := EF.Arcsin(FXA5A00.Minus_One_Minus_Delta, 2.0*Pi);
---pwb-math Report.Failed("Argument_Error not raised by Function Arcsin " &
---pwb-math "with specified cycle, when provided an input " &
---pwb-math "parameter less than -1.0");
---pwb-math Dont_Optimize_Float(The_Result, 4);
---pwb-math exception
---pwb-math when Argument_Error => null; -- OK, expected exception.
---pwb-math when others =>
---pwb-math Report.Failed("Unexpected exception raised by Function Arcsin " &
---pwb-math "with specified cycle, when provided an input " &
---pwb-math "parameter less than -1.0");
---pwb-math end;
---pwb-math
- -- Check that Argument_Error is raised by the Arcsin function with
- -- specified cycle, whenever the Cycle parameter is zero or negative.
-
- begin
- New_Float_Result := GEF.Arcsin(2.0, 0.0);
- Report.Failed("Argument_Error not raised by Function Arcsin " &
- "with specified cycle of 0.0");
- Dont_Optimize_New_Float(New_Float_Result, 5);
- exception
- when Argument_Error => null; -- OK, expected exception.
- when others =>
- Report.Failed("Unexpected exception raised by Function Arcsin " &
- "with specified cycle of 0.0");
- end;
-
- begin
- The_Result := EF.Arcsin(2.0, -2.0*Pi);
- Report.Failed("Argument_Error not raised by Function Arcsin " &
- "with specified negative cycle parameter");
- Dont_Optimize_Float(The_Result, 6);
- exception
- when Argument_Error => null; -- OK, expected exception.
- when others =>
- Report.Failed("Unexpected exception raised by Function Arcsin " &
- "with specified negative cycle parameter");
- end;
-
-
---pwb-math -- Check the prescribed result of function Arcsin with specified Cycle
---pwb-math -- parameter, when the value of parameter X is 0.0.
---pwb-math
---pwb-math if GEF.Arcsin(X => 0.0, Cycle => 2.0*Pi) /= 0.0 or
---pwb-math EF.Arcsin(0.0, 2.0*Pi) /= 0.0
---pwb-math then
---pwb-math Report.Failed("Incorrect result from Function Arcsin with " &
---pwb-math "specified Cycle parameter, when the value " &
---pwb-math "of parameter X is 0.0");
---pwb-math end if;
---pwb-math
---pwb-math
---pwb-math -- Test of the Arcsin function with specified Cycle parameter with
---pwb-math -- various input parameters.
---pwb-math
---pwb-math if not FXA5A00.Result_Within_Range(GEF.Arcsin( 0.01, 2.0*Pi),
---pwb-math 0.010,
---pwb-math 0.001) or
---pwb-math not FXA5A00.Result_Within_Range( EF.Arcsin( 0.14, 2.0*Pi),
---pwb-math 0.141,
---pwb-math 0.001) or
---pwb-math not FXA5A00.Result_Within_Range(GEF.Arcsin( 0.37, 2.0*Pi),
---pwb-math 0.379,
---pwb-math 0.001) or
---pwb-math not FXA5A00.Result_Within_Range( EF.Arcsin( 0.55, 2.0*Pi),
---pwb-math 0.582,
---pwb-math 0.001) or
---pwb-math not FXA5A00.Result_Within_Range(GEF.Arcsin(-0.22, 2.0*Pi),
---pwb-math -0.222,
---pwb-math 0.001) or
---pwb-math not FXA5A00.Result_Within_Range( EF.Arcsin(-0.99, 2.0*Pi),
---pwb-math -1.43,
---pwb-math 0.01) or
---pwb-math not FXA5A00.Result_Within_Range( EF.Arcsin(1.0, 360.0),
---pwb-math 90.0,
---pwb-math 0.1) or
---pwb-math not FXA5A00.Result_Within_Range( EF.Arcsin(1.0, 100.0),
---pwb-math 25.0,
---pwb-math 0.1)
---pwb-math then
---pwb-math Report.Failed("Incorrect result from Arcsin with specified " &
---pwb-math "cycle parameter with various input parameters");
---pwb-math end if;
-
- -- Testing of Arcsinh Function, both instantiated and pre-instantiated
- -- version.
-
- -- Check that no exception occurs on computing the Arcsinh with very
- -- large (positive and negative) input values.
-
- begin
- New_Float_Result := GEF.Arcsinh(New_Float(FXA5A00.Large));
- Dont_Optimize_New_Float(New_Float_Result, 7);
- exception
- when others =>
- Report.Failed("Unexpected exception on Arcsinh with large " &
- "positive value");
- end;
-
- begin
- The_Result := EF.Arcsinh(FXA5A00.Minus_Large);
- Dont_Optimize_Float(The_Result, 8);
- exception
- when others =>
- Report.Failed("Unexpected exception on Arcsinh with large " &
- "negative value");
- end;
-
-
- -- Check that no exception occurs on computing the Arcsinh with very
- -- small (positive and negative) input values.
-
- begin
- New_Float_Result := GEF.Arcsinh(New_Float(FXA5A00.Small));
- Dont_Optimize_New_Float(New_Float_Result, 9);
- exception
- when others =>
- Report.Failed("Unexpected exception on Arcsinh with small " &
- "positive value");
- end;
-
- begin
- The_Result := EF.Arcsinh(-FXA5A00.Small);
- Dont_Optimize_Float(The_Result, 10);
- exception
- when others =>
- Report.Failed("Unexpected exception on Arcsinh with small " &
- "negative value");
- end;
-
-
- -- Check function Arcsinh for prescribed result with parameter 0.0.
-
- if GEF.Arcsinh(X => 0.0) /= 0.0 or
- EF.Arcsinh(X => 0.0) /= 0.0
- then
- Report.Failed("Incorrect result from Function Arcsinh when " &
- "provided a 0.0 input parameter");
- end if;
-
-
- -- Check the results of the Arcsinh function with various input
- -- parameters.
-
- if not Result_Within_Range(GEF.Arcsinh(0.15), 0.149, 0.001) or
- not Result_Within_Range( EF.Arcsinh(0.82), 0.748, 0.001) or
- not Result_Within_Range(GEF.Arcsinh(1.44), 1.161, 0.001) or
- not Result_Within_Range(GEF.Arcsinh(6.70), 2.601, 0.001) or
- not Result_Within_Range( EF.Arcsinh(Pi), 1.862, 0.001) or
- not Result_Within_Range( EF.Arcsinh(-Pi), -1.862, 0.001) or
- not Result_Within_Range(GEF.Arcsinh(-1.0), -0.881, 0.001) or
- not Result_Within_Range( EF.Arcsinh(-5.5), -2.406, 0.001)
- then
- Report.Failed("Incorrect result from Function Arcsin with " &
- "various input parameters");
- end if;
-
-
- exception
- when others => Report.Failed ("Exception raised in Test_Block");
- end Test_Block;
-
- Report.Result;
-
-end CXA5A05;
diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxa5a06.a b/gcc/testsuite/ada/acats/tests/cxa/cxa5a06.a
deleted file mode 100644
index 191a96d7567..00000000000
--- a/gcc/testsuite/ada/acats/tests/cxa/cxa5a06.a
+++ /dev/null
@@ -1,334 +0,0 @@
--- CXA5A06.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that the functions Arccos and Arccosh provide correct
--- results.
---
--- TEST DESCRIPTION:
--- This test examines both the version of Arccos and Arccosh
--- the instantiation of the Ada.Numerics.Generic_Elementary_Functions
--- with a type derived from type Float, as well as the preinstantiated
--- version of this package for type Float.
--- Prescribed results, including instances prescribed to raise
--- exceptions, are examined in the test cases. In addition,
--- certain evaluations are performed where the actual function result
--- is compared with the expected result (within an epsilon range of
--- accuracy).
---
--- TEST FILES:
--- The following files comprise this test:
---
--- FXA5A00.A (foundation code)
--- CXA5A06.A
---
---
--- CHANGE HISTORY:
--- 27 Mar 95 SAIC Initial prerelease version.
--- 13 Jun 95 SAIC Incorporated use of Dont_Optimize procedure, and
--- use of Result_Within_Range function overloaded for
--- FXA5A00.New_Float_Type.
--- 28 Feb 97 PWB.CTA Removed checks with explicit Cycle => 2.0*Pi
---
--- CHANGE NOTE:
--- According to Ken Dritz, author of the Numerics Annex of the RM,
--- one should never specify the cycle 2.0*Pi for the trigonometric
--- functions. In particular, if the machine number for the first
--- argument is not an exact multiple of the machine number for the
--- explicit cycle, then the specified exact results cannot be
--- reasonably expected. The affected checks in this test have been
--- marked as comments, with the additional notation "pwb-math".
--- Phil Brashear
---!
-
-with Ada.Numerics.Elementary_Functions;
-with Ada.Numerics.Generic_Elementary_Functions;
-with FXA5A00;
-with Report;
-
-procedure CXA5A06 is
-begin
-
- Report.Test ("CXA5A06", "Check that the functions Arccos and Arccosh " &
- "provide correct results");
-
- Test_Block:
- declare
-
- use Ada.Numerics;
- use FXA5A00;
-
- package GEF is new Ada.Numerics.Generic_Elementary_Functions(New_Float);
- package EF renames Ada.Numerics.Elementary_Functions;
-
- The_Result : Float;
- New_Float_Result : New_Float;
-
- procedure Dont_Optimize_Float is new Dont_Optimize(Float);
- procedure Dont_Optimize_New_Float is new Dont_Optimize(New_Float);
-
- begin
-
- -- Testing of Arccos Function, both instantiated and pre-instantiated
- -- version.
-
- -- Check that Argument_Error is raised by the Arccos function when the
- -- absolute value of the input parameter is greater than 1.0.
-
- begin
- New_Float_Result := GEF.Arccos(New_Float(FXA5A00.One_Plus_Delta));
- Report.Failed("Argument_Error not raised by the Arccos function " &
- "when the input parameter is greater than 1.0");
- Dont_Optimize_New_Float(New_Float_Result, 1);
- exception
- when Argument_Error => null; -- OK, expected exception.
- when others =>
- Report.Failed("Unexpected exception raised by the Arccos " &
- "function when the input parameter is greater " &
- "than 1.0");
- end;
-
- begin
- The_Result := EF.Arccos(-FXA5A00.Large);
- Report.Failed("Argument_Error not raised by the Arccos function " &
- "when the input parameter is a large negative value");
- Dont_Optimize_Float(The_Result, 2);
- exception
- when Argument_Error => null; -- OK, expected exception.
- when others =>
- Report.Failed("Unexpected exception raised by the Arccos " &
- "function when the input parameter is a " &
- "large negative value");
- end;
-
-
- -- Check the prescribed results of the Arccos function.
-
- if GEF.Arccos(X => 1.0) /= 0.0 or
- EF.Arccos(1.0) /= 0.0
- then
- Report.Failed("Incorrect result returned by the Arccos function " &
- "when provided a parameter value of 0.0");
- end if;
-
-
- -- Check the results of the Arccos function with various input
- -- parameters.
-
- if not Result_Within_Range(GEF.Arccos(0.77), 0.692, 0.001) or
- not Result_Within_Range( EF.Arccos(0.37), 1.19, 0.01) or
- not Result_Within_Range(GEF.Arccos(0.0), Pi/2.0, 0.01) or
- not Result_Within_Range( EF.Arccos(-0.11), 1.68, 0.01) or
- not Result_Within_Range(GEF.Arccos(-0.67), 2.31, 0.01) or
- not Result_Within_Range( EF.Arccos(-0.94), 2.79, 0.01) or
- not Result_Within_Range(GEF.Arccos(-1.0), Pi, 0.01)
- then
- Report.Failed("Incorrect result returned from the Arccos " &
- "function when provided a variety of input " &
- "parameters");
- end if;
-
-
- -- Testing of the Arccos function with specified Cycle parameter.
-
- -- Check that Argument_Error is raised by the Arccos function, with
- -- specified Cycle parameter, when the absolute value of the input
- -- parameter is greater than 1.0.
-
- begin
---pwb-math: Next line: Changed 2.0*Pi to 360.0
- New_Float_Result := GEF.Arccos(New_Float(Large), Cycle => 360.0);
- Report.Failed("Argument_Error not raised by the Arccos function " &
- "with specified Cycle parameter, when the input " &
- "parameter is a large positive value");
- Dont_Optimize_New_Float(New_Float_Result, 3);
- exception
- when Argument_Error => null; -- OK, expected exception.
- when others =>
- Report.Failed("Unexpected exception raised by the Arccos " &
- "function with specified Cycle parameter, when " &
- "the input parameter is a large positive value");
- end;
-
- begin
---pwb-math: Next line: Changed 2.0*Pi to 360.0
- The_Result := EF.Arccos(FXA5A00.Minus_One_Minus_Delta, 360.0);
- Report.Failed("Argument_Error not raised by the Arccos function " &
- "with specified Cycle parameter, when the input " &
- "parameter is less than -1.0");
- Dont_Optimize_Float(The_Result, 4);
- exception
- when Argument_Error => null; -- OK, expected exception.
- when others =>
- Report.Failed("Unexpected exception raised by the Arccos " &
- "function with specified Cycle parameter, " &
- "when the input parameter is less than -1.0");
- end;
-
-
- -- Check that Argument_Error is raised by the Arccos function with
- -- specified cycle when the value of the Cycle parameter is zero or
- -- negative.
-
- begin
- New_Float_Result := GEF.Arccos(X => 1.0, Cycle => 0.0 );
- Report.Failed("Argument_Error not raised by the Arccos function " &
- "with specified Cycle parameter, when the Cycle " &
- "parameter is 0.0");
- Dont_Optimize_New_Float(New_Float_Result, 5);
- exception
- when Argument_Error => null; -- OK, expected exception.
- when others =>
- Report.Failed("Unexpected exception raised by the Arccos " &
- "function with specified Cycle parameter, when " &
- "the Cycle parameter is 0.0");
- end;
-
- begin
- The_Result := EF.Arccos(1.0, Cycle => -2.0*Pi);
- Report.Failed("Argument_Error not raised by the Arccos function " &
- "with specified Cycle parameter, when the Cycle " &
- "parameter is negative");
- Dont_Optimize_Float(The_Result, 6);
- exception
- when Argument_Error => null; -- OK, expected exception.
- when others =>
- Report.Failed("Unexpected exception raised by the Arccos " &
- "function with specified Cycle parameter, when " &
- "the Cycle parameter is negative");
- end;
-
-
- -- Check the prescribed result of the Arccos function with specified
- -- Cycle parameter.
-
---pwb-math: Next two lines: Changed 2.0*Pi to 360.0
- if GEF.Arccos(X => 1.0, Cycle => 360.0) /= 0.0 or
- EF.Arccos(1.0, 360.0) /= 0.0
- then
- Report.Failed("Incorrect result from the Arccos function with " &
- "specified Cycle parameter, when the input " &
- "parameter value is 1.0");
- end if;
-
-
- -- Check the results of the Arccos function, with specified Cycle
- -- parameter, with various input parameters.
-
- if --pwb-math not Result_Within_Range(GEF.Arccos( 0.04, 2.0*Pi), 1.53, 0.01) or
---pwb-math not Result_Within_Range( EF.Arccos( 0.14, 2.0*Pi), 1.43, 0.01) or
---pwb-math not Result_Within_Range(GEF.Arccos( 0.57, 2.0*Pi), 0.96, 0.01) or
---pwb-math not Result_Within_Range( EF.Arccos( 0.99, 2.0*Pi), 0.14, 0.01) or
- not Result_Within_Range(GEF.Arccos(-1.0, 360.0), 180.0, 0.1) or
- not Result_Within_Range(GEF.Arccos(-1.0, 100.0), 50.0, 0.1) or
- not Result_Within_Range(GEF.Arccos( 0.0, 360.0), 90.0, 0.1) or
- not Result_Within_Range(GEF.Arccos( 0.0, 100.0), 25.0, 0.1)
- then
- Report.Failed("Incorrect result returned from the Arccos " &
- "function with specified Cycle parameter, " &
- "when provided a variety of input parameters");
- end if;
-
-
-
- -- Testing of Arccosh Function, both instantiated and pre-instantiated
- -- version.
-
- -- Check that Argument_Error is raised by the Arccosh function when
- -- the value of the parameter X is less than 1.0.
-
- begin
- New_Float_Result := GEF.Arccosh(New_Float(FXA5A00.One_Minus_Delta));
- Report.Failed("Argument_Error not raised by the Arccosh function " &
- "when the parameter value is less than 1.0");
- Dont_Optimize_New_Float(New_Float_Result, 7);
- exception
- when Argument_Error => null; -- OK, expected exception.
- when others =>
- Report.Failed("Unexpected exception raised by the Arccosh " &
- "function when given a parameter value less " &
- "than 1.0");
- end;
-
- begin
- The_Result := EF.Arccosh(0.0);
- Report.Failed("Argument_Error not raised by the Arccosh function " &
- "when the parameter value is 0.0");
- Dont_Optimize_Float(The_Result, 8);
- exception
- when Argument_Error => null; -- OK, expected exception.
- when others =>
- Report.Failed("Unexpected exception raised by the Arccosh " &
- "function when given a parameter value of 0.0");
- end;
-
- begin
- New_Float_Result := GEF.Arccosh(New_Float(-FXA5A00.Large));
- Report.Failed("Argument_Error not raised by the Arccosh function " &
- "when the large negative parameter value");
- Dont_Optimize_New_Float(New_Float_Result, 9);
- exception
- when Argument_Error => null; -- OK, expected exception.
- when others =>
- Report.Failed("Unexpected exception raised by the Arccosh " &
- "function when given a large negative parameter " &
- "value");
- end;
-
-
- -- Check the prescribed results of the Arccosh function.
-
- if GEF.Arccosh(X => 1.0) /= 0.0 or
- EF.Arccosh(1.0) /= 0.0
- then
- Report.Failed("Incorrect result returned by the Arccosh " &
- "function when provided a parameter value of 0.0");
- end if;
-
-
- -- Check the results of the Arccosh function with various input
- -- parameters.
-
- if not Result_Within_Range(GEF.Arccosh(1.03), 0.244, 0.001) or
- not Result_Within_Range( EF.Arccosh(1.28), 0.732, 0.001) or
- not Result_Within_Range(GEF.Arccosh(1.50), 0.962, 0.001) or
- not Result_Within_Range( EF.Arccosh(1.77), 1.17, 0.01) or
- not Result_Within_Range(GEF.Arccosh(2.00), 1.32, 0.01) or
- not Result_Within_Range( EF.Arccosh(4.30), 2.14, 0.01) or
- not Result_Within_Range(GEF.Arccosh(6.90), 2.62, 0.01)
- then
- Report.Failed("Incorrect result returned from the Arccosh " &
- "function when provided a variety of input " &
- "parameters");
- end if;
-
-
- exception
- when others => Report.Failed ("Exception raised in Test_Block");
- end Test_Block;
-
- Report.Result;
-
-end CXA5A06;
diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxa5a07.a b/gcc/testsuite/ada/acats/tests/cxa/cxa5a07.a
deleted file mode 100644
index 179d54c44bf..00000000000
--- a/gcc/testsuite/ada/acats/tests/cxa/cxa5a07.a
+++ /dev/null
@@ -1,413 +0,0 @@
--- CXA5A07.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that the function Arctan provides correct results.
---
--- TEST DESCRIPTION:
--- This test examines both the version of Arctan resulting from the
--- instantiation of the Ada.Numerics.Generic_Elementary_Functions with
--- a type derived from type Float, as well as the preinstantiated
--- version of this package for type Float.
--- Prescribed results, including instances prescribed to raise
--- exceptions, are examined in the test cases. In addition,
--- certain evaluations are performed where the actual function result
--- is compared with the expected result (within an epsilon range of
--- accuracy).
---
--- TEST FILES:
--- The following files comprise this test:
---
--- FXA5A00.A (foundation code)
--- CXA5A07.A
---
---
--- CHANGE HISTORY:
--- 04 Apr 95 SAIC Initial prerelease version.
--- 13 Jun 95 SAIC Incorporated use of Dont_Optimize procedure, and
--- use of Result_Within_Range function overloaded for
--- FXA5A00.New_Float_Type.
--- 28 Feb 97 PWB.CTA Removed checks with explicit Cycle => 2.0*Pi
---
--- CHANGE NOTE:
--- According to Ken Dritz, author of the Numerics Annex of the RM,
--- one should never specify the cycle 2.0*Pi for the trigonometric
--- functions. In particular, if the machine number for the first
--- argument is not an exact multiple of the machine number for the
--- explicit cycle, then the specified exact results cannot be
--- reasonably expected. The affected checks in this test have been
--- marked as comments, with the additional notation "pwb-math".
--- Phil Brashear
---!
-
-with Ada.Numerics.Elementary_Functions;
-with Ada.Numerics.Generic_Elementary_Functions;
-with FXA5A00;
-with Report;
-
-procedure CXA5A07 is
-begin
-
- Report.Test ("CXA5A07", "Check that the Arctan function provides " &
- "correct results");
-
- Test_Block:
- declare
-
- use Ada.Numerics;
- use FXA5A00;
-
- package GEF is new Ada.Numerics.Generic_Elementary_Functions(New_Float);
- package EF renames Ada.Numerics.Elementary_Functions;
-
- Float_Result : Float;
- New_Float_Result : New_Float;
-
- procedure Dont_Optimize_Float is new Dont_Optimize(Float);
- procedure Dont_Optimize_New_Float is new Dont_Optimize(New_Float);
-
- begin
-
- -- Testing of Arctan Function, both instantiated and pre-instantiated
- -- version.
-
- -- Check that Argument_Error is raised by the Arctan function when
- -- provided parameter values of 0.0, 0.0.
-
- begin
- New_Float_Result := GEF.Arctan(Y => 0.0, X => 0.0);
- Report.Failed("Argument_Error not raised when the Arctan " &
- "function is provided input of 0.0, 0.0");
- Dont_Optimize_New_Float(New_Float_Result, 1);
- exception
- when Argument_Error => null; -- OK, expected exception.
- when others =>
- Report.Failed("Incorrect exception raised by the Arctan " &
- "function when provided 0.0, 0.0 input parameters");
- end;
-
-
- -- Check that no exception is raised by the Arctan function when
- -- provided a large positive or negative Y parameter value, when
- -- using the default value for parameter X.
-
- begin
- Float_Result := EF.Arctan(Y => FXA5A00.Large);
- Dont_Optimize_Float(Float_Result, 2);
- exception
- when others =>
- Report.Failed("Exception raised when the Arctan function is " &
- "provided a large positive Y parameter value");
- end;
-
- begin
- New_Float_Result := GEF.Arctan(Y => New_Float(-FXA5A00.Large));
- Dont_Optimize_New_Float(New_Float_Result, 3);
- exception
- when others =>
- Report.Failed("Exception raised when the Arctan function is " &
- "provided a large negative Y parameter value");
- end;
-
-
- -- Check that no exception is raised by the Arctan function when
- -- provided a small positive or negative Y parameter value, when
- -- using the default value for parameter X.
-
- begin
- Float_Result := EF.Arctan(Y => FXA5A00.Small);
- Dont_Optimize_Float(Float_Result, 4);
- exception
- when others =>
- Report.Failed("Exception raised when the Arctan function is " &
- "provided a small positive Y parameter value");
- end;
-
- begin
- New_Float_Result := GEF.Arctan(Y => New_Float(-FXA5A00.Small));
- Dont_Optimize_New_Float(New_Float_Result, 5);
- exception
- when others =>
- Report.Failed("Exception raised when the Arctan function is " &
- "provided a small negative Y parameter value");
- end;
-
-
- -- Check that no exception is raised by the Arctan function when
- -- provided combinations of large and small positive or negative
- -- parameter values for both Y and X input parameters.
-
- begin
- Float_Result := EF.Arctan(Y => FXA5A00.Large, X => FXA5A00.Large);
- Dont_Optimize_Float(Float_Result, 6);
- exception
- when others =>
- Report.Failed("Exception raised when the Arctan function is " &
- "provided large positive X and Y parameter values");
- end;
-
- begin
- New_Float_Result := GEF.Arctan(New_Float(-FXA5A00.Large),
- X => New_Float(FXA5A00.Small));
- Dont_Optimize_New_Float(New_Float_Result, 7);
- exception
- when others =>
- Report.Failed("Exception raised when the Arctan function is " &
- "provided a large negative Y parameter value " &
- "and a small positive X parameter value");
- end;
-
-
- begin
- Float_Result := EF.Arctan(Y => FXA5A00.Small, X => FXA5A00.Large);
- Dont_Optimize_Float(Float_Result, 8);
- exception
- when others =>
- Report.Failed("Exception raised when the Arctan function is " &
- "provided a small positive Y parameter value " &
- "and a large positive X parameter value");
- end;
-
- begin
- New_Float_Result := GEF.Arctan(New_Float(-FXA5A00.Small),
- New_Float(-FXA5A00.Large));
- Dont_Optimize_New_Float(New_Float_Result, 9);
- exception
- when others =>
- Report.Failed("Exception raised when the Arctan function is " &
- "provided a small negative Y parameter value " &
- "and a large negative parameter value");
- end;
-
-
- -- Check that when the Arctan function is provided a Y parameter value
- -- of 0.0 and a positive X parameter input value, the prescribed result
- -- of zero is returned.
-
- if GEF.Arctan(Y => 0.0) /= 0.0 or -- Default X value
- EF.Arctan(Y => 0.0, X => FXA5A00.Large) /= 0.0 or
---pwb-math: Next line: changed 2.0*Pi to 360.0
- GEF.Arctan(0.0, 360.0) /= 0.0 or
- EF.Arctan(0.0, FXA5A00.Small) /= 0.0
- then
- Report.Failed("Incorrect results from the Arctan function when " &
- "provided a Y parameter value of 0.0 and various " &
- "positive X parameter values");
- end if;
-
-
- -- Check that the Arctan function provides correct results when provided
- -- a variety of Y parameter values.
-
- if not FXA5A00.Result_Within_Range(EF.Arctan(Pi), 1.26, 0.01) or
- not FXA5A00.Result_Within_Range(EF.Arctan(-Pi), -1.26, 0.01) or
- not FXA5A00.Result_Within_Range(GEF.Arctan(1.0), 0.785, 0.001) or
- not FXA5A00.Result_Within_Range(EF.Arctan(-1.0), -0.785, 0.001) or
- not FXA5A00.Result_Within_Range(GEF.Arctan(0.25), 0.245, 0.001) or
- not FXA5A00.Result_Within_Range(EF.Arctan(0.92), 0.744, 0.001)
- then
- Report.Failed("Incorrect results from the Arctan function when " &
- "provided a variety of Y parameter values");
- end if;
-
-
-
- -- Check the results of the Arctan function with specified cycle
- -- parameter.
-
- -- Check that the Arctan function with specified Cycle parameter
- -- raises Argument_Error when the value of the Cycle parameter is zero
- -- or negative.
-
- begin
- Float_Result := EF.Arctan(Y => Pi, Cycle => 0.0); -- Default X value
- Report.Failed("Argument_Error not raised by the Arctan function " &
- "with default X parameter value, when the Cycle " &
- "parameter is 0.0");
- Dont_Optimize_Float(Float_Result, 10);
- exception
- when Argument_Error => null; -- OK, expected exception.
- when others =>
- Report.Failed("Incorrect exception raised by the Arctan " &
- "function with default X parameter value, when " &
- "provided a 0.0 cycle parameter value");
- end;
-
- begin
- New_Float_Result := GEF.Arctan(Y => Pi, X => 1.0, Cycle => 0.0);
- Report.Failed("Argument_Error not raised by the Arctan function " &
- "when the Cycle parameter is 0.0");
- Dont_Optimize_New_Float(New_Float_Result, 11);
- exception
- when Argument_Error => null; -- OK, expected exception.
- when others =>
- Report.Failed("Incorrect exception raised by the Arctan " &
- "function when provided a 0.0 cycle parameter " &
- "value");
- end;
-
- begin
- Float_Result := EF.Arctan(Y => Pi, Cycle => -360.0);
- Report.Failed("Argument_Error not raised by the Arctan function " &
- "with a default X parameter value, when the Cycle " &
- "parameter is -360.0");
- Dont_Optimize_Float(Float_Result, 12);
- exception
- when Argument_Error => null; -- OK, expected exception.
- when others =>
- Report.Failed("Incorrect exception raised by the Arctan " &
- "function with a default X parameter value, when " &
- "provided a -360.0 cycle parameter value");
- end;
-
- begin
- New_Float_Result := GEF.Arctan(Y => Pi, X => 1.0, Cycle => -Pi);
- Report.Failed("Argument_Error not raised by the Arctan function " &
- "when the Cycle parameter is -Pi");
- Dont_Optimize_New_Float(New_Float_Result, 13);
- exception
- when Argument_Error => null; -- OK, expected exception.
- when others =>
- Report.Failed("Incorrect exception raised by the Arctan " &
- "function when provided a -Pi cycle parameter " &
- "value");
- end;
-
-
- -- Check that no exception is raised by the Arctan function with
- -- specified Cycle parameter, when provided large and small positive
- -- or negative parameter values for both Y and X input parameters.
-
- begin
- Float_Result := EF.Arctan(Y => -FXA5A00.Large,
- X => -FXA5A00.Large,
---pwb-math: Next line: changed 2.0*Pi to 360.0
- Cycle => 360.0);
- Dont_Optimize_Float(Float_Result, 14);
- exception
- when others =>
- Report.Failed("Exception raised when the Arctan function with " &
- "specified Cycle parameter, when provided large " &
- "negative X and Y parameter values");
- end;
-
-
- begin
- New_Float_Result := GEF.Arctan(New_Float(FXA5A00.Large),
- X => New_Float(-FXA5A00.Small),
---pwb-math: Next line: changed 2.0*Pi to 360.0
- Cycle => 360.0);
- Dont_Optimize_New_Float(New_Float_Result, 15);
- exception
- when others =>
- Report.Failed("Exception raised when the Arctan function with " &
- "specified Cycle parameter, when provided large " &
- "positive Y parameter value and a small negative " &
- "X parameter value");
- end;
-
-
- begin
- Float_Result := EF.Arctan(Y => -FXA5A00.Small,
- X => -FXA5A00.Large,
---pwb-math: Next line: changed 2.0*Pi to 360.0
- Cycle => 360.0);
- Dont_Optimize_Float(Float_Result, 16);
- exception
- when others =>
- Report.Failed("Exception raised when the Arctan function with " &
- "specified Cycle parameter, when provided large " &
- "negative Y parameter value and a large negative " &
- "X parameter value");
- end;
-
- begin
- New_Float_Result := GEF.Arctan(New_Float(FXA5A00.Small),
- New_Float(FXA5A00.Large),
---pwb-math: Next line: changed 2.0*Pi to 360.0
- 360.0);
- Dont_Optimize_New_Float(New_Float_Result, 17);
- exception
- when others =>
- Report.Failed("Exception raised when the Arctan function with " &
- "specified Cycle parameter, when provided a " &
- "small negative Y parameter value and a large " &
- "positive X parameter value");
- end;
-
-
- -- Check that the Arctan function with specified Cycle parameter
- -- provides correct results when provided a variety of Y parameter
- -- input values.
-
---pwb-math if not FXA5A00.Result_Within_Range(EF.Arctan(Pi, Cycle => 2.0*Pi),
---pwb-math 1.26,
---pwb-math 0.01) or
---pwb-math not FXA5A00.Result_Within_Range(EF.Arctan(-Pi, Cycle => 2.0*Pi),
---pwb-math -1.26,
---pwb-math 0.01) or
---pwb-math not FXA5A00.Result_Within_Range(GEF.Arctan(1.0, Cycle => 2.0*Pi),
---pwb-math 0.785,
---pwb-math 0.001) or
---pwb-math not FXA5A00.Result_Within_Range(EF.Arctan(-1.0, Cycle => 2.0*Pi),
---pwb-math -0.785,
---pwb-math 0.001) or
---pwb-math not FXA5A00.Result_Within_Range(GEF.Arctan(0.16, Cycle => 2.0*Pi),
---pwb-math 0.159,
---pwb-math 0.001) or
---pwb-math not FXA5A00.Result_Within_Range(EF.Arctan(1.0, Cycle => 360.0),
---pwb-math 45.0,
---pwb-math 0.1) or
---pwb-math not FXA5A00.Result_Within_Range(GEF.Arctan(1.0, Cycle => 100.0),
---pwb-math 12.5,
---pwb-math 0.1)
-
---pwb-math Next 12 lines are replacements for 21 commented lines above
- if not FXA5A00.Result_Within_Range(GEF.Arctan(1.0, Cycle => 2.0*180.0),
- 45.0,
- 0.001) or
- not FXA5A00.Result_Within_Range(EF.Arctan(-1.0, Cycle => 2.0*180.0),
- -45.0,
- 0.001) or
- not FXA5A00.Result_Within_Range(EF.Arctan(1.0, Cycle => 360.0),
- 45.0,
- 0.1) or
- not FXA5A00.Result_Within_Range(GEF.Arctan(1.0, Cycle => 100.0),
- 12.5,
- 0.1)
- then
- Report.Failed("Incorrect results from the Arctan function with " &
- "specified Cycle parameter when provided a variety " &
- "of Y parameter values");
- end if;
-
-
- exception
- when others => Report.Failed ("Exception raised in Test_Block");
- end Test_Block;
-
- Report.Result;
-
-end CXA5A07;
diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxa5a08.a b/gcc/testsuite/ada/acats/tests/cxa/cxa5a08.a
deleted file mode 100644
index ae2b85a6d43..00000000000
--- a/gcc/testsuite/ada/acats/tests/cxa/cxa5a08.a
+++ /dev/null
@@ -1,474 +0,0 @@
--- CXA5A08.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that the function Arccot provides correct results.
---
--- TEST DESCRIPTION:
--- This test examines both the version of Arccot resulting from the
--- instantiation of the Ada.Numerics.Generic_Elementary_Functions
--- with a type derived from type Float, as well as the preinstantiated
--- version of this package for type Float.
--- Prescribed results, including instances prescribed to raise
--- exceptions, are examined in the test cases. In addition,
--- certain evaluations are performed where the actual function result
--- is compared with the expected result (within an epsilon range of
--- accuracy).
---
--- TEST FILES:
--- The following files comprise this test:
---
--- FXA5A00.A (foundation code)
--- CXA5A08.A
---
---
--- CHANGE HISTORY:
--- 06 Apr 95 SAIC Initial prerelease version.
--- 13 Jun 95 SAIC Incorporated use of Dont_Optimize procedure, and
--- use of Result_Within_Range function overloaded for
--- FXA5A00.New_Float_Type.
--- 18 Apr 96 SAIC Incorporated reviewer comments for ACVC 2.1.
--- 28 Feb 97 CTA.PWB Removed checks with explicit Cycle => 2.0*Pi
---
--- CHANGE NOTE:
--- According to Ken Dritz, author of the Numerics Annex of the RM,
--- one should never specify the cycle 2.0*Pi for the trigonometric
--- functions. In particular, if the machine number for the first
--- argument is not an exact multiple of the machine number for the
--- explicit cycle, then the specified exact results cannot be
--- reasonably expected. The affected checks in this test have been
--- marked as comments, with the additional notation "pwb-math".
--- Phil Brashear
---!
-
-with Ada.Exceptions;
-with Ada.Numerics.Elementary_Functions;
-with Ada.Numerics.Generic_Elementary_Functions;
-with FXA5A00;
-with Report;
-
-procedure CXA5A08 is
-begin
-
- Report.Test ("CXA5A08", "Check that the Arccot function provides " &
- "correct results");
-
- Test_Block:
- declare
-
- use Ada.Exceptions;
- use Ada.Numerics;
- use FXA5A00;
-
- package GEF is new Ada.Numerics.Generic_Elementary_Functions(New_Float);
- package EF renames Ada.Numerics.Elementary_Functions;
-
- Float_Result : Float;
- Angle : Float;
- New_Float_Result : New_Float;
- New_Float_Angle : New_Float;
- Incorrect_Inverse : Boolean := False;
-
- procedure Dont_Optimize_Float is new Dont_Optimize(Float);
- procedure Dont_Optimize_New_Float is new Dont_Optimize(New_Float);
-
- begin
-
- -- Testing of Arccot Function, both instantiated and pre-instantiated
- -- version.
-
- -- Check that Argument_Error is raised by the Arccot function when
- -- provided parameter values of 0.0, 0.0.
-
- begin
- New_Float_Result := GEF.Arccot(X => 0.0, Y => 0.0);
- Report.Failed("Argument_Error not raised when the Arccot " &
- "function is provided input of 0.0, 0.0");
- Dont_Optimize_New_Float(New_Float_Result, 1);
- exception
- when Argument_Error => null; -- OK, expected exception.
- when others =>
- Report.Failed("Incorrect exception raised by the Arccot " &
- "function when provided 0.0, 0.0 input parameters");
- end;
-
-
- -- Check that no exception is raised by the Arccot function when
- -- provided a large positive or negative X parameter value, when
- -- using the default value for parameter Y.
-
- begin
- Float_Result := EF.Arccot(X => FXA5A00.Large);
- Dont_Optimize_Float(Float_Result, 2);
- exception
- when others =>
- Report.Failed("Exception raised when the Arccot function is " &
- "provided a large positive X parameter value");
- end;
-
- begin
- New_Float_Result := GEF.Arccot(X => New_Float(-FXA5A00.Large));
- Dont_Optimize_New_Float(New_Float_Result, 3);
- exception
- when others =>
- Report.Failed("Exception raised when the Arccot function is " &
- "provided a large negative X parameter value");
- end;
-
-
- -- Check that no exception is raised by the Arccot function when
- -- provided a small positive or negative X parameter value, when
- -- using the default value for parameter Y.
-
- begin
- Float_Result := EF.Arccot(X => FXA5A00.Small);
- Dont_Optimize_Float(Float_Result, 4);
- exception
- when others =>
- Report.Failed("Exception raised when the Arccot function is " &
- "provided a small positive X parameter value");
- end;
-
- begin
- New_Float_Result := GEF.Arccot(X => New_Float(-FXA5A00.Small));
- Dont_Optimize_New_Float(New_Float_Result, 5);
- exception
- when others =>
- Report.Failed("Exception raised when the Arccot function is " &
- "provided a small negative X parameter value");
- end;
-
-
- -- Check that no exception is raised by the Arccot function when
- -- provided combinations of large and small positive or negative
- -- parameter values for both X and Y input parameters.
-
- begin
- Float_Result := EF.Arccot(X => FXA5A00.Large, Y => FXA5A00.Large);
- Dont_Optimize_Float(Float_Result, 6);
- exception
- when others =>
- Report.Failed("Exception raised when the Arccot function is " &
- "provided large positive X and Y parameter values");
- end;
-
- begin
- New_Float_Result := GEF.Arccot(New_Float(-FXA5A00.Large),
- Y => New_Float(FXA5A00.Small));
- Dont_Optimize_New_Float(New_Float_Result, 7);
- exception
- when others =>
- Report.Failed("Exception raised when the Arccot function is " &
- "provided a large negative X parameter value " &
- "and a small positive Y parameter value");
- end;
-
-
- begin
- Float_Result := EF.Arccot(X => FXA5A00.Small, Y => FXA5A00.Large);
- Dont_Optimize_Float(Float_Result, 8);
- exception
- when others =>
- Report.Failed("Exception raised when the Arccot function is " &
- "provided a small positive X parameter value " &
- "and a large positive Y parameter value");
- end;
-
- begin
- New_Float_Result := GEF.Arccot(New_Float(-FXA5A00.Small),
- New_Float(-FXA5A00.Large));
- Dont_Optimize_New_Float(New_Float_Result, 9);
- exception
- when others =>
- Report.Failed("Exception raised when the Arccot function is " &
- "provided a small negative X parameter value " &
- "and a large negative Y parameter value");
- end;
-
-
- -- Check that when the Arccot function is provided a Y parameter value
- -- of 0.0 and a positive X parameter input value, the prescribed result
- -- of zero is returned.
-
- if EF.Arccot(X => FXA5A00.Large, Y => 0.0) /= 0.0 or
- GEF.Arccot(2.0*Pi, Y => 0.0) /= 0.0 or
- EF.Arccot(FXA5A00.Small, 0.0) /= 0.0 or
- EF.Arccot(X => FXA5A00.Large, Y => 0.0, Cycle => 360.0) /= 0.0 or
- GEF.Arccot(2.0*Pi, Y => 0.0, Cycle => 360.0) /= 0.0 or
- EF.Arccot(FXA5A00.Small, 0.0, Cycle => 360.0) /= 0.0
- then
- Report.Failed("Incorrect results from the Arccot function when " &
- "provided a Y parameter value of 0.0 and various " &
- "positive X parameter values");
- end if;
-
-
- -- Check that the Arccot function provides correct results when
- -- provided a variety of X parameter values.
-
- if not Result_Within_Range( EF.Arccot( 1.0), Pi/4.0, 0.001) or
- not Result_Within_Range(GEF.Arccot( 0.0), Pi/2.0, 0.001) or
- not Result_Within_Range( EF.Arccot(-1.0), 3.0*Pi/4.0, 0.001)
- then
- Report.Failed("Incorrect results from the Arccot function when " &
- "provided a variety of Y parameter values");
- end if;
-
-
- -- Check the results of the Arccot function with specified cycle
- -- parameter.
-
- -- Check that the Arccot function with specified Cycle parameter
- -- raises Argument_Error when the value of the Cycle parameter is zero
- -- or negative.
-
- begin
- Float_Result := EF.Arccot(X => Pi, Cycle => 0.0); -- Default Y value
- Report.Failed("Argument_Error not raised by the Arccot function " &
- "with default Y parameter value, when the Cycle " &
- "parameter is 0.0");
- Dont_Optimize_Float(Float_Result, 10);
- exception
- when Argument_Error => null; -- OK, expected exception.
- when others =>
- Report.Failed("Incorrect exception raised by the Arccot " &
- "function with default Y parameter value, when " &
- "provided a 0.0 cycle parameter value");
- end;
-
- begin
- New_Float_Result := GEF.Arccot(X => Pi, Y => 1.0, Cycle => 0.0);
- Report.Failed("Argument_Error not raised by the Arccot function " &
- "when the Cycle parameter is 0.0");
- Dont_Optimize_New_Float(New_Float_Result, 11);
- exception
- when Argument_Error => null; -- OK, expected exception.
- when others =>
- Report.Failed("Incorrect exception raised by the Arccot " &
- "function when provided a 0.0 cycle parameter " &
- "value");
- end;
-
- begin
- Float_Result := EF.Arccot(X => Pi, Cycle => -360.0);
- Report.Failed("Argument_Error not raised by the Arccot function " &
- "with a default Y parameter value, when the Cycle " &
- "parameter is -360.0");
- Dont_Optimize_Float(Float_Result, 12);
- exception
- when Argument_Error => null; -- OK, expected exception.
- when others =>
- Report.Failed("Incorrect exception raised by the Arccot " &
- "function with a default Y parameter value, when " &
- "provided a -360.0 cycle parameter value");
- end;
-
- begin
- New_Float_Result := GEF.Arccot(X => Pi, Y => 1.0, Cycle => -Pi);
- Report.Failed("Argument_Error not raised by the Arccot function " &
- "when the Cycle parameter is -Pi");
- Dont_Optimize_New_Float(New_Float_Result, 13);
- exception
- when Argument_Error => null; -- OK, expected exception.
- when others =>
- Report.Failed("Incorrect exception raised by the Arccot " &
- "function when provided a -Pi cycle parameter " &
- "value");
- end;
-
-
- -- Check that no exception is raised by the Arccot function with
- -- specified Cycle parameter, when provided large and small positive
- -- or negative parameter values for both X and Y input parameters.
-
- begin
- Float_Result := EF.Arccot(X => -FXA5A00.Large,
- Y => -FXA5A00.Large,
---pwb-math Next line: changed 2.0*Pi to 360.0
- Cycle => 360.0);
- Dont_Optimize_Float(Float_Result, 14);
- exception
- when others =>
- Report.Failed("Exception raised when the Arccot function with " &
- "specified Cycle parameter, when provided large " &
- "negative X and Y parameter values");
- end;
-
-
- begin
- New_Float_Result := GEF.Arccot(New_Float(FXA5A00.Large),
- Y => New_Float(-FXA5A00.Small),
---pwb-math Next line: changed 2.0*Pi to 360.0
- Cycle => 360.0);
- Dont_Optimize_New_Float(New_Float_Result, 15);
- exception
- when others =>
- Report.Failed("Exception raised when the Arccot function with " &
- "specified Cycle parameter, when provided large " &
- "positive X parameter value and a small negative " &
- "Y parameter value");
- end;
-
-
- begin
- Float_Result := EF.Arccot(X => -FXA5A00.Small,
- Y => -FXA5A00.Large,
---pwb-math Next line: changed 2.0*Pi to 360.0
- Cycle => 360.0);
- Dont_Optimize_Float(Float_Result, 16);
- exception
- when others =>
- Report.Failed("Exception raised when the Arccot function with " &
- "specified Cycle parameter, when provided small " &
- "negative X parameter value and a large negative " &
- "Y parameter value");
- end;
-
- begin
- New_Float_Result := GEF.Arccot(New_Float(FXA5A00.Small),
- New_Float(FXA5A00.Large),
---pwb-math Next line: changed 2.0*Pi to 360.0
- 360.0);
- Dont_Optimize_New_Float(New_Float_Result, 17);
- exception
- when others =>
- Report.Failed("Exception raised when the Arccot function with " &
- "specified Cycle parameter, when provided a " &
- "small positive X parameter value and a large " &
- "positive Y parameter value");
- end;
-
-
- -- Check that the Arccot function with specified Cycle parameter
- -- provides correct results when provided a variety of X parameter
- -- input values.
-
- if not FXA5A00.Result_Within_Range(GEF.Arccot( 0.0, Cycle => 360.0),
- 90.0,
- 0.001) or
- not FXA5A00.Result_Within_Range(EF.Arccot( 0.0, Cycle => 100.0),
- 25.0,
- 0.001) or
- not FXA5A00.Result_Within_Range(GEF.Arccot( 1.0, Cycle => 360.0),
- 45.0,
- 0.001) or
- not FXA5A00.Result_Within_Range(EF.Arccot( 1.0, Cycle => 100.0),
- 12.5,
- 0.001) or
- not FXA5A00.Result_Within_Range(GEF.Arccot(-1.0, Cycle => 360.0),
- 135.0,
- 0.001) or
- not FXA5A00.Result_Within_Range(EF.Arccot(-1.0, Cycle => 100.0),
- 37.5,
- 0.001)
- then
- Report.Failed("Incorrect results from the Arccot function with " &
- "specified Cycle parameter when provided a variety " &
- "of X parameter values");
- end if;
-
-
- if not FXA5A00.Result_Within_Range(EF.Arccot(0.2425355, 0.9701420),
- EF.Arccot(0.25),
- 0.01) or
- not FXA5A00.Result_Within_Range(EF.Arccot(0.3162277, 0.9486831),
- Ef.Arccot(0.33),
- 0.01)
- then
- Report.Failed("Incorrect results from the Arccot function with " &
- "comparison to other Arccot function results");
- end if;
-
-
- if not FXA5A00.Result_Within_Range(EF.Cot(EF.Arccot(0.4472135,
- 0.8944270)),
- 0.5,
- 0.01) or
- not FXA5A00.Result_Within_Range(EF.Cot(EF.Arccot(0.9987380,
- 0.0499369)),
- 20.0,
- 0.1)
- then
- Report.Failed("Incorrect results from the Arccot function when " &
- "used as argument to Cot function");
- end if;
-
-
- -- Check that inverse function results are correct.
- -- Default Cycle test.
-
- Angle := 0.001;
- while Angle < Pi and not Incorrect_Inverse loop
- if not Result_Within_Range(EF.Arccot(EF.Cot(Angle)), Angle, 0.001)
- then
- Incorrect_Inverse := True;
- end if;
- Angle := Angle + 0.001;
- end loop;
-
- if Incorrect_Inverse then
- Report.Failed("Incorrect results returned from the Inverse " &
- "comparison of Cot and Arccot using the default " &
- "cycle value");
- Incorrect_Inverse := False;
- end if;
-
- -- Non-Default Cycle test.
-
- New_Float_Angle := 0.01;
- while New_Float_Angle < 180.0 and not Incorrect_Inverse loop
- if not Result_Within_Range(EF.Arccot(EF.Cot(Float(New_Float_Angle),
- Cycle => 360.0),
- Cycle => 360.0),
- Float(New_Float_Angle),
- 0.01) or
- not Result_Within_Range(GEF.Arccot(
- New_Float(GEF.Cot(New_Float_Angle,
- Cycle => 360.0)),
- Cycle => 360.0),
- Float(New_Float_Angle),
- 0.01)
- then
- Incorrect_Inverse := True;
- end if;
- New_Float_Angle := New_Float_Angle + 0.01;
- end loop;
-
- if Incorrect_Inverse then
- Report.Failed("Incorrect results returned from the Inverse " &
- "comparison of Cot and Arccot using non-default " &
- "cycle value");
- end if;
-
-
- exception
- when The_Error : others =>
- Report.Failed ("The following exception was raised in the " &
- "Test_Block: " & Exception_Name(The_Error));
- end Test_Block;
-
- Report.Result;
-
-end CXA5A08;
diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxa5a09.a b/gcc/testsuite/ada/acats/tests/cxa/cxa5a09.a
deleted file mode 100644
index 22bd2f8909c..00000000000
--- a/gcc/testsuite/ada/acats/tests/cxa/cxa5a09.a
+++ /dev/null
@@ -1,400 +0,0 @@
--- CXA5A09.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that the function Log provides correct results.
---
--- TEST DESCRIPTION:
--- This test examines both the version of Log resulting from the
--- instantiation of the Ada.Numerics.Generic_Elementary_Functions with
--- with a type derived from type Float,as well as the preinstantiated
--- version of this package for type Float.
--- Prescribed results, including instances prescribed to raise
--- exceptions, are examined in the test cases. In addition,
--- certain evaluations are performed where the actual function result
--- is compared with the expected result (within an epsilon range of
--- accuracy).
---
--- TEST FILES:
--- The following files comprise this test:
---
--- FXA5A00.A (foundation code)
--- CXA5A09.A
---
---
--- CHANGE HISTORY:
--- 11 Apr 95 SAIC Initial prerelease version.
--- 13 Jun 95 SAIC Incorporated use of Dont_Optimize procedure, and
--- use of Result_Within_Range function overloaded for
--- FXA5A00.New_Float_Type.
--- 29 Jun 98 EDS Protected exception tests by first testing
--- for 'Machine_Overflows
---
---!
-
-with Ada.Numerics.Elementary_Functions;
-with Ada.Numerics.Generic_Elementary_Functions;
-with FXA5A00;
-with Report;
-
-procedure CXA5A09 is
-begin
-
- Report.Test ("CXA5A09", "Check that the Log function provides " &
- "correct results");
-
- Test_Block:
- declare
-
- use Ada.Numerics;
- use FXA5A00;
-
- package GEF is new Ada.Numerics.Generic_Elementary_Functions(New_Float);
- package EF renames Ada.Numerics.Elementary_Functions;
-
- Arg,
- Float_Result : Float := 0.0;
- New_Float_Result : New_Float := 0.0;
-
- Incorrect_Inverse,
- Incorrect_Inverse_Base_2,
- Incorrect_Inverse_Base_8,
- Incorrect_Inverse_Base_10,
- Incorrect_Inverse_Base_16 : Boolean := False;
-
- procedure Dont_Optimize_Float is new Dont_Optimize(Float);
- procedure Dont_Optimize_New_Float is new Dont_Optimize(New_Float);
-
- begin
-
- -- Testing of Log Function, both instantiated and pre-instantiated
- -- version.
-
- -- Check that Argument_Error is raised when the parameter X is negative.
-
- begin
- New_Float_Result := GEF.Log(X => -1.0);
- Report.Failed("Argument_Error not raised by the Log function " &
- "when the input parameter is negative");
- Dont_Optimize_New_Float(New_Float_Result, 1);
- exception
- when Argument_Error => null; -- OK, expected exception.
- when others =>
- Report.Failed("Unexpected exception raised by the Log function " &
- "when the input parameter is negative");
- end;
-
- begin
- Float_Result := EF.Log(X => -FXA5A00.Large);
- Report.Failed("Argument_Error not raised by the Log function " &
- "when the input parameter is negative");
- Dont_Optimize_Float(Float_Result, 2);
- exception
- when Argument_Error => null; -- OK, expected exception.
- when others =>
- Report.Failed("Unexpected exception raised by the Log function " &
- "when the input parameter is negative");
- end;
-
-
- -- Check that Constraint_Error is raised when the Log function is
- -- provided an input parameter of zero.
-
- if New_Float'Machine_Overflows = True then
- begin
- New_Float_Result := GEF.Log(X => 0.0);
- Report.Failed("Constraint_Error not raised by the Log function " &
- "when the input parameter is zero");
- Dont_Optimize_New_Float(New_Float_Result, 3);
- exception
- when Constraint_Error => null; -- OK, expected exception.
- when others =>
- Report.Failed("Unexpected exception raised by the Log function "
- & "when the input parameter is zero");
- end;
- end if;
-
-
- -- Check for the reference manual prescribed results of the Log function.
-
- if GEF.Log(X => 1.0) /= 0.0 or
- EF.Log(X => 1.0) /= 0.0
- then
- Report.Failed("Incorrect result from Function Log when provided " &
- "an input parameter value of 1.0");
- end if;
-
-
- -- Check that the Log function provides correct results when provided
- -- a variety of input parameters.
-
- if not FXA5A00.Result_Within_Range(GEF.Log(0.015), -4.20, 0.01) or
- not FXA5A00.Result_Within_Range(GEF.Log(0.592), -0.524, 0.001) or
- not FXA5A00.Result_Within_Range(GEF.Log(0.997), -0.003, 0.001) or
- not FXA5A00.Result_Within_Range(GEF.Log(1.341), 0.293, 0.001) or
- not FXA5A00.Result_Within_Range( EF.Log(2.826), 1.04, 0.01) or
- not FXA5A00.Result_Within_Range( EF.Log(10.052), 2.31, 0.01) or
- not FXA5A00.Result_Within_Range( EF.Log(2569.143), 7.85, 0.01)
- then
- Report.Failed("Incorrect results from Function Log when provided " &
- "a variety of input parameter values");
- end if;
-
- Arg := 0.001;
- while Arg < 1.0 and not Incorrect_Inverse loop
- if not Result_Within_Range(EF."**"(e,EF.Log(Arg)), Arg, 0.001) then
- Incorrect_Inverse := True;
- end if;
- Arg := Arg + 0.001;
- end loop;
-
- if Incorrect_Inverse then
- Report.Failed("Incorrect inverse result comparing ""**"" and " &
- "Log function over argument range 0.001..1.0");
- Incorrect_Inverse := False;
- end if;
-
- Arg := 1.0;
- while Arg < 10.0 and not Incorrect_Inverse loop
- if not Result_Within_Range(EF."**"(e,EF.Log(Arg)), Arg, 0.01) then
- Incorrect_Inverse := True;
- end if;
- Arg := Arg + 0.01;
- end loop;
-
- if Incorrect_Inverse then
- Report.Failed("Incorrect inverse result comparing ""**"" and " &
- "Log function over argument range 1.0..10.0");
- Incorrect_Inverse := False;
- end if;
-
- Arg := 1.0;
- while Arg < 1000.0 and not Incorrect_Inverse loop
- if not Result_Within_Range(EF."**"(e,EF.Log(Arg)), Arg, 0.1) then
- Incorrect_Inverse := True;
- end if;
- Arg := Arg + 1.0;
- end loop;
-
- if Incorrect_Inverse then
- Report.Failed("Incorrect inverse result comparing ""**"" and " &
- "Log function over argument range 1.0..1000.0");
- end if;
-
-
- -- Testing of Log Function, with specified Base parameter, both
- -- instantiated and pre-instantiated versions.
-
- -- Check that Argument_Error is raised by the Log function with
- -- specified Base parameter, when the X parameter value is negative.
-
- begin
- New_Float_Result := GEF.Log(X => -1.0, Base => 16.0);
- Report.Failed("Argument_Error not raised by the Log function " &
- "with Base parameter, when the input parameter " &
- "value is -1.0");
- Dont_Optimize_New_Float(New_Float_Result, 4);
- exception
- when Argument_Error => null; -- OK, expected exception.
- when others =>
- Report.Failed("Unexpected exception raised by the Log function " &
- "with Base parameter, when the X parameter value " &
- "is -1.0");
- end;
-
- begin
- Float_Result := EF.Log(X => -FXA5A00.Large, Base => 8.0);
- Report.Failed("Argument_Error not raised by the Log function " &
- "with Base parameter, when the X parameter " &
- "value is a large negative value");
- Dont_Optimize_Float(Float_Result, 5);
- exception
- when Argument_Error => null; -- OK, expected exception.
- when others =>
- Report.Failed("Unexpected exception raised by the Log function " &
- "with Base parameter, when the X parameter " &
- "value is a large negative value");
- end;
-
-
- -- Check that Argument_Error is raised by the Log function when
- -- the specified Base parameter is zero.
-
- begin
- New_Float_Result := GEF.Log(X => 10.0, Base => 0.0);
- Report.Failed("Argument_Error not raised by the Log function " &
- "with Base parameter of 0.0");
- Dont_Optimize_New_Float(New_Float_Result, 6);
- exception
- when Argument_Error => null; -- OK, expected exception.
- when others =>
- Report.Failed("Unexpected exception raised by the Log function " &
- "with Base parameter of 0.0");
- end;
-
-
- -- Check that Argument_Error is raised by the Log function when
- -- the specified Base parameter is one.
-
- begin
- Float_Result := EF.Log(X => 12.3, Base => 1.0);
- Report.Failed("Argument_Error not raised by the Log function " &
- "with Base parameter of 1.0");
- Dont_Optimize_Float(Float_Result, 7);
- exception
- when Argument_Error => null; -- OK, expected exception.
- when others =>
- Report.Failed("Unexpected exception raised by the Log function " &
- "with Base parameter of 1.0");
- end;
-
-
- -- Check that Argument_Error is raised by the Log function when
- -- the specified Base parameter is negative.
-
- begin
- New_Float_Result := GEF.Log(X => 12.3, Base => -10.0);
- Report.Failed("Argument_Error not raised by the Log function " &
- "with negative Base parameter");
- Dont_Optimize_New_Float(New_Float_Result, 8);
- exception
- when Argument_Error => null; -- OK, expected exception.
- when others =>
- Report.Failed("Unexpected exception raised by the Log function " &
- "with negative Base parameter");
- end;
-
-
- -- Check that Constraint_Error is raised by the Log function when the
- -- input X parameter value is 0.0.
-
- if New_Float'Machine_Overflows = True then
- begin
- New_Float_Result := GEF.Log(X => 0.0, Base => 16.0);
- Report.Failed("Constraint_Error not raised by the Log function " &
- "with specified Base parameter, when the value of " &
- "the parameter X is 0.0");
- Dont_Optimize_New_Float(New_Float_Result, 9);
- exception
- when Constraint_Error => null; -- OK, expected exception.
- when others =>
- Report.Failed("Unexpected exception raised by Function Log" &
- "with specified Base parameter, when the value " &
- "of the parameter X is 0.0");
- end;
- end if;
-
- -- Check for the prescribed results of the Log function with specified
- -- Base parameter.
-
- if GEF.Log(X => 1.0, Base => 16.0) /= 0.0 or
- EF.Log(X => 1.0, Base => 10.0) /= 0.0 or
- GEF.Log(1.0, Base => 8.0) /= 0.0 or
- EF.Log(1.0, 2.0) /= 0.0
- then
- Report.Failed("Incorrect result from Function Log with specified " &
- "Base parameter when provided an parameter X input " &
- "value of 1.0");
- end if;
-
-
- -- Check that the Log function with specified Base parameter provides
- -- correct results when provided a variety of input parameters.
-
- if not Result_Within_Range(GEF.Log( 10.0, e), 2.30, 0.01) or
- not Result_Within_Range( EF.Log( 8.0, 2.0), 3.0, 0.01) or
- not Result_Within_Range(GEF.Log(256.0, 2.0), 8.0, 0.01) or
- not Result_Within_Range( EF.Log(512.0, 8.0), 3.0, 0.01) or
- not Result_Within_Range(GEF.Log(0.5649, e), -0.57, 0.01) or
- not Result_Within_Range( EF.Log(1.7714, e), 0.57, 0.01) or
- not Result_Within_Range(GEF.Log(0.5718, 10.0), -0.243, 0.001) or
- not Result_Within_Range( EF.Log(466.25, 10.0), 2.67, 0.01)
- then
- Report.Failed("Incorrect results from Function Log with specified " &
- "Base parameter, when provided a variety of input " &
- "parameter values");
- end if;
-
-
- Arg := 1.0;
- while Arg < 1000.0 and
- not (Incorrect_Inverse_Base_2 and Incorrect_Inverse_Base_8 and
- Incorrect_Inverse_Base_10 and Incorrect_Inverse_Base_16)
- loop
- if not FXA5A00.Result_Within_Range(EF."**"(2.0,EF.Log(Arg,2.0)),
- Arg,
- 0.001)
- then
- Incorrect_Inverse_Base_2 := True;
- end if;
- if not FXA5A00.Result_Within_Range(EF."**"(8.0,EF.Log(Arg,8.0)),
- Arg,
- 0.001)
- then
- Incorrect_Inverse_Base_8 := True;
- end if;
- if not FXA5A00.Result_Within_Range(EF."**"(10.0,EF.Log(Arg,10.0)),
- Arg,
- 0.001)
- then
- Incorrect_Inverse_Base_10 := True;
- end if;
- if not FXA5A00.Result_Within_Range(EF."**"(16.0,EF.Log(Arg,16.0)),
- Arg,
- 0.001)
- then
- Incorrect_Inverse_Base_16 := True;
- end if;
- Arg := Arg + 1.0;
- end loop;
-
- if Incorrect_Inverse_Base_2 then
- Report.Failed("Incorrect inverse result comparing ""**"" and " &
- "Log function for Base 2");
- end if;
-
- if Incorrect_Inverse_Base_8 then
- Report.Failed("Incorrect inverse result comparing ""**"" and " &
- "Log function for Base 8");
- end if;
-
- if Incorrect_Inverse_Base_10 then
- Report.Failed("Incorrect inverse result comparing ""**"" and " &
- "Log function for Base 10");
- end if;
-
- if Incorrect_Inverse_Base_16 then
- Report.Failed("Incorrect inverse result comparing ""**"" and " &
- "Log function for Base 16");
- end if;
-
-
- exception
- when others => Report.Failed ("Exception raised in Test_Block");
- end Test_Block;
-
- Report.Result;
-
-end CXA5A09;
diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxa5a10.a b/gcc/testsuite/ada/acats/tests/cxa/cxa5a10.a
deleted file mode 100644
index 4804d6729fc..00000000000
--- a/gcc/testsuite/ada/acats/tests/cxa/cxa5a10.a
+++ /dev/null
@@ -1,551 +0,0 @@
--- CXA5A10.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that the functions Exp and Sqrt, and the exponentiation
--- operator "**" provide correct results.
---
--- TEST DESCRIPTION:
--- This test examines both the versions of Exp, Sqrt, and "**"
--- resulting from the instantiation of the
--- Ada.Numerics.Generic_Elementary_Functions with a type derived from
--- type Float, as well as the preinstantiated version of this package
--- for type Float.
--- Prescribed results (stated as such in the reference manual),
--- including instances prescribed to raise exceptions, are examined
--- in the test cases. In addition, certain evaluations are performed
--- for the preinstantiated package where the actual function result is
--- compared with the expected result (within an epsilon range of
--- accuracy).
---
--- TEST FILES:
--- The following files comprise this test:
---
--- FXA5A00.A (foundation code)
--- CXA5A10.A
---
---
--- CHANGE HISTORY:
--- 17 Apr 95 SAIC Initial prerelease version.
--- 13 Jun 95 SAIC Incorporated use of Dont_Optimize procedure, and
--- use of Result_Within_Range function overloaded for
--- FXA5A00.New_Float_Type.
--- 18 Apr 96 SAIC Incorporated reviewer comments for ACVC 2.1.
--- 01 Oct 01 RLB Protected Constraint_Error exception tests by
--- first testing for 'Machine_Overflows.
---
---!
-
-with Ada.Exceptions;
-with Ada.Numerics.Elementary_Functions;
-with Ada.Numerics.Generic_Elementary_Functions;
-with FXA5A00;
-with Report;
-
-procedure CXA5A10 is
-begin
-
- Report.Test ("CXA5A10", "Check that Exp, Sqrt, and the ""**"" operator " &
- "provide correct results");
-
- Test_Block:
- declare
-
- use FXA5A00, Ada.Numerics;
- use Ada.Exceptions;
-
- package GEF is new Ada.Numerics.Generic_Elementary_Functions(New_Float);
- package EF renames Ada.Numerics.Elementary_Functions;
-
- use GEF, EF;
-
- Arg,
- Float_Result : Float;
- New_Float_Result : New_Float;
-
- Flag_1, Flag_2, Flag_3, Flag_4,
- Incorrect_Inverse_Base_e,
- Incorrect_Inverse_Base_2,
- Incorrect_Inverse_Base_8,
- Incorrect_Inverse_Base_10,
- Incorrect_Inverse_Base_16 : Boolean := False;
-
- procedure Dont_Optimize_Float is new Dont_Optimize(Float);
- procedure Dont_Optimize_New_Float is new Dont_Optimize(New_Float);
-
- begin
-
- -- Testing of the "**" operator, both instantiated and pre-instantiated
- -- version.
-
- -- Check that Argument_Error is raised by the exponentiation operator
- -- when the value of the Left parameter (operand) is negative.
-
- begin
- New_Float_Result := GEF."**"(Left => -10.0,
- Right => 2.0);
- Report.Failed("Argument_Error not raised by the instantiated " &
- "version of the exponentiation operator when the " &
- "value of the Left parameter is negative");
- Dont_Optimize_New_Float(New_Float_Result, 1);
- exception
- when Argument_Error => null; -- OK, expected exception.
- when others =>
- Report.Failed("Unexpected exception raised by the " &
- "instantiated version of the exponentiation " &
- "operator when the value of the Left parameter " &
- "is negative");
- end;
-
- begin
- Float_Result := (-FXA5A00.Small) ** 4.0;
- Report.Failed("Argument_Error not raised by the preinstantiated " &
- "version of the exponentiation operator when the " &
- "value of the Left parameter is negative");
- Dont_Optimize_Float(Float_Result, 2);
- exception
- when Argument_Error => null; -- OK, expected exception.
- when others =>
- Report.Failed("Unexpected exception raised by the " &
- "preinstantiated version of the exponentiation " &
- "operator when the value of the Left parameter " &
- "is negative");
- end;
-
-
- -- Check that Argument_Error is raised by the exponentiation operator
- -- when both parameters (operands) have the value 0.0.
-
- begin
- New_Float_Result := GEF."**"(0.0, Right => 0.0);
- Report.Failed("Argument_Error not raised by the instantiated " &
- "version of the exponentiation operator when " &
- "both operands are zero");
- Dont_Optimize_New_Float(New_Float_Result, 3);
- exception
- when Argument_Error => null; -- OK, expected exception.
- when others =>
- Report.Failed("Unexpected exception raised by the " &
- "instantiated version of the exponentiation " &
- "operator when both operands are zero");
- end;
-
- begin
- Float_Result := 0.0**0.0;
- Report.Failed("Argument_Error not raised by the preinstantiated " &
- "version of the exponentiation operator when both " &
- "operands are zero");
- Dont_Optimize_Float(Float_Result, 4);
- exception
- when Argument_Error => null; -- OK, expected exception.
- when others =>
- Report.Failed("Unexpected exception raised by the " &
- "preinstantiated version of the exponentiation " &
- "operator when both operands are zero");
- end;
-
-
- -- Check that Constraint_Error is raised by the exponentiation
- -- operator when the value of the left parameter (operand) is zero,
- -- and the value of the right parameter (exponent) is negative.
- -- This check applies only if Machine_Overflows is true [A.5.1(28, 30)].
-
- if New_Float'Machine_Overflows = True then
- begin
- New_Float_Result := GEF."**"(0.0, Right => -2.0);
- Report.Failed("Constraint_Error not raised by the instantiated " &
- "version of the exponentiation operator when " &
- "the left parameter is 0.0, and the right " &
- "parameter is negative");
- Dont_Optimize_New_Float(New_Float_Result, 5);
- exception
- when Constraint_Error => null; -- OK, expected exception.
- when others =>
- Report.Failed("Unexpected exception raised by the " &
- "instantiated version of the exponentiation " &
- "operator when the left parameter is 0.0, " &
- "and the right parameter is negative");
- end;
- end if;
-
- if Float'Machine_Overflows = True then
- begin
- Float_Result := 0.0 ** (-FXA5A00.Small);
- Report.Failed("Constraint_Error not raised by the " &
- "preinstantiated version of the exponentiation " &
- "operator when the left parameter is 0.0, and the " &
- "right parameter is negative");
- Dont_Optimize_Float(Float_Result, 6);
- exception
- when Constraint_Error => null; -- OK, expected exception.
- when others =>
- Report.Failed("Unexpected exception raised by the " &
- "preinstantiated version of the exponentiation " &
- "operator when the left parameter is 0.0, and " &
- "the right parameter is negative");
- end;
- end if;
-
- -- Prescribed results.
- -- Check that exponentiation by a 0.0 exponent yields the value one.
-
- if GEF."**"(Left => 10.0, Right => 0.0) /= 1.0 or
- EF."**"(FXA5A00.Large, Right => 0.0) /= 1.0 or
- GEF."**"(3.0, 0.0) /= 1.0 or
- FXA5A00.Small ** 0.0 /= 1.0
- then
- Report.Failed("Incorrect results returned from the ""**"" " &
- "operator when the value of the exponent is 0.0");
- end if;
-
-
- -- Check that exponentiation by a unit exponent yields the value
- -- of the left operand.
-
- if GEF."**"(Left => 50.0, Right => 1.0) /= 50.0 or
- EF."**"(FXA5A00.Large, Right => 1.0) /= FXA5A00.Large or
- GEF."**"(6.0, 1.0) /= 6.0 or
- FXA5A00.Small ** 1.0 /= FXA5A00.Small
- then
- Report.Failed("Incorrect results returned from the ""**"" " &
- "operator when the value of the exponent is 1.0");
- end if;
-
-
- -- Check that exponentiation of the value 1.0 yields the value 1.0.
-
- if GEF."**"(Left => 1.0, Right => 16.0) /= 1.0 or
- EF."**"(1.0, Right => FXA5A00.Large) /= 1.0 or
- GEF."**"(1.0, 3.0) /= 1.0 or
- 1.0 ** FXA5A00.Small /= 1.0
- then
- Report.Failed("Incorrect results returned from the ""**"" " &
- "operator when the value of the operand is 1.0");
- end if;
-
-
- -- Check that exponentiation of the value 0.0 yields the value 0.0.
-
- if GEF."**"(Left => 0.0, Right => 10.0) /= 0.0 or
- EF."**"(0.0, Right => FXA5A00.Large) /= 0.0 or
- GEF."**"(0.0, 4.0) /= 0.0 or
- 0.0 ** FXA5A00.Small /= 0.0
- then
- Report.Failed("Incorrect results returned from the ""**"" " &
- "operator when the value of the operand is 0.0");
- end if;
-
-
- -- Check that exponentiation of various operands with a variety of
- -- of exponent values yield correct results.
-
- if not Result_Within_Range(GEF."**"(5.0, 2.0), 25.0, 0.01) or
- not Result_Within_Range(GEF."**"(1.225, 1.5), 1.36, 0.01) or
- not Result_Within_Range(GEF."**"(0.26, 2.0), 0.068, 0.001) or
- not Result_Within_Range( EF."**"(e, 5.0), 148.4, 0.1) or
- not Result_Within_Range( EF."**"(10.0, e), 522.7, 0.1) or
- not Result_Within_Range( EF."**"(e, (-3.0)), 0.050, 0.001) or
- not Result_Within_Range(GEF."**"(10.0,(-2.0)), 0.010, 0.001)
- then
- Report.Failed("Incorrect results returned from the ""**"" " &
- "operator with a variety of operand and exponent " &
- "values");
- end if;
-
-
- -- Use the following loops to check for internal consistency between
- -- inverse functions.
-
- declare
- -- Use the relative error value to account for non-exact
- -- computations.
- TC_Relative_Error: Float := 0.005;
- begin
- for i in 1..5 loop
- for j in 0..5 loop
- if not Incorrect_Inverse_Base_e and
- not FXA5A00.Result_Within_Range
- (Float(i)**Float(j),
- e**(Float(j)*EF.Log(Float(i))),
- TC_Relative_Error)
- then
- Incorrect_Inverse_Base_e := True;
- Report.Failed("Incorrect Log-** Inverse calc for Base e " &
- "with i= " & Integer'Image(i) & " and j= " &
- Integer'Image(j));
- end if;
- if not Incorrect_Inverse_Base_2 and
- not FXA5A00.Result_Within_Range
- (Float(i)**Float(j),
- 2.0**(Float(j)*EF.Log(Float(i),2.0)),
- TC_Relative_Error)
- then
- Incorrect_Inverse_Base_2 := True;
- Report.Failed("Incorrect Log-** Inverse calc for Base 2 " &
- "with i= " & Integer'Image(i) & " and j= " &
- Integer'Image(j));
- end if;
- if not Incorrect_Inverse_Base_8 and
- not FXA5A00.Result_Within_Range
- (Float(i)**Float(j),
- 8.0**(Float(j)*EF.Log(Float(i),8.0)),
- TC_Relative_Error)
- then
- Incorrect_Inverse_Base_8 := True;
- Report.Failed("Incorrect Log-** Inverse calc for Base 8 " &
- "with i= " & Integer'Image(i) & " and j= " &
- Integer'Image(j));
- end if;
- if not Incorrect_Inverse_Base_10 and
- not FXA5A00.Result_Within_Range
- (Float(i)**Float(j),
- 10.0**(Float(j)*EF.Log(Float(i),10.0)),
- TC_Relative_Error)
- then
- Incorrect_Inverse_Base_10 := True;
- Report.Failed("Incorrect Log-** Inverse calc for Base 10 " &
- "with i= " & Integer'Image(i) & " and j= " &
- Integer'Image(j));
- end if;
- if not Incorrect_Inverse_Base_16 and
- not FXA5A00.Result_Within_Range
- (Float(i)**Float(j),
- 16.0**(Float(j)*EF.Log(Float(i),16.0)),
- TC_Relative_Error)
- then
- Incorrect_Inverse_Base_16 := True;
- Report.Failed("Incorrect Log-** Inverse calc for Base 16 " &
- "with i= " & Integer'Image(i) & " and j= " &
- Integer'Image(j));
- end if;
- end loop;
- end loop;
- end;
-
- -- Reset Flags.
- Incorrect_Inverse_Base_e := False;
- Incorrect_Inverse_Base_2 := False;
- Incorrect_Inverse_Base_8 := False;
- Incorrect_Inverse_Base_10 := False;
- Incorrect_Inverse_Base_16 := False;
-
-
- -- Testing of Exp Function, both instantiated and pre-instantiated
- -- version.
-
- -- Check that the result of the Exp Function, when provided an X
- -- parameter value of 0.0, is 1.0.
-
- if GEF.Exp(X => 0.0) /= 1.0 or
- EF.Exp(0.0) /= 1.0
- then
- Report.Failed("Incorrect result returned by Function Exp when " &
- "given a parameter value of 0.0");
- end if;
-
-
- -- Check that the Exp Function provides correct results when provided
- -- a variety of input parameter values.
-
- if not Result_Within_Range(GEF.Exp(0.001), 1.01, 0.01) or
- not Result_Within_Range( EF.Exp(0.1), 1.11, 0.01) or
- not Result_Within_Range(GEF.Exp(1.2697), 3.56, 0.01) or
- not Result_Within_Range( EF.Exp(3.2525), 25.9, 0.1) or
- not Result_Within_Range(GEF.Exp(-0.2198), 0.803, 0.001) or
- not Result_Within_Range( EF.Exp(-1.6621), 0.190, 0.001) or
- not Result_Within_Range(GEF.Exp(-2.3888), 0.092, 0.001) or
- not Result_Within_Range( EF.Exp(-5.4415), 0.004, 0.001)
- then
- Report.Failed("Incorrect result from Function Exp when provided " &
- "a variety of input parameter values");
- end if;
-
- -- Use the following loops to check for internal consistency between
- -- inverse functions.
-
- Arg := 0.01;
- while Arg < 10.0 loop
- if not Incorrect_Inverse_Base_e and
- FXA5A00.Result_Within_Range(EF.Exp(Arg),
- e**(Arg*EF.Log(Arg)),
- 0.001)
- then
- Incorrect_Inverse_Base_e := True;
- Report.Failed("Incorrect Exp-** Inverse calc for Base e");
- end if;
- if not Incorrect_Inverse_Base_2 and
- FXA5A00.Result_Within_Range(EF.Exp(Arg),
- 2.0**(Arg*EF.Log(Arg,2.0)),
- 0.001)
- then
- Incorrect_Inverse_Base_2 := True;
- Report.Failed("Incorrect Exp-** Inverse calc for Base 2");
- end if;
- if not Incorrect_Inverse_Base_8 and
- FXA5A00.Result_Within_Range(EF.Exp(Arg),
- 8.0**(Arg*EF.Log(Arg,8.0)),
- 0.001)
- then
- Incorrect_Inverse_Base_8 := True;
- Report.Failed("Incorrect Exp-** Inverse calc for Base 8");
- end if;
- if not Incorrect_Inverse_Base_10 and
- FXA5A00.Result_Within_Range(EF.Exp(Arg),
- 10.0**(Arg*EF.Log(Arg,10.0)),
- 0.001)
- then
- Incorrect_Inverse_Base_10 := True;
- Report.Failed("Incorrect Exp-** Inverse calc for Base 10");
- end if;
- if not Incorrect_Inverse_Base_16 and
- FXA5A00.Result_Within_Range(EF.Exp(Arg),
- 16.0**(Arg*EF.Log(Arg,16.0)),
- 0.001)
- then
- Incorrect_Inverse_Base_16 := True;
- Report.Failed("Incorrect Exp-** Inverse calc for Base 16");
- end if;
- Arg := Arg + 0.01;
- end loop;
-
-
- -- Testing of Sqrt Function, both instantiated and pre-instantiated
- -- version.
-
- -- Check that Argument_Error is raised by the Sqrt Function when
- -- the value of the input parameter X is negative.
-
- begin
- Float_Result := EF.Sqrt(X => -FXA5A00.Small);
- Report.Failed("Argument_Error not raised by Function Sqrt " &
- "when provided a small negative input parameter " &
- "value");
- Dont_Optimize_Float(Float_Result, 7);
- exception
- when Argument_Error => null; -- OK, expected exception.
- when others =>
- Report.Failed("Unexpected exception raised by Function Sqrt " &
- "when provided a small negative input parameter " &
- "value");
- end;
-
- begin
- New_Float_Result := GEF.Sqrt(X => -64.0);
- Report.Failed("Argument_Error not raised by Function Sqrt " &
- "when provided a large negative input parameter " &
- "value");
- Dont_Optimize_New_Float(New_Float_Result, 8);
- exception
- when Argument_Error => null; -- OK, expected exception.
- when others =>
- Report.Failed("Unexpected exception raised by Function Sqrt " &
- "when provided a large negative input parameter " &
- "value");
- end;
-
-
- -- Check that the Sqrt Function, when given an X parameter value of 0.0,
- -- returns a result of 0.0.
-
- if GEF.Sqrt(X => 0.0) /= 0.0 or
- EF.Sqrt(0.0) /= 0.0
- then
- Report.Failed("Incorrect result from Function Sqrt when provided " &
- "an input parameter value of 0.0");
- end if;
-
-
- -- Check that the Sqrt Function, when given an X parameter input value
- -- of 1.0, returns a result of 1.0.
-
- if GEF.Sqrt(X => 1.0) /= 1.0 or
- EF.Sqrt(1.0) /= 1.0
- then
- Report.Failed("Incorrect result from Function Sqrt when provided " &
- "an input parameter value of 1.0");
- end if;
-
-
- -- Check that the Sqrt Function provides correct results when provided
- -- a variety of input parameter values.
-
- if not FXA5A00.Result_Within_Range(GEF.Sqrt(0.0327), 0.181, 0.001) or
- not FXA5A00.Result_Within_Range( EF.Sqrt(0.1808), 0.425, 0.001) or
- not FXA5A00.Result_Within_Range(GEF.Sqrt(1.0556), 1.03, 0.01) or
- not FXA5A00.Result_Within_Range( EF.Sqrt(32.8208), 5.73, 0.01) or
- not FXA5A00.Result_Within_Range( EF.Sqrt(27851.0), 166.9, 0.1) or
- not FXA5A00.Result_Within_Range( EF.Sqrt(61203.4), 247.4, 0.1) or
- not FXA5A00.Result_Within_Range( EF.Sqrt(655891.0), 809.9, 0.1)
- then
- Report.Failed("Incorrect result from Function Sqrt when provided " &
- "a variety of input parameter values");
- end if;
-
- -- Check internal consistency between functions.
-
- Arg := 0.01;
- while Arg < 10.0 loop
- if not Flag_1 and
- not FXA5A00.Result_Within_Range(Arg,
- EF.Sqrt(Arg)*EF.Sqrt(Arg),
- 0.01)
- then
- Report.Failed("Inconsistency found in Case 1");
- Flag_1 := True;
- end if;
- if not Flag_2 and
- not FXA5A00.Result_Within_Range(Arg, EF.Sqrt(Arg)**2.0, 0.01)
- then
- Report.Failed("Inconsistency found in Case 2");
- Flag_2 := True;
- end if;
- if not Flag_3 and
- not FXA5A00.Result_Within_Range(EF.Log(Arg),
- EF.Log(Sqrt(Arg)**2.0), 0.01)
- then
- Report.Failed("Inconsistency found in Case 3");
- Flag_3 := True;
- end if;
- if not Flag_4 and
- not FXA5A00.Result_Within_Range(EF.Log(Arg),
- 2.00*EF.Log(EF.Sqrt(Arg)),
- 0.01)
- then
- Report.Failed("Inconsistency found in Case 4");
- Flag_4 := True;
- end if;
- Arg := Arg + 1.0;
- end loop;
-
-
- exception
- when The_Error : others =>
- Report.Failed ("The following exception was raised in the " &
- "Test_Block: " & Exception_Name(The_Error));
- end Test_Block;
-
- Report.Result;
-
-end CXA5A10;
diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxa8001.a b/gcc/testsuite/ada/acats/tests/cxa/cxa8001.a
deleted file mode 100644
index 16f30752db1..00000000000
--- a/gcc/testsuite/ada/acats/tests/cxa/cxa8001.a
+++ /dev/null
@@ -1,243 +0,0 @@
--- CXA8001.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that all elements to be transferred to a sequential file of
--- mode Append_File will be placed following the last element currently
--- in the file.
--- Check that it is possible to append data to a file that has been
--- previously appended to.
--- Check that the predefined procedure Write will place an element after
--- the last element in the file in mode Append_File.
---
--- TEST DESCRIPTION:
--- This test implements a sequential file system that has the capability
--- to store data records at the end of a file. Initially, the file is
--- opened with mode Out_File, and data is written to the file. The file
--- is closed, then reopened with mode Append_File. An additional record
--- is written, and again the file is closed. The file is then reopened,
--- again with mode Append_File, and another record is written to the
--- file.
--- The file is closed again, the reopened with mode In_File, and the data
--- in the file is read and checked for proper ordering within the file.
---
--- An expected common usage of Append_File mode would be in the opening
--- of a file that currently contains data. Likewise, the reopening of
--- files in Append_Mode that have been previously appended to for the
--- addition of more data would be frequently encountered. This test
--- attempts to simulate both situations. (Of course, in an actual user
--- environment, the open/write/close processing would be performed using
--- looping structures, rather than the straight-line processing displayed
--- here.)
---
--- APPLICABILITY CRITERIA:
--- Applicable to all systems capable of supporting IO operations on
--- external Sequential_IO files.
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 27 Feb 97 PWB.CTA Allowed for non-support of some IO operations
---!
-
-with Sequential_IO;
-with Report;
-
-procedure CXA8001 is
-
- -- Declare data types and objects to be stored in the file.
- subtype Name_Type is String (1 .. 10);
- type Tickets is range 0 .. 1000;
-
- type Order_Type is record
- Name : Name_Type;
- No_of_Tickets : Tickets;
- end record;
-
- package Order_IO is new Sequential_IO (Order_Type); -- Declare Seq_IO
- -- package,
- Order_File : Order_IO.File_Type; -- and file object.
- Order_Filename : constant String :=
- Report.Legal_File_Name ( Nam => "CXA8001" );
- Incomplete : exception;
-
-begin
-
- Report.Test ("CXA8001", "Check that all elements to be transferred to a " &
- "sequential file of mode Append_File will be " &
- "placed following the last element currently " &
- "in the file");
-
- Test_for_Sequential_IO_Support:
- begin
-
- -- An implementation that does not support Sequential_IO in a particular
- -- environment will raise Use_Error or Name_Error on calls to various
- -- Sequential_IO operations. This block statement encloses a call to
- -- Create, which should produce an exception in a non-supportive
- -- environment. These exceptions will be handled to produce a
- -- Not_Applicable result.
-
- Order_IO.Create (File => Order_File, -- Create Sequential_IO file
- Mode => Order_IO.Out_File, -- with mode Out_File.
- Name => Order_Filename);
-
- exception
-
- when Order_IO.Use_Error | Order_IO.Name_Error =>
- Report.Not_Applicable
- ( "Files not supported - Create as Out_File for Sequential_IO" );
- raise Incomplete;
-
- end Test_for_Sequential_IO_Support;
-
- Operational_Test_Block:
- declare
- -- Assign values into the component fields of the data objects.
- Buyer_1 : constant Order_Type := ("John Smith", 3);
- Buyer_2 : constant Order_Type :=
- (Name => "Jane Jones", No_of_Tickets => 2);
- Buyer_3 : Order_Type := ("Mike Brown", 5);
-
- begin
- Order_IO.Write (File => Order_File, -- Write initial data item
- Item => Buyer_1); -- to file.
-
- Order_IO.Close (File => Order_File); -- Close file.
-
- --
- -- Enter additional data records into the file. (Append to a file of
- -- previous mode Out_File).
- --
- Order_IO.Open (Order_File, -- Open Sequential_IO file
- Order_IO.Append_File, -- with mode Append_File.
- Order_Filename);
-
- Order_IO.Write (Order_File, Buyer_2); -- Write second data item
- -- to file.
- Order_IO.Close (File => Order_File); -- Close file.
-
- -- Check to determine whether file is actually closed.
- begin
- Order_IO.Write (Order_File, Buyer_2);
- Report.Failed("Exception not raised on Write to Closed file");
- exception
- when Order_IO.Status_Error => null; -- Expected exception.
- when others =>
- Report.Failed("Incorrect exception on Write to Closed file");
- end;
-
- --
- -- The following code segment demonstrates appending data to a file
- -- that has been previously appended to.
- --
-
- Order_IO.Open (Order_File, -- Open Sequential_IO file
- Order_IO.Append_File, -- with mode Append_File.
- Order_Filename );
-
- Order_IO.Write (Order_File, Buyer_3); -- Write third data item
- -- to file.
- Order_IO.Close (File => Order_File); -- Close file.
-
-
- Test_Verification_Block:
- declare
- TC_Order1, TC_Order2, TC_Order3 : Order_Type;
- begin
-
- Order_IO.Open (Order_File, -- Open Sequential_IO file
- Order_IO.In_File, -- with mode In_File.
- Order_Filename );
-
- Order_IO.Read (File => Order_File, -- Read records from file.
- Item => TC_Order1);
- Order_IO.Read (Order_File, TC_Order2);
- Order_IO.Read (Order_File, TC_Order3);
-
- -- Compare the contents of each with the individual data items.
- -- If items read from file do not match the items placed into
- -- the file, in the appropriate order, then fail.
-
- if ((TC_Order1 /= Buyer_1) or
- (TC_Order2.Name /= Buyer_2.Name) or
- (TC_Order2.No_of_Tickets /= Buyer_2.No_of_Tickets) or
- not ((TC_Order3.Name = "Mike Brown") and
- (TC_Order3.No_of_Tickets = 5))) then
- Report.Failed ("Incorrect appending of record data in file");
- end if;
-
- -- Check to determine that no more than three data records were
- -- actually written to the file.
- if not Order_IO.End_Of_File (Order_File) then
- Report.Failed("File not empty after three reads");
- end if;
-
- exception
-
- when Order_IO.End_Error => -- If three items not in
- -- file (data overwritten),
- -- then fail.
- Report.Failed ("Incorrect number of record elements in file");
-
- when others =>
- Report.Failed ("Error raised during data verification");
-
- end Test_Verification_Block;
-
- exception
-
- when others =>
- Report.Failed("Exception raised during Sequential_IO processing");
-
- end Operational_Test_Block;
-
- Deletion:
- begin
- -- Check that file is open prior to deleting it.
- if Order_IO.Is_Open(Order_File) then
- Order_IO.Delete (Order_File);
- else
- Order_IO.Open(Order_File, Order_IO.In_File, Order_Filename);
- Order_IO.Delete (Order_File);
- end if;
-
- exception
- when others =>
- Report.Failed
- ( "Delete not properly implemented for Sequential_IO" );
-
- end Deletion;
-
- Report.Result;
-
-exception
- when Incomplete =>
- Report.Result;
- when others =>
- Report.Failed ( "Unexpected exception" );
- Report.Result;
-
-end CXA8001;
diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxa8002.a b/gcc/testsuite/ada/acats/tests/cxa/cxa8002.a
deleted file mode 100644
index 8670e98bac9..00000000000
--- a/gcc/testsuite/ada/acats/tests/cxa/cxa8002.a
+++ /dev/null
@@ -1,285 +0,0 @@
--- CXA8002.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that resetting a file using mode Append_File allows for the
--- writing of elements to the file starting after the last element in
--- the file.
--- Check that the result of function Name can be used on a subsequent
--- reopen of the file.
--- Check that a mode change occurs on reset of a file to/from mode
--- Append_File.
---
--- TEST DESCRIPTION:
--- This test simulates the read/write of data from/to an individual
--- sequential file. New data can be appended to the end of the existing
--- file, and the same file can be reset to allow reading of data from
--- the file. This process can occur multiple times.
--- When the mode of the file is changed with a Reset, the current mode
--- value assigned to the file is checked using the result of function
--- Mode. This, in conjunction with the read/write operations, verifies
--- that a mode change has taken place on Reset.
---
--- An expected common usage of the scenarios found in this test would
--- be a case where a single data file is kept open continuously, being
--- reset for read/append of data. For systems that do not support a
--- direct form of I/O, this would allow for efficient use of a sequential
--- I/O file.
---
--- APPLICABILITY CRITERIA:
--- Applicable to all systems capable of supporting IO operations on
--- external Sequential_IO files.
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 19 Feb 97 PWB.CTA Fixed handling for file non-support and Reset
--- non-support.
---!
-
-with Sequential_IO;
-with Report;
-
-procedure CXA8002 is
- subtype Employee_Data is String (1 .. 11);
- package Data_IO is new Sequential_IO (Employee_Data);
-
- Employee_Data_File : Data_IO.File_Type;
- Employee_Filename : constant String :=
- Report.Legal_File_Name (Nam => "CXA8002");
-
- Incomplete : exception;
-
-begin
-
- Report.Test ("CXA8002", "Check that resetting a file using mode " &
- "Append_File allows for the writing of " &
- "elements to the file starting after the " &
- "last element in the file");
-
- Test_for_Sequential_IO_Support:
- begin
-
- -- An implementation that does not support Sequential_IO in a particular
- -- environment will raise Use_Error or Name_Error on calls to various
- -- Sequential_IO operations. This block statement encloses a call to
- -- Create, which should produce an exception in a non-supportive
- -- environment. These exceptions will be handled to produce a
- -- Not_Applicable result.
-
- Data_IO.Create (File => Employee_Data_File, -- Create file in
- Mode => Data_IO.Append_File, -- mode Append_File.
- Name => Employee_Filename);
-
- --
- -- The following portion of code demonstrates the fact that a sequential
- -- file can be created in Append_File mode, and that data can be written
- -- to the file.
- --
-
- exception
- when Data_IO.Use_Error | Data_IO.Name_Error =>
- Report.Not_Applicable
- ( "Sequential files not supported - Create as Append_File");
- raise Incomplete;
- end Test_for_Sequential_IO_Support;
- Operational_Test_Block:
- declare
- Blank_Data : constant Employee_Data := " ";
- Employee_1 : constant Employee_Data := "123-45-6789";
- Employee_2 : Employee_Data := "987-65-4321";
-
- -- Note: Artificial numerical data chosen above to prevent any
- -- unintended similarity with persons alive or dead.
-
- TC_Employee_Data : Employee_Data := Blank_Data;
-
-
- function TC_Mode_Selection (Selector : Integer)
- return Data_IO.File_Mode is
- begin
- case Report.Ident_Int(Selector) is
- when 1 => return Data_IO.In_File;
- when 2 => return Data_IO.Out_File;
- when others => return Data_IO.Append_File;
- end case;
- end TC_Mode_Selection;
-
- Employee_Filename : constant String := -- Use function Name to
- Data_IO.Name (File => Employee_Data_File); -- store filename in
- -- string variable.
- begin
-
- Data_IO.Write (File => Employee_Data_File, -- Write initial data
- Item => Employee_1); -- entry to file.
-
- --
- -- The following portion of code demonstrates that a sequential file
- -- can be reset to various file modes, including Append_File mode,
- -- allowing data to be added to the end of the file.
- --
- begin
- Data_IO.Reset (File => Employee_Data_File, -- Reset file with
- Mode => Data_IO.In_File); -- mode In_File.
- exception
- when Data_IO.Use_Error =>
- Report.Not_Applicable
- ("Reset to In_File not supported for Sequential_IO");
- raise Incomplete;
- when others =>
- Report.Failed
- ("Unexpected exception on Reset to In_File (Sequential_IO)");
- raise Incomplete;
- end;
- if Data_IO."="(Data_IO.Mode (Employee_Data_File),
- TC_Mode_Selection (1)) then -- Compare In_File mode
- -- Reset successful,
- Data_IO.Read (File => Employee_Data_File, -- now verify file data.
- Item => TC_Employee_Data);
-
- if ((TC_Employee_Data (1 .. 7) /= "123-45-") or
- (TC_Employee_Data (5 .. 11) /= "45-6789")) then
- Report.Failed ("Data read error");
- end if;
-
- else
- Report.Failed ("File mode not changed by Reset");
- end if;
-
- --
- -- Simulate appending data to a file that has previously been written
- -- to and read from.
- --
- begin
- Data_IO.Reset (File => Employee_Data_File, -- Reset file with
- Mode => Data_IO.Append_File); -- mode Append_File.
- exception
- when Data_IO.Use_Error =>
- Report.Not_Applicable
- ("Reset to Append_File not supported for Sequential_IO");
- raise Incomplete;
- when others =>
- Report.Failed
- ("Unexpected exception on Reset to Append_File (Sequential_IO)");
- raise Incomplete;
- end;
-
- if Data_IO.Is_Open (Employee_Data_File) then -- File remains open
- -- following Reset to
- -- Append_File mode?
-
- if Data_IO."=" (Data_IO.Mode (Employee_Data_File),
- TC_Mode_Selection (3)) then -- Compare to
- -- Append_File mode.
- Data_IO.Write (File => Employee_Data_File, -- Write additional
- Item => Employee_2); -- data to file.
- else
- Report.Failed ("File mode not changed by Reset");
- end if;
-
- else
- Report.Failed
- ("File status not Open following Reset to Append mode");
- end if;
-
- Data_IO.Close (Employee_Data_File);
-
-
- Test_Verification_Block:
- begin
-
- Data_IO.Open (File => Employee_Data_File, -- Reopen file, using
- Mode => Data_IO.In_File, -- previous result of
- Name => Employee_Filename); -- function Name.
-
- TC_Employee_Data := Blank_Data; -- Clear record field.
- Data_IO.Read (Employee_Data_File, -- Read first record,
- TC_Employee_Data); -- check ordering of
- -- records.
-
- if not ((TC_Employee_Data (1 .. 3) = "123") and then
- (TC_Employee_Data (4 .. 11) = "-45-6789")) then
- Report.Failed ("Data read error - first record");
- end if;
-
- TC_Employee_Data := Blank_Data; -- Clear record field.
- Data_IO.Read (Employee_Data_File, -- Read second record,
- TC_Employee_Data); -- check for ordering of
- -- records.
-
- if ((TC_Employee_Data (1 .. 6) /= "987-65") or else
- not (TC_Employee_Data (3 .. 11) = "7-65-4321")) then
- Report.Failed ("Data read error - second record");
- end if;
-
- -- Check that only two items were written to the file.
- if not Data_IO.End_Of_File(Employee_Data_File) then
- Report.Failed("Incorrect number of records in file");
- end if;
-
- exception
-
- when Data_IO.End_Error => -- If two items not in
- -- file (data overwritten),
- -- then fail.
- Report.Failed ("Incorrect number of record elements in file");
-
- when others =>
- Report.Failed ("Error raised during data verification");
-
- end Test_Verification_Block;
-
- exception
-
- when others =>
- Report.Failed("Exception raised during Sequential_IO processing");
-
- end Operational_Test_Block;
-
- Final_Block:
- begin
- -- Check that file is open prior to deleting it.
- if Data_IO.Is_Open(Employee_Data_File) then
- Data_IO.Delete (Employee_Data_File);
- else
- Data_IO.Open(Employee_Data_File,
- Data_IO.In_File,
- Employee_Filename);
- Data_IO.Delete (Employee_Data_File);
- end if;
- exception
- when others =>
- Report.Failed ("Sequential_IO Delete not properly supported");
- end Final_Block;
-
- Report.Result;
-
-exception
- when Incomplete =>
- Report.Result;
- when others =>
- Report.Failed ("Unexpected exception");
- Report.Result;
-end CXA8002;
diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxa8003.a b/gcc/testsuite/ada/acats/tests/cxa/cxa8003.a
deleted file mode 100644
index cf9b5e07598..00000000000
--- a/gcc/testsuite/ada/acats/tests/cxa/cxa8003.a
+++ /dev/null
@@ -1,214 +0,0 @@
--- CXA8003.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that Append_File mode has not been added to package Direct_IO.
---
--- TEST DESCRIPTION:
--- This test uses a procedure to change the mode of an existing Direct_IO
--- file. The file descriptor is passed as a parameter, along with a
--- numeric indicator for the new mode. Based on the numeric parameter,
--- a Direct_IO.Reset is performed using a File_Mode'Value transformation
--- of a string constant into a File_Mode value. An attempt to reset a
--- Direct_IO file to mode Append_File should cause an Constraint_Error
--- to be raised, as Append_File mode has not been added to Direct_IO in
--- Ada 9X.
---
--- APPLICABILITY CRITERIA:
--- This test is applicable to all implementations supporting Direct_IO
--- files.
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 19 Feb 97 PWB.CTA Allowed for non-support of Reset for certain
--- modes.
---!
-
-with Direct_IO;
-with Report;
-
-procedure CXA8003 is
- Incomplete : exception;
- begin
-
- Report.Test ("CXA8003", "Check that Append_File mode has not " &
- "been added to package Direct_IO");
-
- Test_for_Direct_IO_Support:
- declare
-
- subtype String_Data_Type is String (1 .. 20);
- type Numeric_Data_Type is range 1 .. 512;
- type Composite_Data_Type is array (1 .. 3) of String_Data_Type;
-
- type File_Data_Type is record
- Data_Field_1 : String_Data_Type;
- Data_Field_2 : Numeric_Data_Type;
- Data_Field_3 : Composite_Data_Type;
- end record;
-
- package Dir_IO is new Direct_IO (File_Data_Type);
-
- Data_File : Dir_IO.File_Type;
- Dir_Filename : constant String := Report.Legal_File_Name;
-
- begin
-
- -- An application creates a text file with mode Out_File.
- -- Use_Error will be raised if Direct_IO operations or external
- -- files are not supported.
-
- Dir_IO.Create (Data_File,
- Dir_IO.Out_File,
- Dir_Filename);
-
- Change_File_Mode:
- declare
-
- TC_Append_Test_Executed : Boolean := False;
-
- type Mode_Selection_Type is ( A, I, IO, O );
-
-
- procedure Change_Mode (File : in out Dir_IO.File_Type;
- To : in Mode_Selection_Type) is
- begin
- case To is
- when A =>
- TC_Append_Test_Executed := True;
- Dir_IO.Reset
- (File, Dir_IO.File_Mode'Value("Append_File"));
- when I =>
- begin
- Dir_IO.Reset
- (File, Dir_IO.File_Mode'Value("In_File"));
- exception
- when Dir_IO.Use_Error =>
- Report.Not_Applicable
- ("Reset to In_File not supported: Direct_IO");
- raise Incomplete;
- end;
- when IO =>
- begin
- Dir_IO.Reset
- (File, Dir_IO.File_Mode'Value("Inout_File"));
- exception
- when Dir_IO.Use_Error =>
- Report.Not_Applicable
- ("Reset to InOut_File not supported: Direct_IO");
- raise Incomplete;
- end;
- when O =>
- begin
- Dir_IO.Reset
- (File, Dir_IO.File_Mode'Value("Out_File"));
- exception
- when Dir_IO.Use_Error =>
- Report.Not_Applicable
- ("Reset to Out_File not supported: Direct_IO");
- raise Incomplete;
- end;
- end case;
- end Change_Mode;
-
-
- begin
-
- -- At some point in the processing, the application may call a
- -- procedure to change the mode of the file (perhaps for
- -- additional data entry, data verification, etc.). It is at
- -- this point that a use of Append_File mode for a Direct_IO
- -- file would cause an exception.
-
- for I in reverse Mode_Selection_Type loop
- Change_Mode (Data_File, I);
- Report.Comment
- ("Mode changed to " &
- Dir_IO.File_Mode'Image (Dir_IO.Mode (Data_File)));
- end loop;
-
- Report.Failed("No error raised on change to Append_File mode");
-
- exception
-
- -- A handler has been provided in the application, which
- -- handles the constraint error, allowing processing to
- -- continue.
-
- when Constraint_Error =>
-
- if TC_Append_Test_Executed then
- Report.Comment ("Constraint_Error correctly raised on " &
- "attempted Append_File mode selection " &
- "for a Direct_IO file");
- else
- Report.Failed ("Append test was not executed");
- end if;
-
- when Incomplete => raise;
-
- when others => Report.Failed ("Unexpected exception raised");
-
- end Change_File_Mode;
-
- Final_Block:
- begin
- if Dir_IO.Is_Open (Data_File) then
- Dir_IO.Delete (Data_File);
- else
- Dir_IO.Open (Data_File, Dir_IO.In_File, Dir_Filename);
- Dir_IO.Delete (Data_File);
- end if;
- exception
- when others =>
- Report.Failed ("Delete not properly supported: Direct_IO");
- end Final_Block;
-
- exception
-
- -- Since Use_Error or Name_Error can be raised if, for the
- -- specified mode, the environment does not support Direct_IO
- -- operations, the following handlers are included:
-
- when Dir_IO.Name_Error =>
- Report.Not_Applicable("Name_Error raised on Direct IO Create");
-
- when Dir_IO.Use_Error =>
- Report.Not_Applicable("Use_Error raised on Direct IO Create");
-
- when others =>
- Report.Failed
- ("Unexpected exception raised on Direct IO Create");
-
- end Test_for_Direct_IO_Support;
-
- Report.Result;
-
-exception
- when Incomplete =>
- Report.Result;
-
-end CXA8003;
diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxa9001.a b/gcc/testsuite/ada/acats/tests/cxa/cxa9001.a
deleted file mode 100644
index 4fe9c357614..00000000000
--- a/gcc/testsuite/ada/acats/tests/cxa/cxa9001.a
+++ /dev/null
@@ -1,287 +0,0 @@
--- CXA9001.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that the operations defined in the generic package
--- Ada.Storage_IO provide the ability to store and retrieve objects
--- which may include implicit levels of indirection in their
--- implementation, from an in-memory buffer.
---
--- TEST DESCRIPTION:
--- The following scenario demonstrates how an object of a type with
--- (potential) levels of indirection (based on the implementation)
--- can be "flattened" and written/read to/from a Direct_IO file.
--- In this small example, we have attempted to simulate the situation
--- where two independent programs are using a particular Direct_IO file,
--- one writing data to the file, and the second program reading that file.
--- The Storage_IO Read and Write procedures are used to "flatten"
--- and reconstruct objects of the record type.
---
--- APPLICABILITY CRITERIA:
--- Applicable to implementations capable of supporting external
--- Direct_IO files.
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 07 Jun 95 SAIC Modified to constrain type used with Storage_IO.
--- 20 Nov 95 SAIC Corrected and enhanced for ACVC 2.0.1.
--- 25 Feb 97 PWB.CTA Allowed for non-support of some IO operations
---!
-
-with Report;
-with Ada.Storage_IO;
-with Ada.Direct_IO;
-
-procedure CXA9001 is
- package Dir_IO is new Ada.Direct_IO (Integer);
- Test_File : Dir_IO.File_Type;
- Incomplete : exception;
-begin
-
- Report.Test ("CXA9001", "Check that the operations defined in the " &
- "generic package Ada.Storage_IO provide the " &
- "ability to store and retrieve objects which " &
- "may include implicit levels of indirection in " &
- "their implementation, from an in-memory buffer");
-
-
- Test_For_Direct_IO_Support:
- begin
-
- -- The following Create does not have any bearing on the test scenario,
- -- but is included to check that the implementation supports Direct_IO
- -- files. An exception on this Create statement will raise a Name_Error
- -- or Use_Error, which will be handled to produce a Not_Applicable
- -- result. If created, the file is immediately deleted, as it is not
- -- needed for the program scenario.
-
- Dir_IO.Create (Test_File, Dir_IO.Out_File, Report.Legal_File_Name(1));
-
- exception
-
- when Dir_IO.Use_Error | Dir_IO.Name_Error =>
- Report.Not_Applicable
- ( "Files not supported - Create as Out_File for Direct_IO" );
- raise Incomplete;
-
- end Test_for_Direct_IO_Support;
-
- Deletion1:
- begin
- Dir_IO.Delete (Test_File);
- exception
- when others =>
- Report.Failed
- ( "Delete not properly implemented for Direct_IO - 1" );
- end Deletion1;
-
-
- Test_Block:
- declare
-
- The_Filename : constant String := Report.Legal_File_Name(2);
-
- -- The following type is the basic unit used in this test. It is
- -- incorporated into the definition of the Unit_Array_Type.
-
- type Unit_Type is
- record
- Position : Natural := 19;
- String_Value : String (1..9) := (others => 'X');
- end record;
-
- TC_Size : Natural := Natural'First;
-
- procedure Data_Storage (Number_Of_Units : in Natural;
- Result : out Natural) is
-
- -- Type based on input parameter. Uses type Unit_Type
- -- as the array element.
- type Unit_Array_Type is array (1..Number_Of_Units)
- of Unit_Type;
-
- -- This type definition is the ultimate storage type used
- -- in this test; uses type Unit_Array_Type as a record
- -- component field.
- -- This record type contains a component that is an array of
- -- records, with each of these records containing a Natural
- -- and a String value (i.e., a record containing an array of
- -- records).
-
- type Data_Storage_Type is
- record
- Data_Value : Natural := Number_Of_Units;
- Unit_Array : Unit_Array_Type;
- end record;
-
- -- The instantiation of the following generic package is a
- -- central point in this test. Storage_IO is instantiated for
- -- a specific data type, and will be used to "flatten" objects
- -- of that type into buffers. Direct_IO is instantiated for
- -- these Storage_IO buffers.
-
- package Flat_Storage_IO is
- new Ada.Storage_IO (Data_Storage_Type);
- package Buffer_IO is
- new Ada.Direct_IO (Flat_Storage_IO.Buffer_Type);
-
- Buffer_File : Buffer_IO.File_Type;
- Outbound_Buffer : Flat_Storage_IO.Buffer_Type;
- Storage_Item : Data_Storage_Type;
-
- begin -- procedure Data_Storage
-
- Buffer_IO.Create (Buffer_File,
- Buffer_IO.Out_File,
- The_Filename);
-
- Flat_Storage_IO.Write (Buffer => Outbound_Buffer,
- Item => Storage_Item);
-
- -- At this point, any levels of indirection have been removed
- -- by the Storage_IO procedure, and the buffered data can be
- -- written to a file.
-
- Buffer_IO.Write (Buffer_File, Outbound_Buffer);
- Buffer_IO.Close (Buffer_File);
- Result := Storage_Item.Unit_Array'Last + -- 5 +
- Storage_Item.Unit_Array -- 9
- (Storage_Item.Unit_Array'First).String_Value'Length;
-
- exception
- when others =>
- Report.Failed ("Data storage error");
- if Buffer_IO.Is_Open (Buffer_File) then
- Buffer_IO.Close (Buffer_File);
- end if;
- end Data_Storage;
-
- procedure Data_Retrieval (Number_Of_Units : in Natural;
- Result : out Natural) is
- type Unit_Array_Type is array (1..Number_Of_Units)
- of Unit_Type;
-
- type Data_Storage_Type is
- record
- Data_Value : Natural := Number_Of_Units;
- Unit_Array : Unit_Array_Type;
- end record;
-
- package Flat_Storage_IO is
- new Ada.Storage_IO (Data_Storage_Type);
- package Reader_IO is
- new Ada.Direct_IO (Flat_Storage_IO.Buffer_Type);
-
- Reader_File : Reader_IO.File_Type;
- Inbound_Buffer : Flat_Storage_IO.Buffer_Type;
- Storage_Item : Data_Storage_Type;
- TC_Item : Data_Storage_Type;
-
- begin -- procedure Data_Retrieval
-
- Reader_IO.Open (Reader_File, Reader_IO.In_File, The_Filename);
- Reader_IO.Read (Reader_File, Inbound_Buffer);
-
- Flat_Storage_IO.Read (Inbound_Buffer, Storage_Item);
-
- -- Validate the reconstructed value against an "unflattened"
- -- value.
-
- if Storage_Item.Data_Value /= TC_Item.Data_Value
- then
- Report.Failed ("Data_Retrieval Error - 1");
- end if;
-
- for i in 1..Number_Of_Units loop
- if Storage_Item.Unit_Array(i).String_Value'Length /=
- TC_Item.Unit_Array(i).String_Value'Length or
- Storage_Item.Unit_Array(i).Position /=
- TC_Item.Unit_Array(i).Position or
- Storage_Item.Unit_Array(i).String_Value /=
- TC_Item.Unit_Array(i).String_Value
- then
- Report.Failed ("Data_Retrieval Error - 2");
- end if;
- end loop;
-
- Result := Storage_Item.Unit_Array'Last + -- 5 +
- Storage_Item.Unit_Array -- 9
- (Storage_Item.Unit_Array'First).String_Value'Length;
-
- if Reader_IO.Is_Open (Reader_File) then
- Reader_IO.Delete (Reader_File);
- else
- Reader_IO.Open (Reader_File,
- Reader_IO.In_File,
- The_Filename);
- Reader_IO.Delete (Reader_File);
- end if;
-
- exception
- when others =>
- Report.Failed ("Exception raised in Data_Retrieval");
- if Reader_IO.Is_Open (Reader_File) then
- Reader_IO.Delete (Reader_File);
- else
- Reader_IO.Open (Reader_File,
- Reader_IO.In_File,
- The_Filename);
- Reader_IO.Delete (Reader_File);
- end if;
- end Data_Retrieval;
-
-
- begin -- Test_Block
-
- -- The number of Units is provided in this call to Data_Storage.
- Data_Storage (Number_Of_Units => Natural(Report.Ident_Int(5)),
- Result => TC_Size);
-
- if TC_Size /= 14 then
- Report.Failed ("Data_Storage error in Data_Storage");
- end if;
-
- Data_Retrieval (Number_Of_Units => Natural(Report.Ident_Int(5)),
- Result => TC_Size);
-
- if TC_Size /= 14 then
- Report.Failed ("Data retrieval error in Data_Retrieval");
- end if;
-
- exception
- when others => Report.Failed ("Exception raised in Test_Block");
- end Test_Block;
-
- Report.Result;
-
-exception
- when Incomplete =>
- Report.Result;
- when others =>
- Report.Failed ( "Unexpected exception" );
- Report.Result;
-
-end CXA9001;
diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxa9002.a b/gcc/testsuite/ada/acats/tests/cxa/cxa9002.a
deleted file mode 100644
index 415a56630ad..00000000000
--- a/gcc/testsuite/ada/acats/tests/cxa/cxa9002.a
+++ /dev/null
@@ -1,482 +0,0 @@
--- CXA9002.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that the operations defined in the generic package
--- Ada.Storage_IO provide the ability to store and retrieve objects
--- of tagged types from in-memory buffers.
---
--- TEST DESCRIPTION:
--- The following scenario demonstrates how objects of a tagged type,
--- extended types, and twice extended types can be written/read
--- to/from Direct_IO files. The Storage_IO subprograms, Read and Write,
--- demonstrated in this scenario, perform tag "fixing" prior to/following
--- transfer to the Direct_IO files.
--- This method is especially important for those implementations that
--- represent tags as pointers, or for cases where the tagged objects
--- are read in by a program other than the one that wrote them.
---
--- In this small example, we have attempted to simulate the situation
--- where two independent programs are using a series of Direct_IO files,
--- one writing data to the files, and the second program reading the
--- data from those files. Two procedures are defined, the first
--- simulating the program responsible for writing, the second simulating
--- a separate program opening and reading the data from the files.
---
--- The hierarchy of types used in this test can be displayed as follows:
---
--- Account_Type
--- / \
--- / \
--- / \
--- Cash_Account_Type Investment_Account_Type
--- / \
--- / \
--- / \
--- Checking_Account_Type Savings_Account_Type
---
--- APPLICABILITY CRITERIA:
--- Applicable to implementations capable of supporting external
--- Direct_IO files.
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 08 Nov 95 SAIC Corrected incorrect prefix of 'Tag for ACVC 2.0.1,
--- and mode of files in Procedure Read_Data.
--- Added verification of objects reconstructed from
--- files.
--- 27 Feb 97 PWB.CTA Allowed for non-support of some IO operations
---!
-
-package CXA9002_0 is
-
- type Investment_Type is (Stocks, Bonds, Mutual_Funds);
- type Savings_Type is (Standard, Business, Impound);
-
- type Account_Type is tagged
- record
- Num : String (1..3);
- end record;
-
- type Cash_Account_Type is new Account_Type with
- record
- Years_As_Customer : Natural := 1;
- end record;
-
- type Investment_Account_Type is new Account_Type with
- record
- Investment_Vehicle : Investment_Type := Stocks;
- end record;
-
- type Checking_Account_Type is new Cash_Account_Type with
- record
- Checks_Per_Year : Positive := 200;
- Interest_Bearing : Boolean := False;
- end record;
-
- type Savings_Account_Type is new Cash_Account_Type with
- record
- Kind : Savings_Type := Standard;
- end record;
-
-end CXA9002_0;
-
----
-
-with Report;
-with Ada.Storage_IO;
-with Ada.Direct_IO;
-with Ada.Tags;
-with CXA9002_0;
-
-procedure CXA9002 is
- package Dir_IO is new Ada.Direct_IO (Integer);
- Test_File : Dir_IO.File_Type;
- Incomplete : exception;
-begin
-
- Report.Test ("CXA9002", "Check that the operations defined in the " &
- "generic package Ada.Storage_IO provide the " &
- "ability to store and retrieve objects of " &
- "tagged types from in-memory buffers");
-
-
- Test_For_Direct_IO_Support:
- begin
-
- -- The following Create does not have any bearing on the test scenario,
- -- but is included to check that the implementation supports Direct_IO
- -- files. An exception on this Create statement will raise a Name_Error
- -- or Use_Error, which will be handled to produce a Not_Applicable
- -- result. If created, the file is immediately deleted, as it is not
- -- needed for the program scenario.
-
- Dir_IO.Create (Test_File,
- Dir_IO.Out_File,
- Report.Legal_File_Name(1));
- exception
-
- when Dir_IO.Use_Error | Dir_IO.Name_Error =>
- Report.Not_Applicable
- ( "Files not supported - Create as Out_File for Direct_IO" );
- raise Incomplete;
-
- end Test_for_Direct_IO_Support;
-
- Deletion:
- begin
- Dir_IO.Delete (Test_File);
- exception
- when others =>
- Report.Failed
- ( "Delete not properly implemented for Direct_IO" );
- end Deletion;
-
- Test_Block:
- declare
-
- use CXA9002_0;
-
- Acct_Filename : constant String := Report.Legal_File_Name(1);
- Cash_Filename : constant String := Report.Legal_File_Name(2);
- Inv_Filename : constant String := Report.Legal_File_Name(3);
- Chk_Filename : constant String := Report.Legal_File_Name(4);
- Sav_Filename : constant String := Report.Legal_File_Name(5);
-
- type Tag_Pointer_Type is access String;
-
- TC_Account_Type_Tag,
- TC_Cash_Account_Type_Tag,
- TC_Investment_Account_Type_Tag,
- TC_Checking_Account_Type_Tag,
- TC_Savings_Account_Type_Tag : Tag_Pointer_Type;
-
- TC_Account : Account_Type :=
- (Num => "123");
-
- TC_Cash_Account : Cash_Account_Type :=
- (Num => "234",
- Years_As_Customer => 3);
-
- TC_Investment_Account : Investment_Account_Type :=
- (Num => "456",
- Investment_Vehicle => Bonds);
-
- TC_Checking_Account : Checking_Account_Type :=
- (Num => "567",
- Years_As_Customer => 2,
- Checks_Per_Year => 300,
- Interest_Bearing => True);
-
- TC_Savings_Account : Savings_Account_Type :=
- (Num => "789",
- Years_As_Customer => 14,
- Kind => Business);
-
- procedure Buffer_Data is
-
- Account : Account_Type :=
- TC_Account;
- Cash_Account : Cash_Account_Type :=
- TC_Cash_Account;
- Investment_Account : Investment_Account_Type :=
- TC_Investment_Account;
- Checking_Account : Checking_Account_Type :=
- TC_Checking_Account;
- Savings_Account : Savings_Account_Type :=
- TC_Savings_Account;
-
- -- The instantiations below are a central point in this test.
- -- Storage_IO is instantiated for each of the specific tagged
- -- type. These instantiated packages will be used to compress
- -- tagged objects of these various types into buffers that will
- -- be written to the Direct_IO files declared below.
-
- package Acct_SIO is new Ada.Storage_IO (Account_Type);
- package Cash_SIO is new Ada.Storage_IO (Cash_Account_Type);
- package Inv_SIO is new Ada.Storage_IO (Investment_Account_Type);
- package Chk_SIO is new Ada.Storage_IO (Checking_Account_Type);
- package Sav_SIO is new Ada.Storage_IO (Savings_Account_Type);
-
- -- Direct_IO is instantiated for the buffer types defined in the
- -- instantiated Storage_IO packages.
-
- package Acct_DIO is new Ada.Direct_IO (Acct_SIO.Buffer_Type);
- package Cash_DIO is new Ada.Direct_IO (Cash_SIO.Buffer_Type);
- package Inv_DIO is new Ada.Direct_IO (Inv_SIO.Buffer_Type);
- package Chk_DIO is new Ada.Direct_IO (Chk_SIO.Buffer_Type);
- package Sav_DIO is new Ada.Direct_IO (Sav_SIO.Buffer_Type);
-
- Acct_Buffer : Acct_SIO.Buffer_Type;
- Cash_Buffer : Cash_SIO.Buffer_Type;
- Inv_Buffer : Inv_SIO.Buffer_Type;
- Chk_Buffer : Chk_SIO.Buffer_Type;
- Sav_Buffer : Sav_SIO.Buffer_Type;
-
- Acct_File : Acct_DIO.File_Type;
- Cash_File : Cash_DIO.File_Type;
- Inv_File : Inv_DIO.File_Type;
- Chk_File : Chk_DIO.File_Type;
- Sav_File : Sav_DIO.File_Type;
-
- begin
-
- Acct_DIO.Create (Acct_File, Acct_DIO.Out_File, Acct_Filename);
- Cash_DIO.Create (Cash_File, Cash_DIO.Out_File, Cash_Filename);
- Inv_DIO.Create (Inv_File, Inv_DIO.Out_File, Inv_Filename);
- Chk_DIO.Create (Chk_File, Chk_DIO.Out_File, Chk_Filename);
- Sav_DIO.Create (Sav_File, Sav_DIO.Out_File, Sav_Filename);
-
- -- Store the tag values of the objects declared above for
- -- comparison with tag values of objects following processing.
-
- TC_Account_Type_Tag :=
- new String'(Ada.Tags.External_Tag(Account_Type'Tag));
-
- TC_Cash_Account_Type_Tag :=
- new String'(Ada.Tags.External_Tag(Cash_Account_Type'Tag));
-
- TC_Investment_Account_Type_Tag :=
- new String'(Ada.Tags.External_Tag(Investment_Account_Type'Tag));
-
- TC_Checking_Account_Type_Tag :=
- new String'(Ada.Tags.External_Tag(Checking_Account_Type'Tag));
-
- TC_Savings_Account_Type_Tag :=
- new String'(Ada.Tags.External_Tag(Savings_Account_Type'Tag));
-
- -- Prepare tagged data for writing to the Direct_IO files using
- -- Storage_IO procedure to place data in buffers.
-
- Acct_SIO.Write (Buffer => Acct_Buffer, Item => Account);
- Cash_SIO.Write (Cash_Buffer, Cash_Account);
- Inv_SIO.Write (Inv_Buffer, Item => Investment_Account);
- Chk_SIO.Write (Buffer => Chk_Buffer, Item => Checking_Account);
- Sav_SIO.Write (Sav_Buffer, Savings_Account);
-
- -- At this point, the data and associated tag values have been
- -- buffered by the Storage_IO procedure, and the buffered data
- -- can be written to the appropriate Direct_IO file.
-
- Acct_DIO.Write (File => Acct_File, Item => Acct_Buffer);
- Cash_DIO.Write (Cash_File, Cash_Buffer);
- Inv_DIO.Write (Inv_File, Item => Inv_Buffer);
- Chk_DIO.Write (File => Chk_File, Item =>Chk_Buffer);
- Sav_DIO.Write (Sav_File, Sav_Buffer);
-
- -- Close all Direct_IO files.
-
- Acct_DIO.Close (Acct_File);
- Cash_DIO.Close (Cash_File);
- Inv_DIO.Close (Inv_File);
- Chk_DIO.Close (Chk_File);
- Sav_DIO.Close (Sav_File);
-
- exception
- when others => Report.Failed("Exception raised in Buffer_Data");
- end Buffer_Data;
-
- procedure Read_Data is
-
- Account : Account_Type;
- Cash_Account : Cash_Account_Type;
- Investment_Account : Investment_Account_Type;
- Checking_Account : Checking_Account_Type;
- Savings_Account : Savings_Account_Type;
-
- -- Storage_IO is instantiated for each of the specific tagged
- -- type.
-
- package Acct_SIO is new Ada.Storage_IO (Account_Type);
- package Cash_SIO is new Ada.Storage_IO (Cash_Account_Type);
- package Inv_SIO is new Ada.Storage_IO (Investment_Account_Type);
- package Chk_SIO is new Ada.Storage_IO (Checking_Account_Type);
- package Sav_SIO is new Ada.Storage_IO (Savings_Account_Type);
-
- -- Direct_IO is instantiated for the buffer types defined in the
- -- instantiated Storage_IO packages.
-
- package Acct_DIO is new Ada.Direct_IO (Acct_SIO.Buffer_Type);
- package Cash_DIO is new Ada.Direct_IO (Cash_SIO.Buffer_Type);
- package Inv_DIO is new Ada.Direct_IO (Inv_SIO.Buffer_Type);
- package Chk_DIO is new Ada.Direct_IO (Chk_SIO.Buffer_Type);
- package Sav_DIO is new Ada.Direct_IO (Sav_SIO.Buffer_Type);
-
- Acct_Buffer : Acct_SIO.Buffer_Type;
- Cash_Buffer : Cash_SIO.Buffer_Type;
- Inv_Buffer : Inv_SIO.Buffer_Type;
- Chk_Buffer : Chk_SIO.Buffer_Type;
- Sav_Buffer : Sav_SIO.Buffer_Type;
-
- Acct_File : Acct_DIO.File_Type;
- Cash_File : Cash_DIO.File_Type;
- Inv_File : Inv_DIO.File_Type;
- Chk_File : Chk_DIO.File_Type;
- Sav_File : Sav_DIO.File_Type;
-
- begin
-
- -- Open the Direct_IO files.
-
- Acct_DIO.Open (Acct_File, Acct_DIO.In_File, Acct_Filename);
- Cash_DIO.Open (Cash_File, Cash_DIO.In_File, Cash_Filename);
- Inv_DIO.Open (Inv_File, Inv_DIO.In_File, Inv_Filename);
- Chk_DIO.Open (Chk_File, Chk_DIO.In_File, Chk_Filename);
- Sav_DIO.Open (Sav_File, Sav_DIO.In_File, Sav_Filename);
-
- -- Read the buffer data from the files using Direct_IO.
-
- Acct_DIO.Read (File => Acct_File, Item => Acct_Buffer);
- Cash_DIO.Read (Cash_File, Cash_Buffer);
- Inv_DIO.Read (Inv_File, Item => Inv_Buffer);
- Chk_DIO.Read (File => Chk_File, Item =>Chk_Buffer);
- Sav_DIO.Read (Sav_File, Sav_Buffer);
-
- -- At this point, the data and associated tag values are stored
- -- in buffers. Use the Storage_IO procedure Read to recreate the
- -- tagged objects from the buffers.
-
- Acct_SIO.Read (Buffer => Acct_Buffer, Item => Account);
- Cash_SIO.Read (Cash_Buffer, Cash_Account);
- Inv_SIO.Read (Inv_Buffer, Item => Investment_Account);
- Chk_SIO.Read (Buffer => Chk_Buffer, Item => Checking_Account);
- Sav_SIO.Read (Sav_Buffer, Savings_Account);
-
- -- Delete all Direct_IO files.
-
- Acct_DIO.Delete (Acct_File);
- Cash_DIO.Delete (Cash_File);
- Inv_DIO.Delete (Inv_File);
- Chk_DIO.Delete (Chk_File);
- Sav_DIO.Delete (Sav_File);
-
- Data_Verification_Block:
- begin
-
- if Account /= TC_Account then
- Report.Failed("Incorrect Account object reconstructed");
- end if;
-
- if Cash_Account /= TC_Cash_Account then
- Report.Failed
- ("Incorrect Cash_Account object reconstructed");
- end if;
-
- if Investment_Account /= TC_Investment_Account then
- Report.Failed
- ("Incorrect Investment_Account object reconstructed");
- end if;
-
- if Checking_Account /= TC_Checking_Account then
- Report.Failed
- ("Incorrect Checking_Account object reconstructed");
- end if;
-
- if Savings_Account /= TC_Savings_Account then
- Report.Failed
- ("Incorrect Savings_Account object reconstructed");
- end if;
-
- exception
- when others =>
- Report.Failed
- ("Exception raised during Data_Verification Block");
- end Data_Verification_Block;
-
-
- -- To ensure that the tags of the values reconstructed by
- -- Storage_IO were properly preserved, object tag values following
- -- object reconstruction are compared with tag values of objects
- -- stored prior to processing.
-
- Tag_Verification_Block:
- begin
-
- if TC_Account_Type_Tag.all /=
- Ada.Tags.External_Tag(Account_Type'Class(Account)'Tag)
- then
- Report.Failed("Incorrect Account tag");
- end if;
-
- if TC_Cash_Account_Type_Tag.all /=
- Ada.Tags.External_Tag(
- Cash_Account_Type'Class(Cash_Account)'Tag)
- then
- Report.Failed("Incorrect Cash_Account tag");
- end if;
-
- if TC_Investment_Account_Type_Tag.all /=
- Ada.Tags.External_Tag(
- Investment_Account_Type'Class(Investment_Account)'Tag)
- then
- Report.Failed("Incorrect Investment_Account tag");
- end if;
-
- if TC_Checking_Account_Type_Tag.all /=
- Ada.Tags.External_Tag(
- Checking_Account_Type'Class(Checking_Account)'Tag)
- then
- Report.Failed("Incorrect Checking_Account tag");
- end if;
-
- if TC_Savings_Account_Type_Tag.all /=
- Ada.Tags.External_Tag(
- Savings_Account_Type'Class(Savings_Account)'Tag)
- then
- Report.Failed("Incorrect Savings_Account tag");
- end if;
-
- exception
- when others =>
- Report.Failed ("Exception raised during tag evaluation");
- end Tag_Verification_Block;
-
- exception
- when others => Report.Failed ("Exception in Read_Data");
- end Read_Data;
-
- begin -- Test_Block
-
- -- Enter the data into the appropriate files.
- Buffer_Data;
-
- -- Reconstruct the data from files, and verify the results.
- Read_Data;
-
- exception
- when others => Report.Failed ("Exception raised in Test_Block");
- end Test_Block;
-
- Report.Result;
-
-exception
- when Incomplete =>
- Report.Result;
- when others =>
- Report.Failed ( "Unexpected exception" );
- Report.Result;
-
-end CXA9002;
diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxaa001.a b/gcc/testsuite/ada/acats/tests/cxa/cxaa001.a
deleted file mode 100644
index 6c2af987009..00000000000
--- a/gcc/testsuite/ada/acats/tests/cxa/cxaa001.a
+++ /dev/null
@@ -1,279 +0,0 @@
--- CXAA001.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that the Line_Length and Page_Length maximums for a Text_IO
--- file of mode Append_File are initially zero (unbounded) after a
--- Create, Open, or Reset, and that these values can be modified using
--- the procedures Set_Line_Length and Set_Page_Length.
--- Check that setting the Line_Length and Page_Length attributes to zero
--- results in an unbounded Text_IO file.
--- Check that setting the line length when in Append_Mode doesn't
--- change the length of lines previously written to the Text_IO file.
---
--- TEST DESCRIPTION:
--- This test attempts to simulate a possible text processing environment.
--- String values, from a number of different string types, are written to
--- a Text_IO file. Prior to the writing of each, the line length is set
--- to the particular length of the data being written. In addition, the
--- default line and page lengths are checked, to determine whether they
--- are unbounded (length = 0) following a create, reset, or open of a
--- Text_IO file with mode Append_File.
---
--- APPLICABILITY CRITERIA:
--- This test is applicable only to implementations that support text
--- files.
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 27 Feb 97 PWB.CTA Allowed for non-support of some IO operations
---!
-
-with Ada.Text_IO;
-with Report;
-
-procedure CXAA001 is
- use Ada;
- Data_File : Text_IO.File_Type;
- Data_Filename : constant String :=
- Report.Legal_File_Name ( Nam => "CXAA001" );
- Incomplete : exception;
-begin
-
- Report.Test ("CXAA001","Check that the Line_Length and Page_Length " &
- "maximums for a Text_IO file of mode Append_File " &
- "are initially zero (unbounded) after a Create, " &
- "Open, or Reset, and that these values can be " &
- "modified using the procedures Set_Line_Length " &
- "and Set_Page_Length");
-
- Test_for_Text_IO_Support:
- begin
-
- -- An implementation that does not support Text_IO in a particular
- -- environment will raise Use_Error on calls to various
- -- Text_IO operations. This block statement encloses a call to
- -- Create, which should raise an exception in a non-supportive
- -- environment. This exception will be handled to produce a
- -- Not_Applicable result.
-
- Text_IO.Create (File => Data_File,
- Mode => Text_IO.Append_File,
- Name => Data_Filename);
-
- exception
-
- when Text_IO.Use_Error | Text_IO.Name_Error =>
- Report.Not_Applicable
- ( "Files not supported - Create as Append_File for Text_IO" );
- raise Incomplete;
-
- end Test_for_Text_IO_Support;
-
- Operational_Test_Block:
- declare
-
- subtype Confidential_Data_Type is string (1 .. 10);
- subtype Secret_Data_Type is string (1 .. 20);
- subtype Top_Secret_Data_Type is string (1 .. 30);
-
- Zero : constant Text_IO.Count := 0;
- Confidential_Data_Size : constant Text_IO.Count := 10;
- Secret_Data_Size : constant Text_IO.Count := 20;
- Top_Secret_Data_Size : constant Text_IO.Count := 30;
-
- -- The following generic procedure is designed to simulate a text
- -- processing environment where line and page sizes are set and
- -- verified prior to the writing of data to a file.
-
- generic
- Data_Size : Text_IO.Count;
- procedure Write_Data_To_File (Data_Item : in String);
-
- procedure Write_Data_To_File (Data_Item : in String) is
- use Text_IO; -- Used to provide visibility to the "/=" operator.
- begin
- if (Text_IO.Line_Length (Data_File) /= Zero) then -- Check default
- Report.Failed("Line not of unbounded length"); -- line length,
- elsif (Text_IO.Page_Length (Data_File) /= Zero) then -- default
- Report.Failed ("Page not of unbounded length"); -- page length.
- end if;
-
- Text_IO.Set_Line_Length (File => Data_File, -- Set the line
- To => Data_Size); -- length.
- Text_IO.Set_Page_Length (File => Data_File, -- Set the page
- To => Data_Size); -- length.
- -- Verify the lengths set.
- if (Integer(Text_IO.Line_Length (Data_File)) /=
- Report.Ident_Int(Integer(Data_Size))) then
- Report.Failed ("Line length not set to appropriate length");
- elsif (Integer(Text_IO.Page_Length (Data_File)) /=
- Report.Ident_Int(Integer(Data_Size))) then
- Report.Failed ("Page length not set to appropriate length");
- end if;
-
- Text_IO.Put_Line (File => Data_File, -- Write data to
- Item => Data_Item); -- file.
-
- end Write_Data_To_File;
-
- -- Instantiation for the three data types/sizes.
-
- procedure Write_Confidential_Data is
- new Write_Data_To_File (Data_Size => Confidential_Data_Size);
-
- procedure Write_Secret_Data is
- new Write_Data_To_File (Data_Size => Secret_Data_Size);
-
- procedure Write_Top_Secret_Data is
- new Write_Data_To_File (Data_Size => Top_Secret_Data_Size);
-
- Confidential_Item : Confidential_Data_Type := "Confidenti";
- Secret_Item : Secret_Data_Type := "Secret Data Values ";
- Top_Secret_Item : Top_Secret_Data_Type :=
- "Extremely Top Secret Data ";
-
- begin
-
- -- The following call simulates processing occurring after the create
- -- of a Text_IO file with mode Append_File.
-
- Write_Confidential_Data (Confidential_Item);
-
- -- The following call simulates processing occurring after the reset
- -- of a Text_IO file with mode Append_File.
-
- Reset1:
- begin
- Text_IO.Reset (Data_File, Text_IO.Append_File); -- Reset to
- -- Append_File mode.
- exception
- when Text_IO.Use_Error =>
- Report.Not_Applicable
- ( "Reset to Append_File not supported for Text_IO" );
- raise Incomplete;
- end Reset1;
-
- Write_Secret_Data (Data_Item => Secret_Item);
-
- Text_IO.Close (Data_File); -- Close file.
-
- -- The following processing simulates processing occurring after the
- -- opening of an existing file with mode Append_File.
-
- Text_IO.Open (Data_File, -- Open file in
- Text_IO.Append_File, -- Append_File mode.
- Data_Filename);
-
- Write_Top_Secret_Data (Top_Secret_Item);
-
- Test_Verification_Block:
- declare
- TC_String1,
- TC_String2,
- TC_String3 : String (1..80) := (others => ' ');
- TC_Length1,
- TC_Length2,
- TC_Length3 : Natural := 0;
- begin
-
- Reset2:
- begin
- Text_IO.Reset (Data_File, Text_IO.In_File); -- Reset for reading.
- exception
- when Text_IO.Use_Error =>
- Report.Not_Applicable
- ( "Reset to In_File not supported for Text_IO" );
- raise Incomplete;
- end Reset2;
-
- Text_IO.Get_Line (Data_File, TC_String1, TC_Length1);
- Text_IO.Get_Line (Data_File, TC_String2, TC_Length2);
- Text_IO.Get_Line (Data_File, TC_String3, TC_Length3);
-
- -- Verify that the line lengths of each line were accurate.
- -- Note: Each data line was written to the file after the
- -- particular line length had been set (to the data length).
-
- if not ((TC_Length1 = Natural(Confidential_Data_Size)) and
- (TC_Length2 = Natural(Secret_Data_Size)) and
- (TC_Length3 = Natural(Top_Secret_Data_Size))) then
- Report.Failed ("Inaccurate line lengths read from file");
- end if;
-
- -- Verify that the data read from the file are accurate.
-
- if (TC_String1(1..TC_Length1) /= Confidential_Item) or else
- (TC_String2(1..TC_Length2) /= Secret_Item) or else
- (TC_String3(1..TC_Length3) /= Top_Secret_Item) then
- Report.Failed ("Corrupted data items read from file");
- end if;
-
- exception
-
- when Incomplete =>
- raise;
-
- when others =>
- Report.Failed ("Error raised during data verification");
-
- end Test_Verification_Block;
-
- exception
-
- when Incomplete =>
- raise;
-
- when others =>
- Report.Failed ("Exception raised during Text_IO processing");
-
- end Operational_Test_Block;
-
- Deletion:
- begin
- -- Check that the file is open prior to deleting it.
- if Text_IO.Is_Open(Data_File) then
- Text_IO.Delete(Data_File);
- else
- Text_IO.Open(Data_File, Text_IO.In_File, Data_Filename);
- Text_IO.Delete(Data_File);
- end if;
- exception
- when others =>
- Report.Failed
- ( "Delete not properly implemented for Text_IO" );
- end Deletion;
-
- Report.Result;
-
-exception
- when Incomplete =>
- Report.Result;
- when others =>
- Report.Failed ( "Unexpected exception" );
- Report.Result;
-
-end CXAA001;
diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxaa002.a b/gcc/testsuite/ada/acats/tests/cxa/cxaa002.a
deleted file mode 100644
index 953d33f1d44..00000000000
--- a/gcc/testsuite/ada/acats/tests/cxa/cxaa002.a
+++ /dev/null
@@ -1,257 +0,0 @@
--- CXAA002.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that the procedures New_Page, Set_Line, Set_Col, and New_Line
--- subprograms perform properly on a text file created with mode
--- Append_File.
--- Check that the attributes Page, Line, and Column are all set to 1
--- following the creation of a text file with mode Append_File.
--- Check that the functions Page, Line, and Col perform properly on a
--- text file created with mode Append_File.
--- Check that the procedures Put and Put_Line perform properly on text
--- files created with mode Append_File.
--- Check that the procedure Set_Line sets the current line number to
--- the value specified by the parameter "To" for text files created with
--- mode Append_File.
--- Check that the procedure Set_Col sets the current column number to
--- the value specified by the parameter "To" for text files created with
--- mode Append_File.
---
--- TEST DESCRIPTION:
--- This test is designed to simulate the text processing that could
--- occur with files that have been created in Append_File mode. Various
--- calls to Text_IO formatting subprograms are called to properly
--- position text appended to a document. The text content and position
--- are subsequently verified for accuracy.
---
--- APPLICABILITY CRITERIA:
--- This test is applicable only to implementations that support text
--- files.
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 27 Feb 97 PWB.CTA Allowed for non-support of some IO operations
-
---!
-
-with Ada.Text_IO;
-with Report;
-
-procedure CXAA002 is
- use Ada;
- Data_File : Text_IO.File_Type;
- Data_Filename : constant String :=
- Report.Legal_File_Name ( Nam => "CXAA002" );
- Incomplete : exception;
-begin
-
- Report.Test ("CXAA002", "Check that page, line, and column formatting " &
- "subprograms perform properly on text files " &
- "created with mode Append_File");
-
- Test_for_Text_IO_Support:
- begin
-
- -- An implementation that does not support Text_IO in a particular
- -- environment will raise Use_Error on calls to various
- -- Text_IO operations. This block statement encloses a call to
- -- Create, which should raise the exception in a non-supportive
- -- environment. This exception will be handled to produce a
- -- Not_Applicable result.
-
- Text_IO.Create (File => Data_File,
- Mode => Text_IO.Append_File,
- Name => Data_Filename);
-
- exception
-
- when Text_IO.Use_Error | Text_IO.Name_Error =>
- Report.Not_Applicable
- ( "Files not supported - Create as Append_File for Text_IO" );
- raise Incomplete;
-
- end Test_for_Text_IO_Support;
-
- Operational_Test_Block:
- declare
- Default_Position : constant Text_IO.Positive_Count := 1;
- Section_Header : constant String := "VII. ";
- Appendix_Title : constant String := "Appendix A";
- Appendix_Content : constant String := "TBD";
-
- -- The following procedure simulates the addition of an Appendix page
- -- to an existing text file.
- procedure Position_Appendix_Text is
- use Text_IO; -- To provide visibility to the "/=" operator.
- begin
-
- -- Test control code.
- -- Verify initial page, line, column number.
- if "/="(Text_IO.Page (Data_File), Default_Position) then
- Report.Failed ("Incorrect default page number");
- end if;
- if Text_IO.Line (Data_File) /= Default_Position then
- Report.Failed ("Incorrect default line number");
- end if;
- if "/="(Text_IO.Col (Data_File), Default_Position) then
- Report.Failed ("Incorrect default column number");
- end if;
-
- -- Simulated usage code.
- -- Set new page/line positions.
- Text_IO.Put_Line
- (Data_File, "Add some optional data to the file here");
- Text_IO.New_Page (Data_File);
- Text_IO.New_Line (File => Data_File, Spacing => 2);
-
- -- Test control code.
- if Integer(Text_IO.Page (Data_File)) /= Report.Ident_Int(2) or else
- Integer(Text_IO.Line (Data_File)) /= Report.Ident_Int(3) then
- Report.Failed ("Incorrect results from page/line positioning");
- end if;
-
- -- Simulated usage code.
- Text_IO.Put (Data_File, Section_Header); -- Position title
- Text_IO.Put_Line (Data_File, Appendix_Title); -- of Appendix.
-
- Text_IO.Set_Line (File => Data_File, To => 5); -- Set new
- Text_IO.Set_Col (File => Data_File, To => 8); -- position.
-
- -- Test control code.
- if (Integer(Text_IO.Line (Data_File)) /= Report.Ident_Int(5)) or
- (Integer(Text_IO.Col (Data_File)) /= Report.Ident_Int(8)) then
- Report.Failed ("Incorrect results from line/column positioning");
- end if;
-
- -- Simulated usage code. -- Position
- Text_IO.Put_Line (Data_File, Appendix_Content); -- content of
- -- Appendix.
- end Position_Appendix_Text;
-
- begin
-
- -- This code section simulates a scenario that could occur in a
- -- text processing environment:
- -- A document is created/modified/edited Then...
- -- Text is to be appended to the document.
- -- A procedure is called to perform that operation.
- -- The position on the appended page is set, verified, and text is
- -- appended to the existing file.
- --
- -- Note: The text file has been originally created in Append_File
- -- mode, and has not been closed prior to this processing.
-
- Position_Appendix_Text;
-
- Test_Verification_Block:
- declare
- TC_Page,
- TC_Line,
- TC_Column : Text_IO.Positive_Count;
- TC_Position : Natural := 0;
- Blanks : constant String := " ";
- TC_String : String (1 .. 17) := Blanks;
- begin
-
- Reset1:
- begin
- Text_IO.Reset (Data_File, Text_IO.In_File);
- exception
- when Text_IO.Use_Error =>
- Report.Not_Applicable
- ( "Reset to In_File not supported for Text_IO" );
- raise Incomplete;
- end Reset1;
-
- Text_IO.Skip_Page (Data_File);
- -- Loop to the third line
- for I in 1 .. 3 loop -- and read the contents.
- Text_IO.Get_Line (Data_File, TC_String, TC_Position);
- end loop;
-
- if (TC_Position /= 16) or else -- Verify the title line.
- (TC_String (1..4) /= "VII.") or else
- (TC_String (3..16) /= ("I. " & Appendix_Title)) then
- Report.Failed ("Incorrect positioning of title line");
- end if;
-
- TC_String := Blanks; -- Clear string.
- -- Loop to the fifth line
- for I in 4 .. 5 loop -- and read the contents.
- Text_IO.Get_Line (Data_File, TC_String, TC_Position);
- end loop;
-
- if (TC_Position /= 10) or -- Verify the contents.
- (TC_String (8..10) /= Appendix_Content) then
- Report.Failed ("Incorrect positioning of contents line");
- end if;
-
- exception
-
- when Incomplete =>
- raise;
-
- when others =>
- Report.Failed ("Error raised during data verification");
-
- end Test_Verification_Block;
-
- exception
-
- when Incomplete =>
- raise;
-
- when others =>
- Report.Failed ("Exception raised during Text_IO processing");
-
- end Operational_Test_Block;
-
- Deletion:
- begin
- -- Delete the external file.
- if Text_IO.Is_Open(Data_File) then
- Text_IO.Delete(Data_File);
- else
- Text_IO.Open(Data_File, Text_IO.In_File, Data_Filename);
- Text_IO.Delete(Data_File);
- end if;
- exception
- when others =>
- Report.Failed
- ( "Delete not properly implemented for Text_IO" );
- end Deletion;
-
- Report.Result;
-
-exception
- when Incomplete =>
- Report.Result;
- when others =>
- Report.Failed ( "Unexpected exception" );
- Report.Result;
-
-end CXAA002;
diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxaa003.a b/gcc/testsuite/ada/acats/tests/cxa/cxaa003.a
deleted file mode 100644
index c9580dfb343..00000000000
--- a/gcc/testsuite/ada/acats/tests/cxa/cxaa003.a
+++ /dev/null
@@ -1,293 +0,0 @@
--- CXAA003.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that the procedures New_Page, Set_Line, Set_Col, and New_Line
--- subprograms perform properly on a text file reset (from Out_File)
--- with mode Append_File.
--- Check that the attributes Page, Line, and Column are all set to 1
--- following the reset of a text file with mode Append_File.
--- Check that the functions Page, Line, and Col perform properly on a
--- text file reset with mode Append_File.
--- Check that the procedures Put and Put_Line perform properly on text
--- files reset with mode Append_File.
--- Check that the procedure Set_Line sets the current line number to
--- the value specified by the parameter "To" for text files reset with
--- mode Append_File. Check that Set_Line has no effect if the specified
--- line equals the current line.
--- Check that the procedure Set_Col sets the current column number to
--- the value specified by the parameter "To" for text files reset with
--- mode Append_File.
---
--- TEST DESCRIPTION:
--- This test is designed to simulate the text processing that could
--- occur with files that have been created in Out_File mode,
--- and then reset to Append_File mode.
--- Various calls to Text_IO formatting subprograms are called to properly
--- position text appended to a document. The text content and position
--- are subsequently verified for accuracy.
---
--- APPLICABILITY CRITERIA:
--- This test is applicable only to implementations that support text
--- files.
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 24 Feb 97 PWB.CTA Allowed for non-support of some IO operations.
---!
-
-with Ada.Text_IO;
-with Report;
-
-procedure CXAA003 is
- use Ada;
- Data_File : Text_IO.File_Type;
- Data_Filename : constant String :=
- Report.Legal_File_Name ( Nam => "CXAA003" );
- Incomplete : exception;
-
-begin
-
- Report.Test ("CXAA003", "Check that page, line, and column formatting " &
- "subprograms perform properly on text files " &
- "reset with mode Append_File");
-
- Test_for_Text_IO_Support:
- begin
-
- -- An implementation that does not support Text_IO in a particular
- -- environment will raise Use_Error on calls to various
- -- Text_IO operations. This block statement encloses a call to
- -- Create, which should raise the exception in a non-supportive
- -- environment. This exception will be handled to produce a
- -- Not_Applicable result.
-
- Text_IO.Create (File => Data_File,
- Mode => Text_IO.Out_File,
- Name => Data_Filename);
- exception
- when Text_IO.Use_Error | Text_IO.Name_Error =>
- Report.Not_Applicable
- ( "Text files not supported - Create as Out_File" );
- raise Incomplete;
- end Test_for_Text_IO_Support;
-
- Operational_Test_Block:
- declare
-
- Default_Position : constant Text_IO.Positive_Count := 1;
-
- Section_Header : constant String := "IX. ";
- Glossary_Title : constant String := "GLOSSARY";
- Glossary_Content : constant String := "TBD";
-
- -- The following procedure simulates the addition of a Glossary page
- -- to an existing text file that has been reset with mode
- -- Append_File.
-
- procedure Position_Glossary_Text
- (The_File : in out Text_IO.File_Type) is
- use Text_IO; -- To provide visibility to the "/=" operator.
- begin
-
- -- Test control code.
- -- Verify initial page value.
- if (Text_IO.Page (The_File) /= Default_Position) then
- Report.Failed ("Incorrect default page number");
- end if;
- -- Verify initial line number.
- if (Text_IO.Line (The_File) /= Default_Position) then
- Report.Failed ("Incorrect default line number");
- end if;
- -- Verify initial column number.
- if (Text_IO.Col (The_File) /= Default_Position) then
- Report.Failed ("Incorrect default column number");
- end if;
- -- Simulated usage code. Set new page/line positions.
- Text_IO.New_Page (The_File);
- Text_IO.New_Page (The_File);
- Text_IO.New_Line (File => The_File, Spacing => 1);
-
- -- Test control code.
- if (Integer(Text_IO.Page(The_File)) /=
- Report.Ident_Int(3)) or else
- (Integer(Text_IO.Line (The_File)) /=
- Report.Ident_Int(2)) then
- Report.Failed ("Incorrect results from page/line positioning");
- end if;
-
- -- Simulated usage code. Position title of Glossary.
- Text_IO.Put (The_File, Section_Header);
- Text_IO.Put_Line (The_File, Glossary_Title);
- -- Set line to the current line.
- Text_IO.Set_Line (File => The_File, To => 3);
-
- -- Test control code.
- if (Integer(Text_IO.Page (The_File)) /= Report.Ident_Int(3)) or
- (Integer(Text_IO.Line (The_File)) /= Report.Ident_Int(3)) or
- (Integer(Text_IO.Col (The_File)) /= Report.Ident_Int(1)) then
- Report.Failed ("Set_Line failed for current line");
- end if;
-
- -- Simulated usage code.
- Text_IO.Set_Line (File => The_File, To => 4); -- Set new
- Text_IO.Set_Col (File => The_File, To => 10); -- position.
-
- -- Test control code.
- if (Integer(Text_IO.Line (The_File)) /= Report.Ident_Int(4)) or
- (Integer(Text_IO.Col (The_File)) /= Report.Ident_Int(10)) then
- Report.Failed
- ("Incorrect results from line/column positioning");
- end if;
-
- -- Simulated usage code. -- Position
- Text_IO.Put_Line (The_File, Glossary_Content); -- content of
- -- Glossary.
- end Position_Glossary_Text;
-
-
- begin
-
- -- In the scenario, data is added to the file here.
- Text_IO.Put_Line (File => Data_File, Item => "Some optional data");
-
- -- This code section simulates a scenario that could occur in a
- -- text processing environment. Text is to be appended to an
- -- existing document:
- -- The file is reset to append mode.
- -- A procedure is called to perform the positioning and placement
- -- of text.
- -- The position on the appended page is set, verified, and text is
- -- placed in the file.
- --
- -- Note: The text file has been originally created in Out_File
- -- mode, and has subsequently been reset to Append_File mode.
-
- Reset1:
- begin
- -- Reset has effect of calling New_Page.
- Text_IO.Reset (Data_File, Text_IO.Append_File);
- exception
- when Text_IO.Use_Error =>
- Report.Not_Applicable
- ( "Reset to Append_File not supported for Text_IO" );
- raise Incomplete;
- end Reset1;
-
- Position_Glossary_Text (The_File => Data_File);
-
- Test_Verification_Block:
- declare
- TC_Page, TC_Line, TC_Column : Text_IO.Positive_Count;
- TC_Position : Natural := 0;
- Blanks : constant String :=
- " ";
- TC_String : String (1 .. 15) := Blanks;
- begin
- Reset2:
- begin
- Text_IO.Reset (Data_File, Text_IO.In_File);
- exception
- when Text_IO.Use_Error =>
- Report.Not_Applicable
- ( "Reset to In_File not supported for Text_IO" );
- raise Incomplete;
- end Reset2;
-
- Text_IO.Skip_Page (Data_File);
- Text_IO.Skip_Page (Data_File);
-
- -- If the Reset to Append_File mode actually put a page terminator
- -- on the file, as allowed (but not required) by RM A.10.2(4), then
- -- we are now on page 3, an empty page. We'll need to skip one more.
-
- if Text_IO.End_Of_Page (Data_File) then
- Text_IO.Skip_Page (Data_File);
- end if;
-
- -- Now we're on the Glossary page.
-
- -- Loop to the second line
- for I in 1 .. 2 loop -- and read the contents.
- Text_IO.Get_Line (Data_File, TC_String, TC_Position);
- end loop;
- if (TC_Position /= 13) or else -- Verify the title line.
- (TC_String (1..2) /= "IX") or else
- (TC_String (3..13) /= (". " & Glossary_Title)) then
- Report.Failed ("Incorrect positioning of title line");
- end if;
-
- TC_String := Blanks; -- Clear string.
- -- Loop to the fourth line
- for I in 3 .. 4 loop -- and read the contents.
- Text_IO.Get_Line (Data_File, TC_String, TC_Position);
- end loop;
-
- if (TC_Position /= 12) or -- Verify the contents.
- (TC_String (8..12) /= " " & Glossary_Content) then
- Report.Failed ("Incorrect positioning of contents line");
- end if;
-
- exception
- when Incomplete =>
- raise;
- when others =>
- Report.Failed ("Error raised during data verification");
-
- end Test_Verification_Block;
-
- exception
- when Incomplete =>
- raise;
- when others =>
- Report.Failed ("Exception raised during Text_IO processing");
-
- end Operational_Test_Block;
-
- Final_Block:
- begin
- -- Delete the external file.
- if Text_IO.Is_Open (Data_File) then
- Text_IO.Delete (Data_File);
- else
- Text_IO.Open (Data_File, Text_IO.In_File, Data_Filename);
- Text_IO.Delete (Data_File);
- end if;
- exception
- when others =>
- Report.Failed ( "Delete not properly implemented for Text_IO" );
- end Final_Block;
-
- Report.Result;
-
- exception
- when Incomplete =>
- Report.Result;
- when others =>
- Report.Failed ( "Unexpected exception" );
- Report.Result;
-
-end CXAA003;
diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxaa004.a b/gcc/testsuite/ada/acats/tests/cxa/cxaa004.a
deleted file mode 100644
index f3ea17ebad3..00000000000
--- a/gcc/testsuite/ada/acats/tests/cxa/cxaa004.a
+++ /dev/null
@@ -1,260 +0,0 @@
--- CXAA004.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that the procedures New_Page, Set_Line, Set_Col, and New_Line
--- perform properly on a text file opened with mode Append_File.
--- Check that the attributes Page, Line, and Column are all set to 1
--- following the opening of a text file with mode Append_File.
--- Check that the functions Page, Line, and Col perform properly on a
--- text file opened with mode Append_File.
--- Check that the procedures Put and Put_Line perform properly on text
--- files opened with mode Append_File.
--- Check that the procedure Set_Line sets the current line number to
--- the value specified by the parameter "To" for text files opened with
--- mode Append_File.
--- Check that the procedure Set_Col sets the current column number to
--- the value specified by the parameter "To" for text files reset with
--- mode Append_File.
---
--- TEST DESCRIPTION:
--- This test is designed to simulate the text processing that could
--- occur with files that have been created in Out_File mode,
--- and then reset to Append_File mode.
--- Various calls to Text_IO formatting subprograms are called to properly
--- position text appended to a document. The text content and position
--- are subsequently verified for accuracy.
---
--- APPLICABILITY CRITERIA:
--- This test is applicable only to implementations that support text
--- files.
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 24 Feb 97 PWB.CTA Allowed for non-support of some IO operations.
---!
-
-with Ada.Text_IO;
-with Report;
-
-procedure CXAA004 is
- use Ada;
- Data_File : Text_IO.File_Type;
- Data_Filename : constant String :=
- Report.Legal_File_Name ( Nam => "CXAA004" );
- Incomplete : exception;
-
-begin
-
- Report.Test ("CXAA004", "Check that page, line, and column formatting " &
- "subprograms perform properly on text files " &
- "opened with mode Append_File");
-
- Test_for_Text_IO_Support:
- begin
-
- -- An implementation that does not support Text_IO in a particular
- -- environment will raise Use_Error on calls to various
- -- Text_IO operations. This block statement encloses a call to
- -- Create, which should raise the exception in a non-supportive
- -- environment. This exception will be handled to produce a
- -- Not_Applicable result.
-
- Text_IO.Create (File => Data_File,
- Mode => Text_IO.Out_File,
- Name => Data_Filename);
-
- exception
- when Text_IO.Use_Error | Text_IO.Name_Error =>
- Report.Not_Applicable
- ( "Files not supported - Create for Text_IO" );
- raise Incomplete;
- end Test_for_Text_IO_Support;
-
- Operational_Test_Block:
- declare
- use Text_IO; -- To provide visibility to the "/=" operator.
-
- Default_Position : constant Text_IO.Positive_Count := 1;
-
- Section_Header : constant String := "X. ";
- Reference_Title : constant String := "REFERENCES";
- Reference_Content : constant String := "Available Upon Request";
-
- begin
-
- -- Some amount of text processing would occur here in the scenario
- -- following file creation, prior to file closure.
- Text_IO.Put_Line (File => Data_File, Item => "Some optional data");
-
- -- Close has the effect of a call to New_Page (adding a page
- -- terminator).
- Text_IO.Close (Data_File);
-
- -- This code section simulates a scenario that could occur in a
- -- text processing environment:
- -- Certain text is to be appended to a document.
- -- The file is opened in Append_File mode.
- -- The position on the appended page is set, verified, and text
- -- is placed in the file.
- --
- -- Note: The text file has been originally created in Out_File
- -- mode, has been subsequently closed and is now being reopened in
- -- Append_File mode for further processing.
-
- Text_IO.Open (Data_File, Text_IO.Append_File, Data_Filename);
-
- -- Test control code.
- if (Text_IO.Page(Data_File) /= Default_Position) then -- Verify init.
- Report.Failed ("Incorrect default page number"); -- page value.
- end if;
- if (Text_IO.Line(Data_File) /= Default_Position) then -- Verify init.
- Report.Failed ("Incorrect default line number"); -- line number.
- end if;
- if (Text_IO.Col (Data_File) /= Default_Position) then -- Verify init.
- Report.Failed ("Incorrect default column number"); -- column no.
- end if;
-
- -- Simulated usage code.
- Text_IO.New_Page (Data_File); -- Set new page/
- Text_IO.New_Line (File => Data_File, Spacing => 2); -- line pos.
- Text_IO.Put (Data_File, Section_Header); -- Position
- Text_IO.Put_Line (Data_File, Reference_Title); -- title.
-
- -- Test control code. -- Verify new
- if (Integer(Text_IO.Page (Data_File)) /= -- page and
- Report.Ident_Int(2)) or else -- line.
- (Integer(Text_IO.Line (Data_File)) /=
- Report.Ident_Int(4)) then
- Report.Failed ("Incorrect results from page/line positioning");
- end if;
-
- -- Simulated usage code.
- Text_IO.Set_Line (File => Data_File, To => 8); -- Set new
- Text_IO.Set_Col (File => Data_File, To => 30); -- position.
- Text_IO.Put_Line (Data_File, Reference_Content);
-
- -- Test control code.
- if (Integer(Text_IO.Line (Data_File)) /=
- Report.Ident_Int(9)) or -- Verify new
- (Integer(Text_IO.Col (Data_File)) /= -- position.
- Report.Ident_Int(1)) then
- Report.Failed ("Incorrect results from line/column positioning");
- end if;
-
- Test_Verification_Block:
- declare
- TC_Page, TC_Line, TC_Column : Text_IO.Positive_Count;
- TC_Position : Natural := 0;
- TC_String : String (1 .. 55) := (others => ' ');
- begin
-
- Reset1:
- begin
- Text_IO.Reset (Data_File, Text_IO.In_File);
- exception
- when Text_IO.Use_Error =>
- Report.Not_Applicable
- ( "Reset to In_File not supported for Text_IO" );
- raise Incomplete;
- end Reset1;
-
- Text_IO.Skip_Page (Data_File);
-
- -- If the Reset to Append_File mode actually put a page terminator
- -- in the file, as allowed (but not required) by RM A.10.2(4), then
- -- we are now on page 2, an empty page. Therefore, we need to skip
- -- one more page.
-
- if Text_IO.End_Of_Page (Data_File) then
- Text_IO.Skip_Page (Data_File);
- end if;
-
- -- Now we're on the reference page.
-
- -- Loop to the third line
- for I in 1 .. 3 loop -- and read the contents.
- Text_IO.Get_Line (Data_File, TC_String, TC_Position);
- end loop;
-
- if (TC_Position /= 14) or else -- Verify the title line.
- (TC_String (1..6) /= "X. RE") or else
- (TC_String (2..14) /= (". " & Reference_Title)) then
- Report.Failed ("Incorrect positioning of title line");
- end if;
- -- Loop to the eighth line
- for I in 4 .. 8 loop -- and read the contents.
- Text_IO.Get_Line (Data_File, TC_String, TC_Position);
- end loop;
-
- if (TC_Position /= 51) or -- Verify the contents.
- (TC_String (30..51) /= "Available Upon Request") then
- Report.Failed ("Incorrect positioning of contents line");
- end if;
-
- exception
-
- when Incomplete =>
- raise;
- when others =>
- Report.Failed ("Error raised during data verification");
-
- end Test_Verification_Block;
-
- exception
-
- when Incomplete =>
- raise;
- when others =>
- Report.Failed ("Exception raised during Text_IO processing");
-
- end Operational_Test_Block;
-
- Final_Block:
- begin
- -- Delete the external file.
- if Text_IO.Is_Open (Data_File) then
- Text_IO.Delete (Data_File);
- else
- Text_IO.Open (Data_File, Text_IO.In_File, Data_Filename);
- Text_IO.Delete (Data_File);
- end if;
- exception
- when others =>
- Report.Failed ( "Delete not properly implemented - Text_IO" );
- end Final_Block;
-
- Report.Result;
-
-exception
-
- when Incomplete =>
- Report.Result;
- when others =>
- Report.Failed ("Unexpected exception");
- Report.Result;
-
-end CXAA004;
diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxaa005.a b/gcc/testsuite/ada/acats/tests/cxa/cxaa005.a
deleted file mode 100644
index 7b2a0bc39d3..00000000000
--- a/gcc/testsuite/ada/acats/tests/cxa/cxaa005.a
+++ /dev/null
@@ -1,292 +0,0 @@
--- CXAA005.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that the procedure Put, when called with string parameters, does
--- not update the line number of a text file of mode Append_File, when
--- the line length is unbounded (i.e., only the column number is
--- updated).
--- Check that a call to the procedure Put with a null string argument
--- has no measurable effect on a text file of mode Append_File.
---
--- TEST DESCRIPTION:
--- This test is designed to ensure that when a string is appended to an
--- unbounded text file, it is placed following the last element currently
--- in the file. For an unbounded text file written with Put procedures
--- only (not Put_Line), the line number should not be incremented by
--- subsequent calls to Put in Append_File mode. Only the column number
--- should be incremented based on the length of the string parameter
--- placed in the file. If a call to Put with a null string argument is
--- made, no change to the line or column number should occur, and no
--- element(s) should be added to the file, so that there would be no
--- measurable change to the file.
---
--- APPLICABILITY CRITERIA:
--- This test is applicable to all implementations that support Text_IO
--- processing and external files.
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 24 Feb 97 CTA.PWB Allowed for non-support of some IO operations.
---!
-
-with Ada.Text_IO;
-with Report;
-
-procedure CXAA005 is
- An_Unbounded_File : Ada.Text_IO.File_Type;
- Unbounded_File_Name : constant String :=
- Report.Legal_File_Name ( Nam => "CXAA005" );
- Incomplete : exception;
-
-begin
-
- Report.Test ("CXAA005", "Check that the procedure Put does not " &
- "increment line numbers when used with " &
- "unbounded text files of mode Append_File");
-
- Test_for_Text_IO_Support:
- begin
-
- -- An application creates a text file in mode Out_File, with the intention
- -- of entering string data packets into the file as appropriate. In the
- -- event that the particular environment where the application is running
- -- does not support Text_IO, Use_Error will be raised on calls to Text_IO
- -- operations.
- -- This exception will be handled to produce a Not_Applicable result.
-
- Ada.Text_IO.Create (File => An_Unbounded_File,
- Mode => Ada.Text_IO.Out_File,
- Name => Unbounded_File_Name);
- exception
- when Ada.Text_IO.Use_Error | Ada.Text_IO.Name_Error =>
- Report.Not_Applicable
- ( "Files not supported - Create for Text_IO" );
- raise Incomplete;
- end Test_For_Text_IO_Support;
-
- Operational_Test_Block:
- declare
- subtype String_Sequence_Type is string (1 .. 20);
- type String_Pointer_Type is access String_Sequence_Type;
-
--- During the course of processing, the application creates a variety of data
--- pointers that refer to particular data items. The possibility of having
--- null data values in this environment exists.
-
- Data_Packet_1 : String_Pointer_Type :=
- new String_Sequence_Type'("One Data Sequence 01");
-
- Data_Packet_2 : String_Pointer_Type :=
- new String_Sequence_Type'("New Data Sequence 02");
-
- Blank_Data_Packet : String_Pointer_Type :=
- new String_Sequence_Type'(" ");
-
- Null_Data_Packet : constant String := "";
-
- TC_Line, TC_Col : Natural := 0;
-
- function TC_Mode_Selection (Selector : Integer)
- return Ada.Text_IO.File_Mode is
- begin
- case Selector is
- when 1 => return Ada.Text_IO.In_File;
- when 2 => return Ada.Text_IO.Out_File;
- when others => return Ada.Text_IO.Append_File;
- end case;
- end TC_Mode_Selection;
-
- begin
-
--- The application places some data into the file, using the Put subroutine.
--- This operation can occur one-to-many times.
-
- Ada.Text_IO.Put (An_Unbounded_File, Data_Packet_1.all);
-
- -- Test control code.
- if (Integer(Ada.Text_IO.Col (An_Unbounded_File)) /=
- Report.Ident_Int(21)) or
- (Integer(Ada.Text_IO.Line (An_Unbounded_File)) /=
- Report.Ident_Int(1)) then
- Report.Failed ("Incorrect Col position after 1st Put");
- end if;
-
--- The application may close the file at some point following its initial
--- entry of data.
-
- Ada.Text_IO.Close (An_Unbounded_File);
-
--- At some later point in the processing, more data needs to be added to the
--- file, so the application opens the file in Append_File mode.
-
- Ada.Text_IO.Open (File => An_Unbounded_File,
- Mode => Ada.Text_IO.Append_File,
- Name => Unbounded_File_Name);
-
- -- Test control code.
- -- Store line/column number for later comparison.
- TC_Line := Natural(Ada.Text_IO.Line(An_Unbounded_File));
- TC_Col := Natural(Ada.Text_IO.Col(An_Unbounded_File));
-
--- Additional data items can then be appended to the file.
-
- Ada.Text_IO.Put (An_Unbounded_File, Blank_Data_Packet.all);
-
- -- Test control code.
- if (Natural(Ada.Text_IO.Col (An_Unbounded_File)) /=
- (TC_Col + 20)) or
- (Natural(Ada.Text_IO.Line (An_Unbounded_File)) /=
- TC_Line) then
- Report.Failed ("Incorrect Col position after 2nd Put");
- end if;
-
--- In order to accommodate various scenarios, the application may have changed
--- the mode of the data file to In_File in order to retrieve/verify some of
--- the data contained there. However, with the need to place more data into
--- the file, the file can be reset to Append_File mode.
-
- Reset1:
- begin
- Ada.Text_IO.Reset (An_Unbounded_File,
- TC_Mode_Selection (Report.Ident_Int(3)));
- exception
- when Ada.Text_IO.Use_Error =>
- Report.Not_Applicable
- ( "Reset to Append_File not supported for Text_IO" );
- raise Incomplete;
- end Reset1;
-
- -- Test control code.
- -- Store line/column number for later comparison.
- TC_Line := Natural(Ada.Text_IO.Line(An_Unbounded_File));
- TC_Col := Natural(Ada.Text_IO.Col(An_Unbounded_File));
-
--- Additional data can then be appended to the file. On some occasions, an
--- attempt to enter a null string value into the file may occur. This should
--- have no effect on the file, leaving it unchanged.
-
- -- No measurable effect from Put with null string.
- Ada.Text_IO.Put (An_Unbounded_File, Null_Data_Packet);
-
- -- Test control code.
- -- There should be no change following the Put above.
- if (Natural(Ada.Text_IO.Col (An_Unbounded_File)) /=
- TC_Col) or
- (Natural(Ada.Text_IO.Line (An_Unbounded_File)) /=
- TC_Line) then
- Report.Failed ("Incorrect Col position after 3rd Put");
- end if;
-
--- Additional data can be appended to the file.
-
- Ada.Text_IO.Put (An_Unbounded_File, Data_Packet_2.all);
-
- -- Test control code.
- if (Natural(Ada.Text_IO.Col (An_Unbounded_File)) /=
- (TC_Col + 20)) or
- (Integer(Ada.Text_IO.Line (An_Unbounded_File)) /=
- TC_Line) then
- Report.Failed ("Incorrect Col position after 4th Put");
- end if;
-
- Test_Verification_Block:
- declare
- File_Data : String (1 .. 80);
- TC_Width : Natural;
- begin
-
--- The application has the capability to reset the file to In_File mode to
--- verify some of the data that is contained there.
-
- Reset2:
- begin
- Ada.Text_IO.Reset (An_Unbounded_File, Ada.Text_IO.In_File);
- exception
- when Ada.Text_IO.Use_Error =>
- Report.Not_Applicable
- ( "Reset to In_File not supported - Text_IO" );
- raise Incomplete;
- end Reset2;
-
- Ada.Text_IO.Get_Line (An_Unbounded_File,
- File_Data,
- TC_Width);
-
- -- Test control code.
- -- Since it is implementation defined whether a page
- -- terminator separates preexisting text from new text
- -- following an open in append mode (as occurred above),
- -- verify only that the first data item written to the
- -- file was not overwritten by any subsequent call to Put.
-
- if (File_Data (File_Data'First) /= 'O') or
- (File_Data (20) /= '1') then
- Report.Failed ("Data placed incorrectly in file");
- end if;
-
- exception
- when Incomplete =>
- raise;
- when others =>
- Report.Failed ("Error raised during data verification");
- end Test_Verification_Block;
-
- exception
- when Incomplete =>
- raise;
- when others =>
- Report.Failed ("Exception in Text_IO processing");
- end Operational_Test_Block;
-
- Final_Block:
- begin
- -- Delete the external file.
- if Ada.Text_IO.Is_Open(An_Unbounded_File) then
- Ada.Text_IO.Delete (An_Unbounded_File);
- else
- Ada.Text_IO.Open(An_Unbounded_File,
- Ada.Text_IO.In_File,
- Unbounded_File_Name);
- Ada.Text_IO.Delete (An_Unbounded_File);
- end if;
- exception
- when others =>
- Report.Failed
- ( "Delete not properly implemented -- Text_IO" );
- end Final_Block;
-
- Report.Result;
-
-exception
-
- when Incomplete =>
- Report.Result;
- when others =>
- Report.Failed ( "Unexpected exception" );
- Report.Result;
-
-end CXAA005;
diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxaa006.a b/gcc/testsuite/ada/acats/tests/cxa/cxaa006.a
deleted file mode 100644
index 518d43b896e..00000000000
--- a/gcc/testsuite/ada/acats/tests/cxa/cxaa006.a
+++ /dev/null
@@ -1,285 +0,0 @@
--- CXAA006.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that for a bounded line length text file of mode Append_File,
--- when the number of characters to be output exceeds the number of
--- columns remaining on the current line, a call to Put will output
--- characters of the string sufficient to fill the remaining columns of
--- the line (up to line length), then output a line terminator, reset the
--- column number, increment the line number, then output the balance of
--- the item.
---
--- Check that the procedure Put does not raise Layout_Error when the
--- number of characters to be output exceeds the line length of a bounded
--- text file of mode Append_File.
---
--- TEST DESCRIPTION:
--- This test demonstrates the situation where an application intends to
--- output variable length string elements to a text file in the most
--- efficient manner possible. This is the case in a typesetting
--- environment where text is compressed and split between lines of a
--- bounded length.
---
--- The procedure Put will break string parameters placed in the file at
--- the point of the line length. Two examples are demonstrated in this
--- test, one being the case where only one column remains on a line, and
--- the other being the case where a larger portion of the line remains
--- unfilled, but still not sufficient to contain the entire output
--- string.
---
--- During the course of the test, the file is reset to Append_File mode,
--- and the bounded line length is modified for different lines of the
--- file.
---
--- APPLICABILITY CRITERIA:
--- This test is applicable to all implementations that support Text_IO
--- processing and external files.
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 25 Feb 97 PWB.CTA Allowed for non-support of some IO operations
---!
-
-with Ada.Text_IO;
-with Report;
-
-procedure CXAA006 is
-
- A_Bounded_File : Ada.Text_IO.File_Type;
- Bounded_File_Name : constant String :=
- Report.Legal_File_Name ( Nam => "CXAA006" );
- Incomplete : exception;
-
-begin
-
- Report.Test ("CXAA006", "Check that procedure Put will correctly " &
- "output string items to a bounded line " &
- "length text file of mode Append_File");
-
- Test_for_Text_IO_Support:
- begin
-
--- An application creates a text file in mode Append_File, with the intention
--- of using the procedure Put to compress variable length string data into the
--- file in the most efficient manner possible.
-
- Ada.Text_IO.Create (File => A_Bounded_File,
- Mode => Ada.Text_IO.Append_File,
- Name => Bounded_File_Name);
- exception
- when Ada.Text_IO.Use_Error | Ada.Text_IO.Name_Error =>
- Report.Not_Applicable
- ( "Files not supported - Create with Append_File for Text_IO" );
- raise Incomplete;
- end Test_For_Text_IO_Support;
-
- Operational_Test_Block:
- declare
- Twelve_Characters : constant String := "12Characters";
- Nineteen_Characters : constant String := "Nineteen_Characters";
- TC_Line : Natural := 0;
-
- function TC_Mode_Selection (Selector : Integer)
- return Ada.Text_IO.File_Mode is
- begin
- case Selector is
- when 1 => return Ada.Text_IO.In_File;
- when 2 => return Ada.Text_IO.Out_File;
- when others => return Ada.Text_IO.Append_File;
- end case;
- end TC_Mode_Selection;
-
- begin
-
--- The application sets the line length of the file to be bound at 20. All
--- lines in this file will be limited to that length.
-
- Ada.Text_IO.Set_Line_Length (A_Bounded_File, 20);
-
- Ada.Text_IO.Put (A_Bounded_File, Nineteen_Characters);
-
- -- Test control code.
- if (Integer(Ada.Text_IO.Line (A_Bounded_File)) /=
- Report.Ident_Int(1)) or
- (Integer(Ada.Text_IO.Col (A_Bounded_File)) /=
- Report.Ident_Int(20)) then
- Report.Failed ("Incorrect position after 1st Put");
- end if;
-
--- The application finds that there is only one column available on the
--- current line, so the next string item to be output must be broken at
--- the appropriate place (following the first character).
-
- Ada.Text_IO.Put (File => A_Bounded_File,
- Item => Twelve_Characters);
-
- -- Test control code.
- if (Integer(Ada.Text_IO.Line (A_Bounded_File)) /=
- Report.Ident_Int(2)) or
- (Integer(Ada.Text_IO.Col (A_Bounded_File)) /=
- Report.Ident_Int(12)) then
- Report.Failed ("Incorrect position after 2nd Put");
- end if;
-
--- The application subsequently modifies the processing, resetting the file
--- at this point to In_File mode in order to verify data that has been written
--- to the file. Following this, the application resets the file to Append_File
--- mode in order to continue the placement of data into the file, but modifies
--- the original bounded line length for subsequent lines to be appended.
-
- -- Reset to Append mode; call outputs page terminator and
- -- resets line length to Unbounded.
- Reset1:
- begin
- Ada.Text_IO.Reset (A_Bounded_File,
- TC_Mode_Selection (Report.Ident_Int(3)));
- exception
- when Ada.Text_IO.Use_Error =>
- Report.Not_Applicable
- ( "Reset to Append_File not supported for Text_IO" );
- raise Incomplete;
- end Reset1;
-
- Ada.Text_IO.Set_Line_Length (A_Bounded_File, 15);
-
- -- Store line number for later comparison.
- TC_Line := Natural(Ada.Text_IO.Line(A_Bounded_File));
-
--- The application finds that fifteen columns are available on the current
--- line but that the string item to be output exceeds this available space.
--- It must be split at the end of the line, and the balance placed on the
--- next file line.
-
- Ada.Text_IO.Put (File => A_Bounded_File,
- Item => Nineteen_Characters);
-
- -- Test control code.
- -- Positioned on new line at col 5.
- if (Natural(Ada.Text_IO.Line (A_Bounded_File)) /=
- (TC_Line + 1)) or
- (Integer(Ada.Text_IO.Col (A_Bounded_File)) /=
- Report.Ident_Int(5)) then
- Report.Failed ("Incorrect position after 3rd Put");
- end if;
-
-
- Test_Verification_Block:
- declare
- First_String : String (1 .. 80);
- Second_String : String (1 .. 80);
- Third_String : String (1 .. 80);
- Fourth_String : String (1 .. 80);
- TC_Width1 : Natural;
- TC_Width2 : Natural;
- TC_Width3 : Natural;
- TC_Width4 : Natural;
- begin
-
--- The application has the capability to reset the file to In_File mode to
--- verify some or all of the data that is contained there.
-
- Reset2:
- begin
- Ada.Text_IO.Reset (A_Bounded_File, Ada.Text_IO.In_File);
- exception
- when others =>
- Report.Not_Applicable
- ( "Reset to In_File not supported for Text_IO" );
- raise Incomplete;
- end Reset2;
-
- Ada.Text_IO.Get_Line
- (A_Bounded_File, First_String, TC_Width1);
- Ada.Text_IO.Get_Line
- (A_Bounded_File, Second_String, TC_Width2);
- Ada.Text_IO.Get_Line
- (A_Bounded_File, Third_String, TC_Width3);
- Ada.Text_IO.Get_Line
- (A_Bounded_File, Fourth_String, TC_Width4);
-
- -- Test control code.
- if (First_String (1..TC_Width1) /= Nineteen_Characters & "1") or
- (Second_String (1..TC_Width2) /= "2Characters") or
- (Third_String (1..TC_Width3) /=
- Nineteen_Characters(1..15)) or
- (Fourth_String (1..TC_Width4) /= "ters")
- then
- Report.Failed ("Data placed incorrectly in file");
- end if;
-
- exception
-
- when Incomplete =>
- raise;
-
- when Ada.Text_IO.End_Error =>
- Report.Failed ("Incorrect number of lines in file");
-
- when others =>
- Report.Failed ("Error raised during data verification");
-
- end Test_Verification_Block;
-
- exception
-
- when Ada.Text_IO.Layout_Error =>
- Report.Failed ("Layout Error raised when positioning text");
-
- when others =>
- Report.Failed ("Exception in Text_IO processing");
-
- end Operational_Test_Block;
-
- Final_Block:
- begin
- -- Delete the external file.
- if Ada.Text_IO.Is_Open(A_Bounded_File) then
- Ada.Text_IO.Delete (A_Bounded_File);
- else
- Ada.Text_IO.Open (A_Bounded_File,
- Ada.Text_IO.In_File,
- Bounded_File_Name);
- Ada.Text_IO.Delete (A_Bounded_File);
- end if;
-
- exception
- when others =>
- Report.Failed
- ( "Delete not properly implemented for Text_IO" );
- end Final_Block;
-
- Report.Result;
-
-exception
-
- when Incomplete =>
- Report.Result;
- when others =>
- Report.Failed ( "Unexpected exception" );
- Report.Result;
-
-end CXAA006;
diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxaa007.a b/gcc/testsuite/ada/acats/tests/cxa/cxaa007.a
deleted file mode 100644
index fe79c2d7a86..00000000000
--- a/gcc/testsuite/ada/acats/tests/cxa/cxaa007.a
+++ /dev/null
@@ -1,263 +0,0 @@
--- CXAA007.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that the capabilities of Text_IO.Integer_IO perform correctly
--- on files of Append_File mode, for instantiations with integer and
--- user-defined subtypes.
--- Check that the formatting parameters available in the package can
--- be used and modified successfully in the storage and retrieval of
--- data.
---
--- TEST DESCRIPTION:
--- This test simulates a receiving department inventory system. Data on
--- items received is entered into an inventory database. This information
--- consists of integer entry number, item number, and bar code.
--- One item is placed into the inventory file immediately following file
--- creation, subsequent items are entered following file opening in
--- Append_File mode. Data items are validated by reading all data from
--- the file and comparing against known values (those used to enter the
--- data originally).
---
--- This test verifies issues of create in Append_File mode, appending to
--- a file previously appended to, opening in Append_File mode, resetting
--- from Append_File mode to In_File mode, as well as a variety of Text_IO
--- and Integer_IO predefined subprograms.
---
--- APPLICABILITY CRITERIA:
--- This test is applicable only to implementations that support text
--- files.
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 25 Feb 97 PWB.CTA Allowed for non-support of some IO operations
---!
-
-with Ada.Text_IO;
-with Report;
-
-procedure CXAA007 is
- use Ada;
-
- Inventory_File : Text_IO.File_Type;
- Inventory_Filename : constant String :=
- Report.Legal_File_Name ( Nam => "CXAA007" );
- Incomplete : exception;
-
-begin
-
- Report.Test ("CXAA007", "Check that the capabilities of " &
- "Text_IO.Integer_IO operate correctly for files " &
- "with mode Append_File");
-
- Test_for_Text_IO_Support:
- begin
-
- -- An implementation that does not support Text_IO in a particular
- -- environment will raise Use_Error on calls to various
- -- Text_IO operations. This block statement encloses a call to
- -- Create, which should raise the exception in a non-supportive
- -- environment. This exception will be handled to produce a
- -- Not_Applicable result.
-
- Text_IO.Create (File => Inventory_File,
- Mode => Text_IO.Append_File,
- Name => Inventory_Filename);
- exception
- when Text_IO.Use_Error | Text_IO.Name_Error =>
- Report.Not_Applicable
- ( "Files not supported - Create with Append_File for Text_IO" );
- raise Incomplete;
- end Test_for_Text_IO_Support;
-
- Operational_Test_Block:
- declare
-
- Max_Entries_Per_Order : constant Natural := 4;
-
- type Bar_Code_Type is range 0 .. 127; -- Values to be stored as base
- -- two numbers in file.
- type Item_Type is record
- Entry_Number : Natural := 0;
- Item_Number : Integer := 0;
- Bar_Code : Bar_Code_Type := 0;
- end record;
-
- type Inventory_Type is
- array (1 .. Max_Entries_Per_Order) of Item_Type;
-
- Inventory_List : Inventory_Type := ((1, 119, 87), -- Items received
- (2, 206, 44), -- this order.
- (3, -25, 126),
- (4, -18, 31));
-
- Daily_Order : constant := 1;
- Entry_Field_Width : constant Natural := 1;
- Item_Base : constant Natural := 16;
- Items_Inventoried : Natural := 1;
- Items_To_Inventory : Natural := 4;
-
- package Entry_IO is new Text_IO.Integer_IO (Natural);
- package Item_IO is new Text_IO.Integer_IO (Integer);
- package Bar_Code_IO is new Text_IO.Integer_IO (Bar_Code_Type);
-
-
- -- The following procedure simulates the addition of inventory item
- -- information into a data file.
-
- procedure Update_Inventory (The_Item : in Item_Type) is
- Spacer : constant String := " ";
- begin
- -- Enter all the incoming data into the inventory file.
- Entry_IO.Put (Inventory_File, The_Item.Entry_Number);
- Text_IO.Put (Inventory_File, Spacer);
- Item_IO.Put (Inventory_File, The_Item.Item_Number);
- Text_IO.Put (Inventory_File, Spacer);
- Bar_Code_IO.Put(File => Inventory_File,
- Item => The_Item.Bar_Code,
- Width => 13,
- Base => 2);
- Text_IO.New_Line(Inventory_File);
- end Update_Inventory;
-
-
- begin
-
- -- This code section simulates a receiving department maintaining a
- -- data file containing information on items that have been ordered
- -- and received.
- --
- -- As new orders are received, the file is opened in Append_File
- -- mode.
- -- Data is taken from the inventory list and entered into the file,
- -- in specific format.
- -- Enter the order into the inventory file. This is item 1 in
- -- the inventory list.
- -- The data entry process can be repeated numerous times as required.
-
- Entry_IO.Put (Inventory_File,
- Inventory_List(Daily_Order).Entry_Number);
- Item_IO.Put (Inventory_File,
- Inventory_List(Daily_Order).Item_Number);
- Bar_Code_IO.Put (File => Inventory_File,
- Item => Inventory_List(Daily_Order).Bar_Code);
- Text_IO.New_Line (Inventory_File);
-
- Text_IO.Close (Inventory_File);
-
-
- Entry_IO.Default_Width := Entry_Field_Width; -- Modify the default
- -- width of Entry_IO.
- Item_IO.Default_Base := Item_Base; -- Modify the default
- -- number base of
- -- Item_IO
- Text_IO.Open (Inventory_File,
- Text_IO.Append_File, -- Open in Append mode.
- Inventory_Filename);
- -- Enter items
- while (Items_Inventoried < Items_To_Inventory) loop -- 2-4 into the
- Items_Inventoried := Items_Inventoried + 1; -- inventory file.
- Update_Inventory (The_Item => Inventory_List (Items_Inventoried));
- end loop;
-
- Test_Verification_Block: -- Read and check
- declare -- all the data
- TC_Entry : Natural; -- values that
- TC_Item : Integer; -- have been
- TC_Bar_Code : Bar_Code_Type; -- entered in the
- TC_Item_Count : Natural := 0; -- data file.
- begin
-
- Reset1:
- begin
- Text_IO.Reset (Inventory_File, Text_IO.In_File); -- Reset for
- -- reading.
- exception
- when Text_IO.Use_Error =>
- Report.Not_Applicable
- ( "Reset to mode In_File not supported for Text_IO" );
- raise Incomplete;
- end Reset1;
-
- while not Text_IO.End_Of_File (Inventory_File) loop
- Entry_IO.Get (Inventory_File, TC_Entry);
- Item_IO.Get (Inventory_File, TC_Item);
- Bar_Code_IO.Get (Inventory_File, TC_Bar_Code);
- Text_IO.Skip_Line (Inventory_File);
- TC_Item_Count := TC_Item_Count + 1;
-
- if (TC_Item /= Inventory_List(TC_Entry).Item_Number) or
- (TC_Bar_Code /= Inventory_List(TC_Entry).Bar_Code) then
- Report.Failed ("Error in integer data read from file");
- end if;
- end loop;
-
- if (TC_Item_Count /= Max_Entries_Per_Order) then
- Report.Failed ("Incorrect number of records read from file");
- end if;
-
- exception
- when Incomplete =>
- raise;
- when others =>
- Report.Failed ("Error raised during data verification");
- end Test_Verification_Block;
-
- exception
- when Incomplete =>
- raise;
- when others =>
- Report.Failed ("Exception in Text_IO.Integer_IO processing");
- end Operational_Test_Block;
-
- Final_Block:
- begin
- -- Delete the external file.
- if Text_IO.Is_Open(Inventory_File) then
- Text_IO.Delete (Inventory_File);
- else
- Text_IO.Open (Inventory_File, Text_IO.In_File, Inventory_Filename);
- Text_IO.Delete (Inventory_File);
- end if;
-
- exception
-
- when others =>
- Report.Failed ( "Delete not properly implemented for Text_IO" );
-
- end Final_Block;
-
- Report.Result;
-
-exception
-
- when Incomplete =>
- Report.Result;
- when others =>
- Report.Failed ( "Unexpected exception" );
- Report.Result;
-
-end CXAA007;
diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxaa008.a b/gcc/testsuite/ada/acats/tests/cxa/cxaa008.a
deleted file mode 100644
index c21d07ea9ac..00000000000
--- a/gcc/testsuite/ada/acats/tests/cxa/cxaa008.a
+++ /dev/null
@@ -1,271 +0,0 @@
--- CXAA008.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that the capabilities provided in instantiations of the
--- Ada.Text_IO.Fixed_IO package operate correctly when the mode of
--- the file is Append_File. Check that Fixed_IO procedures Put and Get
--- properly transfer fixed point data to/from data files that are in
--- Append_File mode. Check that the formatting parameters available in
--- the package can be used and modified successfully in the appending and
--- retrieval of data.
---
--- TEST DESCRIPTION:
--- This test simulates order processing, with data values being written
--- to a file, in a specific format, using Fixed_IO. Validation is done
--- on this process by reading the data values from the file, and
--- comparing them for equality with the values originally written to
--- the file.
---
--- This test verifies issues of create in Append_File mode, appending to
--- a file previously appended to, resetting to Append_File mode,
--- resetting from Append_File mode to In_File mode, as well as a
--- variety of Text_IO and Fixed_IO predefined subprograms.
---
--- APPLICABILITY CRITERIA:
--- This test is applicable only to implementations that support text
--- files.
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 25 Feb 97 PWB.CTA Allowed for non-support of some IO operations
---!
-
-with Ada.Text_IO;
-with Report;
-
-procedure CXAA008 is
- use Ada;
-
- Inventory_File : Text_IO.File_Type;
- Inventory_Filename : constant String :=
- Report.Legal_File_Name ( Nam => "CXAA008" );
- Incomplete : exception;
-
-begin
-
- Report.Test ("CXAA008", "Check that the capabilities of " &
- "Text_IO.Fixed_IO operate correctly for files " &
- "with mode Append_File");
-
- Test_for_Text_IO_Support:
- begin
-
- -- An implementation that does not support Text_IO in a particular
- -- environment will raise Use_Error on calls to various
- -- Text_IO operations. This block statement encloses a call to
- -- Create, which should raise the exception in a non-supportive
- -- environment. This exception will be handled to produce a
- -- Not_Applicable result.
-
- Text_IO.Create (File => Inventory_File,
- Mode => Text_IO.Append_File,
- Name => Inventory_Filename);
-
- exception
- when Text_IO.Use_Error | Text_IO.Name_Error =>
- Report.Not_Applicable
- ( "Files not supported - Create with Append_File for Text_IO" );
- raise Incomplete;
- end Test_For_Text_IO_Support;
-
- Operational_Test_Block:
- declare
-
- Daily_Orders_Received : constant Natural := 4;
-
- type Item_Type is delta 0.1 range 0.0 .. 5000.0;
- type Cost_Type is delta 0.01 range 0.0 .. 10_000.0;
- type Profit_Type is delta 0.01 range -100.0 .. 1000.0;
-
- type Product_Type is record
- Item_Number : Item_Type := 0.0;
- Unit_Cost : Cost_Type := 0.00;
- Percent_Markup : Profit_Type := 0.00;
- end record;
-
- type Inventory_Type is
- array (1 .. Daily_Orders_Received) of Product_Type;
-
- Daily_Inventory : Inventory_Type := (( 1.0, 1.75, 50.00),
- ( 155.0, 20.00, -5.50),
- (3343.5, 2.50, 126.50),
- (4986.0, 180.00, 31.75));
-
- package Item_IO is new Text_IO.Fixed_IO (Item_Type);
- package Cost_IO is new Text_IO.Fixed_IO (Cost_Type);
- package Markup_IO is new Text_IO.Fixed_IO (Profit_Type);
-
-
- function TC_Mode_Selection (Selector : Integer)
- return Text_IO.File_Mode is
- begin
- case Selector is
- when 1 => return Text_IO.In_File;
- when 2 => return Text_IO.Out_File;
- when others => return Text_IO.Append_File;
- end case;
- end TC_Mode_Selection;
-
-
- -- The following function simulates the addition of inventory item
- -- information into a data file. Boolean status of True is returned
- -- if all of the data entry was successful, False otherwise.
-
- function Update_Inventory (The_List : Inventory_Type)
- return Boolean is
- begin
- for I in 1 .. Daily_Orders_Received loop
- Item_IO.Put (Inventory_File, The_List(I).Item_Number);
- Cost_IO.Put (Inventory_File, The_List(I).Unit_Cost, 10, 4, 0);
- Markup_IO.Put(File => Inventory_File,
- Item => The_List(I).Percent_Markup,
- Fore => 6,
- Aft => 3,
- Exp => 2);
- Text_IO.New_Line (Inventory_File);
- end loop;
- return (True); -- Return a Status value.
- exception
- when others => return False;
- end Update_Inventory;
-
-
- begin
-
- -- This code section simulates a receiving department maintaining a
- -- data file containing information on items that have been ordered
- -- and received.
-
- -- Whenever items are received, the file is reset to Append_File
- -- mode. Data is taken from an inventory list and entered into the
- -- file, in specific format.
-
- Reset1:
- begin -- Reset to
- Text_IO.Reset (Inventory_File, -- Append mode.
- TC_Mode_Selection (Report.Ident_Int(3)));
- exception
- when Text_IO.Use_Error =>
- Report.Not_Applicable
- ( "Reset to Append_File not supported for Text_IO" );
- end Reset1;
-
- -- Enter data.
- if not Update_Inventory (The_List => Daily_Inventory) then
- Report.Failed ("Exception occurred during inventory update");
- raise Incomplete;
- end if;
-
- Test_Verification_Block:
- declare
- TC_Item : Item_Type;
- TC_Cost : Cost_Type;
- TC_Markup : Profit_Type;
- TC_Item_Count : Natural := 0;
- begin
-
- Reset2:
- begin
- Text_IO.Reset (Inventory_File, Text_IO.In_File); -- Reset for
- -- reading.
- exception
- when Text_IO.Use_Error =>
- Report.Not_Applicable
- ( "Reset to In_File not supported for Text_IO" );
- raise Incomplete;
- end Reset2;
-
- while not Text_IO.End_Of_File (Inventory_File) loop
- Item_IO.Get (Inventory_File, TC_Item);
- Cost_IO.Get (Inventory_File, TC_Cost);
- Markup_IO.Get (File => Inventory_File,
- Item => TC_Markup,
- Width => 0);
- Text_IO.Skip_Line (Inventory_File);
- TC_Item_Count := TC_Item_Count + 1;
-
- -- Verify all of the data fields read from the file. Compare
- -- with the values that were originally entered into the file.
-
- if (TC_Item /= Daily_Inventory(TC_Item_Count).Item_Number) then
- Report.Failed ("Error in Item_Number read from file");
- end if;
- if (TC_Cost /= Daily_Inventory(TC_Item_Count).Unit_Cost) then
- Report.Failed ("Error in Unit_Cost read from file");
- end if;
- if not (TC_Markup =
- Daily_Inventory(TC_Item_Count).Percent_Markup) then
- Report.Failed ("Error in Percent_Markup read from file");
- end if;
-
- end loop;
-
- if (TC_Item_Count /= Daily_Orders_Received) then
- Report.Failed ("Incorrect number of records read from file");
- end if;
-
- exception
- when Incomplete =>
- raise;
- when others =>
- Report.Failed ("Error raised during data verification");
- end Test_Verification_Block;
-
- exception
- when Incomplete =>
- raise;
- when others =>
- Report.Failed ("Exception in Text_IO.Fixed_IO processing");
- end Operational_Test_Block;
-
- Final_Block:
- begin
- -- Delete the external file.
- if Text_IO.Is_Open (Inventory_File) then
- Text_IO.Delete (Inventory_File);
- else
- Text_IO.Open (Inventory_File, Text_IO.In_File, Inventory_Filename);
- Text_IO.Delete (Inventory_File);
- end if;
-
- exception
-
- when others =>
- Report.Failed ( "Delete not properly implemented for Text_IO" );
-
- end Final_Block;
-
- Report.Result;
-
-exception
- when Incomplete =>
- Report.Result;
- when others =>
- Report.Failed ( "Unexpected exception" );
- Report.Result;
-
-end CXAA008;
diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxaa009.a b/gcc/testsuite/ada/acats/tests/cxa/cxaa009.a
deleted file mode 100644
index d478060808a..00000000000
--- a/gcc/testsuite/ada/acats/tests/cxa/cxaa009.a
+++ /dev/null
@@ -1,290 +0,0 @@
--- CXAA009.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that the capabilities provided in instantiations of the
--- Ada.Text_IO.Float_IO package operate correctly when the mode of
--- the file is Append_File. Check that Float_IO procedures Put and Get
--- properly transfer floating point data to/from data files that are in
--- Append_File mode. Check that the formatting parameters available in
--- the package can be used and modified successfully in the appending and
--- retrieval of data.
---
--- TEST DESCRIPTION:
--- This test is designed to simulate an environment where a data file
--- that holds floating point information is created, written to, and
--- closed. In the future, the file can be reopened in Append_File mode,
--- additional data can be appended to it, and then closed. This process
--- of Open/Append/Close can be repeated as necessary. All data written
--- to the file is verified for accuracy when retrieved from the file.
---
--- This test verifies issues of create in Append_File mode, appending to
--- a file previously appended to, opening in Append_File mode, resetting
--- from Append_File mode to In_File mode, as well as a variety of Text_IO
--- and Float_IO predefined subprograms.
---
--- APPLICABILITY CRITERIA:
--- This test is applicable only to implementations that support text
--- files.
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 25 Feb 97 PWB.CTA Allowed for non-support of some IO operations
---!
-
-with Ada.Text_IO;
-with Report;
-
-procedure CXAA009 is
-
- use Ada;
- Loan_File : Text_IO.File_Type;
- Loan_Filename : constant String :=
- Report.Legal_File_Name ( Nam => "CXAA009" );
- Incomplete : exception;
-
-begin
-
- Report.Test ("CXAA009", "Check that the capabilities of " &
- "Text_IO.Float_IO operate correctly for files " &
- "with mode Append_File");
-
- Test_for_Text_IO_Support:
- begin
-
- -- An implementation that does not support Text_IO in a particular
- -- environment will raise Use_Error on calls to various
- -- Text_IO operations. This block statement encloses a call to
- -- Create, which should raise the exception in a non-supportive
- -- environment. This exception will be handled to produce a
- -- Not_Applicable result.
-
- Text_IO.Create (File => Loan_File, -- Create in
- Mode => Text_IO.Out_File, -- Out_File mode.
- Name => Loan_Filename);
-
- exception
-
- when Text_IO.Use_Error | Text_IO.Name_Error =>
- Report.Not_Applicable
- ( "Files not supported - Create as Out_File for Text_IO" );
- raise Incomplete;
-
- end Test_for_Text_IO_Support;
-
- Operational_Test_Block:
- declare
- Total_Loans_Outstanding : constant Natural := 3;
- Transaction_Status : Boolean := False;
-
- type Account_Balance_Type is digits 6 range 0.0 .. 1.0E6;
- type Loan_Balance_Type is digits 6;
- type Interest_Rate_Type is digits 4 range 0.0 .. 30.00;
-
- type Loan_Info_Type is record
- Account_Balance : Account_Balance_Type := 0.00;
- Loan_Balance : Loan_Balance_Type := 0.00;
- Loan_Interest_Rate : Interest_Rate_Type := 0.00;
- end record;
-
- Home_Refinance_Loan : Loan_Info_Type :=
- (14_500.00, 135_000.00, 6.875);
- Line_Of_Credit_Loan : Loan_Info_Type :=
- ( 5490.00, -3000.00, 13.75);
- Small_Business_Loan : Loan_Info_Type :=
- (Account_Balance => 45_000.00,
- Loan_Balance => 10_500.00,
- Loan_Interest_Rate => 5.875);
-
- package Acct_IO is new Text_IO.Float_IO (Account_Balance_Type);
- package Loan_IO is new Text_IO.Float_IO (Loan_Balance_Type);
- package Rate_IO is new Text_IO.Float_IO (Interest_Rate_Type);
-
-
- -- The following procedure performs the addition of loan information
- -- into a data file. Boolean status of True is returned if all of
- -- the data entry was successful, False otherwise.
- -- This demonstrates use of Float_IO using a variety of data formats.
-
- procedure Update_Loan_Info (The_File : in out Text_IO.File_Type;
- The_Loan : in Loan_Info_Type;
- Status : out Boolean ) is
- begin
- Acct_IO.Put (The_File, The_Loan.Account_Balance);
- Loan_IO.Put (The_File, The_Loan.Loan_Balance, 15, 2, 0);
- Rate_IO.Put (File => The_File,
- Item => The_Loan.Loan_Interest_Rate,
- Fore => 6,
- Aft => 3,
- Exp => 0);
- Text_IO.New_Line (The_File);
- Status := True;
- exception
- when others => Status := False;
- end Update_Loan_Info;
-
-
- begin
-
- -- This code section simulates a bank maintaining a data file
- -- containing information on loans that have been made.
- -- The scenario:
- -- The loan file was created in Out_File mode.
- -- Some number of data records are added.
- -- The file is closed.
- -- The file is subsequently reopened in Append_File mode.
- -- Data is appended to the file.
- -- The file is closed.
- -- Repeat the Open/Append/Close process as required.
- -- Verify data in the file.
- -- etc.
-
- Update_Loan_Info(Loan_File, Home_Refinance_Loan, Transaction_Status);
-
- if not Transaction_Status then
- Report.Failed ("Failure in update of first loan data");
- end if;
-
- Text_IO.Close (Loan_File);
-
- -- When subsequent data items are to be added to the file, the file
- -- is opened in Append_File mode.
-
- Text_IO.Open (Loan_File, -- Open with
- Text_IO.Append_File, -- Append mode.
- Loan_Filename);
-
- Update_Loan_Info(Loan_File, Line_Of_Credit_Loan, Transaction_Status);
-
- if not Transaction_Status then
- Report.Failed("Failure in update of first loan data");
- end if;
-
- Text_IO.Close(Loan_File);
-
- -- To add additional data to the file, the file
- -- is again opened in Append_File mode (appending to a file
- -- previously appended to).
-
- Text_IO.Open (Loan_File, -- Open with
- Text_IO.Append_File, -- Append mode.
- Loan_Filename);
-
- Update_Loan_Info(Loan_File, Small_Business_Loan, Transaction_Status);
-
- if not Transaction_Status then
- Report.Failed("Failure in update of first loan data");
- end if;
-
- Test_Verification_Block:
- declare
- type Ledger_Type is
- array (1 .. Total_Loans_Outstanding) of Loan_Info_Type;
- TC_Bank_Ledger : Ledger_Type;
- TC_Item_Count : Natural := 0;
- begin
-
- Reset1:
- begin
- Text_IO.Reset (Loan_File, Text_IO.In_File); -- Reset for
- -- reading.
- exception
- when Text_IO.Use_Error =>
- Report.Not_Applicable
- ( "Reset to In_File not supported for Text_IO" );
- raise Incomplete;
- end Reset1;
-
- while not Text_IO.End_Of_File (Loan_File) loop
- TC_Item_Count := TC_Item_Count + 1;
- Acct_IO.Get (Loan_File,
- TC_Bank_Ledger(TC_Item_Count).Account_Balance);
- Loan_IO.Get (Loan_File,
- TC_Bank_Ledger(TC_Item_Count).Loan_Balance,
- 0);
- Rate_IO.Get(File => Loan_File,
- Item =>
- TC_Bank_Ledger(TC_Item_Count).Loan_Interest_Rate,
- Width => 0);
- Text_IO.Skip_Line(Loan_File);
-
- end loop;
-
- -- Verify all of the data fields read from the file. Compare
- -- with the values that were originally entered into the file.
-
- if (TC_Bank_Ledger(1) /= Home_Refinance_Loan) or
- (TC_Bank_Ledger(2) /= Line_Of_Credit_Loan) or
- (TC_Bank_Ledger(3) /= Small_Business_Loan) then
- Report.Failed("Error in data read from file");
- end if;
-
- if (TC_Item_Count /= Total_Loans_Outstanding) then
- Report.Failed ("Incorrect number of records read from file");
- end if;
-
- exception
- when Incomplete =>
- raise;
- when others =>
- Report.Failed ("Error raised during data verification");
- end Test_Verification_Block;
-
- exception
- when Incomplete =>
- raise;
- when others =>
- Report.Failed ("Exception in Text_IO.Float_IO processing");
- end Operational_Test_Block;
-
- Final_Block:
- begin
- -- Delete the external file.
- if Text_IO.Is_Open(Loan_File) then
- Text_IO.Delete(Loan_File);
- else
- Text_IO.Open(Loan_File, Text_IO.In_File, Loan_Filename);
- Text_IO.Delete(Loan_File);
- end if;
-
- exception
-
- when Text_IO.Use_Error =>
- Report.Failed
- ( "Delete not properly implemented for Text_IO" );
-
- end Final_Block;
-
- Report.Result;
-
-exception
- when Incomplete =>
- Report.Result;
- when others =>
- Report.Failed ( "Unexpected exception" );
- Report.Result;
-
-end CXAA009;
diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxaa010.a b/gcc/testsuite/ada/acats/tests/cxa/cxaa010.a
deleted file mode 100644
index 5678aee6bcf..00000000000
--- a/gcc/testsuite/ada/acats/tests/cxa/cxaa010.a
+++ /dev/null
@@ -1,335 +0,0 @@
--- CXAA010.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that the operations defined in package Ada.Text_IO.Decimal_IO
--- are available, and that they function correctly when used for the
--- input/output of Decimal types.
---
--- TEST DESCRIPTION:
--- This test demonstrates the Put and Get procedures found in the
--- generic package Ada.Text_IO.Decimal_IO. Both Put and Get are
--- overloaded to allow placement or extraction of decimal values
--- to/from a text file or a string. This test demonstrates both forms
--- of each subprogram.
--- The test defines an array of records containing decimal value
--- and string component fields. All component values are placed in a
--- Text_IO file, with the decimal values being placed there using the
--- version of Put defined for files, and using user-specified formatting
--- parameters. The data is later extracted from the file, with the
--- decimal values being removed using the version of Get defined for
--- files. Decimal values are then written to strings, using the
--- appropriate Put procedure. Finally, extraction of the decimal data
--- from the strings completes the evaluation of the Decimal_IO package
--- subprograms.
--- The reconstructed data is verified at the end of the test against the
--- data originally written to the file.
---
--- APPLICABILITY CRITERIA:
--- Applicable to all implementations capable of supporting external
--- Text_IO files and Decimal Fixed Point Types
---
--- All implementations must attempt to compile this test.
---
--- For implementations validating against Information Systems Annex (F):
--- this test must execute and report PASSED.
---
--- For implementations not validating against Annex F:
--- this test may report compile time errors at one or more points
--- indicated by "-- ANX-F RQMT", in which case it may be graded as inapplicable.
--- Otherwise, the test must execute and report PASSED.
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 20 Feb 95 SAIC Modified test to allow for Use_Error/Name_Error
--- generation by an implementation not supporting
--- Text_IO operations.
--- 14 Nov 95 SAIC Corrected string indexing for ACVC 2.0.1.
--- 27 Feb 97 PWB.CTA Allowed for non-support of some IO operations
--- 16 FEB 98 EDS Modified documentation.
---!
-
-with Ada.Text_IO;
-with Report;
-
-procedure CXAA010 is
- use Ada.Text_IO;
- Tax_Roll : Ada.Text_IO.File_Type;
- Tax_Roll_Name : constant String :=
- Report.Legal_File_Name ( Nam => "CXAA010" );
- Incomplete : exception;
-begin
-
- Report.Test ("CXAA010", "Check that the operations defined in package " &
- "Ada.Text_IO.Decimal_IO are available, and " &
- "that they function correctly when used for " &
- "the input/output of Decimal types");
-
- Test_for_Decimal_IO_Support:
- begin
-
- -- An implementation that does not support Text_IO creation or naming
- -- of external files in a particular environment will raise Use_Error
- -- or Name_Error on a call to Text_IO Create. This block statement
- -- encloses a call to Create, which should produce an exception in a
- -- non-supportive environment. Either of these exceptions will be
- -- handled to produce a Not_Applicable result.
-
- Ada.Text_IO.Create (Tax_Roll, Ada.Text_IO.Out_File, Tax_Roll_Name);
-
- exception
-
- when Ada.Text_IO.Use_Error | Ada.Text_IO.Name_Error =>
- Report.Not_Applicable
- ( "Files not supported - Create as Out_File for Text_IO" );
- raise Incomplete;
-
- end Test_for_Decimal_IO_Support;
-
- Taxation:
- declare
-
- ID_Length : constant := 5;
- Price_String_Length : constant := 5;
- Value_String_Length : constant := 6;
- Total_String_Length : constant := 20;
- Spacer : constant String := " "; -- Two blanks.
-
- type Price_Type is delta 0.1 digits 4; -- ANX-F RQMT
- type Value_Type is delta 0.01 digits 5; -- ANX-F RQMT
-
- type Property_Type is
- record
- Parcel_ID : String (1..ID_Length);
- Purchase_Price : Price_Type;
- Assessed_Value : Value_Type;
- end record;
-
- type City_Block_Type is array (1..4) of Property_Type;
-
- subtype Tax_Bill_Type is string (1..Total_String_Length);
- type Tax_Bill_Array_Type is array (1..4) of Tax_Bill_Type;
-
- Neighborhood : City_Block_Type :=
- (("X9254", 123.0, 135.00), ("X3569", 345.0, 140.50),
- ("X3434", 234.0, 179.50), ("X8838", 456.0, 158.00));
-
- Neighborhood_Taxes : Tax_Bill_Array_Type;
-
- package Price_IO is new Ada.Text_IO.Decimal_IO (Price_Type);
- package Value_IO is new Ada.Text_IO.Decimal_IO (Value_Type);
-
- begin -- Taxation
-
- Assessors_Office:
- begin
-
- for Parcel in City_Block_Type'Range loop
- -- Note: All data in the file will be separated with a
- -- two-character blank spacer.
- Ada.Text_IO.Put(Tax_Roll, Neighborhood(Parcel).Parcel_ID);
- Ada.Text_IO.Put(Tax_Roll, Spacer);
-
- -- Use Decimal_IO.Put with non-default format parameters to
- -- place decimal data into file.
- Price_IO.Put (Tax_Roll, Neighborhood(Parcel).Purchase_Price,
- Fore => 3, Aft =>1, Exp => 0);
- Ada.Text_IO.Put(Tax_Roll, Spacer);
-
- Value_IO.Put (Tax_Roll, Neighborhood(Parcel).Assessed_Value,
- Fore => 3, Aft =>2, Exp => 0);
- Ada.Text_IO.New_Line(Tax_Roll);
- end loop;
-
- Ada.Text_IO.Close (Tax_Roll);
-
- exception
- when others =>
- Report.Failed ("Exception raised in Assessor's Office");
- end Assessors_Office;
-
-
- Twice_A_Year:
- declare
-
- procedure Collect_Tax(Index : in Integer;
- Tax_Array : in out Tax_Bill_Array_Type) is
- ID : String (1..ID_Length);
- Price : Price_Type := 0.0;
- Value : Value_Type := 0.00;
- Price_String : String (1..Price_String_Length);
- Value_String : String (1..Value_String_Length);
- begin
-
- -- Extract information from the Text_IO file; one string, two
- -- decimal values.
- -- Note that the Spacers that were put in the file above are
- -- not individually read here, due to the fact that each call
- -- to Decimal_IO.Get below uses a zero in the Width field,
- -- which allows each Get procedure to skip these leading blanks
- -- prior to extracting the numeric value.
-
- Ada.Text_IO.Get (Tax_Roll, ID);
-
- -- A zero value of Width is provided, so the following
- -- two calls to Decimal_IO.Get will skip the leading blanks,
- -- (from the Spacer variable above), then read the numeric
- -- literals.
-
- Price_IO.Get (Tax_Roll, Price, 0);
- Value_IO.Get (Tax_Roll, Value, 0);
- Ada.Text_IO.Skip_Line (Tax_Roll);
-
- -- Convert the values read from the file into string format,
- -- using user-specified format parameters.
- -- Format of the Price_String should be "nnn.n"
- -- Format of the Value_String should be "nnn.nn"
-
- Price_IO.Put (To => Price_String,
- Item => Price,
- Aft => 1);
- Value_IO.Put (Value_String, Value, 2);
-
- -- Construct a string of length 20 that contains the Parcel_ID,
- -- the Purchase_Price, and the Assessed_Value, separated by
- -- two-character blank data spacers. Store this string
- -- into the string array out parameter.
- -- Format of each Tax_Array element should be
- -- "Xnnnn nnn.n nnn.nn" (with an 'n' signifying a digit).
-
- Tax_Array(Index) := ID & Spacer &
- Price_String & Spacer &
- Value_String;
- exception
- when Data_Error =>
- Report.Failed("Data Error raised during the extraction " &
- "of decimal data from the file");
- when others =>
- Report.Failed("Exception in Collect_Tax procedure");
- end Collect_Tax;
-
-
- begin -- Twice_A_Year
-
- Ada.Text_IO.Open (Tax_Roll, Ada.Text_IO.In_File, Tax_Roll_Name);
-
- -- Determine property tax bills for the entire neighborhood from
- -- the information that is stored in the file. Store information
- -- in the Neighborhood_Taxes string array.
-
- for Parcel in City_Block_Type'Range loop
- Collect_Tax (Parcel, Neighborhood_Taxes);
- end loop;
-
- exception
- when others =>
- Report.Failed ("Exception in Twice_A_Year Block");
- end Twice_A_Year;
-
- -- Use Decimal_IO Get procedure to extract information from a string.
- -- Verify data against original values.
- Validation_Block:
- declare
- TC_ID : String (1..ID_Length); -- 1..5
- TC_Price : Price_Type;
- TC_Value : Value_Type;
- Length : Positive;
- Front,
- Rear : Integer := 0;
- begin
-
- for Parcel in City_Block_Type'Range loop
- -- Extract values from the strings of the string array.
- -- Each element of the string array is 20 characters long; the
- -- first five characters are the Parcel_ID, two blank characters
- -- separate data, the next five characters contain the Price
- -- decimal value, two blank characters separate data, the last
- -- six characters contain the Value decimal value.
- -- Extract each of these components in turn.
-
- Front := 1; -- 1
- Rear := ID_Length; -- 5
- TC_ID := Neighborhood_Taxes(Parcel)(Front..Rear);
-
- -- Extract the decimal value from the next slice of the string.
- Front := Rear + 3; -- 8
- Rear := Front + Price_String_Length - 1; -- 12
- Price_IO.Get (Neighborhood_Taxes(Parcel)(Front..Rear),
- Item => TC_Price,
- Last => Length);
-
- -- Extract next decimal value from slice of string, based on
- -- length of preceding strings read from string array element.
- Front := Rear + 3; -- 15
- Rear := Total_String_Length; -- 20
- Value_IO.Get (Neighborhood_Taxes(Parcel)(Front..Rear),
- Item => TC_Value,
- Last => Length);
-
- if TC_ID /= Neighborhood(Parcel).Parcel_ID or
- TC_Price /= Neighborhood(Parcel).Purchase_Price or
- TC_Value /= Neighborhood(Parcel).Assessed_Value
- then
- Report.Failed ("Incorrect data validation");
- end if;
-
- end loop;
-
- exception
- when others => Report.Failed ("Exception in Validation Block");
- end Validation_Block;
-
- -- Check that the Text_IO file is open, then delete.
-
- if not Ada.Text_IO.Is_Open (Tax_Roll) then
- Report.Failed ("File not left open after processing");
- Ada.Text_IO.Open (Tax_Roll, Ada.Text_IO.Out_File, Tax_Roll_Name);
- end if;
-
- Ada.Text_IO.Delete (Tax_Roll);
-
- exception
- when others =>
- Report.Failed ("Exception in Taxation block");
- -- Check that the Text_IO file is open, then delete.
- if not Ada.Text_IO.Is_Open (Tax_Roll) then
- Ada.Text_IO.Open (Tax_Roll,
- Ada.Text_IO.Out_File,
- Tax_Roll_Name);
- end if;
- Ada.Text_IO.Delete (Tax_Roll);
- end Taxation;
-
- Report.Result;
-
-exception
- when Incomplete =>
- Report.Result;
- when others =>
- Report.Failed ( "Unexpected exception" );
- Report.Result;
-
-end CXAA010;
diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxaa011.a b/gcc/testsuite/ada/acats/tests/cxa/cxaa011.a
deleted file mode 100644
index 8cc136d35ab..00000000000
--- a/gcc/testsuite/ada/acats/tests/cxa/cxaa011.a
+++ /dev/null
@@ -1,266 +0,0 @@
--- CXAA011.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that the operations of Text_IO.Enumeration_IO perform correctly
--- on files of Append_File mode, for instantiations using
--- enumeration types. Check that Enumeration_IO procedures Put and Get
--- properly transfer enumeration data to/from data files.
--- Check that the formatting parameters available in the package can
--- be used and modified successfully in the storage and retrieval of data.
---
--- TEST DESCRIPTION:
--- This test is designed to simulate an environment where a data file
--- that holds enumeration type information is reset from it current mode
--- to allow the appending of data to the end of the This process
--- of Reset/Write can be repeated as necessary. All data written
--- to the file is verified for accuracy when retrieved from the file.
---
--- This test verifies issues of resetting a file created in Out_File mode
--- to Append_File mode, resetting from Append_File mode to In_File mode,
--- as well as a variety of Text_IO and Enumeration_IO predefined
--- subprograms.
---
--- APPLICABILITY CRITERIA:
--- This test is applicable only to implementations that support text
--- files.
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 25 Feb 97 PWB.CTA Allowed for non-support of some IO operations
---!
-
-with Ada.Text_IO;
-with Report;
-
-procedure CXAA011 is
- use Ada;
-
- Status_Log : Text_IO.File_Type;
- Status_Log_Filename : constant String :=
- Report.Legal_File_Name ( Nam => "CXAA011" );
- Incomplete : exception;
-
-begin
-
- Report.Test ("CXAA011", "Check that the operations of " &
- "Text_IO.Enumeration_IO operate correctly for " &
- "files with mode Append_File");
-
- Test_for_Text_IO_Support:
- begin
-
- -- An implementation that does not support Text_IO in a particular
- -- environment will raise Use_Error on calls to various
- -- Text_IO operations. This block statement encloses a call to
- -- Create, which should raise the exception in a non-supportive
- -- environment. This exception will be handled to produce a
- -- Not_Applicable result.
-
- Text_IO.Create (File => Status_Log,
- Mode => Text_IO.Out_File,
- Name => Status_Log_Filename);
- exception
-
- when Text_IO.Use_Error | Text_IO.Name_Error =>
- Report.Not_Applicable
- ( "Files not supported - Create as Out_File for Text_IO" );
- raise Incomplete;
-
- end Test_for_Text_IO_Support;
-
-
- Operational_Test_Block:
- declare
-
- type Days_In_Week is (Monday, Tuesday, Wednesday, Thursday, Friday,
- Saturday, Sunday);
- type Hours_In_Day is (A0000, A0600, P1200, P0600); -- Six hour
- -- blocks.
- type Status_Type is (Operational, Off_Line);
-
- type Status_Record_Type is record
- Day : Days_In_Week;
- Hour : Hours_In_Day;
- Status : Status_Type;
- end record;
-
- Morning_Reading : Status_Record_Type :=
- (Wednesday, A0600, Operational);
- Evening_Reading : Status_Record_Type :=
- (Saturday, P0600, Off_Line);
-
- package Day_IO is new Text_IO.Enumeration_IO (Days_In_Week);
- package Hours_IO is new Text_IO.Enumeration_IO (Hours_In_Day);
- package Status_IO is new Text_IO.Enumeration_IO (Status_Type);
-
-
- -- The following function simulates the hourly recording of equipment
- -- status.
-
- function Record_Status (Reading : Status_Record_Type)
- return Boolean is
- use Text_IO; -- To provide visibility to type Type_Set and
- -- enumeration literal Upper_Case.
- begin
- Day_IO.Put (File => Status_Log,
- Item => Reading.Day,
- Set => Type_Set'(Upper_Case));
- Hours_IO.Put (Status_Log, Reading.Hour, 7);
- Status_IO.Put (Status_Log, Reading.Status,
- Width => 8, Set => Lower_Case);
- Text_IO.New_Line (Status_Log);
- return (True);
- exception
- when others => return False;
- end Record_Status;
-
- begin
-
- -- The usage scenario intended is as follows:
- -- File is created.
- -- Unrelated/unknown file processing occurs.
- -- On six hour intervals, file is reset to Append_File mode.
- -- Data is appended to file.
- -- Unrelated/unknown file processing resumes.
- -- Reset/Append process is repeated.
-
- Reset1:
- begin
- Text_IO.Reset (Status_Log, -- Reset to
- Text_IO.Append_File); -- Append mode.
- exception
- when Text_IO.Use_Error =>
- Report.Not_Applicable
- ( "Reset to Append_File not supported for Text_IO" );
- raise Incomplete;
- end Reset1;
-
- Day_IO.Default_Width := Days_In_Week'Width + 5; -- Default values
- -- are modifiable.
-
- if not Record_Status (Morning_Reading) then -- Enter data.
- Report.Failed ("Exception occurred during data file update");
- end if;
-
- Reset2:
- begin
- Text_IO.Reset (Status_Log, -- Reset to
- Text_IO.Append_File); -- Append mode.
- exception
- when Text_IO.Use_Error =>
- Report.Not_Applicable
- ( "Reset to Append_File not supported for Text_IO" );
- raise Incomplete;
- end Reset2;
-
- if not Record_Status (Evening_Reading) then -- Enter data.
- Report.Failed ("Exception occurred during data file update");
- end if;
-
- Test_Verification_Block:
- declare
- TC_Reading1 : Status_Record_Type;
- TC_Reading2 : Status_Record_Type;
- begin
-
- Reset3:
- begin
- Text_IO.Reset (Status_Log, Text_IO.In_File); -- Reset for
- -- reading.
- exception
- when Text_IO.Use_Error =>
- Report.Not_Applicable
- ( "Reset to In_File not supported for Text_IO" );
- raise Incomplete;
- end Reset3;
-
- Day_IO.Get (Status_Log, TC_Reading1.Day); -- Read data from
- Hours_IO.Get (Status_Log, TC_Reading1.Hour); -- first record.
- Status_IO.Get (Status_Log, TC_Reading1.Status);
- Text_IO.Skip_Line (Status_Log);
-
- -- Verify the data read from the file. Compare with the
- -- record that was originally entered into the file.
-
- if (TC_Reading1 /= Morning_Reading) then
- Report.Failed ("Data error on reading first record");
- end if;
-
- Day_IO.Get (Status_Log, TC_Reading2.Day); -- Read data from
- Hours_IO.Get (Status_Log, TC_Reading2.Hour); -- second record.
- Status_IO.Get (Status_Log, TC_Reading2.Status);
- Text_IO.Skip_Line (Status_Log);
-
- -- Verify all of the data fields read from the file. Compare
- -- with the values that were originally entered into the file.
-
- if (TC_Reading2.Day /= Evening_Reading.Day) or
- (TC_Reading2.Hour /= Evening_Reading.Hour) or
- (TC_Reading2.Status /= Evening_Reading.Status) then
- Report.Failed ("Data error on reading second record");
- end if;
-
- exception
- when Incomplete =>
- raise;
- when others =>
- Report.Failed ("Error raised during data verification");
- end Test_Verification_Block;
-
- exception
- when Incomplete =>
- raise;
- when others =>
- Report.Failed ("Exception in Text_IO.Enumeration_IO processing");
- end Operational_Test_Block;
-
- Final_Block:
- begin
- -- Delete the external file.
- if Text_IO.Is_Open (Status_Log) then
- Text_IO.Delete (Status_Log);
- else
- Text_IO.Open (Status_Log, Text_IO.Out_File, Status_Log_Filename);
- Text_IO.Delete (Status_Log);
- end if;
- exception
- when Text_IO.Use_Error =>
- Report.Failed
- ( "Delete not properly implemented for Text_IO" );
-
- end Final_Block;
-
- Report.Result;
-
-exception
- when Incomplete =>
- Report.Result;
- when others =>
- Report.Failed ( "Unexpected exception" );
- Report.Result;
-
-end CXAA011;
diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxaa012.a b/gcc/testsuite/ada/acats/tests/cxa/cxaa012.a
deleted file mode 100644
index 07523b44170..00000000000
--- a/gcc/testsuite/ada/acats/tests/cxa/cxaa012.a
+++ /dev/null
@@ -1,167 +0,0 @@
--- CXAA012.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that the exception Mode_Error is raised when an attempt is made
--- to read from (perform a Get_Line) or use the predefined End_Of_File
--- function on a text file with mode Append_File.
---
--- TEST DESCRIPTION:
--- A scenario is created that demonstrates the potential for the
--- incorrect usage of predefined text processing subprograms, resulting
--- from their use with files of the wrong Mode. This results in the
--- raising of Mode_Error exceptions, which is handled within blocks
--- embedded in the test.
--- A count is kept to ensure that each anticipated exception is in fact
--- raised and handled properly.
---
--- APPLICABILITY CRITERIA:
--- This test is applicable only to implementations that support text
--- files.
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 27 Feb 97 PWB.CTA Allowed for non-support of some IO operations
---!
-
-with Ada.Text_IO;
-with Report;
-
-procedure CXAA012 is
- use Ada;
- Text_File : Text_IO.File_Type;
- Text_Filename : constant String :=
- Report.Legal_File_Name ( Nam => "CXAA012" );
- Incomplete : exception;
-begin
-
- Report.Test ("CXAA012", "Check that the exception Mode_Error is " &
- "raised when an attempt is made to read " &
- "from (perform a Get_Line) or use the " &
- "predefined End_Of_File function on a " &
- "text file with mode Append_File");
-
- Test_for_Text_IO_Support:
- begin
-
- -- Use_Error or Name_Error will be raised if Text_IO operations
- -- or external files are not supported.
-
- Text_IO.Create (Text_File, Text_IO.Out_File, Text_Filename);
-
- exception
- when Text_IO.Use_Error | Text_IO.Name_Error =>
- Report.Not_Applicable
- ( "Files not supported - Create as Out_File for Text_IO" );
- raise Incomplete;
- end Test_for_Text_IO_Support;
-
- -- The application writes some amount of data to the file.
-
- Text_IO.Put_Line (Text_File, "Data entered into the file");
-
- Text_IO.Close (Text_File);
-
- Operational_Test_Block:
- declare
- TC_Number_Of_Forced_Mode_Errors : constant Natural := 2;
- TC_Mode_Errors : Natural := 0;
- begin
-
- Text_IO.Open (Text_File, Text_IO.Append_File, Text_Filename);
-
- Test_for_Reading:
- declare
- TC_Data : String (1..80);
- TC_Length : Natural := 0;
- begin
-
--- During the course of its processing, the application may become confused
--- and erroneously attempt to read data from the file that is currently in
--- Append_File mode (instead of the anticipated In_File mode).
--- This would result in the raising of Mode_Error.
-
- Text_IO.Get_Line (Text_File, TC_Data, TC_Length);
- Report.Failed ("Exception not raised by Get_Line");
-
--- An exception handler present within the application handles the exception
--- and processing can continue.
-
- exception
- when Text_IO.Mode_Error =>
- TC_Mode_Errors := TC_Mode_Errors + 1;
- when others =>
- Report.Failed ("Exception in Get_Line processing");
- end Test_for_Reading;
-
-
- Test_for_End_Of_File:
- declare
- TC_End_Of_File : Boolean;
- begin
-
--- Again, during the course of its processing, the application attempts to
--- call the End_Of_File function for the file that is currently in
--- Append_File mode (instead of the anticipated In_File mode).
-
- TC_End_Of_File := Text_IO.End_Of_File (Text_File);
- Report.Failed ("Exception not raised by End_Of_File");
-
--- Once again, an exception handler present within the application handles
--- the exception and processing continues.
-
- exception
- when Text_IO.Mode_Error =>
- TC_Mode_Errors := TC_Mode_Errors + 1;
- when others =>
- Report.Failed("Exception in End_Of_File processing");
- end Test_for_End_Of_File;
-
-
- if (TC_Mode_Errors /= TC_Number_Of_Forced_Mode_Errors) then
- Report.Failed ("Incorrect number of exceptions handled");
- end if;
-
- end Operational_Test_Block;
-
- -- Delete the external file.
- if Text_IO.Is_Open (Text_File) then
- Text_IO.Delete (Text_File);
- else
- Text_IO.Open (Text_File, Text_IO.In_File, Text_Filename);
- Text_IO.Delete (Text_File);
- end if;
-
- Report.Result;
-
-exception
- when Incomplete =>
- Report.Result;
- when others =>
- Report.Failed ( "Unexpected exception" );
- Report.Result;
-
-end CXAA012;
diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxaa013.a b/gcc/testsuite/ada/acats/tests/cxa/cxaa013.a
deleted file mode 100644
index be658ca13e0..00000000000
--- a/gcc/testsuite/ada/acats/tests/cxa/cxaa013.a
+++ /dev/null
@@ -1,167 +0,0 @@
--- CXAA013.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that the exception Mode_Error is raised when an attempt is made
--- to skip a line or page using the predefined Skip_Line and Skip_Page
--- procedures on a text file with mode Append_File.
---
--- TEST DESCRIPTION:
--- A scenario is created that demonstrates the potential for the
--- incorrect usage of predefined text processing subprograms, which
--- results in the raising of a Mode_Error exception.
--- A count is kept to ensure that each anticipated exception is in fact
--- raised and handled properly.
---
--- APPLICABILITY CRITERIA:
--- This test is applicable only to implementations that support text
--- files.
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 28 Feb 97 PWB.CTA Allowed for non-support of some IO operations
---!
-
-with Ada.Text_IO;
-with Report;
-
-procedure CXAA013 is
- use Ada;
- Text_File : Text_IO.File_Type;
- Text_Filename : constant String :=
- Report.Legal_File_Name ( Nam => "CXAA013" );
- Incomplete : exception;
-
-begin
-
- Report.Test ("CXAA013", "Check that the exception Mode_Error is " &
- "raised when an attempt is made to skip " &
- "a line or page using the predefined " &
- "Skip_Line and Skip_Page procedures on " &
- "a text file with mode Append_File");
-
- Test_for_Text_IO_Support:
- begin
-
--- An application creates a text file with mode Append_File.
--- Use_Error will be raised if Text_IO operations or external files are not
--- supported.
-
- Text_IO.Create (Text_File, Text_IO.Append_File, Text_Filename);
-
- exception
-
- when Text_IO.Use_Error | Text_IO.Name_Error =>
- Report.Not_Applicable
- ( "Files not supported - Create as Append_File for Text_IO" );
- raise Incomplete;
-
- end Test_for_Text_IO_Support;
-
--- The application writes some amount of data to the file.
-
- Text_IO.Put_Line (Text_File, "Data entered into the file");
-
- Operational_Test_Block:
- declare
- TC_Number_Of_Forced_Mode_Errors : constant Natural := 2;
- TC_Mode_Errors : Natural := 0;
- begin
-
- Test_for_Skip_Line:
- declare
- TC_Spacing : constant Text_IO.Count := 3;
- begin
-
--- During the course of its processing, the application may attempt to
--- invoke the Skip_Line procedure on a file that is currently in Append_File
--- mode (instead of the anticipated In_File mode). This results in the
--- raising of Mode_Error.
-
- Text_IO.Skip_Line (Text_File, TC_Spacing);
- Report.Failed ("Exception not raised by Skip_Line");
-
--- An exception handler present within the application handles the exception
--- and processing can continue.
-
- exception
- when Text_IO.Mode_Error =>
- TC_Mode_Errors := TC_Mode_Errors + 1;
- when others =>
- Report.Failed("Exception in Skip_Line processing");
- end Test_for_Skip_Line;
-
- Test_for_Skip_Page:
- begin
-
--- Again, during the course of its processing, the application incorrectly
--- assumes that the file mode is In_File, this time attempting to call the
--- Skip_Page procedure for the file (that is currently in Append_File mode).
-
- Text_IO.Skip_Page (Text_File);
- Report.Failed ("Exception not raised by Skip_Page");
-
--- Once again, an exception handler present within the application handles
--- the exception and processing continues.
-
- exception
- when Text_IO.Mode_Error =>
- TC_Mode_Errors := TC_Mode_Errors + 1;
- when others =>
- Report.Failed("Exception in Skip_Page processing");
- end Test_for_Skip_Page;
-
- if (TC_Mode_Errors /= TC_Number_Of_Forced_Mode_Errors) then
- Report.Failed ("Incorrect number of exceptions handled");
- end if;
-
- end Operational_Test_Block;
-
- Deletion:
- begin
- -- Delete the external file.
- if Text_IO.Is_Open (Text_File) then
- Text_IO.Delete (Text_File);
- else
- Text_IO.Open (Text_File, Text_IO.In_File, Text_Filename);
- Text_IO.Delete (Text_File);
- end if;
- exception
- when others =>
- Report.Failed
- ( "Delete not properly implemented for Text_IO" );
- end Deletion;
-
- Report.Result;
-
-exception
- when Incomplete =>
- Report.Result;
- when others =>
- Report.Failed ( "Unexpected exception" );
- Report.Result;
-
-end CXAA013;
diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxaa014.a b/gcc/testsuite/ada/acats/tests/cxa/cxaa014.a
deleted file mode 100644
index 0b74c616959..00000000000
--- a/gcc/testsuite/ada/acats/tests/cxa/cxaa014.a
+++ /dev/null
@@ -1,178 +0,0 @@
--- CXAA014.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that the exception Mode_Error is raised when an attempt is made
--- to check for the end of a line or page using the predefined functions
--- End_Of_Line or End_Of_Page on a text file with mode Append_File.
---
--- TEST DESCRIPTION:
--- A scenario is created that demonstrates the potential for the
--- incorrect usage of predefined text processing subprograms, which
--- results in the raising of a Mode_Error exception.
--- A count is kept to ensure that each anticipated exception is in fact
--- raised and handled properly.
---
--- APPLICABILITY CRITERIA:
--- This test is applicable only to implementations that support text
--- files.
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 28 Feb 97 PWB.CTA Allowed for non-support of some IO operations
---!
-
-with Ada.Text_IO;
-with Report;
-
-procedure CXAA014 is
- use Ada;
- Text_File : Text_IO.File_Type;
- Text_Filename : constant String :=
- Report.Legal_File_Name ( Nam => "CXAA014" );
- Incomplete : exception;
-
-begin
-
- Report.Test ("CXAA014", "Check that the exception Mode_Error is " &
- "raised when an attempt is made to check " &
- "for the end of a line or page using the " &
- "predefined functions End_Of_Line or " &
- "End_Of_Page on a text file with mode " &
- "Append_File");
-
- Test_for_Text_IO_Support:
- begin
-
--- Use_Error will be raised if Text_IO operations or external files are not
--- supported.
-
- Text_IO.Create (Text_File, Text_IO.Out_File, Text_Filename);
-
- exception
-
- when Text_IO.Use_Error | Text_IO.Name_Error =>
- Report.Not_Applicable
- ( "Files not supported - Create as Out_File for Text_IO" );
- raise Incomplete;
-
- end Test_for_Text_IO_Support;
-
-
--- The application writes some amount of data to the file.
-
- for I in 1 .. 10 loop
- Text_IO.Put_Line (Text_File, "Data entered into the file");
- end loop;
-
- Text_IO.Close (Text_File);
-
- Operational_Test_Block:
- declare
- TC_Number_Of_Forced_Mode_Errors : constant Natural := 2;
- TC_Mode_Errors : Natural := 0;
- begin
-
- Text_IO.Open (Text_File, Text_IO.Append_File, Text_Filename);
-
- Test_for_End_Of_Line:
- declare
- TC_End_Of_Line : Boolean;
- begin
-
--- During the course of its processing, the application may attempt to
--- invoke the End_Of_Line function on a file that is currently in Append_File
--- mode (instead of the anticipated In_File mode). This results in the
--- raising of Mode_Error.
-
- TC_End_Of_Line := Text_IO.End_Of_Line (Text_File);
- Report.Failed ("Exception not raised by End_Of_Line");
-
--- An exception handler present within the application handles the exception
--- and processing can continue.
-
- exception
- when Text_IO.Mode_Error =>
- TC_Mode_Errors := TC_Mode_Errors + 1;
- when others =>
- Report.Failed("Exception in End_Of_Line processing");
- end Test_for_End_Of_Line;
-
-
- Test_for_End_Of_Page:
- declare
- TC_End_Of_Page : Boolean;
- begin
-
--- Again, during the course of its processing, the application incorrectly
--- assumes that the file mode is In_File, this time attempting to call the
--- End_Of_Page function for the file (that is currently in Append_File mode).
-
- TC_End_Of_Page := Text_IO.End_Of_Page (Text_File);
- Report.Failed ("Exception not raised by End_Of_Page");
-
--- Once again, an exception handler present within the application handles
--- the exception and processing continues.
-
- exception
- when Text_IO.Mode_Error =>
- TC_Mode_Errors := TC_Mode_Errors + 1;
- when others =>
- Report.Failed("Exception in End_Of_Page processing");
- end Test_for_End_Of_Page;
-
-
- if (TC_Mode_Errors /= TC_Number_Of_Forced_Mode_Errors) then
- Report.Failed ("Incorrect number of exceptions handled");
- end if;
-
- end Operational_Test_Block;
-
- Deletion:
- begin
- -- Delete the external file.
- if Text_IO.Is_Open (Text_File) then
- Text_IO.Delete (Text_File);
- else
- Text_IO.Open (Text_File, Text_IO.In_File, Text_Filename);
- Text_IO.Delete (Text_File);
- end if;
- exception
- when others =>
- Report.Failed
- ( "Delete not properly implemented for Text_IO" );
- end Deletion;
-
- Report.Result;
-
-exception
- when Incomplete =>
- Report.Result;
- when others =>
- Report.Failed ( "Unexpected exception" );
- Report.Result;
-
-end CXAA014;
diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxaa015.a b/gcc/testsuite/ada/acats/tests/cxa/cxaa015.a
deleted file mode 100644
index 919ef05ca7e..00000000000
--- a/gcc/testsuite/ada/acats/tests/cxa/cxaa015.a
+++ /dev/null
@@ -1,227 +0,0 @@
--- CXAA015.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that the exception Status_Error is raised when an attempt is
--- made to create or open a file in Append_File mode when the file is
--- already open.
--- Check that the exception Name_Error is raised by procedure Open when
--- attempting to open a file in Append_File mode when the name supplied
--- as the filename does not correspond to an existing external file.
---
--- TEST DESCRIPTION:
--- A scenario is created that demonstrates the potential for the
--- inappropriate usage of text processing subprograms Create and Open,
--- resulting in the raising of Status_Error and Name_Error exceptions.
--- A count is kept to ensure that each anticipated exception is in fact
--- raised and handled properly.
---
--- APPLICABILITY CRITERIA:
--- This test is applicable only to implementations that support text
--- files.
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 28 Feb 97 PWB.CTA Allowed for non-support of some IO operations
---!
-
-with Ada.Text_IO;
-with Report;
-
-procedure CXAA015 is
- use Ada;
- Text_File : Text_IO.File_Type;
- Text_Filename : constant String :=
- Report.Legal_File_Name ( Nam => "CXAA015" );
- Incomplete : exception;
-
-begin
-
- Report.Test ("CXAA015", "Check that the appropriate exceptions " &
- "are raised when procedures Create and " &
- "Open are used to inappropriately operate " &
- "on files of mode Append_File");
-
- Test_for_Text_IO_Support:
- begin
-
--- An application creates a text file with mode Append_File.
--- Use_Error will be raised if Text_IO operations or external files are not
--- supported.
-
- Text_IO.Create (Text_File, Text_IO.Append_File, Text_Filename);
- exception
-
- when Text_IO.Use_Error | Text_IO.Name_Error =>
- Report.Not_Applicable
- ( "Files not supported - Create as Append_File for Text_IO" );
- raise Incomplete;
-
- end Test_for_Text_IO_Support;
-
-
--- The application writes some amount of data to the file.
-
- for I in 1 .. 5 loop
- Text_IO.Put_Line (Text_File, "Data entered into the file");
- end loop;
-
- Operational_Test_Block:
- declare
- TC_Number_Of_Forced_Errors : constant Natural := 3;
- TC_Errors : Natural := 0;
- begin
-
-
- Test_for_Create:
- begin
-
--- During the course of its processing, the application may (erroneously)
--- attempt to create the same file already in existence in Append_File mode.
--- This results in the raising of Status_Error.
-
- Text_IO.Create (Text_File,
- Text_IO.Append_File,
- Text_Filename);
- Report.Failed ("Exception not raised by Create");
-
--- An exception handler present within the application handles the exception
--- and processing can continue.
-
- exception
- when Text_IO.Status_Error =>
- TC_Errors := TC_Errors + 1;
- when others =>
- Report.Failed("Exception in Create processing");
- end Test_for_Create;
-
-
- First_Test_For_Open:
- begin
-
--- Again, during the course of its processing, the application incorrectly
--- attempts to Open a file (in Append_File mode) that is already open.
-
- Text_IO.Open (Text_File, Text_IO.Append_File, Text_Filename);
- Report.Failed ("Exception not raised by improper Open - 1");
-
--- Once again, an exception handler present within the application handles
--- the exception and processing continues.
-
- exception
- when Text_IO.Status_Error =>
- TC_Errors := TC_Errors + 1;
-
--- At some point in its processing, the application closes the file that is
--- currently open.
-
- Text_IO.Close (Text_File);
- when others =>
- Report.Failed("Exception in Open processing - 1");
- end First_Test_For_Open;
-
-
- Open_With_Wrong_Filename:
- declare
- TC_Wrong_Filename : constant String :=
- Report.Legal_File_Name(2);
- begin
-
--- At this point, the application attempts to Open (in Append_File mode) the
--- file used in previous processing, but it attempts this Open using a name
--- string that does not correspond to any existing external file.
--- First make sure the file doesn't exist. (If it did, then the check
--- for open in append mode wouldn't work.)
-
- Verify_No_File:
- begin
- Text_IO.Open (Text_File,
- Text_IO.In_File,
- TC_Wrong_Filename);
- exception
- when Text_IO.Name_Error =>
- null;
- when others =>
- Report.Failed ( "Unexpected exception on Open check" );
- end Verify_No_File;
-
- Delete_No_File:
- begin
- if Text_IO.Is_Open (Text_File) then
- Text_IO.Delete (Text_File);
- end if;
- exception
- when others =>
- Report.Failed ( "Unexpected exception - Delete check" );
- end Delete_No_File;
-
- Text_IO.Open (Text_File,
- Text_IO.Append_File,
- TC_Wrong_Filename);
- Report.Failed ("Exception not raised by improper Open - 2");
-
--- An exception handler for the Name_Error, present within the application,
--- catches the exception and processing continues.
-
- exception
- when Text_IO.Name_Error =>
- TC_Errors := TC_Errors + 1;
- when others =>
- Report.Failed("Exception in Open processing - 2");
- end Open_With_Wrong_Filename;
-
-
- if (TC_Errors /= TC_Number_Of_Forced_Errors) then
- Report.Failed ("Incorrect number of exceptions handled");
- end if;
-
- end Operational_Test_Block;
-
- Deletion:
- begin
- -- Delete the external file.
- if Text_IO.Is_Open (Text_File) then
- Text_IO.Delete (Text_File);
- else
- Text_IO.Open (Text_File, Text_IO.In_File, Text_Filename);
- Text_IO.Delete (Text_File);
- end if;
- exception
- when others =>
- Report.Failed
- ( "Delete not properly implemented for Text_IO" );
- end Deletion;
-
- Report.Result;
-
-exception
- when Incomplete =>
- Report.Result;
- when others =>
- Report.Failed ( "Unexpected exception" );
- Report.Result;
-
-end CXAA015;
diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxaa016.a b/gcc/testsuite/ada/acats/tests/cxa/cxaa016.a
deleted file mode 100644
index 8ae69a12664..00000000000
--- a/gcc/testsuite/ada/acats/tests/cxa/cxaa016.a
+++ /dev/null
@@ -1,462 +0,0 @@
--- CXAA016.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that the type File_Access is available in Ada.Text_IO, and that
--- objects of this type designate File_Type objects.
--- Check that function Set_Error will set the current default error file.
--- Check that versions of Ada.Text_IO functions Standard_Input,
--- Standard_Output, Standard_Error return File_Access values designating
--- the standard system input, output, and error files.
--- Check that versions of Ada.Text_IO functions Current_Input,
--- Current_Output, Current_Error return File_Access values designating
--- the current system input, output, and error files.
---
--- TEST DESCRIPTION:
--- This test tests the use of File_Access objects in referring
--- to File_Type objects, as well as several new functions that return
--- File_Access objects as results.
--- Four user-defined files are created. These files will be set to
--- function as current system input, output, and error files.
--- Data will be read from and written to these files during the
--- time at which they function as the current system files.
--- An array of File_Access objects will be defined. It will be
--- initialized using functions that return File_Access objects
--- referencing the Standard and Current Input, Output, and Error files.
--- This "saves" the initial system environment, which will be modified
--- to use the user-defined files as the current default Input, Output,
--- and Error files. At the end of the test, the data in this array
--- will be used to restore the initial system environment.
---
--- APPLICABILITY CRITERIA:
--- This test is applicable to implementations capable of supporting
--- external Text_IO files.
---
---
--- CHANGE HISTORY:
--- 25 May 95 SAIC Initial prerelease version.
--- 22 Apr 96 SAIC Incorporated reviewer comments for ACVC 2.1.
--- 26 Feb 97 PWB.CTA Allowed for non-support of some IO operations.
--- 18 Jan 99 RLB Repaired to allow Not_Applicable systems to
--- fail delete.
---!
-
-with Ada.Text_IO;
-package CXAA016_0 is
- New_Input_File,
- New_Output_File,
- New_Error_File_1,
- New_Error_File_2 : aliased Ada.Text_IO.File_Type;
-end CXAA016_0;
-
-
-with Report;
-with Ada.Exceptions;
-with Ada.Text_IO; use Ada.Text_IO;
-with CXAA016_0; use CXAA016_0;
-
-procedure CXAA016 is
-
- Non_Applicable_System : exception;
- No_Reset : exception;
- Not_Applicable_System : Boolean := False;
-
- procedure Delete_File ( A_File : in out Ada.Text_IO.File_Type;
- ID_Num : in Integer ) is
- begin
- if not Ada.Text_IO.Is_Open ( A_File ) then
- Ada.Text_IO.Open ( A_File,
- Ada.Text_IO.In_File,
- Report.Legal_File_Name ( ID_Num ) );
- end if;
- Ada.Text_IO.Delete ( A_File );
- exception
- when Ada.Text_IO.Name_Error =>
- if Not_Applicable_System then
- null; -- File probably wasn't created.
- else
- Report.Failed ( "Can't open file for Text_IO" );
- end if;
- when Ada.Text_IO.Use_Error =>
- if Not_Applicable_System then
- null; -- File probably wasn't created.
- else
- Report.Failed ( "Delete not properly implemented for Text_IO" );
- end if;
- when others =>
- Report.Failed ( "Unexpected exception in Delete_File" );
- end Delete_File;
-
-begin
-
- Report.Test ("CXAA016", "Check that the type File_Access is available " &
- "in Ada.Text_IO, and that objects of this " &
- "type designate File_Type objects");
- Test_Block:
- declare
-
- use Ada.Exceptions;
-
- type System_File_Array_Type is
- array (Integer range <>) of File_Access;
-
- -- Fill the following array with the File_Access results of six
- -- functions.
-
- Initial_Environment : System_File_Array_Type(1..6) :=
- ( Standard_Input,
- Standard_Output,
- Standard_Error,
- Current_Input,
- Current_Output,
- Current_Error );
-
- New_Input_Ptr : File_Access := New_Input_File'Access;
- New_Output_Ptr : File_Access := New_Output_File'Access;
- New_Error_Ptr : File_Access := New_Error_File_1'Access;
-
- Line : String(1..80);
- Length : Natural := 0;
-
- Line_1 : constant String := "This is the first line in the Output file";
- Line_2 : constant String := "This is the next line in the Output file";
- Line_3 : constant String := "This is the first line in Error file 1";
- Line_4 : constant String := "This is the next line in Error file 1";
- Line_5 : constant String := "This is the first line in Error file 2";
- Line_6 : constant String := "This is the next line in Error file 2";
-
-
-
- procedure New_File (The_File : in out File_Type;
- Mode : in File_Mode;
- Next : in Integer) is
- begin
- Create (The_File, Mode, Report.Legal_File_Name(Next));
- exception
- -- The following two exceptions may be raised if a system is not
- -- capable of supporting external Text_IO files. The handler will
- -- raise a user-defined exception which will result in a
- -- Not_Applicable result for the test.
- when Use_Error | Name_Error => raise Non_Applicable_System;
- end New_File;
-
-
-
- procedure Check_Initial_Environment (Env : System_File_Array_Type) is
- begin
- -- Check that the system has defined the following sources/
- -- destinations for input/output/error, and that the six functions
- -- returning File_Access values are available.
- if not (Env(1) = Standard_Input and
- Env(2) = Standard_Output and
- Env(3) = Standard_Error and
- Env(4) = Current_Input and
- Env(5) = Current_Output and
- Env(6) = Current_Error)
- then
- Report.Failed("At the start of the test, the Standard and " &
- "Current File_Access values associated with " &
- "system Input, Output, and Error files do " &
- "not correspond");
- end if;
- end Check_Initial_Environment;
-
-
-
- procedure Load_Input_File (Input_Ptr : in File_Access) is
- begin
- -- Load data into the file that will function as the user-defined
- -- system input file.
- Put_Line(Input_Ptr.all, Line_1);
- Put_Line(Input_Ptr.all, Line_2);
- Put_Line(Input_Ptr.all, Line_3);
- Put_Line(Input_Ptr.all, Line_4);
- Put_Line(Input_Ptr.all, Line_5);
- Put_Line(Input_Ptr.all, Line_6);
- end Load_Input_File;
-
-
-
- procedure Restore_Initial_Environment
- (Initial_Env : System_File_Array_Type) is
- begin
- -- Restore the Current Input, Output, and Error files to their
- -- original states.
-
- Set_Input (Initial_Env(4).all);
- Set_Output(Initial_Env(5).all);
- Set_Error (Initial_Env(6).all);
-
- -- At this point, the user-defined files that were functioning as
- -- the Current Input, Output, and Error files have been replaced in
- -- that capacity by the state of the original environment.
-
- declare
-
- -- Capture the state of the current environment.
-
- Current_Env : System_File_Array_Type (1..6) :=
- (Standard_Input, Standard_Output, Standard_Error,
- Current_Input, Current_Output, Current_Error);
- begin
-
- -- Compare the current environment with that of the saved
- -- initial environment.
-
- if Current_Env /= Initial_Env then
- Report.Failed("Restored file environment was not the same " &
- "as the initial file environment");
- end if;
- end;
- end Restore_Initial_Environment;
-
-
-
- procedure Verify_Files (O_File, E_File_1, E_File_2 : in File_Type) is
- Str_1, Str_2, Str_3, Str_4, Str_5, Str_6 : String (1..80);
- Len_1, Len_2, Len_3, Len_4, Len_5, Len_6 : Natural;
- begin
-
- -- Get the lines that are contained in all the files, and verify
- -- them against the expected results.
-
- Get_Line(O_File, Str_1, Len_1); -- The user defined output file
- Get_Line(O_File, Str_2, Len_2); -- should contain two lines of data.
-
- if Str_1(1..Len_1) /= Line_1 or
- Str_2(1..Len_2) /= Line_2
- then
- Report.Failed("Incorrect results from Current_Output file");
- end if;
-
- Get_Line(E_File_1, Str_3, Len_3); -- The first error file received
- Get_Line(E_File_1, Str_4, Len_4); -- two lines of data originally,
- Get_Line(E_File_1, Str_5, Len_5); -- then had two additional lines
- Get_Line(E_File_1, Str_6, Len_6); -- appended from the second error
- -- file.
- if Str_3(1..Len_3) /= Line_3 or
- Str_4(1..Len_4) /= Line_4 or
- Str_5(1..Len_5) /= Line_5 or
- Str_6(1..Len_6) /= Line_6
- then
- Report.Failed("Incorrect results from first Error file");
- end if;
-
- Get_Line(E_File_2, Str_5, Len_5); -- The second error file
- Get_Line(E_File_2, Str_6, Len_6); -- received two lines of data.
-
- if Str_5(1..Len_5) /= Line_5 or
- Str_6(1..Len_6) /= Line_6
- then
- Report.Failed("Incorrect results from second Error file");
- end if;
-
- end Verify_Files;
-
-
-
- begin
-
- Check_Initial_Environment (Initial_Environment);
-
- -- Create user-defined text files that will be set to serve as current
- -- system input, output, and error files.
-
- New_File (New_Input_File, Out_File, 1); -- Will be reset prior to use.
- New_File (New_Output_File, Out_File, 2);
- New_File (New_Error_File_1, Out_File, 3);
- New_File (New_Error_File_2, Out_File, 4);
-
- -- Enter several lines of text into the new input file. This file will
- -- be reset to mode In_File to function as the current system input file.
- -- Note: File_Access value used as parameter to this procedure.
-
- Load_Input_File (New_Input_Ptr);
-
- -- Reset the New_Input_File to mode In_File, to allow it to act as the
- -- current system input file.
-
- Reset1:
- begin
- Reset (New_Input_File, In_File);
- exception
- when Ada.Text_IO.Use_Error =>
- Report.Not_Applicable
- ( "Reset to In_File not supported for Text_IO - 1" );
- raise No_Reset;
- end Reset1;
-
- -- Establish new files that will function as the current system Input,
- -- Output, and Error files.
-
- Set_Input (New_Input_File);
- Set_Output(New_Output_Ptr.all);
- Set_Error (New_Error_Ptr.all);
-
- -- Perform various file processing tasks, exercising specific new
- -- Text_IO functionality.
- --
- -- Read two lines from Current_Input and write them to Current_Output.
-
- for i in 1..2 loop
- Get_Line(Current_Input, Line, Length);
- Put_Line(Current_Output, Line(1..Length));
- end loop;
-
- -- Read two lines from Current_Input and write them to Current_Error.
-
- for i in 1..2 loop
- Get_Line(Current_Input, Line, Length);
- Put_Line(Current_Error, Line(1..Length));
- end loop;
-
- -- Reset the Current system error file.
-
- Set_Error (New_Error_File_2);
-
- -- Read two lines from Current_Input and write them to Current_Error.
-
- for i in 1..2 loop
- Get_Line(Current_Input, Line, Length);
- Put_Line(Current_Error, Line(1..Length));
- end loop;
-
- -- At this point in the processing, the new Output file, and each of
- -- the two Error files, contain two lines of data.
- -- Note that New_Error_File_1 has been replaced by New_Error_File_2
- -- as the current system error file, allowing New_Error_File_1 to be
- -- reset (Mode_Error raised otherwise).
- --
- -- Reset the first Error file to Append_File mode, and then set it to
- -- function as the current system error file.
-
- Reset2:
- begin
- Reset (New_Error_File_1, Append_File);
- exception
- when Ada.Text_IO.Use_Error =>
- Report.Not_Applicable
- ( "Reset to Append_File not supported for Text_IO - 2" );
- raise No_Reset;
- end Reset2;
-
- Set_Error (New_Error_File_1);
-
- -- Reset the second Error file to In_File mode, then set it to become
- -- the current system input file.
-
- Reset3:
- begin
- Reset (New_Error_File_2, In_File);
- exception
- when Ada.Text_IO.Use_Error =>
- Report.Not_Applicable
- ( "Reset to In_File not supported for Text_IO - 3" );
- raise No_Reset;
- end Reset3;
-
- New_Error_Ptr := New_Error_File_2'Access;
- Set_Input (New_Error_Ptr.all);
-
- -- Append all of the text lines (2) in the new current system input
- -- file onto the current system error file.
-
- while not End_Of_File(Current_Input) loop
- Get_Line(Current_Input, Line, Length);
- Put_Line(Current_Error, Line(1..Length));
- end loop;
-
- -- Restore the original system file environment, based upon the values
- -- stored at the start of this test.
- -- Check that the original environment has been restored.
-
- Restore_Initial_Environment (Initial_Environment);
-
- -- Reset all three files to In_File_Mode prior to verification.
- -- Note: If these three files had still been the designated Current
- -- Input, Output, or Error files for the system, a Reset
- -- operation at this point would raise Mode_Error.
- -- However, at this point, the environment has been restored to
- -- its original state, and these user-defined files are no longer
- -- designated as current system files, allowing a Reset.
-
- Reset4:
- begin
- Reset(New_Error_File_1, In_File);
- exception
- when Ada.Text_IO.Use_Error =>
- Report.Not_Applicable
- ( "Reset to In_File not supported for Text_IO - 4" );
- raise No_Reset;
- end Reset4;
-
- Reset5:
- begin
- Reset(New_Error_File_2, In_File);
- exception
- when Ada.Text_IO.Use_Error =>
- Report.Not_Applicable
- ( "Reset to In_File not supported for Text_IO - 5" );
- raise No_Reset;
- end Reset5;
-
- Reset6:
- begin
- Reset(New_Output_File, In_File);
- exception
- when Ada.Text_IO.Use_Error =>
- Report.Not_Applicable
- ( "Reset to In_File not supported for Text_IO - 6" );
- raise No_Reset;
- end Reset6;
-
- -- Check that all the files contain the appropriate data.
-
- Verify_Files (New_Output_File, New_Error_File_1, New_Error_File_2);
-
- exception
- when No_Reset =>
- null;
- when Non_Applicable_System =>
- Report.Not_Applicable("System not capable of supporting external " &
- "text files -- Name_Error/Use_Error raised " &
- "during text file creation");
- Not_Applicable_System := True;
- when The_Error : others =>
- Report.Failed ("The following exception was raised in the " &
- "Test_Block: " & Exception_Name(The_Error));
- end Test_Block;
-
- Delete_Block:
- begin
- Delete_File ( New_Input_File, 1 );
- Delete_File ( New_Output_File, 2 );
- Delete_File ( New_Error_File_1, 3 );
- Delete_File ( New_Error_File_2, 4 );
- end Delete_Block;
-
- Report.Result;
-
-end CXAA016;
diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxaa017.a b/gcc/testsuite/ada/acats/tests/cxa/cxaa017.a
deleted file mode 100644
index 17d0922cc24..00000000000
--- a/gcc/testsuite/ada/acats/tests/cxa/cxaa017.a
+++ /dev/null
@@ -1,400 +0,0 @@
--- CXAA017.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that Ada.Text_IO function Look_Ahead sets parameter End_Of_Line
--- to True if at the end of a line; otherwise check that it returns the
--- next character from a file (without consuming it), while setting
--- End_Of_Line to False.
---
--- Check that Ada.Text_IO function Get_Immediate will return the next
--- control or graphic character in parameter Item from the specified
--- file. Check that the version of Ada.Text_IO function Get_Immediate
--- with the Available parameter will, if a character is available in the
--- specified file, return the character in parameter Item, and set
--- parameter Available to True.
---
--- TEST DESCRIPTION:
--- This test exercises specific capabilities of two Text_IO subprograms,
--- Look_Ahead and Get_Immediate. A file is prepared that contains a
--- variety of graphic and control characters on several lines.
--- In processing this file, a call to Look_Ahead is performed to ensure
--- that characters are available, then individual characters are
--- extracted from the current line using Get_Immediate. The characters
--- returned from both subprogram calls are compared with the expected
--- character result. Processing on each file line continues until
--- Look_Ahead indicates that the end of the line is next. Separate
--- verification is performed to ensure that all characters of each line
--- are processed, and that the Available and End_Of_Line parameters
--- of the subprograms are properly set in the appropriate instances.
---
--- APPLICABILITY CRITERIA:
--- This test is applicable to implementations capable of supporting
--- external Text_IO files.
---
---
--- CHANGE HISTORY:
--- 30 May 95 SAIC Initial prerelease version.
--- 01 May 96 SAIC Incorporated reviewer comments for ACVC 2.1.
--- 26 Feb 97 PWB.CTA Allowed for non-support of some IO operations.
---!
-
-with Ada.Text_IO;
-package CXAA017_0 is
-
- User_Defined_Input_File : aliased Ada.Text_IO.File_Type;
-
-end CXAA017_0;
-
-
-with CXAA017_0; use CXAA017_0;
-with Ada.Characters.Latin_1;
-with Ada.Exceptions;
-with Ada.Text_IO;
-with Report;
-
-procedure CXAA017 is
-
- use Ada.Characters.Latin_1;
- use Ada.Exceptions;
- use Ada.Text_IO;
-
- Non_Applicable_System : exception;
- No_Reset : exception;
-
-begin
-
- Report.Test ("CXAA017", "Check that Ada.Text_IO subprograms " &
- "Look_Ahead and Get_Immediate are available " &
- "and produce correct results");
-
- Test_Block:
- declare
-
- User_Input_Ptr : File_Access := User_Defined_Input_File'Access;
-
- UDLA_Char, -- Acronym UDLA => "User Defined Look Ahead"
- UDGI_Char, -- Acronym UDGI => "User Defined Get Immediate"
- TC_Char : Character := Ada.Characters.Latin_1.NUL;
-
- UDLA_End_Of_Line,
- UDGI_Available : Boolean := False;
-
- Char_Pos : Natural;
-
- -- This string contains five ISO 646 Control characters and six ISO 646
- -- Graphic characters:
- TC_String_1 : constant String := STX &
- SI &
- DC2 &
- CAN &
- US &
- Space &
- Ampersand &
- Solidus &
- 'A' &
- LC_X &
- DEL;
-
- -- This string contains two ISO 6429 Control and six ISO 6429 Graphic
- -- characters:
- TC_String_2 : constant String := IS4 &
- SCI &
- Yen_Sign &
- Masculine_Ordinal_Indicator &
- UC_I_Grave &
- Multiplication_Sign &
- LC_C_Cedilla &
- LC_Icelandic_Thorn;
-
- TC_Number_Of_Strings : constant := 2;
-
- type String_Access_Type is access constant String;
- type String_Ptr_Array_Type is
- array (1..TC_Number_Of_Strings) of String_Access_Type;
-
- TC_String_Ptr_Array : String_Ptr_Array_Type :=
- (new String'(TC_String_1),
- new String'(TC_String_2));
-
-
-
- procedure Create_New_File (The_File : in out File_Type;
- Mode : in File_Mode;
- Next : in Integer) is
- begin
- Create (The_File, Mode, Report.Legal_File_Name(Next));
- exception
- -- The following two exceptions can be raised if a system is not
- -- capable of supporting external Text_IO files. The handler will
- -- raise a user-defined exception which will result in a
- -- Not_Applicable result for the test.
- when Use_Error | Name_Error => raise Non_Applicable_System;
- end Create_New_File;
-
-
-
- procedure Load_File (The_File : in out File_Type) is
- -- This procedure will load several strings into the file denoted
- -- by the input parameter. A call to New_Line will add line/page
- -- termination characters, which will be available for processing
- -- along with the text in the file.
- begin
- Put_Line (The_File, TC_String_Ptr_Array(1).all);
- New_Line (The_File, Spacing => 1);
- Put_Line (The_File, TC_String_Ptr_Array(2).all);
- end Load_File;
-
-
- begin
-
- -- Create user-defined text file that will serve as the appropriate
- -- sources of input to the procedures under test.
-
- Create_New_File (User_Defined_Input_File, Out_File, 1);
-
- -- Enter several lines of text into the new input file.
- -- The characters that make up these text strings will be processed
- -- using the procedures being exercised in this test.
-
- Load_File (User_Defined_Input_File);
-
- -- Check that Mode_Error is raised by Look_Ahead and Get_Immedidate
- -- if the mode of the file object is not In_File.
- -- Currently, the file mode is Out_File.
-
- begin
- Look_Ahead(User_Defined_Input_File, UDLA_Char, UDLA_End_Of_Line);
- Report.Failed("Mode_Error not raised by Look_Ahead");
- Report.Comment("This char should never be printed: " & UDLA_Char);
- exception
- when Mode_Error => null; -- OK, expected exception.
- when The_Error : others =>
- Report.Failed ("The following exception was raised during the " &
- "check that Look_Ahead raised Mode_Error when " &
- "provided a file object that is not in In_File " &
- "mode: " & Exception_Name(The_Error));
- end;
-
- begin
- Get_Immediate(User_Defined_Input_File, UDGI_Char);
- Report.Failed("Mode_Error not raised by Get_Immediate");
- Report.Comment("This char should never be printed: " & UDGI_Char);
- exception
- when Mode_Error => null; -- OK, expected exception.
- when The_Error : others =>
- Report.Failed ("The following exception was raised during the " &
- "check that Get_Immediate raised Mode_Error " &
- "when provided a file object that is not in " &
- "In_File mode: " & Exception_Name(The_Error));
- end;
-
-
- -- The file will then be reset to In_File mode to properly function as
- -- a source of input.
-
- Reset1:
- begin
- Reset (User_Defined_Input_File, In_File);
- exception
- when Ada.Text_IO.Use_Error =>
- Report.Not_Applicable
- ( "Reset to In_File not supported for Text_IO" );
- raise No_Reset;
- end Reset1;
-
- -- Process the input file, exercising various Text_IO
- -- functionality, and validating the results at each step.
- -- Note: The designated File_Access object is used in processing
- -- the New_Default_Input_File in the second loop below.
-
- -- Process characters in first line of text of each file.
-
- Char_Pos := 1;
-
- -- Check that the first line is not blank.
-
- Look_Ahead(User_Defined_Input_File, UDLA_Char, UDLA_End_Of_Line);
-
- while not UDLA_End_Of_Line loop
-
- -- Use the Get_Immediate procedure on the file to get the next
- -- available character on the current line.
-
- Get_Immediate(User_Defined_Input_File, UDGI_Char);
-
- -- Check that the characters returned by both procedures are the
- -- same, and that they match the expected character from the file.
-
- if UDLA_Char /= TC_String_Ptr_Array(1).all(Char_Pos) or
- UDGI_Char /= TC_String_Ptr_Array(1).all(Char_Pos)
- then
- Report.Failed("Incorrect retrieval of character " &
- Integer'Image(Char_Pos) & " of first string");
- end if;
-
- -- Increment the character position counter.
- Char_Pos := Char_Pos + 1;
-
- -- Check the next character on the line. If at the end of line,
- -- the processing flow will exit the While loop.
-
- Look_Ahead(User_Defined_Input_File, UDLA_Char, UDLA_End_Of_Line);
-
- end loop;
-
- -- Check to ensure that the "end of line" results returned from the
- -- Look_Ahead procedure (used to exit the above While loop) corresponds
- -- with the result of Function End_Of_Line.
-
- if not End_Of_Line(User_Defined_Input_File)
- then
- Report.Failed("Result of procedure Look_Ahead that indicated " &
- "being at the end of the line does not correspond " &
- "with the result of function End_Of_Line");
- end if;
-
- -- Check that all characters in the string were processed.
-
- if Char_Pos-1 /= TC_String_1'Length then
- Report.Failed("Not all of the characters on the first line " &
- "were processed");
- end if;
-
-
- -- Call procedure Skip_Line to advance beyond the end of the first line.
-
- Skip_Line(User_Defined_Input_File);
-
-
- -- Process the second line in the file (a blank line).
-
- Look_Ahead(User_Input_Ptr.all, UDLA_Char, UDLA_End_Of_Line);
-
- if not UDLA_End_Of_Line then
- Report.Failed("Incorrect end of line determination from procedure " &
- "Look_Ahead when processing a blank line");
- end if;
-
- -- Call procedure Skip_Line to advance beyond the end of the second line.
-
- Skip_Line(User_Input_Ptr.all);
-
-
- -- Process characters in the third line of the file (second line
- -- of text)
- -- Note: The version of Get_Immediate used in processing this line has
- -- the Boolean parameter Available.
-
- Char_Pos := 1;
-
- -- Check whether the line is blank (i.e., at end of line, page, or file).
-
- Look_Ahead(User_Input_Ptr.all, UDLA_Char, UDLA_End_Of_Line);
-
- while not UDLA_End_Of_Line loop
-
- -- Use the Get_Immediate procedure on the file to get access to the
- -- next character on the current line.
-
- Get_Immediate(User_Input_Ptr.all, UDGI_Char, UDGI_Available);
-
- -- Check that the Available parameter of Get_Immediate was set
- -- to indicate that a character was available in the file.
- -- Check that the characters returned by both procedures are the
- -- same, and they all match the expected character from the file.
-
- if not UDGI_Available or
- UDLA_Char /= TC_String_Ptr_Array(2).all(Char_Pos) or
- UDGI_Char /= TC_String_Ptr_Array(2).all(Char_Pos)
- then
- Report.Failed("Incorrect retrieval of character " &
- Integer'Image(Char_Pos) & " of second string");
- end if;
-
- -- Increment the character position counter.
-
- Char_Pos := Char_Pos + 1;
-
- -- Check the next character on the line. If at the end of line,
- -- the processing flow will exit the While loop.
-
- Look_Ahead(User_Input_Ptr.all, UDLA_Char, UDLA_End_Of_Line);
-
- end loop;
-
- -- Check to ensure that the "end of line" results returned from the
- -- Look_Ahead procedure (used to exit the above While loop) corresponds
- -- with the result of Function End_Of_Line.
-
- if not End_Of_Line(User_Defined_Input_File)
- then
- Report.Failed("Result of procedure Look_Ahead that indicated " &
- "being at the end of the line does not correspond " &
- "with the result of function End_Of_Line");
- end if;
-
- -- Check that all characters in the second string were processed.
-
- if Char_Pos-1 /= TC_String_2'Length then
- Report.Failed("Not all of the characters on the second line " &
- "were processed");
- end if;
-
-
- Deletion:
- begin
- -- Delete the user defined file.
-
- if Is_Open(User_Defined_Input_File) then
- Delete(User_Defined_Input_File);
- else
- Open(User_Defined_Input_File, Out_File, Report.Legal_File_Name(1));
- Delete(User_Defined_Input_File);
- end if;
- exception
- when others =>
- Report.Failed
- ( "Delete not properly implemented for Text_IO" );
- end Deletion;
-
-
- exception
-
- when No_Reset =>
- null;
-
- when Non_Applicable_System =>
- Report.Not_Applicable("System not capable of supporting external " &
- "text files -- Name_Error/Use_Error raised " &
- "during text file creation");
- when The_Error : others =>
- Report.Failed ("The following exception was raised in the " &
- "Test_Block: " & Exception_Name(The_Error));
- end Test_Block;
-
- Report.Result;
-
-end CXAA017;
diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxaa018.a b/gcc/testsuite/ada/acats/tests/cxa/cxaa018.a
deleted file mode 100644
index 53b16fea498..00000000000
--- a/gcc/testsuite/ada/acats/tests/cxa/cxaa018.a
+++ /dev/null
@@ -1,277 +0,0 @@
--- CXAA018.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that the subprograms defined in the package Text_IO.Modular_IO
--- provide correct results.
---
--- TEST DESCRIPTION:
--- This test checks that the subprograms defined in the
--- Ada.Text_IO.Modular_IO package provide correct results.
--- A modular type is defined and used to instantiate the generic
--- package Ada.Text_IO.Modular_IO. Values of the modular type are
--- written to a Text_IO file, and to a series of string variables, using
--- different versions of the procedure Put from the instantiated IO
--- package. These modular data items are retrieved from the file and
--- string variables using the appropriate instantiated version of
--- procedure Get. A variety of Base and Width parameter values are
--- used in the procedure calls.
---
--- APPLICABILITY CRITERIA:
--- This test is applicable to all implementations that support Text_IO
--- processing and external files.
---
---
--- CHANGE HISTORY:
--- 03 Jul 95 SAIC Initial prerelease version.
--- 01 May 96 SAIC Incorporated reviewer comments for ACVC 2.1.
---
---!
-
-with Ada.Text_IO;
-with System;
-with Report;
-
-procedure CXAA018 is
-begin
-
- Report.Test ("CXAA018", "Check that the subprograms defined in " &
- "the package Text_IO.Modular_IO provide " &
- "correct results");
-
- Test_for_Text_IO_Support:
- declare
- Data_File : Ada.Text_IO.File_Type;
- Data_Filename : constant String := Report.Legal_File_Name;
- begin
-
- -- An application creates a text file in mode Out_File, with the
- -- intention of entering modular data into the file as appropriate.
- -- In the event that the particular environment where the application
- -- is running does not support Text_IO, Use_Error or Name_Error will be
- -- raised on calls to Text_IO operations. Either of these exceptions
- -- will be handled to produce a Not_Applicable result.
-
- Ada.Text_IO.Create (File => Data_File,
- Mode => Ada.Text_IO.Out_File,
- Name => Data_Filename);
-
- Test_Block:
- declare
-
- type Mod_Type is mod System.Max_Binary_Modulus;
- -- Max_Binary_Modulus must be at least 2**16, which would result
- -- in a base range of 0..65535 (zero to one less than the given
- -- modulus) for this modular type.
-
- package Mod_IO is new Ada.Text_IO.Modular_IO(Mod_Type);
- use Ada.Text_IO, Mod_IO;
- use type Mod_Type;
-
- Number_Of_Modular_Items : constant := 6;
- Number_Of_Error_Items : constant := 1;
-
- TC_Modular : Mod_Type;
- TC_Last_Character_Read : Positive;
-
- Modular_Array : array (1..Number_Of_Modular_Items) of Mod_Type :=
- ( 0, 97, 255, 1025, 12097, 65535 );
-
-
- procedure Load_File (The_File : in out Ada.Text_IO.File_Type) is
- begin
- -- This procedure does not create, open, or close the data file;
- -- The_File file object must be Open at this point.
- -- This procedure is designed to load Modular_Type data into a
- -- data file.
- --
- -- Use the Modular_IO procedure Put to enter modular data items
- -- into the data file.
-
- for i in 1..Number_Of_Modular_Items loop
- -- Use default Base parameter of 10.
- Mod_IO.Put(File => Data_File,
- Item => Modular_Array(i),
- Width => 6,
- Base => Mod_IO.Default_Base);
- end loop;
-
- -- Enter data into the file such that on the corresponding "Get"
- -- of this data, Data_Error must be raised. This value is outside
- -- the base range of Modular_Type.
- -- Text_IO is used to enter the value in the file.
-
- for i in 1..Number_Of_Error_Items loop
- Ada.Text_IO.Put(The_File, "-10");
- end loop;
-
- end Load_File;
-
-
-
- procedure Process_File(The_File : in out Ada.Text_IO.File_Type) is
- begin
- -- This procedure does not create, open, or close the data file;
- -- The_File file object must be Open at this point.
- -- Use procedure Get (for Files) to extract the modular data from
- -- the Text_IO file.
-
- for i in 1..Number_Of_Modular_Items loop
- Mod_IO.Get(The_File, TC_Modular, Width => 6);
-
- if TC_Modular /= Modular_Array(i) then
- Report.Failed("Incorrect modular data read from file " &
- "data item #" & Integer'Image(i));
- end if;
- end loop;
-
- -- The final item in the Data_File is a modular value that is
- -- outside the base range 0..Num'Last. This value should raise
- -- Data_Error on an attempt to "Get" it from the file.
-
- for i in 1..Number_Of_Error_Items loop
- begin
- Mod_IO.Get(The_File, TC_Modular, Mod_IO.Default_Width);
- Report.Failed
- ("Exception Data_Error not raised when Get " &
- "was used to read modular data outside base " &
- "range of type, item # " &
- Integer'Image(i));
- exception
- when Ada.Text_IO.Data_Error =>
- null; -- OK, expected exception.
- when others =>
- Report.Failed("Unexpected exception raised when Get " &
- "was used to read modular data outside " &
- "base range of type from Data_File, " &
- "data item #" & Integer'Image(i));
- end;
- end loop;
-
- exception
- when others =>
- Report.Failed
- ("Unexpected exception raised in Process_File");
- end Process_File;
-
-
-
- begin -- Test_Block.
-
- -- Place modular values into data file.
-
- Load_File(Data_File);
- Ada.Text_IO.Close(Data_File);
-
- -- Read modular values from data file.
-
- Ada.Text_IO.Open(Data_File, Ada.Text_IO.In_File, Data_Filename);
- Process_File(Data_File);
-
- -- Verify versions of Modular_IO procedures Put and Get for Strings.
-
- Modular_IO_in_Strings:
- declare
- TC_String_Array : array (1..Number_Of_Modular_Items)
- of String(1..30) := (others =>(others => ' '));
- begin
-
- -- Place modular values into strings using the Procedure Put,
- -- Use a variety of different "Base" parameter values.
- -- Note: This version of Put uses the length of the given
- -- string as the value of the "Width" parameter.
-
- for i in 1..2 loop
- Mod_IO.Put(To => TC_String_Array(i),
- Item => Modular_Array(i),
- Base => Mod_IO.Default_Base);
- end loop;
- for i in 3..4 loop
- Mod_IO.Put(TC_String_Array(i),
- Modular_Array(i),
- Base => 2);
- end loop;
- for i in 5..6 loop
- Mod_IO.Put(TC_String_Array(i), Modular_Array(i), 16);
- end loop;
-
- -- Get modular values from strings using the Procedure Get.
- -- Compare with expected modular values.
-
- for i in 1..Number_Of_Modular_Items loop
-
- Mod_IO.Get(From => TC_String_Array(i),
- Item => TC_Modular,
- Last => TC_Last_Character_Read);
-
- if TC_Modular /= Modular_Array(i) then
- Report.Failed("Incorrect modular data value obtained " &
- "from String following use of Procedures " &
- "Put and Get from Strings, Modular_Array " &
- "item #" & Integer'Image(i));
- end if;
- end loop;
-
- exception
- when others =>
- Report.Failed("Unexpected exception raised during the " &
- "evaluation of Put and Get for Strings");
- end Modular_IO_in_Strings;
-
- exception
- when others => Report.Failed ("Exception raised in Test_Block");
- end Test_Block;
-
-
- -- Delete the external file.
- if Ada.Text_IO.Is_Open(Data_File) then
- Ada.Text_IO.Delete(Data_File);
- else
- Ada.Text_IO.Open(Data_File,
- Ada.Text_IO.In_File,
- Data_Filename);
- Ada.Text_IO.Delete(Data_File);
- end if;
-
- exception
-
- -- Since Use_Error can be raised if, for the specified mode,
- -- the environment does not support Text_IO operations, the
- -- following handlers are included:
-
- when Ada.Text_IO.Use_Error =>
- Report.Not_Applicable ("Use_Error raised on Text_IO Create");
-
- when Ada.Text_IO.Name_Error =>
- Report.Not_Applicable ("Name_Error raised on Text_IO Create");
-
- when others =>
- Report.Failed ("Unexpected exception raised on text file Create");
-
- end Test_for_Text_IO_Support;
-
- Report.Result;
-
-end CXAA018;
diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxaa019.a b/gcc/testsuite/ada/acats/tests/cxa/cxaa019.a
deleted file mode 100644
index 04c257e97b6..00000000000
--- a/gcc/testsuite/ada/acats/tests/cxa/cxaa019.a
+++ /dev/null
@@ -1,138 +0,0 @@
--- CXAA019.A
---
--- Grant of Unlimited Rights
---
--- The Ada Conformity Assessment Authority (ACAA) holds unlimited
--- rights in the software and documentation contained herein. Unlimited
--- rights are the same as those granted by the U.S. Government for older
--- parts of the Ada Conformity Assessment Test Suite, and are defined
--- in DFAR 252.227-7013(a)(19). By making this public release, the ACAA
--- intends to confer upon all recipients unlimited rights equal to those
--- held by the ACAA. These rights include rights to use, duplicate,
--- release or disclose the released technical data and computer software
--- in whole or in part, in any manner and for any purpose whatsoever, and
--- to have or permit others to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that Standard_Output can be flushed. Check that 'in' parameters of
--- types Ada.Text_IO.File_Type and Ada.Streams.Stream_IO.File_Type can be
--- flushed. (Defect Report 8652/0051).
---
--- CHANGE HISTORY:
--- 12 FEB 2001 PHL Initial version
--- 16 MAR 2001 RLB Readied for release; fixed Not_Applicable check
--- to terminate test gracefully.
---
---!
-with Ada.Streams.Stream_Io;
-use Ada.Streams;
-with Ada.Text_Io;
-with Ada.Wide_Text_Io;
-with Report;
-use Report;
-procedure CXAA019 is
-
- procedure Check (File : in Ada.Text_Io.File_Type) is
- begin
- Ada.Text_Io.Put_Line
- (File, " - CXAA019 About to flush a Text_IO file passed " &
- "as 'in' parameter");
- Ada.Text_Io.Flush (File);
- end Check;
-
- procedure Check (File : in Ada.Wide_Text_Io.File_Type) is
- begin
- Ada.Wide_Text_Io.Put_Line
- (File, " - CXAA019 About to flush a Wide_Text_IO file passed " &
- "as 'in' parameter");
- Ada.Wide_Text_Io.Flush (File);
- end Check;
-
- procedure Check (File : in Stream_Io.File_Type) is
- S : Stream_Element_Array (1 .. 10);
- begin
- for I in S'Range loop
- S (I) := Stream_Element (Character'Pos ('A') + I);
- end loop;
- Stream_Io.Write (File, S);
- Comment ("About to flush a Stream_IO file passed as 'in' parameter");
- Stream_Io.Flush (File);
- end Check;
-
-
-begin
- Test ("CXAA019",
- "Check that Standard_Output can be flushed; check that " &
- "'in' Ada.Text_IO.File_Type and Ada.Streams.Stream_IO.File_Type" &
- "parameters can be flushed");
-
- Ada.Text_Io.Put_Line (Ada.Text_Io.Standard_Output,
- " - CXAA019 About to flush Standard_Output");
- Ada.Text_Io.Flush (Ada.Text_Io.Standard_Output);
-
- Check (Ada.Text_Io.Current_Output);
-
- declare
- TC_OK : Boolean := False;
- F : Ada.Text_Io.File_Type;
- begin
- begin
- Ada.Text_Io.Create (F, Name => Legal_File_Name (X => 1));
- TC_OK := True;
- exception
- when others =>
- Not_Applicable ("Unable to create Out mode Text_IO file");
- end;
- if TC_OK then
- Check (F);
- Ada.Text_Io.Delete (F);
- end if;
- end;
-
- declare
- TC_OK : Boolean := False;
- F : Ada.Wide_Text_Io.File_Type;
- begin
- begin
- Ada.Wide_Text_Io.Create (F, Name => Legal_File_Name (X => 2));
- TC_OK := True;
- exception
- when others =>
- Not_Applicable ("Unable to create Out mode Wide_Text_IO file");
- end;
- if TC_OK then
- Check (F);
- Ada.Wide_Text_Io.Delete (F);
- end if;
- end;
-
- declare
- TC_OK : Boolean := False;
- F : Stream_Io.File_Type;
- begin
- begin
- Stream_Io.Create (F, Name => Legal_File_Name (X => 3));
- TC_OK := True;
- exception
- when others =>
- Not_Applicable ("Unable to create Out mode Stream_IO file");
- end;
- if TC_OK then
- Check (F);
- Stream_Io.Delete (F);
- end if;
- end;
-
- Result;
-end CXAA019;
-
diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxab001.a b/gcc/testsuite/ada/acats/tests/cxa/cxab001.a
deleted file mode 100644
index 483acd16cb2..00000000000
--- a/gcc/testsuite/ada/acats/tests/cxa/cxab001.a
+++ /dev/null
@@ -1,272 +0,0 @@
--- CXAB001.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that the operations defined in package Wide_Text_IO allow for
--- the input/output of Wide_Character and Wide_String data.
---
--- TEST DESCRIPTION:
--- This test is designed to exercise the components of the Wide_Text_IO
--- package, including the Put/Get utilities for Wide_Characters and
--- Wide_String objects.
--- The test utilizes the Put and Get procedures defined for
--- Wide_Characters, as well as the Put, Get, Put_Line, and Get_Line
--- procedures defined for Wide_Strings. In addition, many of the
--- additional subprograms found in package Wide_Text_IO are used in this
--- test.
---
--- APPLICABILITY CRITERIA:
--- This test is applicable to all implementations capable of supporting
--- external Wide_Text_IO files.
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 26 Feb 97 CTA.PWB Allowed for non-support of some IO operations.
---!
-
-with Ada.Wide_Text_IO;
-with Report;
-
-procedure CXAB001 is
-
- Filter_File : Ada.Wide_Text_IO.File_Type;
- Filter_Filename : constant String :=
- Report.Legal_File_Name ( Nam => "CXAB001" );
- Incomplete : exception;
-
-
-begin
-
- Report.Test ("CXAB001", "Check that the operations defined in package " &
- "Wide_Text_IO allow for the input/output of " &
- "Wide_Character and Wide_String data");
-
-
- Test_for_Wide_Text_IO_Support:
- begin
-
- -- An implementation that does not support Wide_Text_IO in a particular
- -- environment will raise Use_Error on calls to various
- -- Wide_Text_IO operations. This block statement encloses a call to
- -- Create, which should raise an exception in a non-supportive
- -- environment. This exception will be handled to produce a
- -- Not_Applicable result.
-
- Ada.Wide_Text_IO.Create (File => Filter_File, -- Create.
- Mode => Ada.Wide_Text_IO.Out_File,
- Name => Filter_Filename);
-
- exception
-
- when Ada.Wide_Text_IO.Use_Error | Ada.Wide_Text_IO.Name_Error =>
- Report.Not_Applicable
- ( "Files not supported - Create as Out_File for Wide_Text_IO" );
- raise Incomplete;
-
- end Test_for_Wide_Text_IO_Support;
-
- Operational_Test_Block:
- declare
-
- First_String : constant Wide_String := "Somewhere ";
- Second_String : constant Wide_String := "Over The ";
- Third_String : constant Wide_String := "Rainbow";
- Current_Char : Wide_Character := ' ';
-
- begin
-
- Enter_Data_In_File:
- declare
- Pos : Natural := 1;
- Bad_Character_Found : Boolean := False;
- begin
- -- Use the Put procedure defined for Wide_Character data to
- -- write all of the wide characters of the First_String into
- -- the file individually, followed by a call to New_Line.
-
- while Pos <= First_String'Length loop
- Ada.Wide_Text_IO.Put (Filter_File, First_String (Pos)); -- Put.
- Pos := Pos + 1;
- end loop;
- Ada.Wide_Text_IO.New_Line (Filter_File); -- New_Line.
-
- -- Reset to In_File mode and read file contents, using the Get
- -- procedure defined for Wide_Character data.
- Reset1:
- begin
- Ada.Wide_Text_IO.Reset (Filter_File, -- Reset.
- Ada.Wide_Text_IO.In_File);
- exception
- when Ada.Wide_Text_IO.Use_Error =>
- Report.Not_Applicable
- ( "Reset to In_File not supported for Wide_Text_IO" );
- raise Incomplete;
- end Reset1;
-
- Pos := 1;
- while Pos <= First_String'Length loop
- Ada.Wide_Text_IO.Get (Filter_File, Current_Char); -- Get.
- -- Verify the wide character against the original string.
- if Current_Char /= First_String(Pos) then
- Bad_Character_Found := True;
- end if;
- Pos := Pos + 1;
- end loop;
-
- if Bad_Character_Found then
- Report.Failed ("Incorrect Wide_Character read from file - 1");
- end if;
-
- -- Following user file/string processing, the Wide_String data
- -- of the Second_String and Third_String Wide_String objects are
- -- appended to the file.
- -- The Put procedure defined for Wide_String data is used to
- -- transfer the Second_String, followed by a call to New_Line.
- -- The Put_Line procedure defined for Wide_String data is used
- -- to transfer the Third_String.
- Reset2:
- begin
- Ada.Wide_Text_IO.Reset (Filter_File, -- Reset.
- Ada.Wide_Text_IO.Append_File);
-
- exception
- when Ada.Wide_Text_IO.Use_Error =>
- Report.Not_Applicable
- ( "Reset to Append_File not supported for Wide_Text_IO" );
- raise Incomplete;
- end Reset2;
-
- Ada.Wide_Text_IO.Put (Filter_File, Second_String); -- Put.
- Ada.Wide_Text_IO.New_Line (Filter_File); -- New_Line.
-
- Ada.Wide_Text_IO.Put_Line (Filter_File, Third_String); -- Put_Line.
- Ada.Wide_Text_IO.Close (Filter_File); -- Close.
-
- exception
-
- when Incomplete =>
- raise;
-
- when others =>
- Report.Failed ("Exception in Enter_Data_In_File block");
- raise;
-
- end Enter_Data_In_File;
-
- ---
-
- Filter_Block:
- declare
-
- Pos : Positive := 1;
- TC_String2 : Wide_String (1..Second_String'Length);
- TC_String3 : Wide_String (1..Third_String'Length);
- Last : Natural := Natural'First;
-
- begin
-
- Ada.Wide_Text_IO.Open (Filter_File, -- Open.
- Ada.Wide_Text_IO.In_File,
- Filter_Filename);
-
-
- -- Read the data of the First_String from the file, using the
- -- Get procedure defined for Wide_Character data.
- -- Verify that the character corresponds to the data originally
- -- written to the file.
-
- while Pos <= First_String'Length loop
- Ada.Wide_Text_IO.Get (Filter_File, Current_Char); -- Get.
- if Current_Char /= First_String(Pos) then
- Report.Failed
- ("Incorrect Wide_Character read from file - 2");
- end if;
- Pos := Pos + 1;
- end loop;
-
- -- The first line of the file has been read, move to the second.
- Ada.Wide_Text_IO.Skip_Line (Filter_File); -- Skip_Line.
-
- -- Read the Wide_String data from the second and third lines of
- -- the file.
- Ada.Wide_Text_IO.Get (Filter_File, TC_String2); -- Get.
- Ada.Wide_Text_IO.Skip_Line (Filter_File); -- Skip_Line.
- Ada.Wide_Text_IO.Get_Line (Filter_File, -- Get_Line.
- TC_String3, Last);
-
- -- Verify data of second and third strings.
- if TC_String2 /= Second_String then
- Report.Failed ("Incorrect Wide_String read from file - 1");
- end if;
- if TC_String3 /= Third_String then
- Report.Failed ("Incorrect Wide_String read from file - 2");
- end if;
-
- -- The file should now be at EOF.
- if not Ada.Wide_Text_IO.End_Of_File (Filter_File) then -- EOF.
- Report.Failed ("File not empty following filtering");
- end if;
-
- exception
- when others =>
- Report.Failed ("Exception in Filter_Block");
- raise;
- end Filter_Block;
-
- exception
-
- when Incomplete =>
- raise;
- when others =>
- Report.Failed ("Exception raised in Operational Test Block");
-
- end Operational_Test_Block;
-
- Deletion:
- begin
- if Ada.Wide_Text_IO.Is_Open (Filter_File) then -- Is_Open.
- Ada.Wide_Text_IO.Delete (Filter_File); -- Delete.
- else
- Ada.Wide_Text_IO.Open (Filter_File, -- Open.
- Ada.Wide_Text_IO.Out_File,
- Filter_Filename);
- Ada.Wide_Text_IO.Delete (Filter_File); -- Delete.
- end if;
- exception
- when others =>
- Report.Failed ("Delete not properly implemented for Wide_Text_IO");
- end Deletion;
-
- Report.Result;
-
-exception
- when Incomplete =>
- Report.Result;
- when others =>
- Report.Failed ( "Unexpected exception" );
- Report.Result;
-
-end CXAB001;
diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxac001.a b/gcc/testsuite/ada/acats/tests/cxa/cxac001.a
deleted file mode 100644
index a77d561f5d6..00000000000
--- a/gcc/testsuite/ada/acats/tests/cxa/cxac001.a
+++ /dev/null
@@ -1,292 +0,0 @@
--- CXAC001.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that the attribute T'Write will, for any specific non-limited
--- type T, write an item of the subtype to the stream.
---
--- Check that the attribute T'Read will, for a specific non-limited
--- type T, read a value of the subtype from the stream.
---
--- TEST DESCRIPTION:
--- The scenario depicted in this test is that of an environment where
--- product data is stored in stream form, then reconstructed into the
--- appropriate data structures. Several records of product information
--- are stored in an array; the array is passed as a parameter to a
--- procedure for storage in the stream. A header is created based on the
--- number of data records stored in the array. The header is then written
--- to the stream, followed by each record maintained in the array.
--- In order to retrieve data from the stream, the header information is
--- read from the stream, and the data stored in the header is used to
--- perform the appropriate number of read operations of record data from
--- the stream. All data read from the stream is validated against the
---- values that were written to the stream.
---
--- APPLICABILITY CRITERIA:
--- Applicable to all systems capable of supporting IO operations on
--- external Stream_IO files.
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 08 Nov 95 SAIC Corrected call to Read in Procedure Retrieve_Data
--- for ACVC 2.0.1.
--- 27 Feb 08 PWB.CTA Allowed for non-support of certain IO operations.
---!
-
-with Ada.Streams.Stream_IO;
-with Report;
-
-procedure CXAC001 is
-
- package Strm_Pack renames Ada.Streams.Stream_IO;
- The_File : Strm_Pack.File_Type;
- The_Filename : constant String :=
- Report.Legal_File_Name ( Nam => "CXAC001" );
- Incomplete : exception;
-
-
-begin
-
- Report.Test ("CXAC001", "Check that the 'Read and 'Write attributes " &
- "will transfer an object of a specific, " &
- "non-limited type to/from a stream");
-
- Test_for_Stream_IO_Support:
- begin
-
- -- If an implementation does not support Stream_IO in a particular
- -- environment, the exception Use_Error or Name_Error will be raised on
- -- calls to various Stream_IO operations. This block statement
- -- encloses a call to Create, which should produce an exception in a
- -- non-supportive environment. These exceptions will be handled to
- -- produce a Not_Applicable result.
-
- Strm_Pack.Create (The_File, Strm_Pack.Out_File, The_Filename);
-
- exception
-
- when Ada.Streams.Stream_IO.Use_Error |
- Ada.Streams.Stream_IO.Name_Error =>
- Report.Not_Applicable
- ( "Files not supported - Create as Out_File for Stream_IO" );
- raise Incomplete;
-
- end Test_for_Stream_IO_Support;
-
- Operational_Test_Block:
- declare
-
- The_Stream : Strm_Pack.Stream_Access;
- Todays_Date : String (1 .. 6) := "271193";
-
- type ID_Type is range 1 .. 100;
- type Size_Type is (Small, Medium, Large, XLarge);
-
- type Header_Type is record
- Number_of_Elements : Natural := 0;
- Origination_Date : String (1 .. 6);
- end record;
-
- type Data_Type is record
- ID : ID_Type;
- Size : Size_Type;
- end record;
-
- type Data_Array_Type is array (Positive range <>) of Data_Type;
-
- Product_Information_1 : Data_Array_Type (1 .. 3) := ((20, Large),
- (55, Small),
- (89, XLarge));
-
- Product_Information_2 : Data_Array_Type (1 .. 4) := (( 5, XLarge),
- (27, Small),
- (79, Medium),
- (93, XLarge));
-
- procedure Store_Data ( The_Stream : in Strm_Pack.Stream_Access;
- The_Array : in Data_Array_Type ) is
- Header : Header_Type;
- begin
-
- -- Fill in header info.
- Header.Number_of_Elements := The_Array'Length;
- Header.Origination_Date := Todays_Date;
-
- -- Write header to stream.
- Header_Type'Write (The_Stream, Header);
-
- -- Write each record in the array to the stream.
- for I in 1 .. Header.Number_of_Elements loop
- Data_Type'Write (The_Stream, The_Array (I));
- end loop;
-
- end Store_Data;
-
- procedure Retrieve_Data (The_Stream : in Strm_Pack.Stream_Access;
- The_Header : out Header_Type;
- The_Array : out Data_Array_Type ) is
- begin
-
- -- Read header from the stream.
- Header_Type'Read (The_Stream, The_Header);
-
- -- Read the records from the stream into the array.
- for I in 1 .. The_Header.Number_of_Elements loop
- Data_Type'Read (The_Stream, The_Array (I));
- end loop;
-
- end Retrieve_Data;
-
- begin
-
- -- Assign access value.
- The_Stream := Strm_Pack.Stream (The_File);
-
- -- Product information is to be stored in the stream file. These
- -- data arrays are of different sizes (actually, the records
- -- are stored individually, not as a single array). Prior to the
- -- record data being written, a header record is initialized with
- -- information about the data to be written, then itself is written
- -- to the stream.
-
- Store_Data (The_Stream, Product_Information_1);
- Store_Data (The_Stream, Product_Information_2);
-
- Test_Verification_Block:
- declare
- Product_Header_1 : Header_Type;
- Product_Header_2 : Header_Type;
- Product_Array_1 : Data_Array_Type (1 .. 3);
- Product_Array_2 : Data_Array_Type (1 .. 4);
- begin
-
- Reset1:
- begin
- Strm_Pack.Reset (The_File, Strm_Pack.In_File);
- exception
- when Ada.Streams.Stream_IO.Use_Error =>
- Report.Not_Applicable
- ( "Reset to In_File not supported for Stream_IO" );
- raise Incomplete;
- end Reset1;
-
- -- Data is read from the stream, first the appropriate header,
- -- then the associated data records, which are then reconstructed
- -- into a data array of product information.
-
- Retrieve_Data (The_Stream, Product_Header_1, Product_Array_1);
-
- -- Validate a field in the header.
- if (Product_Header_1.Origination_Date /= Todays_Date) or
- (Product_Header_1.Number_of_Elements /= 3)
- then
- Report.Failed ("Incorrect Header_1 info read from stream");
- end if;
-
- -- Validate the data records read from the file.
- for I in 1 .. Product_Header_1.Number_of_Elements loop
- if (Product_Array_1(I) /= Product_Information_1(I)) then
- Report.Failed ("Incorrect Product 1 info read from" &
- " record: " & Integer'Image (I));
- end if;
- end loop;
-
- -- Repeat this read and verify operation for the next parcel of
- -- data. Again, header and data record information are read from
- -- the same stream file.
- Retrieve_Data (The_Stream, Product_Header_2, Product_Array_2);
-
- if (Product_Header_2.Origination_Date /= Todays_Date) or
- (Product_Header_2.Number_of_Elements /= 4)
- then
- Report.Failed ("Incorrect Header_2 info read from stream");
- end if;
-
- for I in 1 .. Product_Header_2.Number_of_Elements loop
- if (Product_Array_2(I) /= Product_Information_2(I)) then
- Report.Failed ("Incorrect Product_2 info read from" &
- " record: " & Integer'Image (I));
- end if;
- end loop;
-
- exception
-
- when Incomplete =>
- raise;
-
- when Strm_Pack.End_Error => -- If correct number of
- -- items not in file (data
- -- overwritten), then fail.
- Report.Failed ("Incorrect number of record elements in file");
- if not Strm_Pack.Is_Open (The_File) then
- Strm_Pack.Open (The_File, Strm_Pack.Out_File, The_Filename);
- end if;
-
- when others =>
- Report.Failed ("Exception raised in Data Verification Block");
- if not Strm_Pack.Is_Open (The_File) then
- Strm_Pack.Open (The_File, Strm_Pack.Out_File, The_Filename);
- end if;
-
- end Test_Verification_Block;
-
- exception
-
- when Incomplete =>
- raise;
-
- when others =>
- Report.Failed ("Exception raised in Operational Test Block");
-
- end Operational_Test_Block;
-
- Deletion:
- begin
- -- Delete the file.
- if Strm_Pack.Is_Open (The_File) then
- Strm_Pack.Delete (The_File);
- else
- Strm_Pack.Open (The_File, Strm_Pack.Out_File, The_Filename);
- Strm_Pack.Delete (The_File);
- end if;
-
- exception
-
- when others =>
- Report.Failed
- ( "Delete not properly implemented for Stream_IO" );
- end Deletion;
-
- Report.Result;
-
-exception
- when Incomplete =>
- Report.Result;
- when others =>
- Report.Failed ( "Unexpected exception" );
- Report.Result;
-
-end CXAC001;
diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxac002.a b/gcc/testsuite/ada/acats/tests/cxa/cxac002.a
deleted file mode 100644
index e4b303c4bc9..00000000000
--- a/gcc/testsuite/ada/acats/tests/cxa/cxac002.a
+++ /dev/null
@@ -1,426 +0,0 @@
--- CXAC002.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that the subprograms defined in package Ada.Streams.Stream_IO
--- are accessible, and that they provide the appropriate functionality.
---
--- TEST DESCRIPTION:
--- This test simulates a user filter designed to capitalize the
--- characters of a string. It utilizes a variety of the subprograms
--- contained in the package Ada.Streams.Stream_IO.
--- Its purpose is to demonstrate the use of a variety of the capabilities
--- found in the Ada.Streams.Stream_IO package.
---
--- APPLICABILITY CRITERIA:
--- This test is applicable to all implementations capable of supporting
--- external Stream_IO files.
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 14 Nov 95 SAIC Corrected visibility problems; corrected
--- subtest validating result from function Name
--- for ACVC 2.0.1.
--- 05 Oct 96 SAIC Removed calls to Close/Open in test and replaced
--- them with a single call to Reset (per AI95-0001)
--- 26 Feb 97 PWB.CTA Allowed for non-support of some IO operations.
--- 09 Feb 01 RLB Corrected non-support check to avoid unintended
--- failures.
---!
-
-package CXAC002_0 is
-
- -- This function searches for the first instance of a specified substring
- -- within a specified string, returning boolean result. (Case insensitive
- -- analysis)
-
- function Find (Str : in String; Sub : in String) return Boolean;
-
-end CXAC002_0;
-
-package body CXAC002_0 is
-
- function Find (Str : in String; Sub : in String) return Boolean is
-
- New_Str : String(Str'First..Str'Last);
- New_Sub : String(Sub'First..Sub'Last);
- Pos : Integer := Str'First; -- Character index.
-
- function Upper_Case (Str : in String) return String is
- subtype Upper is Character range 'A'..'Z';
- subtype Lower is Character range 'a'..'z';
- Ret : String(Str'First..Str'Last);
- Pos : Integer;
- begin
- for I in Str'Range loop
- if (Str(I) in Lower) then
- Pos := Upper'Pos(Upper'First) +
- (Lower'Pos(Str(I)) - Lower'Pos(Lower'First));
- Ret(I) := Upper'Val(Pos);
- else
- Ret(I) := Str (I);
- end if;
- end loop;
- return Ret;
- end Upper_Case;
-
- begin
-
- New_Str := Upper_Case(Str); -- Convert Str and Sub to upper
- New_Sub := Upper_Case(Sub); -- case for comparison.
-
- while (Pos <= New_Str'Last-New_Sub'Length+1) -- Search until no more
- and then -- sub-string-length
- (New_Str(Pos..Pos+New_Sub'Length-1) /= New_Sub) -- slices remain.
- loop
- Pos := Pos + 1;
- end loop;
-
- if (Pos > New_Str'Last-New_Sub'Length+1) then -- Substring not found.
- return False;
- else
- return True;
- end if;
-
- end Find;
-
-end CXAC002_0;
-
-
-with Ada.Streams.Stream_IO, CXAC002_0, Report;
-procedure CXAC002 is
- Filter_File : Ada.Streams.Stream_IO.File_Type;
- Filter_Stream : Ada.Streams.Stream_IO.Stream_Access;
- Filter_Filename : constant String :=
- Report.Legal_File_Name ( Nam => "CXAC002" );
- Incomplete : Exception;
-
-begin
-
- Report.Test ("CXAC002", "Check that the subprograms defined in " &
- "package Ada.Streams.Stream_IO are accessible, " &
- "and that they provide the appropriate " &
- "functionality");
-
- Test_for_Stream_IO_Support:
-
- begin
-
- -- If an implementation does not support Stream_IO in a particular
- -- environment, the exception Use_Error or Name_Error will be raised on
- -- calls to various Stream_IO operations. This block statement
- -- encloses a call to Create, which should produce an exception in a
- -- non-supportive environment. These exceptions will be handled to
- -- produce a Not_Applicable result.
-
- Ada.Streams.Stream_IO.Create (Filter_File, -- Create.
- Ada.Streams.Stream_IO.Out_File,
- Filter_Filename);
- exception
-
- when Ada.Streams.Stream_IO.Use_Error | Ada.Streams.Stream_IO.Name_Error =>
- Report.Not_Applicable
- ( "Files not supported - Create as Out_File for Stream_IO" );
- raise Incomplete;
-
- end Test_for_Stream_IO_Support;
-
- Operational_Test_Block:
- declare
-
- use CXAC002_0;
- use type Ada.Streams.Stream_IO.File_Mode;
- use type Ada.Streams.Stream_IO.Count;
-
- File_Size : Ada.Streams.Stream_IO.Count := -- Count.
- Ada.Streams.Stream_IO.Count'First; -- (0)
- File_Index : Ada.Streams.Stream_IO.Positive_Count := -- Pos. Count.
- Ada.Streams.Stream_IO.Positive_Count'First; -- (1)
-
- First_String : constant String := "this is going to be ";
- Second_String : constant String := "the best year of your life";
- Total_Length : constant Natural := First_String'Length +
- Second_String'Length;
- Current_Char : Character := ' ';
-
- Cap_String : String (1..Total_Length) := (others => ' ');
-
- TC_Capital_String : constant String :=
- "THIS IS GOING TO BE THE BEST YEAR OF YOUR LIFE";
-
- begin
-
- if not Ada.Streams.Stream_IO.Is_Open (Filter_File) then -- Is_Open
- Report.Failed ("File not open following Create");
- end if;
-
- -- Call function Find to determine if the filename (Sub) is contained
- -- in the result of Function Name.
-
- if not Find(Str => Ada.Streams.Stream_IO.Name(Filter_File), -- Name.
- Sub => Filter_Filename)
- then
- Report.Failed ("Function Name provided incorrect filename");
- end if;
- -- Stream.
- Filter_Stream := Ada.Streams.Stream_IO.Stream (Filter_File);
-
- ---
-
- Enter_Data_In_Stream:
- declare
- Pos : Natural := 1;
- Bad_Character_Found : Boolean := False;
- begin
-
- -- Enter data from the first string into the stream.
- while Pos <= Natural(First_String'Length) loop
- -- Write all characters of the First_String to the stream.
- Character'Write (Filter_Stream, First_String (Pos));
- Pos := Pos + 1;
- -- Ensure data put in file on a regular basis.
- if Pos mod 5 = 0 then
- Ada.Streams.Stream_IO.Flush (Filter_File); -- Flush.
- end if;
- end loop;
-
- Ada.Streams.Stream_IO.Flush (Filter_File); -- Flush.
- -- Reset to In_File mode and read stream contents.
- Reset1:
- begin
- Ada.Streams.Stream_IO.Reset (Filter_File, -- Reset.
- Ada.Streams.Stream_IO.In_File);
- exception
- when Ada.Streams.Stream_IO.Use_Error =>
- Report.Not_Applicable
- ( "Reset to In_File not supported for Stream_IO" );
- raise Incomplete;
- end Reset1;
-
- Pos := 1;
- while Pos <= First_String'Length loop
- -- Read one character from the stream.
- Character'Read (Filter_Stream, Current_Char); -- 'Read
- -- Verify character against the original string.
- if Current_Char /= First_String(Pos) then
- Bad_Character_Found := True;
- end if;
- Pos := Pos + 1;
- end loop;
-
- if Bad_Character_Found then
- Report.Failed ("Incorrect character read from stream");
- end if;
-
- -- Following user stream/string processing, the stream file is
- -- appended to as follows:
-
- Reset2:
- begin
- Ada.Streams.Stream_IO.Reset (Filter_File, -- Reset.
- Ada.Streams.Stream_IO.Append_File);
- exception
- when Ada.Streams.Stream_IO.Use_Error =>
- Report.Not_Applicable
- ( "Reset to Append_File not supported for Stream_IO" );
- raise Incomplete;
- end Reset2;
-
- if Ada.Streams.Stream_IO.Mode (Filter_File) /= -- Mode.
- Ada.Streams.Stream_IO.Append_File
- then
- Report.Failed ("Incorrect mode following Reset to Append");
- end if;
-
- Pos := 1;
- while Pos <= Natural(Second_String'Length) loop
- -- Write all characters of the Second_String to the stream.
- Character'Write (Filter_Stream, Second_String (Pos)); -- 'Write
- Pos := Pos + 1;
- end loop;
-
- Ada.Streams.Stream_IO.Flush (Filter_File); -- Flush.
-
- -- Record file statistics.
- File_Size := Ada.Streams.Stream_IO.Size (Filter_File); -- Size.
-
- Index_Might_Not_Be_Supported:
- begin
- File_Index := Ada.Streams.Stream_IO.Index (Filter_File); -- Index.
- exception
- when Ada.Streams.Stream_IO.Use_Error =>
- Report.Not_Applicable ( "Index not supported for Stream_IO" );
- raise Incomplete;
- end Index_Might_Not_Be_Supported;
-
- exception
- when Incomplete =>
- raise;
- when others =>
- Report.Failed ("Exception in Enter_Data_In_Stream block");
- raise;
- end Enter_Data_In_Stream;
-
- ---
-
- Filter_Block:
- declare
- Pos : Positive := 1;
- Full_String : constant String := First_String & Second_String;
-
- function Capitalize (Char : Character) return Character is
- begin
- if Char /= ' ' then
- return Character'Val( Character'Pos(Char) -
- (Character'Pos('a') - Character'Pos('A')));
- else
- return Char;
- end if;
- end Capitalize;
-
- begin
-
- Reset3:
- begin
- Ada.Streams.Stream_IO.Reset (Filter_File, -- Reset.
- Ada.Streams.Stream_IO.In_File);
- exception
- when Ada.Streams.Stream_IO.Use_Error =>
- Report.Not_Applicable
- ( "Reset to In_File not supported for Stream_IO" );
- raise Incomplete;
- end Reset3;
-
- if Ada.Streams.Stream_IO.Mode (Filter_File) /= -- Mode.
- Ada.Streams.Stream_IO.In_File
- then
- Report.Failed ("Incorrect mode following Reset to In_File");
- end if;
-
- if not Ada.Streams.Stream_IO.Is_Open (Filter_File) then -- Is_Open
- Report.Failed ( "Reset command did not leave file open" );
- end if;
-
- if Ada.Streams.Stream_IO.Size (Filter_File) /= -- Size.
- File_Size
- then
- Report.Failed ("Reset file is not correct size");
- end if;
-
- if Ada.Streams.Stream_IO.Index (Filter_File) /= 1 then -- Index.
- -- File position should have been reset to start of file.
- Report.Failed ("Index of file not set to 1 following Reset");
- end if;
-
- while Pos <= Full_String'Length loop
- -- Read one character from the stream.
- Character'Read (Filter_Stream, Current_Char); -- 'Read
- -- Verify character against the original string.
- if Current_Char /= Full_String(Pos) then
- Report.Failed ("Incorrect character read from stream");
- else
- -- Capitalize the characters read from the stream, and
- -- place them in a string variable.
- Cap_String(Pos) := Capitalize (Current_Char);
- end if;
- Pos := Pos + 1;
- end loop;
-
- -- File index should now be set to the position following the final
- -- character in the file (the same as the index value stored at
- -- the completion of the Enter_Data_In_Stream block).
- if Ada.Streams.Stream_IO.Index (Filter_File) /= -- Index.
- File_Index
- then
- Report.Failed ("Incorrect file index position");
- end if;
-
- -- The stream file should now be at EOF. -- EOF.
- if not Ada.Streams.Stream_IO.End_Of_File (Filter_File) then
- Report.Failed ("File not empty following filtering");
- end if;
-
- exception
-
- when Incomplete =>
- raise;
- when others =>
- Report.Failed ("Exception in Filter_Block");
- raise;
- end Filter_Block;
-
- ---
-
- Verification_Block:
- begin
-
- -- Verify that the entire string was examined, and that the
- -- process of capitalizing the character data was successful.
- if Cap_String /= TC_Capital_String then
- Report.Failed ("Incorrect Capitalization");
- end if;
-
- exception
- when others =>
- Report.Failed ("Exception in Verification_Block");
- end Verification_Block;
-
-
- exception
-
- when Incomplete =>
- raise;
- when others =>
- Report.Failed ("Exception raised in Operational Test Block");
-
- end Operational_Test_Block;
-
- Deletion:
- begin
- if Ada.Streams.Stream_IO.Is_Open (Filter_File) then -- Is_Open.
- Ada.Streams.Stream_IO.Delete (Filter_File); -- Delete.
- else
- Ada.Streams.Stream_IO.Open (Filter_File, -- Open.
- Ada.Streams.Stream_IO.Out_File,
- Filter_Filename);
- Ada.Streams.Stream_IO.Delete (Filter_File); -- Delete.
- end if;
- exception
- when others =>
- Report.Failed
- ( "Delete not properly implemented for Stream_IO" );
- end Deletion;
-
- Report.Result;
-
-exception
- when Incomplete =>
- Report.Result;
- when others =>
- Report.Failed ( "Unexpected exception" );
- Report.Result;
-
-end CXAC002;
diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxac003.a b/gcc/testsuite/ada/acats/tests/cxa/cxac003.a
deleted file mode 100644
index cc1e044d0a2..00000000000
--- a/gcc/testsuite/ada/acats/tests/cxa/cxac003.a
+++ /dev/null
@@ -1,376 +0,0 @@
--- CXAC003.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that the correct exceptions are raised when improperly
--- manipulating stream file objects.
---
--- TEST DESCRIPTION:
--- This test is designed to focus on Stream_IO file manipulation
--- exceptions. Several potentially common user errors are examined in
--- the test:
---
--- A Status_Error should be raised whenever an attempt is made to perform
--- an operation on a file that is closed.
---
--- A Status_Error should be raised when an attempt is made to open a
--- stream file that is currently open.
---
--- A Mode_Error should be raised when attempting to read from (use the
--- 'Read attribute) on an Out_File or Append_Mode file.
---
--- A Mode_Error should be raised when checking for End Of File on a
--- file with mode Out_File or Append_Mode.
---
--- A Mode_Error should be raised when attempting to write to (use the
--- 'Output attribute) on a file with mode In_File.
---
--- A Name_Error should be raised when the string provided to the Name
--- parameter of an Open operation does not allow association of an
--- external file.
---
--- APPLICABILITY CRITERIA:
--- This test is applicable to all implementations capable of supporting
--- external Stream_IO files.
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 25 Feb 97 PWB.CTA Allowed for non-support of some IO operations
--- 02 Mar 01 PHL Check that Ada.Streams.Stream_IO.Stream raises
--- Status_Error if the file is not open. (DR 8652/
--- 0056).
--- 15 Mar 01 RLB Readied for release.
---!
-
-with Ada.Streams.Stream_IO;
-with Report;
-
-procedure CXAC003 is
-
- Stream_File_Object : Ada.Streams.Stream_IO.File_Type;
- Stream_Access_Value : Ada.Streams.Stream_IO.Stream_Access;
- Stream_Filename : constant String :=
- Report.Legal_File_Name ( Nam => "CXAC003" );
- Incomplete : exception;
-
-begin
-
- Report.Test ("CXAC003", "Check that the correct exceptions are " &
- "raised when improperly manipulating stream " &
- "file objects");
-
- Test_for_Stream_IO_Support:
- begin
- -- If an implementation does not support Stream_IO in a particular
- -- environment, the exception Use_Error or Name_Error will be raised on
- -- calls to various Stream_IO operations. This block statement
- -- encloses a call to Create, which should produce an exception in a
- -- non-supportive environment. These exceptions will be handled to
- -- produce a Not_Applicable result.
-
- Ada.Streams.Stream_IO.Create (Stream_File_Object,
- Ada.Streams.Stream_IO.Out_File,
- Stream_Filename);
-
- exception
-
- when Ada.Streams.Stream_IO.Use_Error | Ada.Streams.Stream_IO.Name_Error =>
- Report.Not_Applicable
- ( "Files not supported - Create as Out_File for Stream_IO" );
- raise Incomplete;
-
- end Test_for_Stream_IO_Support;
-
- Operational_Test_Block:
- begin
- -- A potentially common error in a file processing environment
- -- is to attempt to perform an operation on a stream file that is
- -- not currently open. Status_Error should be raised in this case.
- Check_Status_Error:
- begin
- Ada.Streams.Stream_IO.Close (Stream_File_Object);
- -- Attempt to reset a file that is closed.
- Ada.Streams.Stream_IO.Reset (Stream_File_Object,
- Ada.Streams.Stream_IO.Out_File);
- Report.Failed ("Exception not raised on Reset of closed file");
- exception
- when Ada.Streams.Stream_IO.Status_Error =>
- null;
- when others =>
- Report.Failed ("Incorrect exception raised - 1");
- end Check_Status_Error;
-
- -- A similar error is to use Ada.Streams.Stream_IO.Stream
- -- to attempt to perform an operation on a stream file that is
- -- not currently open. Status_Error should be raised in this case.
- -- (Defect Report 8652/0046, as reflected in Technical Corrigendum 1.)
- Check_Status_Error2:
- begin
- -- Ensure that the file is not open.
- if Ada.Streams.Stream_Io.Is_Open (Stream_File_Object) then
- Ada.Streams.Stream_Io.Close (Stream_File_Object);
- end if;
- Stream_Access_Value :=
- Ada.Streams.Stream_Io.Stream (Stream_File_Object);
- Report.Failed ("Exception not raised on Stream of closed file");
- exception
- when Ada.Streams.Stream_Io.Status_Error =>
- null;
- when others =>
- Report.Failed ("Incorrect exception raised - 2");
- end Check_Status_Error2;
-
- -- Another potentially common error in a file processing environment
- -- is to attempt to Open a stream file that is currently open.
- -- Status_Error should be raised in this case.
- Check_Status_Error3:
- begin
- -- Ensure that the file is open.
- if not Ada.Streams.Stream_IO.Is_Open (Stream_File_Object) then
- Ada.Streams.Stream_IO.Open (Stream_File_Object,
- Ada.Streams.Stream_IO.In_File,
- Stream_Filename);
- end if;
- Ada.Streams.Stream_IO.Open (Stream_File_Object,
- Ada.Streams.Stream_IO.In_File,
- Stream_Filename);
- Report.Failed ("Exception not raised on Open of open file");
- exception
- when Ada.Streams.Stream_IO.Status_Error =>
- null;
- when others =>
- Report.Failed ("Incorrect exception raised - 3");
- end Check_Status_Error3;
-
- -- Another example of a potential error occurring in a file
- -- processing environment is to attempt to use the 'Read attribute
- -- on a stream file that is currently in Out_File or Append_File
- -- mode. Mode_Error should be raised in both of these cases.
- Check_Mode_Error:
- declare
- Int_Var : Integer := -10;
- begin
-
- Reset1:
- begin
- Ada.Streams.Stream_IO.Reset (Stream_File_Object,
- Ada.Streams.Stream_IO.Out_File);
- exception
- when Ada.Streams.Stream_IO.Use_Error =>
- Report.Not_Applicable
- ( "Reset to Out_File not supported for Stream_IO - 1" );
- raise Incomplete;
- end Reset1;
-
- Stream_Access_Value :=
- Ada.Streams.Stream_IO.Stream (Stream_File_Object);
- Integer'Write (Stream_Access_Value, Int_Var);
-
- -- File contains an integer value, but is of mode Out_File.
- Integer'Read (Stream_Access_Value, Int_Var);
- Report.Failed ("Exception not raised by 'Read of Out_File");
- exception
- when Incomplete =>
- raise;
- when Ada.Streams.Stream_IO.Mode_Error =>
- null;
- Try_Read:
- begin
- Reset2:
- begin
- Ada.Streams.Stream_IO.Reset
- (Stream_File_Object, Ada.Streams.Stream_IO.Append_File);
- exception
- when Ada.Streams.Stream_IO.Use_Error =>
- Report.Not_Applicable
- ( "Reset to Append_File not supported " &
- "for Stream_IO - 2" );
- raise Incomplete;
- end Reset2;
-
- Integer'Write (Stream_Access_Value, Int_Var);
- -- Attempt read from Append_File mode file.
- Integer'Read (Stream_Access_Value, Int_Var);
- Report.Failed
- ("Exception not raised by 'Read of Append file");
- exception
- when Incomplete =>
- null;
- when Ada.Streams.Stream_IO.Mode_Error =>
- null;
- when others =>
- Report.Failed ("Incorrect exception raised - 4b");
- end Try_Read;
-
- when others => Report.Failed ("Incorrect exception raised - 4a");
- end Check_Mode_Error;
-
- -- Another example of a this type of potential error is to attempt
- -- to check for End Of File on a stream file that is currently in
- -- Out_File or Append_File mode. Mode_Error should also be raised
- -- in both of these cases.
- Check_End_File:
- declare
- Test_Boolean : Boolean := False;
- begin
- Reset3:
- begin
- Ada.Streams.Stream_IO.Reset (Stream_File_Object,
- Ada.Streams.Stream_IO.Out_File);
- exception
- when Ada.Streams.Stream_IO.Use_Error =>
- Report.Not_Applicable
- ( "Reset to Out_File not supported for Stream_IO - 3" );
- raise Incomplete;
- end Reset3;
-
- Test_Boolean :=
- Ada.Streams.Stream_IO.End_Of_File (Stream_File_Object);
- Report.Failed ("Exception not raised by EOF on Out_File");
- exception
- when Incomplete =>
- null;
- when Ada.Streams.Stream_IO.Mode_Error =>
- null;
- EOF_For_Append_File:
- begin
- Reset4:
- begin
- Ada.Streams.Stream_IO.Reset
- (Stream_File_Object, Ada.Streams.Stream_IO.Append_File);
- exception
- when Ada.Streams.Stream_IO.Use_Error =>
- Report.Not_Applicable
- ( "Reset to Append_File not supported " &
- "for Stream_IO - 4" );
- raise Incomplete;
- end Reset4;
-
- Test_Boolean :=
- Ada.Streams.Stream_IO.End_Of_File (Stream_File_Object);
- Report.Failed
- ("Exception not raised by EOF of Append file");
- exception
- when Incomplete =>
- raise;
- when Ada.Streams.Stream_IO.Mode_Error =>
- null;
- when others =>
- Report.Failed ("Incorrect exception raised - 5b");
- end EOF_For_Append_File;
-
- when others => Report.Failed ("Incorrect exception raised - 5a");
- end Check_End_File;
-
-
-
- -- In a similar situation to the above cases for attribute 'Read,
- -- an attempt to use the 'Output attribute on a stream file that
- -- is currently in In_File mode should result in Mode_Error being
- -- raised.
- Check_Output_Mode_Error:
- begin
- Reset5:
- begin
- Ada.Streams.Stream_IO.Reset (Stream_File_Object,
- Ada.Streams.Stream_IO.In_File);
- exception
- when Ada.Streams.Stream_IO.Use_Error =>
- Report.Not_Applicable
- ( "Reset to In_File not supported for Stream_IO - 6" );
- raise Incomplete;
- end Reset5;
-
- Stream_Access_Value :=
- Ada.Streams.Stream_IO.Stream (Stream_File_Object);
- String'Output (Stream_Access_Value, "User-Oriented String");
- Report.Failed ("Exception not raised by 'Output to In_File");
- exception
- when Incomplete =>
- null;
- when Ada.Streams.Stream_IO.Mode_Error =>
- null;
- when others =>
- Report.Failed ("Incorrect exception raised - 6");
- end Check_Output_Mode_Error;
-
- -- Any case of attempting to Open a stream file with a string for
- -- the parameter Name that does not allow the identification of an
- -- external file will result in the exception Name_Error being
- -- raised.
- Check_Illegal_File_Name:
- begin
- if Ada.Streams.Stream_IO.Is_Open (Stream_File_Object) then
- Ada.Streams.Stream_IO.Close (Stream_File_Object);
- end if;
- -- No external file exists with this filename, allowing no
- -- association with an internal file object, resulting in the
- -- raising of the exception Name_Error.
- Ada.Streams.Stream_IO.Open(File => Stream_File_Object,
- Mode => Ada.Streams.Stream_IO.Out_File,
- Name => Report.Legal_File_Name(2));
- Report.Failed ("Exception not raised by bad filename on Open");
- exception
- when Ada.Streams.Stream_IO.Name_Error =>
- null;
- when others =>
- Report.Failed ("Incorrect exception raised - 7");
- end Check_Illegal_File_Name;
-
- exception
- when Incomplete =>
- null;
- when others =>
- Report.Failed ("Unexpected exception in Operational Test Block");
-
- end Operational_Test_Block;
-
- Deletion:
- begin
- if Ada.Streams.Stream_IO.Is_Open (Stream_File_Object) then
- Ada.Streams.Stream_IO.Delete (Stream_File_Object);
- else
- Ada.Streams.Stream_IO.Open (Stream_File_Object,
- Ada.Streams.Stream_IO.Out_File,
- Stream_Filename);
- Ada.Streams.Stream_IO.Delete (Stream_File_Object);
- end if;
- exception
- when others =>
- Report.Failed
- ( "Delete not properly implemented for Stream_IO" );
- end Deletion;
-
- Report.Result;
-
-exception
- when Incomplete =>
- Report.Result;
- when others =>
- Report.Failed ( "Unexpected exception" );
- Report.Result;
-
-end CXAC003;
diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxac004.a b/gcc/testsuite/ada/acats/tests/cxa/cxac004.a
deleted file mode 100644
index 9cc88b93cfb..00000000000
--- a/gcc/testsuite/ada/acats/tests/cxa/cxac004.a
+++ /dev/null
@@ -1,310 +0,0 @@
--- CXAC004.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that the Stream_Access type and Stream function found in package
--- Ada.Text_IO.Text_Streams allows a text file to be processed with the
--- functionality of streams.
---
--- TEST DESCRIPTION:
--- This test verifies that the package Ada.Text_IO.Text_Streams is
--- available and that the functionality it contains allows a text file to
--- be manipulated as a stream.
--- The test defines data objects of a variety of types that can be stored
--- in a text file. A text file and associated text stream are then
--- defined, and the 'Write attribute is used to enter the individual data
--- items into the text stream. Once all the individual data items have
--- been written to the stream, the 'Output attribute is used to write
--- arrays of these same data objects to the stream.
--- The text file is reset to serve as an input file, and the 'Read
--- attribute is used to extract the individual data items from the
--- stream. These items are then verified against the data originally
--- written to the stream. Finally, the 'Input attribute is used to
--- extract the data arrays from the stream. These arrays are then
--- verified against the original data written to the stream.
---
--- APPLICABILITY CRITERIA:
--- Applicable to implementations that support external text files.
---
--- CHANGE HISTORY:
--- 06 Jul 95 SAIC Initial prerelease version.
--- 26 Feb 97 PWB.CTA Allowed for non-support of some IO operations;
--- removed requirement for support of decimal types.
---!
-
-with Report;
-with Ada.Text_IO;
-with Ada.Text_IO.Text_Streams;
-with Ada.Characters.Latin_1;
-with Ada.Strings.Unbounded;
-
-procedure CXAC004 is
-
- Data_File : Ada.Text_IO.File_Type;
- Data_Filename : constant String :=
- Report.Legal_File_Name ( Nam => "CXAC004" );
- Incomplete : exception;
-
-begin
-
- Report.Test ("CXAC004", "Check that the Stream_Access type and Stream " &
- "function found in package " &
- "Ada.Text_IO.Text_Streams allows a text file to " &
- "be processed with the functionality of streams");
-
- Test_for_IO_Support:
- begin
-
- -- Check for Text_IO support in creating the data file. If the
- -- implementation does not support external files, Name_Error or
- -- Use_Error will be raised at the point of the following call to
- -- Create, resulting in a Not_Applicable test result.
-
- Ada.Text_IO.Create(Data_File, Ada.Text_IO.Out_File, Data_Filename);
-
- exception
-
- when Ada.Text_IO.Use_Error | Ada.Text_IO.Name_Error =>
- Report.Not_Applicable
- ( "Files not supported - Create as Out_File for Text_IO" );
- raise Incomplete;
-
- end Test_for_IO_Support;
-
- Test_Block:
- declare
- use Ada.Characters.Latin_1, Ada.Strings.Unbounded;
- TC_Items : constant := 3;
-
- -- Declare types and objects that will be used as data values to be
- -- written to and read from the text file/stream.
-
- type Enum_Type is (Red, Yellow, Green, Blue, Indigo);
- type Fixed_Type is delta 0.125 range 0.0..255.0;
- type Float_Type is digits 7 range 0.0..1.0E5;
- type Modular_Type is mod 256;
- subtype Str_Type is String(1..4);
-
- type Char_Array_Type is array (1..TC_Items) of Character;
- type Enum_Array_Type is array (1..TC_Items) of Enum_Type;
- type Fixed_Array_Type is array (1..TC_Items) of Fixed_Type;
- type Float_Array_Type is array (1..TC_Items) of Float_Type;
- type Int_Array_Type is array (1..TC_Items) of Integer;
- type Mod_Array_Type is array (1..TC_Items) of Modular_Type;
- type Str_Array_Type is array (1..TC_Items) of Str_Type;
- type Unb_Str_Array_Type is array (1..TC_Items) of Unbounded_String;
-
- Char_Array : Char_Array_Type := ('A', 'z', Yen_Sign);
- TC_Char_Array_1,
- TC_Char_Array_2 : Char_Array_Type := (others => Space);
-
- Enum_Array : Enum_Array_Type := (Blue, Yellow, Indigo);
- TC_Enum_Array_1,
- TC_Enum_Array_2 : Enum_Array_Type := (others => Red);
-
- Fix_Array : Fixed_Array_Type := (0.125, 123.5, 250.750);
- TC_Fix_Array_1,
- TC_Fix_Array_2 : Fixed_Array_Type := (others => 0.0);
-
- Flt_Array : Float_Array_Type := (1.0, 150.0, 1500.0);
- TC_Flt_Array_1,
- TC_Flt_Array_2 : Float_Array_Type := (others => 0.0);
-
- Int_Array : Int_Array_Type := (124, 2349, -24_001);
- TC_Int_Array_1,
- TC_Int_Array_2 : Int_Array_Type := (others => -99);
-
- Mod_Array : Mod_Array_Type := (10, 127, 255);
- TC_Mod_Array_1,
- TC_Mod_Array_2 : Mod_Array_Type := (others => 0);
-
- Str_Array : Str_Array_Type := ("abcd", "klmn", "wxyz");
- TC_Str_Array_1,
- TC_Str_Array_2 : Str_Array_Type := (others => " ");
-
- UStr_Array : Unb_Str_Array_Type :=
- (To_Unbounded_String("cat"),
- To_Unbounded_String("testing"),
- To_Unbounded_String("ACVC"));
- TC_UStr_Array_1,
- TC_UStr_Array_2 : Unb_Str_Array_Type :=
- (others => Null_Unbounded_String);
-
- -- Create a stream access object pointing to the data file.
-
- Data_Stream : Ada.Text_IO.Text_Streams.Stream_Access :=
- Ada.Text_IO.Text_Streams.Stream(File => Data_File);
-
- begin
-
- -- Use the 'Write attribute to enter the three sets of data items
- -- into the data stream.
- -- Note that the data will be mixed within the text file.
-
- for i in 1..TC_Items loop
- Character'Write (Data_Stream, Char_Array(i));
- Enum_Type'Write (Data_Stream, Enum_Array(i));
- Fixed_Type'Write (Data_Stream, Fix_Array(i));
- Float_Type'Write (Data_Stream, Flt_Array(i));
- Integer'Write (Data_Stream, Int_Array(i));
- Modular_Type'Write (Data_Stream, Mod_Array(i));
- Str_Type'Write (Data_Stream, Str_Array(i));
- Unbounded_String'Write(Data_Stream, UStr_Array(i));
- end loop;
-
- -- Use the 'Output attribute to enter the entire arrays of each
- -- type of data items into the data stream.
- -- Note that the array bounds will be written to the stream as part
- -- of the action of the 'Output attribute.
-
- Char_Array_Type'Output (Data_Stream, Char_Array);
- Enum_Array_Type'Output (Data_Stream, Enum_Array);
- Fixed_Array_Type'Output (Data_Stream, Fix_Array);
- Float_Array_Type'Output (Data_Stream, Flt_Array);
- Int_Array_Type'Output (Data_Stream, Int_Array);
- Mod_Array_Type'Output (Data_Stream, Mod_Array);
- Str_Array_Type'Output (Data_Stream, Str_Array);
- Unb_Str_Array_Type'Output (Data_Stream, UStr_Array);
-
- -- Reset the data file to mode In_File. The data file will now serve
- -- as the source of data which will be compared to the original data
- -- written to the file above.
- Reset1:
- begin
- Ada.Text_IO.Reset (File => Data_File, Mode => Ada.Text_IO.In_File);
- exception
- when Ada.Text_IO.Use_Error =>
- Report.Not_Applicable
- ( "Reset to In_File not supported for Text_IO" );
- raise Incomplete;
- end Reset1;
-
- -- Extract and validate all the single data items from the stream.
-
- for i in 1..TC_Items loop
- Character'Read (Data_Stream, TC_Char_Array_1(i));
- Enum_Type'Read (Data_Stream, TC_Enum_Array_1(i));
- Fixed_Type'Read (Data_Stream, TC_Fix_Array_1(i));
- Float_Type'Read (Data_Stream, TC_Flt_Array_1(i));
- Integer'Read (Data_Stream, TC_Int_Array_1(i));
- Modular_Type'Read (Data_Stream, TC_Mod_Array_1(i));
- Str_Type'Read (Data_Stream, TC_Str_Array_1(i));
- Unbounded_String'Read (Data_Stream, TC_UStr_Array_1(i));
- end loop;
-
- if TC_Char_Array_1 /= Char_Array then
- Report.Failed("Character values do not match");
- end if;
- if TC_Enum_Array_1 /= Enum_Array then
- Report.Failed("Enumeration values do not match");
- end if;
- if TC_Fix_Array_1 /= Fix_Array then
- Report.Failed("Fixed point values do not match");
- end if;
- if TC_Flt_Array_1 /= Flt_Array then
- Report.Failed("Floating point values do not match");
- end if;
- if TC_Int_Array_1 /= Int_Array then
- Report.Failed("Integer values do not match");
- end if;
- if TC_Mod_Array_1 /= Mod_Array then
- Report.Failed("Modular values do not match");
- end if;
- if TC_Str_Array_1 /= Str_Array then
- Report.Failed("String values do not match");
- end if;
- if TC_UStr_Array_1 /= UStr_Array then
- Report.Failed("Unbounded_String values do not match");
- end if;
-
- -- Extract and validate all data arrays from the data stream.
- -- Note that the 'Input attribute denotes a function, whereas the
- -- other stream oriented attributes in this test denote procedures.
-
- TC_Char_Array_2 := Char_Array_Type'Input(Data_Stream);
- TC_Enum_Array_2 := Enum_Array_Type'Input(Data_Stream);
- TC_Fix_Array_2 := Fixed_Array_Type'Input(Data_Stream);
- TC_Flt_Array_2 := Float_Array_Type'Input(Data_Stream);
- TC_Int_Array_2 := Int_Array_Type'Input(Data_Stream);
- TC_Mod_Array_2 := Mod_Array_Type'Input(Data_Stream);
- TC_Str_Array_2 := Str_Array_Type'Input(Data_Stream);
- TC_UStr_Array_2 := Unb_Str_Array_Type'Input(Data_Stream);
-
- if TC_Char_Array_2 /= Char_Array then
- Report.Failed("Character array values do not match");
- end if;
- if TC_Enum_Array_2 /= Enum_Array then
- Report.Failed("Enumeration array values do not match");
- end if;
- if TC_Fix_Array_2 /= Fix_Array then
- Report.Failed("Fixed point array values do not match");
- end if;
- if TC_Flt_Array_2 /= Flt_Array then
- Report.Failed("Floating point array values do not match");
- end if;
- if TC_Int_Array_2 /= Int_Array then
- Report.Failed("Integer array values do not match");
- end if;
- if TC_Mod_Array_2 /= Mod_Array then
- Report.Failed("Modular array values do not match");
- end if;
- if TC_Str_Array_2 /= Str_Array then
- Report.Failed("String array values do not match");
- end if;
- if TC_UStr_Array_2 /= UStr_Array then
- Report.Failed("Unbounded_String array values do not match");
- end if;
-
- exception
- when Incomplete =>
- raise;
- when others => Report.Failed ("Exception raised in Test_Block");
- end Test_Block;
-
- Deletion:
- begin
- -- Delete the data file.
- if not Ada.Text_IO.Is_Open(Data_File) then
- Ada.Text_IO.Open(Data_File, Ada.Text_IO.In_File, Data_Filename);
- end if;
- Ada.Text_IO.Delete(Data_File);
-
- exception
- when others =>
- Report.Failed
- ( "Delete not properly implemented for Text_IO" );
-
- end Deletion;
-
- Report.Result;
-
-exception
- when Incomplete =>
- Report.Result;
- when others =>
- Report.Failed ( "Unexpected exception" );
- Report.Result;
-
-end CXAC004;
diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxac005.a b/gcc/testsuite/ada/acats/tests/cxa/cxac005.a
deleted file mode 100644
index 34a971f7a51..00000000000
--- a/gcc/testsuite/ada/acats/tests/cxa/cxac005.a
+++ /dev/null
@@ -1,343 +0,0 @@
--- CXAC005.A
---
--- Grant of Unlimited Rights
---
--- The Ada Conformity Assessment Authority (ACAA) holds unlimited
--- rights in the software and documentation contained herein. Unlimited
--- rights are the same as those granted by the U.S. Government for older
--- parts of the Ada Conformity Assessment Test Suite, and are defined
--- in DFAR 252.227-7013(a)(19). By making this public release, the ACAA
--- intends to confer upon all recipients unlimited rights equal to those
--- held by the ACAA. These rights include rights to use, duplicate,
--- release or disclose the released technical data and computer software
--- in whole or in part, in any manner and for any purpose whatsoever, and
--- to have or permit others to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that stream file positioning work as specified. (Defect Report
--- 8652/0055).
---
--- CHANGE HISTORY:
--- 12 FEB 2001 PHL Initial version.
--- 14 MAR 2001 RLB Readied for release; fixed Not_Applicable check
--- to terminate test gracefully.
---
---!
-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
deleted file mode 100644
index cda8776a53d..00000000000
--- a/gcc/testsuite/ada/acats/tests/cxa/cxaca01.a
+++ /dev/null
@@ -1,291 +0,0 @@
--- CXACA01.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that the default attributes 'Write and 'Read work properly when
--- used with objects of a variety of types, including records with
--- default discriminants, records without default discriminants, but
--- which have the discriminant described in a representation clause for
--- the type, and arrays.
---
--- TEST DESCRIPTION:
--- This test simulates a basic sales record system, using Stream_IO to
--- allow the storage of heterogeneous data in a single stream file.
---
--- Four types of data are written to the stream file for each product.
--- First, the "header" information on the product is written.
--- This is an object of a discriminated (with default) record
--- type. This is followed by an integer object containing a count of
--- the number of sales data records to follow. The corresponding number
--- of sales records follow in the stream. These are of a record type
--- with a discriminant without a default, but where the discriminant is
--- included in the representation clause for the type. Finally, an
--- array object with statistical sales information for the product is
--- written to the stream.
---
--- Objects of both record types specified below (discriminated records
--- with defaults, and discriminated records w/o defaults that have the
--- discriminant included in a representation clause for the type) should
--- have their discriminants included in the stream when using 'Write.
--- Likewise, discriminants should be extracted from the stream when
--- using 'Read.
---
--- APPLICABILITY CRITERIA:
--- Applicable to all implementations that support external
--- Stream_IO files.
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
---
---!
-
-with FXACA00;
-with Ada.Streams.Stream_IO;
-with Report;
-
-procedure CXACA01 is
-
-begin
-
- Report.Test ("CXACA01", "Check that 'Write and 'Read work properly " &
- "when used with complex data types");
-
- Test_for_Stream_IO_Support:
- declare
-
- Info_File : Ada.Streams.Stream_IO.File_Type;
- Info_Stream : Ada.Streams.Stream_IO.Stream_Access;
- The_Filename : constant String := Report.Legal_File_Name;
-
- begin
-
- -- If an implementation does not support Stream_IO in a particular
- -- environment, the exception Use_Error or Name_Error will be raised on
- -- calls to various Stream_IO operations. This block statement
- -- encloses a call to Create, which should produce an exception in a
- -- non-supportive environment. These exceptions will be handled to
- -- produce a Not_Applicable result.
-
- Ada.Streams.Stream_IO.Create (Info_File,
- Ada.Streams.Stream_IO.Out_File,
- The_Filename);
-
- Operational_Test_Block:
- declare
-
- begin
-
- Info_Stream := Ada.Streams.Stream_IO.Stream (Info_File);
-
- -- Write all of the product information (record, integer, and array
- -- objects) defined in package FXACA00 into the stream.
-
- Store_Data_Block:
- begin
-
- -- Write information about first product to the stream.
- FXACA00.Product_Type'Write (Info_Stream, FXACA00.Product_01);
- Integer'Write (Info_Stream, FXACA00.Sale_Count_01);
- FXACA00.Sales_Record_Type'Write(Info_Stream, FXACA00.Sale_Rec_01);
- FXACA00.Sales_Record_Type'Write(Info_Stream, FXACA00.Sale_Rec_02);
- FXACA00.Sales_Statistics_Type'Write
- (Info_Stream, FXACA00.Product_01_Stats);
-
- -- Write information about second product to the stream.
- -- Note: No Sales_Record_Type objects.
- FXACA00.Product_Type'Write (Info_Stream, FXACA00.Product_02);
- Integer'Write (Info_Stream, FXACA00.Sale_Count_02);
- FXACA00.Sales_Statistics_Type'Write
- (Info_Stream, FXACA00.Product_02_Stats);
-
- -- Write information about third product to the stream.
- FXACA00.Product_Type'Write (Info_Stream, FXACA00.Product_03);
- Integer'Write (Info_Stream, FXACA00.Sale_Count_03);
- FXACA00.Sales_Record_Type'Write(Info_Stream, FXACA00.Sale_Rec_03);
- FXACA00.Sales_Record_Type'Write(Info_Stream, FXACA00.Sale_Rec_04);
- FXACA00.Sales_Record_Type'Write(Info_Stream, FXACA00.Sale_Rec_05);
- FXACA00.Sales_Statistics_Type'Write
- (Info_Stream, FXACA00.Product_03_Stats);
-
- end Store_Data_Block;
-
-
- Verify_Data_Block:
- declare
-
- use FXACA00; -- Used within this block only.
-
- type Domestic_Rec_Array_Type is
- array (Positive range <>) of Sales_Record_Type (Domestic);
-
- type Foreign_Rec_Array_Type is
- array (Positive range <>) of Sales_Record_Type (Foreign);
-
- TC_Rec1 : Domestic_Rec_Array_Type (1..2);
- TC_Rec3 : Foreign_Rec_Array_Type (1..3);
-
- TC_Product1 : Product_Type;
- TC_Product2,
- TC_Product3 : Product_Type (Foreign);
-
- TC_Count1,
- TC_Count2,
- TC_Count3 : Integer := -10; -- Initialized to dummy value.
-
- TC_Stat1,
- TC_Stat2,
- TC_Stat3 : Sales_Statistics_Type := (others => 500);
-
- begin
-
- Ada.Streams.Stream_IO.Reset (Info_File,
- Ada.Streams.Stream_IO.In_File);
-
- -- Read all of the data that is contained in the stream.
- -- Compare all data with the original data in package FXACA00
- -- that was written to the stream.
- -- The calls to the read attribute are in anticipated order, based
- -- on the order of data written to the stream. Possible errors,
- -- such as data placement, overwriting, etc., will be manifest as
- -- exceptions raised by the attribute during an unsuccessful read
- -- attempt.
-
- -- Extract data on first product.
- Product_Type'Read (Info_Stream, TC_Product1);
- Integer'Read (Info_Stream, TC_Count1);
-
- -- Two "domestic" variant sales records will be read from the
- -- stream.
- for i in 1 .. TC_Count1 loop
- Sales_Record_Type'Read (Info_Stream, TC_Rec1(i) );
- end loop;
-
- Sales_Statistics_Type'Read (Info_Stream, TC_Stat1);
-
-
- -- Extract data on second product.
- Product_Type'Read (Info_Stream, TC_Product2);
- Integer'Read (Info_Stream, TC_Count2);
- Sales_Statistics_Type'Read (Info_Stream, TC_Stat2);
-
-
- -- Extract data on third product.
- Product_Type'Read (Info_Stream, TC_Product3);
- Integer'Read (Info_Stream, TC_Count3);
-
- -- Three "foreign" variant sales records will be read from the
- -- stream.
- for i in 1 .. TC_Count3 loop
- Sales_Record_Type'Read (Info_Stream, TC_Rec3(i) );
- end loop;
-
- Sales_Statistics_Type'Read (Info_Stream, TC_Stat3);
-
-
- -- After all the data has been correctly extracted, the file
- -- should be empty.
-
- if not Ada.Streams.Stream_IO.End_Of_File (Info_File) then
- Report.Failed ("Stream file not empty");
- end if;
-
- -- Verify that the data values read from the stream are the same
- -- as those written to the stream.
-
- -- Verify the information of the first product.
- if ((Product_01 /= TC_Product1) or else
- (Product_01.Manufacture /= TC_Product1.Manufacture) or else
- (Sale_Count_01 /= TC_Count1) or else
- (Sale_Rec_01 /= TC_Rec1(1)) or else
- (Sale_Rec_01.Buyer /= TC_Rec1(1).Buyer) or else
- (Sale_Rec_02 /= TC_Rec1(2)) or else
- (Sale_Rec_02.Buyer /= TC_Rec1(2).Buyer) or else
- (Product_01_Stats /= TC_Stat1))
- then
- Report.Failed ("Product 1 information incorrect");
- end if;
-
- -- Verify the information of the second product.
- if not ((Product_02 = TC_Product2) and then
- (Sale_Count_02 = TC_Count2) and then
- (Product_02_Stats = TC_Stat2))
- then
- Report.Failed ("Product 2 information incorrect");
- end if;
-
- -- Verify the information of the third product.
- if ((Product_03 /= TC_Product3) or else
- (Product_03.Manufacture /= TC_Product3.Manufacture) or else
- (Sale_Count_03 /= TC_Count3) or else
- (Sale_Rec_03 /= TC_Rec3(1)) or else
- (Sale_Rec_03.Buyer /= TC_Rec3(1).Buyer) or else
- (Sale_Rec_04 /= TC_Rec3(2)) or else
- (Sale_Rec_04.Buyer /= TC_Rec3(2).Buyer) or else
- (Sale_Rec_05 /= TC_Rec3(3)) or else
- (Sale_Rec_05.Buyer /= TC_Rec3(3).Buyer) or else
- (Product_03_Stats /= TC_Stat3))
- then
- Report.Failed ("Product 3 information incorrect");
- end if;
-
- end Verify_Data_Block;
-
- exception
-
- when others =>
- Report.Failed ("Exception raised in Operational Test Block");
-
- end Operational_Test_Block;
-
- if Ada.Streams.Stream_IO.Is_Open (Info_File) then
- Ada.Streams.Stream_IO.Delete (Info_File);
- else
- Ada.Streams.Stream_IO.Open (Info_File,
- Ada.Streams.Stream_IO.In_File,
- The_Filename);
- Ada.Streams.Stream_IO.Delete (Info_File);
- end if;
-
- exception
-
- -- Since Use_Error or Name_Error can be raised if, for the specified
- -- mode, the environment does not support Stream_IO operations,
- -- the following handlers are included:
-
- when Ada.Streams.Stream_IO.Name_Error =>
- Report.Not_Applicable ("Name_Error raised on Stream IO Create");
-
- when Ada.Streams.Stream_IO.Use_Error =>
- Report.Not_Applicable ("Use_Error raised on Stream IO Create");
-
- when others =>
- Report.Failed ("Unexpected exception raised on Stream IO Create");
-
- end Test_for_Stream_IO_Support;
-
- Report.Result;
-
-end CXACA01;
diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxaca02.a b/gcc/testsuite/ada/acats/tests/cxa/cxaca02.a
deleted file mode 100644
index 5106dd3991d..00000000000
--- a/gcc/testsuite/ada/acats/tests/cxa/cxaca02.a
+++ /dev/null
@@ -1,360 +0,0 @@
--- CXACA02.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that user defined subprograms can override the default
--- attributes 'Read and 'Write using attribute definition clauses.
--- Use objects of record types.
---
--- TEST DESCRIPTION:
--- This test demonstrates that the default implementations of the
--- 'Read and 'Write attributes can be overridden by user specified
--- subprograms in conjunction with attribute definition clauses.
--- These attributes have been overridden below, and in the user defined
--- substitutes, values are added or subtracted to global variables.
--- The global variables are evaluated to ensure that the user defined
--- subprograms were used in overriding the type-related default
--- attributes.
---
--- APPLICABILITY CRITERIA:
--- Applicable to all implementations that support external
--- Stream_IO files.
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 21 Nov 95 SAIC Corrected recursive attribute definitions
--- for ACVC 2.0.1.
--- 24 Aug 96 SAIC Corrected typo in test verification criteria.
---
---!
-
-with Report;
-with Ada.Streams.Stream_IO;
-
-procedure CXACA02 is
-begin
-
- Report.Test ("CXACA02", "Check that user defined subprograms can " &
- "override the default attributes 'Read and " &
- "'Write using attribute definition clauses");
-
- Test_for_Stream_IO_Support:
- declare
-
- Data_File : Ada.Streams.Stream_IO.File_Type;
- Data_Stream : Ada.Streams.Stream_IO.Stream_Access;
- The_Filename : constant String := Report.Legal_File_Name;
-
- begin
-
- -- If an implementation does not support Stream_IO in a particular
- -- environment, the exception Use_Error or Name_Error will be raised on
- -- calls to various Stream_IO operations. This block statement
- -- encloses a call to Create, which should produce an exception in a
- -- non-supportive environment. These exceptions will be handled to
- -- produce a Not_Applicable result.
-
- Ada.Streams.Stream_IO.Create (Data_File,
- Ada.Streams.Stream_IO.Out_File,
- The_Filename);
-
- Operational_Test_Block:
- declare
-
- type Origin_Type is (Foreign, Domestic);
- subtype String_Data_Type is String(1..8);
-
- type Product_Type is
- record
- Item : String_Data_Type;
- ID : Natural range 1..100;
- Manufacture : Origin_Type := Domestic;
- Distributor : String_Data_Type;
- Importer : String_Data_Type;
- end record;
-
- type Sales_Record_Type is
- record
- Name : String_Data_Type;
- Sale_Item : Boolean := False;
- Buyer : Origin_Type;
- Quantity_Discount : Boolean;
- Cash_Discount : Boolean;
- end record;
-
-
- -- Mode conformant, user defined subprograms that will override
- -- the type-related attributes.
- -- In this test, the user defines these subprograms to add/subtract
- -- specific values from global variables.
-
- procedure Product_Read
- ( Stream : access Ada.Streams.Root_Stream_Type'Class;
- The_Item : out Product_Type );
-
- procedure Product_Write
- ( Stream : access Ada.Streams.Root_Stream_Type'Class;
- The_Item : Product_Type );
-
- procedure Sales_Read
- ( Stream : access Ada.Streams.Root_Stream_Type'Class;
- The_Item : out Sales_Record_Type );
-
- procedure Sales_Write
- ( Stream : access Ada.Streams.Root_Stream_Type'Class;
- The_Item : Sales_Record_Type );
-
- -- Attribute definition clauses.
-
- for Product_Type'Read use Product_Read;
- for Product_Type'Write use Product_Write;
-
- for Sales_Record_Type'Read use Sales_Read;
- for Sales_Record_Type'Write use Sales_Write;
-
-
- -- Object Declarations
-
- Product_01 : Product_Type :=
- ("Product1", 1, Domestic, "Distrib1", "Import 1");
- Product_02 : Product_Type :=
- ("Product2", 2, Foreign, "Distrib2", "Import 2");
-
- Sale_Rec_01 : Sales_Record_Type :=
- ("Buyer 01", False, Domestic, True, True);
- Sale_Rec_02 : Sales_Record_Type :=
- ("Buyer 02", True, Domestic, True, False);
- Sale_Rec_03 : Sales_Record_Type := (Name => "Buyer 03",
- Sale_Item => True,
- Buyer => Foreign,
- Quantity_Discount => False,
- Cash_Discount => True);
- Sale_Rec_04 : Sales_Record_Type :=
- ("Buyer 04", True, Foreign, False, False);
- Sale_Rec_05 : Sales_Record_Type :=
- ("Buyer 05", False, Foreign, False, False);
-
- TC_Read_Total : Integer := 100;
- TC_Write_Total : Integer := 0;
-
-
- -- Subprogram bodies.
- -- These subprograms are designed to override the default attributes
- -- 'Read and 'Write for the specified types. Each adds/subtracts
- -- a quantity to/from a program control variable, indicating its
- -- activity. In addition, each component of the record is
- -- individually read from or written to the stream, using the
- -- appropriate 'Read or 'Write attribute for the component type.
- -- The string components are moved to/from the stream using the
- -- 'Input and 'Output attributes for the string subtype, so that
- -- the bounds of the strings are also written/read.
-
- procedure Product_Read
- ( Stream : access Ada.Streams.Root_Stream_Type'Class;
- The_Item : out Product_Type ) is
- begin
- TC_Read_Total := TC_Read_Total - 10;
-
- The_Item.Item := String_Data_Type'Input(Data_Stream); -- Field 1.
- Natural'Read(Data_Stream, The_Item.ID); -- Field 2.
- Origin_Type'Read(Data_Stream, -- Field 3.
- The_Item.Manufacture);
- The_Item.Distributor := -- Field 4.
- String_Data_Type'Input(Data_Stream);
- The_Item.Importer := -- Field 5.
- String_Data_Type'Input(Data_Stream);
- end Product_Read;
-
-
- procedure Product_Write
- ( Stream : access Ada.Streams.Root_Stream_Type'Class;
- The_Item : Product_Type ) is
- begin
- TC_Write_Total := TC_Write_Total + 5;
-
- String_Data_Type'Output(Data_Stream, The_Item.Item); -- Field 1.
- Natural'Write(Data_Stream, The_Item.ID); -- Field 2.
- Origin_Type'Write(Data_Stream, -- Field 3.
- The_Item.Manufacture);
- String_Data_Type'Output(Data_Stream, -- Field 4.
- The_Item.Distributor);
- String_Data_Type'Output(Data_Stream, -- Field 5.
- The_Item.Importer);
- end Product_Write;
-
-
- procedure Sales_Read
- ( Stream : access Ada.Streams.Root_Stream_Type'Class;
- The_Item : out Sales_Record_Type ) is
- begin
- TC_Read_Total := TC_Read_Total - 20;
-
- The_Item.Name := String_Data_Type'Input(Data_Stream); -- Field 1.
- Boolean'Read(Data_Stream, The_Item.Sale_Item); -- Field 2.
- Origin_Type'Read(Data_Stream, The_Item.Buyer); -- Field 3.
- Boolean'Read(Data_Stream, The_Item.Quantity_Discount); -- Field 4.
- Boolean'Read(Data_Stream, The_Item.Cash_Discount); -- Field 5.
- end Sales_Read;
-
-
- procedure Sales_Write
- ( Stream : access Ada.Streams.Root_Stream_Type'Class;
- The_Item : Sales_Record_Type ) is
- begin
- TC_Write_Total := TC_Write_Total + 10;
-
- String_Data_Type'Output(Data_Stream, The_Item.Name); -- Field 1.
- Boolean'Write(Data_Stream, The_Item.Sale_Item); -- Field 2.
- Origin_Type'Write(Data_Stream, The_Item.Buyer); -- Field 3.
- Boolean'Write(Data_Stream, The_Item.Quantity_Discount); -- Field 4.
- Boolean'Write(Data_Stream, The_Item.Cash_Discount); -- Field 5.
- end Sales_Write;
-
-
-
- begin
-
- Data_Stream := Ada.Streams.Stream_IO.Stream (Data_File);
-
- -- Write product and sales data to the stream.
-
- Product_Type'Write (Data_Stream, Product_01);
- Sales_Record_Type'Write (Data_Stream, Sale_Rec_01);
- Sales_Record_Type'Write (Data_Stream, Sale_Rec_02);
-
- Product_Type'Write (Data_Stream, Product_02);
- Sales_Record_Type'Write (Data_Stream, Sale_Rec_03);
- Sales_Record_Type'Write (Data_Stream, Sale_Rec_04);
- Sales_Record_Type'Write (Data_Stream, Sale_Rec_05);
-
- -- Read data from the stream, and verify the use of the user specified
- -- attributes.
-
- Verify_Data_Block:
- declare
-
- TC_Product1,
- TC_Product2 : Product_Type;
-
- TC_Sale1,
- TC_Sale2,
- TC_Sale3,
- TC_Sale4,
- TC_Sale5 : Sales_Record_Type;
-
- begin
-
- -- Reset the mode of the stream file so that Read/Input
- -- operations may be performed.
-
- Ada.Streams.Stream_IO.Reset (Data_File,
- Ada.Streams.Stream_IO.In_File);
-
- -- Data is read/reconstructed from the stream, in the order that
- -- the data was placed into the stream.
-
- Product_Type'Read (Data_Stream, TC_Product1);
- Sales_Record_Type'Read (Data_Stream, TC_Sale1);
- Sales_Record_Type'Read (Data_Stream, TC_Sale2);
-
- Product_Type'Read (Data_Stream, TC_Product2);
- Sales_Record_Type'Read (Data_Stream, TC_Sale3);
- Sales_Record_Type'Read (Data_Stream, TC_Sale4);
- Sales_Record_Type'Read (Data_Stream, TC_Sale5);
-
- -- Verify product data was correctly written to/read from stream.
-
- if TC_Product1 /= Product_01 then
- Report.Failed ("Data verification error, Product 1");
- end if;
- if TC_Product2 /= Product_02 then
- Report.Failed ("Data verification error, Product 2");
- end if;
-
- if TC_Sale1 /= Sale_Rec_01 then
- Report.Failed ("Data verification error, Sale_Rec_01");
- end if;
- if TC_Sale2 /= Sale_Rec_02 then
- Report.Failed ("Data verification error, Sale_Rec_02");
- end if;
- if TC_Sale3 /= Sale_Rec_03 then
- Report.Failed ("Data verification error, Sale_Rec_03");
- end if;
- if TC_Sale4 /= Sale_Rec_04 then
- Report.Failed ("Data verification error, Sale_Rec_04");
- end if;
- if TC_Sale5 /= Sale_Rec_05 then
- Report.Failed ("Data verification error, Sale_Rec_05");
- end if;
-
- -- Verify that the user defined subprograms were used to
- -- override the default 'Read and 'Write attributes.
- -- There were two "product" reads and two writes; there
- -- were five "sale record" reads and five writes.
-
- if (TC_Read_Total /= -20) or (TC_Write_Total /= 60) then
- Report.Failed ("Incorrect use of user defined attributes");
- end if;
-
- end Verify_Data_Block;
-
- exception
-
- when others =>
- Report.Failed ("Exception raised in Operational Test Block");
-
- end Operational_Test_Block;
-
- if Ada.Streams.Stream_IO.Is_Open (Data_File) then
- Ada.Streams.Stream_IO.Delete (Data_File);
- else
- Ada.Streams.Stream_IO.Open (Data_File,
- Ada.Streams.Stream_IO.Out_File,
- The_Filename);
- Ada.Streams.Stream_IO.Delete (Data_File);
- end if;
-
-
- exception
-
- -- Since Use_Error or Name_Error can be raised if, for the specified
- -- mode, the environment does not support Stream_IO operations,
- -- the following handlers are included:
-
- when Ada.Streams.Stream_IO.Name_Error =>
- Report.Not_Applicable ("Name_Error raised on Stream IO Create");
-
- when Ada.Streams.Stream_IO.Use_Error =>
- Report.Not_Applicable ("Use_Error raised on Stream IO Create");
-
- when others =>
- Report.Failed ("Unexpected exception raised");
-
- end Test_for_Stream_IO_Support;
-
- Report.Result;
-
-end CXACA02;
diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxacb01.a b/gcc/testsuite/ada/acats/tests/cxa/cxacb01.a
deleted file mode 100644
index ac4a905e830..00000000000
--- a/gcc/testsuite/ada/acats/tests/cxa/cxacb01.a
+++ /dev/null
@@ -1,264 +0,0 @@
--- CXACB01.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that the default attributes 'Input and 'Output work properly when
--- used with objects of a variety of types, including two-dimensional
--- arrays and records without default discriminants.
---
--- TEST DESCRIPTION:
--- This test simulates utility company service record storage, using
--- Stream_IO to allow the storage of heterogeneous data in a single
--- stream file.
---
--- Three types of data are written to the stream file for each utility
--- service customer.
--- First, the general information on the customer is written.
--- This is an object of a discriminated (without default) record
--- type. This is followed by an integer object containing a count of
--- the number of service months for the customer. Finally, a
--- two-dimensional array object with monthly consumption information for
--- the customer is written to the stream.
---
--- Objects of record types with discriminants without defaults should
--- have their discriminants included in the stream when using 'Output.
--- Likewise, discriminants should be extracted
--- from the stream when using 'Input. Similarly, array bounds are written
--- to and read from the stream when using 'Output and 'Input with array
--- objects.
---
--- APPLICABILITY CRITERIA:
--- Applicable to all implementations that support external
--- Stream_IO files.
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
---
---!
-
-with FXACB00;
-with Ada.Streams.Stream_IO;
-with Report;
-
-procedure CXACB01 is
-begin
-
- Report.Test ("CXACB01", "Check that the default attributes 'Input and " &
- "'Output work properly when used with objects " &
- "of record, natural, and array types" );
-
- Test_for_Stream_IO_Support:
- declare
-
- Util_File : Ada.Streams.Stream_IO.File_Type;
- Util_Stream : Ada.Streams.Stream_IO.Stream_Access;
- Utility_Service_Filename : constant String := Report.Legal_File_Name;
-
- begin
-
- -- If an implementation does not support Stream_IO in a particular
- -- environment, the exception Use_Error or Name_Error will be raised on
- -- calls to various Stream_IO operations. This block statement
- -- encloses a call to Create, which should produce an exception in a
- -- non-supportive environment. These exceptions will be handled to
- -- produce a Not_Applicable result.
-
- Ada.Streams.Stream_IO.Create (Util_File,
- Ada.Streams.Stream_IO.Out_File,
- Utility_Service_Filename);
-
- Operational_Test_Block:
- declare
-
- -- The following procedure will store all of the customer specific
- -- information into the stream.
-
- procedure Store_Data_In_Stream
- (Customer : in FXACB00.Service_Type;
- Months : in FXACB00.Months_In_Service_Type;
- History : in FXACB00.Service_History_Type) is
- begin
- FXACB00.Service_Type'Output (Util_Stream, Customer);
- FXACB00.Months_In_Service_Type'Output (Util_Stream, Months);
- FXACB00.Service_History_Type'Output (Util_Stream, History);
- end Store_Data_In_Stream;
-
-
- -- The following procedure will remove from the stream all of the
- -- customer related information.
-
- procedure Retrieve_Data_From_Stream
- (Customer : out FXACB00.Service_Type;
- Months : out FXACB00.Months_In_Service_Type;
- History : out FXACB00.Service_History_Type) is
- begin
- Customer := FXACB00.Service_Type'Input (Util_Stream);
- Months := FXACB00.Months_In_Service_Type'Input (Util_Stream);
- History := FXACB00.Service_History_Type'Input (Util_Stream);
- end Retrieve_Data_From_Stream;
-
-
- begin
-
- Util_Stream := Ada.Streams.Stream_IO.Stream (Util_File);
-
- -- Write all of the customer service information (record, numeric,
- -- and array objects) defined in package FXACB00 into the stream.
-
- Data_Storage_Block:
- begin
-
- Store_Data_In_Stream (Customer => FXACB00.Customer1,
- Months => FXACB00.C1_Months,
- History => FXACB00.C1_Service_History);
-
- Store_Data_In_Stream (FXACB00.Customer2,
- FXACB00.C2_Months,
- History => FXACB00.C2_Service_History);
-
- Store_Data_In_Stream (Months => FXACB00.C3_Months,
- History => FXACB00.C3_Service_History,
- Customer => FXACB00.Customer3);
- end Data_Storage_Block;
-
-
- Data_Verification_Block:
- declare
-
- TC_Residence : FXACB00.Service_Type (FXACB00.Residence);
- TC_Apartment : FXACB00.Service_Type (FXACB00.Apartment);
- TC_Commercial : FXACB00.Service_Type (FXACB00.Commercial);
-
-
- TC_Months1,
- TC_Months2,
- TC_Months3 : FXACB00.Months_In_Service_Type :=
- FXACB00.Months_In_Service_Type'First;
-
-
- TC_History1 :
- FXACB00.Service_History_Type (FXACB00.Quarterly_Period_Type,
- FXACB00.Month_In_Quarter_Type) :=
- (others => (others => FXACB00.Electric_Usage_Type'Last));
-
- TC_History2 :
- FXACB00.Service_History_Type
- (FXACB00.Quarterly_Period_Type range
- FXACB00.Spring .. FXACB00.Summer,
- FXACB00.Month_In_Quarter_Type) :=
- (others => (others => FXACB00.Electric_Usage_Type'Last));
-
- TC_History3 :
- FXACB00.Service_History_Type (FXACB00.Quarterly_Period_Type,
- FXACB00.Month_In_Quarter_Type) :=
- (others => (others => FXACB00.Electric_Usage_Type'Last));
-
- begin
-
- Ada.Streams.Stream_IO.Reset (Util_File,
- Ada.Streams.Stream_IO.In_File);
-
- -- Input all of the data that is contained in the stream.
- -- Compare all data with the original data in package FXACB00
- -- that was written to the stream.
-
- Retrieve_Data_From_Stream (TC_Residence, TC_Months1, TC_History1);
- Retrieve_Data_From_Stream (TC_Apartment, TC_Months2, TC_History2);
- Retrieve_Data_From_Stream (Customer => TC_Commercial,
- Months => TC_Months3,
- History => TC_History3);
-
- -- After all the data has been correctly extracted, the file
- -- should be empty.
-
- if not Ada.Streams.Stream_IO.End_Of_File (Util_File) then
- Report.Failed ("Stream file not empty");
- end if;
-
- -- Verify that the data values read from the stream are the same
- -- as those written to the stream.
-
- if ((FXACB00."/="(FXACB00.Customer1, TC_Residence)) or else
- (FXACB00."/="(FXACB00.Customer2, TC_Apartment)) or else
- (FXACB00."/="(FXACB00.Customer3, TC_Commercial)))
- then
- Report.Failed ("Customer information incorrect");
- end if;
-
- if ((FXACB00."/="(FXACB00.C1_Months, TC_Months1)) or
- (FXACB00."/="(FXACB00.C2_Months, TC_Months2)) or
- (FXACB00."/="(FXACB00.C3_Months, TC_Months3)))
- then
- Report.Failed ("Number of Months information incorrect");
- end if;
-
- if not ((FXACB00."="(FXACB00.C1_Service_History, TC_History1)) and
- (FXACB00."="(FXACB00.C2_Service_History, TC_History2)) and
- (FXACB00."="(FXACB00.C3_Service_History, TC_History3)))
- then
- Report.Failed ("Service history information incorrect");
- end if;
-
- end Data_Verification_Block;
-
- exception
-
- when others =>
- Report.Failed ("Exception raised in Operational Test Block");
-
- end Operational_Test_Block;
-
- -- Delete the file.
- if Ada.Streams.Stream_IO.Is_Open (Util_File) then
- Ada.Streams.Stream_IO.Delete (Util_File);
- else
- Ada.Streams.Stream_IO.Open (Util_File,
- Ada.Streams.Stream_IO.Out_File,
- Utility_Service_Filename);
- Ada.Streams.Stream_IO.Delete (Util_File);
- end if;
-
-
- exception
-
- -- Since Use_Error or Name_Error can be raised if, for the specified
- -- mode, the environment does not support Stream_IO operations,
- -- the following handlers are included:
-
- when Ada.Streams.Stream_IO.Name_Error =>
- Report.Not_Applicable ("Name_Error raised on Stream IO Create");
-
- when Ada.Streams.Stream_IO.Use_Error =>
- Report.Not_Applicable ("Use_Error raised on Stream IO Create");
-
- when others =>
- Report.Failed ("Unexpected exception raised");
-
- end Test_for_Stream_IO_Support;
-
- Report.Result;
-
-end CXACB01;
diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxacb02.a b/gcc/testsuite/ada/acats/tests/cxa/cxacb02.a
deleted file mode 100644
index a0ade9ebe1c..00000000000
--- a/gcc/testsuite/ada/acats/tests/cxa/cxacb02.a
+++ /dev/null
@@ -1,421 +0,0 @@
--- CXACB02.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that user defined subprograms can override the default
--- attributes 'Input and 'Output using attribute definition clauses,
--- when used with objects of discriminated record and multi-dimensional
--- array types.
---
--- TEST DESCRIPTION:
--- This test demonstrates that the default implementations of the
--- 'Input and 'Output attributes can be overridden by user specified
--- subprograms in conjunction with attribute definition clauses.
--- These attributes have been overridden below, and in the user defined
--- substitutes, values are added or subtracted to global variables.
--- Following the completion of the writing/reading test, the global
--- variables are evaluated to ensure that the user defined subprograms
--- were used in overriding the type-related default attributes.
---
--- APPLICABILITY CRITERIA:
--- Applicable to all implementations that support external
--- Stream_IO files.
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 14 Nov 95 SAIC Corrected test errors for ACVC 2.0.1.
---
---!
-
-with Report;
-with Ada.Streams.Stream_IO;
-
-procedure CXACB02 is
-begin
-
- Report.Test ("CXACB02", "Check that user defined subprograms can " &
- "override the default attributes 'Input and " &
- "'Output using attribute definition clauses");
-
- Test_for_Stream_IO_Support:
- declare
-
- Util_File : Ada.Streams.Stream_IO.File_Type;
- Util_Stream : Ada.Streams.Stream_IO.Stream_Access;
- Utility_Filename : constant String := Report.Legal_File_Name;
-
- begin
-
- -- If an implementation does not support Stream_IO in a particular
- -- environment, the exception Use_Error or Name_Error will be raised on
- -- calls to various Stream_IO operations. This block statement
- -- encloses a call to Create, which should produce an exception in a
- -- non-supportive environment. These exceptions will be handled to
- -- produce a Not_Applicable result.
-
- Ada.Streams.Stream_IO.Create (Util_File,
- Ada.Streams.Stream_IO.Out_File,
- Utility_Filename);
-
- Operational_Test_Block:
- declare
-
- type Customer_Type is (Residence, Apartment, Commercial);
- type Electric_Usage_Type is range 0..100000;
- type Months_In_Service_Type is range 1..12;
- type Quarterly_Period_Type is (Spring, Summer, Autumn, Winter);
- subtype Month_In_Quarter_Type is Positive range 1..3;
- type Service_History_Type is
- array (Quarterly_Period_Type range <>,
- Month_In_Quarter_Type range <>) of Electric_Usage_Type;
-
- type Service_Type (Customer : Customer_Type) is
- record
- Name : String (1..21);
- Account_ID : Natural range 0..100;
- case Customer is
- when Residence | Apartment =>
- Low_Income_Credit : Boolean := False;
- when Commercial =>
- Baseline_Allowance : Natural range 0..1000;
- Quantity_Discount : Boolean := False;
- end case;
- end record;
-
-
- -- Mode conformant, user defined subprograms that will override
- -- the type-related attributes.
- -- In this test, the user defines these subprograms to add/subtract
- -- specific values from global variables.
-
- function Service_Input
- (Stream : access Ada.Streams.Root_Stream_Type'Class)
- return Service_Type;
-
- procedure Service_Output
- (Stream : access Ada.Streams.Root_Stream_Type'Class;
- Item : Service_Type);
-
- function History_Input
- (Stream : access Ada.Streams.Root_Stream_Type'Class)
- return Service_History_Type;
-
- procedure History_Output
- (Stream : access Ada.Streams.Root_Stream_Type'Class;
- Item : Service_History_Type);
-
-
- -- Attribute definition clauses.
-
- for Service_Type'Input use Service_Input;
- for Service_Type'Output use Service_Output;
-
- for Service_History_Type'Input use History_Input;
- for Service_History_Type'Output use History_Output;
-
-
- -- Object Declarations
-
- Customer1 : Service_Type (Residence) :=
- (Residence, "1221 Morningstar Lane", 44, False);
- Customer2 : Service_Type (Apartment) :=
- (Customer => Apartment,
- Account_ID => 67,
- Name => "15 South Front St. #8",
- Low_Income_Credit => True);
- Customer3 : Service_Type (Commercial) :=
- (Commercial,
- "12442 Central Avenue ",
- 100,
- Baseline_Allowance => 938,
- Quantity_Discount => True);
-
- C1_Service_History :
- Service_History_Type (Quarterly_Period_Type,
- Month_In_Quarter_Type) :=
- (Spring => (1 => 35, 2 => 39, 3 => 32),
- Summer => (1 => 34, 2 => 33, 3 => 39),
- Autumn => (1 => 45, 2 => 40, 3 => 38),
- Winter => (1 => 53, 2 => 0, 3 => 0));
-
- C2_Service_History :
- Service_History_Type (Quarterly_Period_Type range Spring..Summer,
- Month_In_Quarter_Type) :=
- (Spring => (23, 22, 0), Summer => (0, 0, 0));
-
- C3_Service_History :
- Service_History_Type (Quarterly_Period_Type,
- Month_In_Quarter_Type) :=
- (others => (others => 200));
-
-
- TC_Input_Total : Integer := 0;
- TC_Output_Total : Integer := 0;
-
-
- -- Subprogram bodies.
- -- These subprograms are designed to override the default attributes
- -- 'Input and 'Output for the specified types. Each adds/subtracts
- -- a quantity to/from a program control variable, indicating its
- -- activity. Each user defined "Input" function uses the 'Read
- -- attribute for the type to accomplish the operation. Likewise,
- -- each user defined "Output" subprogram uses the 'Write attribute
- -- for the type.
-
- function Service_Input
- ( Stream : access Ada.Streams.Root_Stream_Type'Class )
- return Service_Type is
- Customer : Customer_Type;
- begin
- TC_Input_Total := TC_Input_Total + 1;
-
- -- Extract the discriminant value from the stream.
- -- This discriminant would not otherwise be extracted from the
- -- stream when the Service_Type'Read attribute is used below.
- Customer_Type'Read (Stream, Customer);
-
- declare
- -- Declare a constant of Service_Type, using the value just
- -- read from the stream as the discriminant value of the
- -- object.
- Service : Service_Type(Customer);
- begin
- Service_Type'Read (Stream, Service);
- return Service;
- end;
- end Service_Input;
-
-
- procedure Service_Output
- ( Stream : access Ada.Streams.Root_Stream_Type'Class;
- Item : Service_Type ) is
- begin
- TC_Output_Total := TC_Output_Total + 2;
- -- Write the discriminant value to the stream.
- -- The attribute 'Write (for the record type) will not write the
- -- discriminant of the record object to the stream. Therefore, it
- -- must be explicitly written using the 'Write attribute of the
- -- discriminant type.
- Customer_Type'Write (Stream, Item.Customer);
- -- Write the record component values (but not the discriminant) to
- -- the stream.
- Service_Type'Write (Stream, Item);
- end Service_Output;
-
-
- function History_Input
- ( Stream : access Ada.Streams.Root_Stream_Type'Class )
- return Service_History_Type is
- Quarter_Bound_Low : Quarterly_Period_Type;
- Quarter_Bound_High : Quarterly_Period_Type;
- Month_Bound_Low : Month_In_Quarter_Type;
- Month_Bound_High : Month_In_Quarter_Type;
- begin
- TC_Input_Total := TC_Input_Total + 3;
-
- -- Read the value of the array bounds from the stream.
- -- Use these bounds in the creation of an array object that will
- -- be used to store data from the stream.
- -- The array bound values would not otherwise be read from the
- -- stream by use of the Service_History_Type'Read attribute.
- Quarterly_Period_Type'Read (Stream, Quarter_Bound_Low);
- Quarterly_Period_Type'Read (Stream, Quarter_Bound_High);
- Month_In_Quarter_Type'Read (Stream, Month_Bound_Low);
- Month_In_Quarter_Type'Read (Stream, Month_Bound_High);
-
- declare
- Service_History_Array :
- Service_History_Type
- (Quarterly_Period_Type range
- Quarter_Bound_Low..Quarter_Bound_High,
- Month_In_Quarter_Type range
- Month_Bound_Low .. Month_Bound_High);
- begin
- Service_History_Type'Read (Stream, Service_History_Array);
- return Service_History_Array;
- end;
- end History_Input;
-
-
- procedure History_Output
- ( Stream : access Ada.Streams.Root_Stream_Type'Class;
- Item : Service_History_Type ) is
- begin
- TC_Output_Total := TC_Output_Total + 7;
- -- Write the upper/lower bounds of the array object dimensions to
- -- the stream.
- Quarterly_Period_Type'Write (Stream, Item'First(1));
- Quarterly_Period_Type'Write (Stream, Item'Last(1));
- Month_In_Quarter_Type'Write (Stream, Item'First(2));
- Month_In_Quarter_Type'Write (Stream, Item'Last(2));
- -- Write the array values to the stream in canonical order (last
- -- dimension varying fastest).
- Service_History_Type'Write (Stream, Item);
- end History_Output;
-
-
-
- begin
-
- Util_Stream := Ada.Streams.Stream_IO.Stream (Util_File);
-
- -- Write data to the stream. A customer service record is followed
- -- by a service history array.
-
- Service_Type'Output (Util_Stream, Customer1);
- Service_History_Type'Output (Util_Stream, C1_Service_History);
-
- Service_Type'Output (Util_Stream, Customer2);
- Service_History_Type'Output (Util_Stream, C2_Service_History);
-
- Service_Type'Output (Util_Stream, Customer3);
- Service_History_Type'Output (Util_Stream, C3_Service_History);
-
-
- -- Read data from the stream, and verify the use of the user specified
- -- attributes.
-
- Verify_Data_Block:
- declare
-
- TC_Residence : Service_Type (Residence);
- TC_Apartment : Service_Type (Apartment);
- TC_Commercial : Service_Type (Commercial);
-
- TC_History1 : Service_History_Type (Quarterly_Period_Type,
- Month_In_Quarter_Type) :=
- (others => (others => Electric_Usage_Type'First));
-
- TC_History2 : Service_History_Type (Quarterly_Period_Type
- range Spring .. Summer,
- Month_In_Quarter_Type) :=
- (others => (others => Electric_Usage_Type'First));
-
- TC_History3 : Service_History_Type (Quarterly_Period_Type,
- Month_In_Quarter_Type) :=
- (others => (others => Electric_Usage_Type'First));
-
- begin
-
- -- Reset Stream file to mode In_File.
-
- Ada.Streams.Stream_IO.Reset (Util_File,
- Ada.Streams.Stream_IO.In_File);
-
- -- Read data from the stream.
-
- TC_Residence := Service_Type'Input (Util_Stream);
- TC_History1 := Service_History_Type'Input (Util_Stream);
-
- TC_Apartment := Service_Type'Input (Util_Stream);
- TC_History2 := Service_History_Type'Input (Util_Stream);
-
- TC_Commercial := Service_Type'Input (Util_Stream);
- TC_History3 := Service_History_Type'Input (Util_Stream);
-
-
- -- Verify product data was correctly written to/read from stream,
- -- including discriminants and array bounds.
-
- if (TC_Residence /= Customer1) or
- (TC_Residence.Customer /= Customer1.Customer) or
- (TC_History1'Last(1) /= C1_Service_History'Last(1)) or
- (TC_History1'First(1) /= C1_Service_History'First(1)) or
- (TC_History1'Last(2) /= C1_Service_History'Last(2)) or
- (TC_History1'First(2) /= C1_Service_History'First(2))
- then
- Report.Failed ("Incorrect data from stream - 1");
- end if;
-
- if (TC_Apartment /= Customer2) or
- (TC_Apartment.Customer /= Customer2.Customer) or
- (TC_History2 /= C2_Service_History) or
- (TC_History2'Last(1) /= C2_Service_History'Last(1)) or
- (TC_History2'First(1) /= C2_Service_History'First(1)) or
- (TC_History2'Last(2) /= C2_Service_History'Last(2)) or
- (TC_History2'First(2) /= C2_Service_History'First(2))
- then
- Report.Failed ("Incorrect data from stream - 2");
- end if;
-
- if (TC_Commercial /= Customer3) or
- (TC_Commercial.Customer /= Customer3.Customer) or
- (TC_History3 /= C3_Service_History) or
- (TC_History3'Last(1) /= C3_Service_History'Last(1)) or
- (TC_History3'First(1) /= C3_Service_History'First(1)) or
- (TC_History3'Last(2) /= C3_Service_History'Last(2)) or
- (TC_History3'First(2) /= C3_Service_History'First(2))
- then
- Report.Failed ("Incorrect data from stream - 3");
- end if;
-
- -- Verify that the user defined subprograms were used to override
- -- the default 'Input and 'Output attributes.
- -- There were three calls on each of the user defined attributes.
-
- if (TC_Input_Total /= 12 ) or (TC_Output_Total /= 27 ) then
- Report.Failed ("Incorrect use of user defined attributes");
- end if;
-
- end Verify_Data_Block;
-
- exception
-
- when others =>
- Report.Failed ("Exception raised in Operational Test Block");
-
- end Operational_Test_Block;
-
- if Ada.Streams.Stream_IO.Is_Open (Util_File) then
- Ada.Streams.Stream_IO.Delete (Util_File);
- else
- Ada.Streams.Stream_IO.Open (Util_File,
- Ada.Streams.Stream_IO.Out_File,
- Utility_Filename);
- Ada.Streams.Stream_IO.Delete (Util_File);
- end if;
-
-
- exception
-
- -- Since Use_Error or Name_Error can be raised if, for the specified
- -- mode, the environment does not support Stream_IO operations,
- -- the following handlers are included:
-
- when Ada.Streams.Stream_IO.Name_Error =>
- Report.Not_Applicable ("Name_Error raised on Stream IO Create");
-
- when Ada.Streams.Stream_IO.Use_Error =>
- Report.Not_Applicable ("Use_Error raised on Stream IO Create");
-
- when others =>
- Report.Failed ("Unexpected exception raised");
-
- end Test_for_Stream_IO_Support;
-
- Report.Result;
-
-end CXACB02;
diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxacc01.a b/gcc/testsuite/ada/acats/tests/cxa/cxacc01.a
deleted file mode 100644
index 3ab88f40e6d..00000000000
--- a/gcc/testsuite/ada/acats/tests/cxa/cxacc01.a
+++ /dev/null
@@ -1,299 +0,0 @@
--- CXACC01.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that the use of 'Class'Output and 'Class'Input allow stream
--- manipulation of objects of non-limited class-wide types.
---
--- TEST DESCRIPTION:
--- This test demonstrates the uses of 'Class'Output and 'Class'Input
--- in moving objects of a particular class to and from a stream file.
--- A procedure uses a class-wide parameter to move objects of specific
--- types in the class to the stream, using the 'Class'Output attribute
--- of the root type of the class. A function returns a class-wide object,
--- using the 'Class'Input attribute of the root type of the class to
--- extract the object from the stream.
--- A field-by-field comparison of record objects is performed to validate
--- the data read from the stream. Operator precedence rules are used
--- in the comparison rather than parentheses.
---
--- APPLICABILITY CRITERIA:
--- This test is applicable to all implementations capable of supporting
--- external Stream_IO files.
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 14 Nov 95 SAIC Corrected prefix of 'Tag attribute for ACVC 2.0.1.
--- 24 Aug 96 SAIC Changed a call to "Create" to "Reset".
--- 26 Feb 97 CTA.PWB Allowed for non-support of some IO operations.
---!
-
-with FXACC00, Ada.Streams.Stream_IO, Ada.Tags, Report;
-
-procedure CXACC01 is
-
- Order_File : Ada.Streams.Stream_IO.File_Type;
- Order_Stream : Ada.Streams.Stream_IO.Stream_Access;
- Order_Filename : constant String :=
- Report.Legal_File_Name ( Nam => "CXACC01" );
- Incomplete : exception;
-
-begin
-
- Report.Test ("CXACC01", "Check that the use of 'Class'Output " &
- "and 'Class'Input allow stream manipulation " &
- "of objects of non-limited class-wide types");
-
- Test_for_Stream_IO_Support:
- begin
-
- -- If an implementation does not support Stream_IO in a particular
- -- environment, the exception Use_Error or Name_Error will be raised on
- -- calls to various Stream_IO operations. This block statement
- -- encloses a call to Create, which should produce an exception in a
- -- non-supportive environment. These exceptions will be handled to
- -- produce a Not_Applicable result.
-
- Ada.Streams.Stream_IO.Create (Order_File,
- Ada.Streams.Stream_IO.Out_File,
- Order_Filename);
-
- exception
-
- when Ada.Streams.Stream_IO.Use_Error | Ada.Streams.Stream_IO.Name_Error =>
- Report.Not_Applicable
- ( "Files not supported - Create as Out_File for Stream_IO" );
- raise Incomplete;
-
- end Test_for_Stream_IO_Support;
-
- Operational_Test_Block:
- declare
-
- -- Store tag values associated with objects of tagged types.
-
- TC_Box_Office_Tag : constant String :=
- Ada.Tags.External_Tag(FXACC00.Ticket_Request'Tag);
-
- TC_Summer_Tag : constant String :=
- Ada.Tags.External_Tag(FXACC00.Subscriber_Request'Tag);
-
- TC_Mayoral_Tag : constant String :=
- Ada.Tags.External_Tag(FXACC00.VIP_Request'Tag);
-
- TC_Late_Tag : constant String :=
- Ada.Tags.External_Tag(FXACC00.Last_Minute_Request'Tag);
-
- -- The following procedure will take an object of the Ticket_Request
- -- class and output it to the stream. Objects of any extended type
- -- in the class can be output to the stream with this procedure.
-
- procedure Order_Entry (Order : FXACC00.Ticket_Request'Class) is
- begin
- FXACC00.Ticket_Request'Class'Output (Order_Stream, Order);
- end Order_Entry;
-
-
- -- The following function will retrieve from the stream an object of
- -- the Ticket_Request class.
-
- function Order_Retrieval return FXACC00.Ticket_Request'Class is
- begin
- return FXACC00.Ticket_Request'Class'Input (Order_Stream);
- end Order_Retrieval;
-
- begin
-
- Order_Stream := Ada.Streams.Stream_IO.Stream (Order_File);
-
- -- Store the data objects in the stream.
- -- Each of the objects is of a different type within the class.
-
- Order_Entry (FXACC00.Box_Office_Request); -- Object of root type
- Order_Entry (FXACC00.Summer_Subscription); -- Obj. of extended type
- Order_Entry (FXACC00.Mayoral_Ticket_Request); -- Obj. of extended type
- Order_Entry (FXACC00.Late_Request); -- Object of twice
- -- extended type.
-
- -- Reset mode of stream to In_File prior to reading data from it.
- Reset1:
- begin
- Ada.Streams.Stream_IO.Reset (Order_File,
- Ada.Streams.Stream_IO.In_File);
- exception
- when Ada.Streams.Stream_IO.Use_Error =>
- Report.Not_Applicable
- ( "Reset to In_File not supported for Stream_IO - 1" );
- raise Incomplete;
- end Reset1;
-
- Process_Order_Block:
- declare
-
- use FXACC00;
-
- -- Declare variables of the root type class,
- -- and initialize them with class-wide objects returned from
- -- the stream as function result.
-
- Order_1 : Ticket_Request'Class := Order_Retrieval;
- Order_2 : Ticket_Request'Class := Order_Retrieval;
- Order_3 : Ticket_Request'Class := Order_Retrieval;
- Order_4 : Ticket_Request'Class := Order_Retrieval;
-
- -- Declare objects of the specific types from within the class
- -- that correspond to the types of the data written to the
- -- stream. Perform a type conversion on the class-wide objects.
-
- Ticket_Order : Ticket_Request :=
- Ticket_Request(Order_1);
- Subscriber_Order : Subscriber_Request :=
- Subscriber_Request(Order_2);
- VIP_Order : VIP_Request :=
- VIP_Request(Order_3);
- Last_Minute_Order : Last_Minute_Request :=
- Last_Minute_Request(Order_4);
-
- begin
-
- -- Perform a field-by-field comparison of all the class-wide
- -- objects input from the stream with specific type objects
- -- originally written to the stream.
-
- if Ticket_Order.Location /=
- Box_Office_Request.Location or
- Ticket_Order.Number_Of_Tickets /=
- Box_Office_Request.Number_Of_Tickets
- then
- Report.Failed ("Ticket_Request object validation failure");
- end if;
-
- if Subscriber_Order.Location /=
- Summer_Subscription.Location or
- Subscriber_Order.Number_Of_Tickets /=
- Summer_Subscription.Number_Of_Tickets or
- Subscriber_Order.Subscription_Number /=
- Summer_Subscription.Subscription_Number
- then
- Report.Failed ("Subscriber_Request object validation failure");
- end if;
-
- if VIP_Order.Location /=
- Mayoral_Ticket_Request.Location or
- VIP_Order.Number_Of_Tickets /=
- Mayoral_Ticket_Request.Number_Of_Tickets or
- VIP_Order.Rank /=
- Mayoral_Ticket_Request.Rank
- then
- Report.Failed ("VIP_Request object validation failure");
- end if;
-
- if Last_Minute_Order.Location /=
- Late_Request.Location or
- Last_Minute_Order.Number_Of_Tickets /=
- Late_Request.Number_Of_Tickets or
- Last_Minute_Order.Rank /=
- Late_Request.Rank or
- Last_Minute_Order.Special_Consideration /=
- Late_Request.Special_Consideration or
- Last_Minute_Order.Donation /=
- Late_Request.Donation
- then
- Report.Failed ("Last_Minute_Request object validation failure");
- end if;
-
- -- Verify tag values from before and after processing.
- -- The 'Tag attribute is used with objects of a class-wide type.
-
- if TC_Box_Office_Tag /=
- Ada.Tags.External_Tag(Order_1'Tag)
- then
- Report.Failed("Failed tag comparison - 1");
- end if;
-
- if TC_Summer_Tag /=
- Ada.Tags.External_Tag(Order_2'Tag)
- then
- Report.Failed("Failed tag comparison - 2");
- end if;
-
- if TC_Mayoral_Tag /=
- Ada.Tags.External_Tag(Order_3'Tag)
- then
- Report.Failed("Failed tag comparison - 3");
- end if;
-
- if TC_Late_Tag /=
- Ada.Tags.External_Tag(Order_4'Tag)
- then
- Report.Failed("Failed tag comparison - 4");
- end if;
-
- end Process_Order_Block;
-
- -- After all the data has been correctly extracted, the file
- -- should be empty.
-
- if not Ada.Streams.Stream_IO.End_Of_File (Order_File) then
- Report.Failed ("Stream file not empty");
- end if;
-
- exception
- when Incomplete =>
- raise;
- when Constraint_Error =>
- Report.Failed ("Constraint_Error raised in Operational Block");
- when others =>
- Report.Failed ("Exception raised in Operational Test Block");
- end Operational_Test_Block;
-
- Deletion:
- begin
- if Ada.Streams.Stream_IO.Is_Open (Order_File) then
- Ada.Streams.Stream_IO.Delete (Order_File);
- else
- Ada.Streams.Stream_IO.Open (Order_File,
- Ada.Streams.Stream_IO.Out_File,
- Order_Filename);
- Ada.Streams.Stream_IO.Delete (Order_File);
- end if;
- exception
- when others =>
- Report.Failed
- ( "Delete not properly implemented for Stream_IO" );
- end Deletion;
-
- Report.Result;
-
-exception
-
- when Incomplete =>
- Report.Result;
- when others =>
- Report.Failed ( "Unexpected exception" );
- Report.Result;
-
-end CXACC01;
diff --git a/gcc/testsuite/ada/acats/tests/cxa/cxaf001.a b/gcc/testsuite/ada/acats/tests/cxa/cxaf001.a
deleted file mode 100644
index ae3497abde0..00000000000
--- a/gcc/testsuite/ada/acats/tests/cxa/cxaf001.a
+++ /dev/null
@@ -1,199 +0,0 @@
--- CXAF001.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that an implementation supports the functionality defined
--- in Package Ada.Command_Line.
---
--- TEST DESCRIPTION:
--- This test verifies that an implementation supports the subprograms
--- contained in package Ada.Command_Line. Each of the subprograms
--- is exercised in a general sense, to ensure that it is available,
--- and that it provides the prescribed results in a known test
--- environment. Function Argument_Count must return zero, or the
--- number of arguments passed to the program calling it. Function
--- Argument is called with a parameter value one greater than the
--- actual number of arguments passed to the executing program, which
--- must result in Constraint_Error being raised. Function Command_Name
--- should return the name of the executing program that called it
--- (specifically, this test name). Function Set_Exit_Status is called
--- with two different parameter values, the constants Failure and
--- Success defined in package Ada.Command_Line.
---
--- The setting of the variable TC_Verbose allows for some additional
--- output to be displayed during the running of the test as an aid in
--- tracing the processing flow of the test.
---
--- APPLICABILITY CRITERIA:
--- This test is applicable to implementations that support the
--- declaration of package Command_Line as defined in the Ada Reference
--- manual.
--- An alternative declaration is allowed for package Command_Line if
--- different functionality is appropriate for the external execution
--- environment.
---
---
--- CHANGE HISTORY:
--- 10 Jul 95 SAIC Initial prerelease version.
--- 02 May 96 SAIC Incorporated reviewer comments for ACVC 2.1.
--- 05 AUG 98 EDS Allow Null string result to be returned from
--- Function Command
---!
-
-with Ada.Command_Line;
-with Ada.Exceptions;
-with Report;
-
-procedure CXAF001 is
-begin
-
- Report.Test ("CXAF001", "Check that an implementation supports the " &
- "functionality defined in Package " &
- "Ada.Command_Line");
-
- Test_Block:
- declare
-
- use Ada.Exceptions;
-
- type String_Access is access all String;
-
- TC_Verbose : Boolean := False;
- Number_Of_Arguments : Natural := Natural'Last;
- Name_Of_Command : String_Access;
-
- begin
-
- -- Check the result of function Argument_Count.
- -- Note: If the external environment does not support passing arguments
- -- to the program invoking the function, the function result
- -- will be zero.
-
- Number_Of_Arguments := Ada.Command_Line.Argument_Count;
- if Number_Of_Arguments = Natural'Last then
- Report.Failed("Argument_Count did not provide a return result");
- end if;
- if TC_Verbose then
- Report.Comment
- ("Argument_Count = " & Integer'Image(Number_Of_Arguments));
- end if;
-
-
- -- Check that the result of Function Argument is Constraint_Error
- -- when the Number argument is outside the range of 1..Argument_Count.
-
- Test_Function_Argument_1 :
- begin
- declare
-
- -- Define a value that will be outside the range of
- -- 1..Argument_Count.
- -- Note: If the external execution environment does not support
- -- passing arguments to a program, then Argument(N) for
- -- any N will raise Constraint_Error, since
- -- Argument_Count = 0;
-
- Arguments_Plus_One : Positive :=
- Ada.Command_Line.Argument_Count + 1;
-
- -- Using the above value in a call to Argument must result in
- -- the raising of Constraint_Error.
-
- Argument_String : constant String :=
- Ada.Command_Line.Argument(Arguments_Plus_One);
-
- begin
- Report.Failed("Constraint_Error not raised by Function " &
- "Argument when provided a Number argument " &
- "out of range");
- end;
- exception
- when Constraint_Error => null; -- OK, expected exception.
- if TC_Verbose then
- Report.Comment ("Argument_Count raised Constraint_Error");
- end if;
- when others =>
- Report.Failed ("Unexpected exception raised by Argument " &
- "in Test_Function_Argument_1 block");
- end Test_Function_Argument_1;
-
-
- -- Check that Function Argument returns a string result.
-
- Test_Function_Argument_2 :
- begin
- if Ada.Command_Line.Argument_Count > 0 then
- Report.Comment
- ("Last argument is: " &
- Ada.Command_Line.Argument(Ada.Command_Line.Argument_Count));
- elsif TC_Verbose then
- Report.Comment("Argument_Count is zero, no test of Function " &
- "Argument for string result");
- end if;
- exception
- when others =>
- Report.Failed ("Unexpected exception raised by Argument " &
- "in Test_Function_Argument_2 block");
- end Test_Function_Argument_2;
-
-
- -- Check the result of Function Command_Name.
-
- Name_Of_Command := new String'(Ada.Command_Line.Command_Name);
-
- if Name_Of_Command = null then
- Report.Failed("Null string pointer returned from Function Command");
- elsif Name_Of_Command.all = "" then
- Report.Comment("Null string result returned from Function Command");
- elsif TC_Verbose then
- Report.Comment("Invoking command is " & Name_Of_Command.all);
- end if;
-
-
- -- Check that procedure Set_Exit_Status is available.
- -- Note: If the external execution environment does not support
- -- returning an exit value from a program, then Set_Exit_Status
- -- does nothing.
-
- Ada.Command_Line.Set_Exit_Status(Ada.Command_Line.Failure);
- if TC_Verbose then
- Report.Comment("Exit status set to Failure");
- end if;
-
- Ada.Command_Line.Set_Exit_Status(Ada.Command_Line.Success);
- if TC_Verbose then
- Report.Comment("Exit status set to Success");
- end if;
-
-
- exception
- when The_Error : others =>
- Report.Failed ("The following exception was raised in the " &
- "Test_Block: " & Exception_Name(The_Error));
- end Test_Block;
-
- Report.Result;
-
-end CXAF001;
diff --git a/gcc/testsuite/ada/acats/tests/cxb/cxb2001.a b/gcc/testsuite/ada/acats/tests/cxb/cxb2001.a
deleted file mode 100644
index 73f9209cd34..00000000000
--- a/gcc/testsuite/ada/acats/tests/cxb/cxb2001.a
+++ /dev/null
@@ -1,633 +0,0 @@
--- CXB2001.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that subprograms Shift_Left, Shift_Right,
--- Shift_Right_Arithmetic, Rotate_Left, and Rotate_Right are available
--- and produce correct results for values of signed and modular
--- integer types of 8 bits.
---
--- TEST DESCRIPTION:
--- This test uses the shift and rotate functions of package Interfaces
--- with a modular type representative of 8 bits. The functions
--- are used as the right hand of assignment statements, as part of
--- conditional statements, and as arguments in other function calls.
---
--- A check is performed in the test to determine whether the bit
--- ordering method used by the machine/implementation is high-order
--- first ("Big Endian") or low-order first ("Little Endian"). The
--- specific subtests use this information to evaluate the results of
--- each of the functions under test.
---
--- Note: In the string associated with each Report.Failed statement, the
--- acronym BE refers to Big Endian, LE refers to Little Endian.
---
--- APPLICABILITY CRITERIA:
--- This test is applicable to all implementations that support signed
--- and modular integer types of 8 bits.
---
---
--- CHANGE HISTORY:
--- 21 Aug 95 SAIC Initial prerelease version.
--- 07 May 96 SAIC Incorporated reviewer comments for ACVC 2.1.
---
---!
-
-with Report;
-with Interfaces;
-with Ada.Exceptions;
-
-procedure CXB2001 is
-begin
-
- Report.Test ("CXB2001",
- "Check that subprograms Shift_Left, Shift_Right, " &
- "Shift_Right_Arithmetic, Rotate_Left, and Rotate_Right " &
- "produce correct results for values of signed and " &
- "modular integer types of 8 bits");
-
- Test_Block:
- declare
-
- use Ada.Exceptions;
- use Interfaces;
-
- TC_Amount : Natural := Natural'First;
- Big_Endian : Boolean := False;
-
- -- Range of type Unsigned_8 is 0..255 (0..Modulus-1).
- TC_Val_Unsigned_8,
- TC_Result_Unsigned_8 : Unsigned_8 := Unsigned_8'First;
-
- begin
-
- -- Determine whether the machine uses high-order first or low-order
- -- first bit ordering.
- -- On a high-order first machine, bit zero of a storage element is
- -- the most significant bit (interpreting the sequence of bits that
- -- represent a component as an unsigned integer value).
- -- On a low-order first machine, bit zero is the least significant.
- -- In this check, a right shift of one place on a Big Endian machine
- -- will yield a result of one, while on a Little Endian machine the
- -- result would be four.
-
- TC_Val_Unsigned_8 := 2;
- Big_Endian := (Shift_Right(TC_Val_Unsigned_8, 1) = 1);
-
-
- -- Note: The shifting and rotating subprograms operate on a bit-by-bit
- -- basis, using the binary representation of the value of the
- -- operands to yield a binary representation for the result.
-
- -- Function Shift_Left.
-
- if Big_Endian then -- High-order first bit ordering.
-
- TC_Amount := 1;
- TC_Val_Unsigned_8 := Unsigned_8'Last; -- 255.
- TC_Result_Unsigned_8 := Shift_Left(Value => TC_Val_Unsigned_8,
- Amount => TC_Amount);
- if TC_Result_Unsigned_8 /= 254 then
- Report.Failed("Incorrect result from BE Shift_Left - 1");
- end if;
-
- if Shift_Left(TC_Val_Unsigned_8, 2) /= 252 or
- Shift_Left(TC_Val_Unsigned_8, 3) /= 248 or
- Shift_Left(TC_Val_Unsigned_8, 5) /= 224 or
- Shift_Left(TC_Val_Unsigned_8, 8) /= 0 or
- Shift_Left(TC_Val_Unsigned_8, 9) /= 0 or
- Shift_Left(TC_Val_Unsigned_8, 0) /= TC_Val_Unsigned_8
- then
- Report.Failed("Incorrect result from BE Shift_Left - 2");
- end if;
-
- TC_Val_Unsigned_8 := 1;
- if Shift_Left(TC_Val_Unsigned_8, 1) /= 2 or
- Shift_Left(TC_Val_Unsigned_8, Amount => 3) /= 8
- then
- Report.Failed("Incorrect result from BE Shift_Left - 3");
- end if;
-
- TC_Val_Unsigned_8 := 7;
- if Shift_Left(TC_Val_Unsigned_8, Amount => 4) /= 112 or
- Shift_Left(Shift_Left(TC_Val_Unsigned_8, 7), 1) /= 0
- then
- Report.Failed("Incorrect result from BE Shift_Left - 4");
- end if;
-
- else -- Low-order first bit ordering.
-
- TC_Amount := 1;
- TC_Val_Unsigned_8 := Unsigned_8'Last; -- 255.
- TC_Result_Unsigned_8 := Shift_Left(TC_Val_Unsigned_8, TC_Amount);
-
- if TC_Result_Unsigned_8 /= 127 then
- Report.Failed("Incorrect result from LE Shift_Left - 1");
- end if;
-
- if Shift_Left(TC_Val_Unsigned_8, 2) /= 63 or
- Shift_Left(TC_Val_Unsigned_8, 3) /= 31 or
- Shift_Left(TC_Val_Unsigned_8, 5) /= 7 or
- Shift_Left(TC_Val_Unsigned_8, 8) /= 0 or
- Shift_Left(TC_Val_Unsigned_8, 0) /= TC_Val_Unsigned_8
- then
- Report.Failed("Incorrect result from LE Shift_Left - 2");
- end if;
-
- TC_Val_Unsigned_8 := 1;
- if Shift_Left(TC_Val_Unsigned_8, 1) /= 0 or
- Shift_Left(TC_Val_Unsigned_8, 7) /= 0
- then
- Report.Failed("Incorrect result from LE Shift_Left - 3");
- end if;
-
- TC_Val_Unsigned_8 := 129;
- if Shift_Left(TC_Val_Unsigned_8, 4) /= 8 or
- Shift_Left(Shift_Left(TC_Val_Unsigned_8, 7), 1) /= 0
- then
- Report.Failed("Incorrect result from LE Shift_Left - 4");
- end if;
-
- end if;
-
-
-
- -- Function Shift_Right.
-
- if Big_Endian then -- High-order first bit ordering.
-
- TC_Amount := 1;
- TC_Val_Unsigned_8 := Unsigned_8'Last; -- 255.
- TC_Result_Unsigned_8 := Shift_Right(TC_Val_Unsigned_8, TC_Amount);
-
- if TC_Result_Unsigned_8 /= 127 then
- Report.Failed("Incorrect result from BE Shift_Right - 1");
- end if;
-
- if Shift_Right(TC_Val_Unsigned_8, 2) /= 63 or
- Shift_Right(TC_Val_Unsigned_8, 3) /= 31 or
- Shift_Right(TC_Val_Unsigned_8, 5) /= 7 or
- Shift_Right(TC_Val_Unsigned_8, 8) /= 0 or
- Shift_Right(TC_Val_Unsigned_8, 0) /= TC_Val_Unsigned_8
- then
- Report.Failed("Incorrect result from BE Shift_Right - 2");
- end if;
-
- TC_Val_Unsigned_8 := 1;
- if Shift_Right(TC_Val_Unsigned_8, 1) /= 0 or
- Shift_Right(TC_Val_Unsigned_8, 7) /= 0
- then
- Report.Failed("Incorrect result from BE Shift_Right - 3");
- end if;
-
- TC_Val_Unsigned_8 := 129;
- if Shift_Right(TC_Val_Unsigned_8, 4) /= 8 or
- Shift_Right(Shift_Right(TC_Val_Unsigned_8, 7), 1) /= 0
- then
- Report.Failed("Incorrect result from BE Shift_Right - 4");
- end if;
-
- else -- Low-order first bit ordering.
-
- TC_Amount := 1;
- TC_Val_Unsigned_8 := Unsigned_8'Last; -- 255.
- TC_Result_Unsigned_8 := Shift_Right(Value => TC_Val_Unsigned_8,
- Amount => TC_Amount);
- if TC_Result_Unsigned_8 /= 254 then
- Report.Failed("Incorrect result from LE Shift_Right - 1");
- end if;
-
- if Shift_Right(TC_Val_Unsigned_8, 2) /= 252 or
- Shift_Right(TC_Val_Unsigned_8, 3) /= 248 or
- Shift_Right(TC_Val_Unsigned_8, 5) /= 224 or
- Shift_Right(TC_Val_Unsigned_8, 8) /= 0 or
- Shift_Right(TC_Val_Unsigned_8, 9) /= 0 or
- Shift_Right(TC_Val_Unsigned_8, 0) /= TC_Val_Unsigned_8
- then
- Report.Failed("Incorrect result from LE Shift_Right - 2");
- end if;
-
- TC_Val_Unsigned_8 := 1;
- if Shift_Right(TC_Val_Unsigned_8, 1) /= 2 or
- Shift_Right(TC_Val_Unsigned_8, Amount => 3) /= 8
- then
- Report.Failed("Incorrect result from LE Shift_Right - 3");
- end if;
-
- TC_Val_Unsigned_8 := 7;
- if Shift_Right(TC_Val_Unsigned_8, Amount => 4) /= 112 or
- Shift_Right(Shift_Right(TC_Val_Unsigned_8, 7), 1) /= 0
- then
- Report.Failed("Incorrect result from LE Shift_Right - 4");
- end if;
-
- end if;
-
-
-
- -- Tests of Shift_Left and Shift_Right in combination.
-
- if Big_Endian then -- High-order first bit ordering.
-
- TC_Val_Unsigned_8 := 32;
-
- if Shift_Left(Shift_Right(TC_Val_Unsigned_8, 2), 2) /=
- TC_Val_Unsigned_8 or
- Shift_Left(Shift_Right(TC_Val_Unsigned_8, 1), 3) /= 128 or
- Shift_Right(Shift_Left(TC_Val_Unsigned_8, 2), 6) /= 2 or
- Shift_Right(Shift_Left(TC_Val_Unsigned_8, 2), 8) /= 0
- then
- Report.Failed("Incorrect result from BE Shift_Left - " &
- "Shift_Right functions used in combination");
- end if;
-
- else -- Low-order first bit ordering.
-
- TC_Val_Unsigned_8 := 32;
-
- if Shift_Left(Shift_Right(TC_Val_Unsigned_8, 2), 2) /=
- TC_Val_Unsigned_8 or
- Shift_Left(Shift_Right(TC_Val_Unsigned_8, 1), 3) /= 8 or
- Shift_Right(Shift_Left(TC_Val_Unsigned_8, 2), 3) /= 64 or
- Shift_Right(Shift_Left(TC_Val_Unsigned_8, 2), 4) /= 128
- then
- Report.Failed("Incorrect result from LE Shift_Left - " &
- "Shift_Right functions used in combination");
- end if;
-
- end if;
-
-
-
- -- Function Shift_Right_Arithmetic.
-
- if Big_Endian then -- High-order first bit ordering.
-
- -- Case where the parameter Value is less than
- -- one half of the modulus. Zero bits will be shifted in.
- -- Modulus of type Unsigned_8 is 256; half of the modulus is 128.
-
- TC_Amount := 1;
- TC_Val_Unsigned_8 := 127; -- Less than one half of modulus.
- TC_Result_Unsigned_8 := Shift_Right_Arithmetic(TC_Val_Unsigned_8,
- TC_Amount);
- if TC_Result_Unsigned_8 /= 63 then
- Report.Failed
- ("Incorrect result from BE Shift_Right_Arithmetic - 1");
- end if;
-
- if Shift_Right_Arithmetic(TC_Val_Unsigned_8, 2) /= 31 or
- Shift_Right_Arithmetic(TC_Val_Unsigned_8, 3) /= 15 or
- Shift_Right_Arithmetic(TC_Val_Unsigned_8, 5) /= 3 or
- Shift_Right_Arithmetic(TC_Val_Unsigned_8, 8) /= 0 or
- Shift_Right_Arithmetic(TC_Val_Unsigned_8, 0) /= TC_Val_Unsigned_8
- then
- Report.Failed
- ("Incorrect result from BE Shift_Right_Arithmetic - 2");
- end if;
-
- TC_Val_Unsigned_8 := 1;
- if Shift_Right_Arithmetic(TC_Val_Unsigned_8, Amount => 1) /= 0 or
- Shift_Right_Arithmetic(TC_Val_Unsigned_8, 3) /= 0
- then
- Report.Failed
- ("Incorrect result from BE Shift_Right_Arithmetic - 3");
- end if;
-
- -- Case where the parameter Value is greater than or equal to
- -- one half of the modulus. One bits will be shifted in.
-
- TC_Amount := 1;
- TC_Val_Unsigned_8 := 128; -- One half of modulus.
- TC_Result_Unsigned_8 := Shift_Right_Arithmetic(TC_Val_Unsigned_8,
- Amount => TC_Amount);
- if TC_Result_Unsigned_8 /= 192 then
- Report.Failed
- ("Incorrect result from BE Shift_Right_Arithmetic - 4");
- end if;
-
- TC_Amount := 1;
- TC_Val_Unsigned_8 := 129; -- Greater than one half of modulus.
- TC_Result_Unsigned_8 := Shift_Right_Arithmetic(TC_Val_Unsigned_8,
- Amount => TC_Amount);
- if TC_Result_Unsigned_8 /= 192 then
- Report.Failed
- ("Incorrect result from BE Shift_Right_Arithmetic - 5");
- end if;
-
- if Shift_Right_Arithmetic(TC_Val_Unsigned_8, 2) /= 224 or
- Shift_Right_Arithmetic(TC_Val_Unsigned_8, 3) /= 240 or
- Shift_Right_Arithmetic(TC_Val_Unsigned_8, 5) /= 252 or
- Shift_Right_Arithmetic(TC_Val_Unsigned_8, 7) /= Unsigned_8'Last or
- Shift_Right_Arithmetic(TC_Val_Unsigned_8, 0) /= TC_Val_Unsigned_8
- then
- Report.Failed
- ("Incorrect result from BE Shift_Right_Arithmetic - 6");
- end if;
-
- TC_Val_Unsigned_8 := Unsigned_8'Last;
- if Shift_Right_Arithmetic(TC_Val_Unsigned_8, 1) /=
- Unsigned_8'Last
- then
- Report.Failed
- ("Incorrect result from BE Shift_Right_Arithmetic - 7");
- end if;
-
- else -- Low-order first bit ordering
-
- -- Case where the parameter Value is less than
- -- one half of the modulus. Zero bits will be shifted in.
-
- TC_Amount := 1;
- TC_Val_Unsigned_8 := 127; -- Less than one half of modulus.
- TC_Result_Unsigned_8 := Shift_Right_Arithmetic(TC_Val_Unsigned_8,
- TC_Amount);
- if TC_Result_Unsigned_8 /= 254 then
- Report.Failed
- ("Incorrect result from LE Shift_Right_Arithmetic - 1");
- end if;
-
- TC_Val_Unsigned_8 := 2;
- if Shift_Right_Arithmetic(TC_Val_Unsigned_8, 2) /= 8 or
- Shift_Right_Arithmetic(TC_Val_Unsigned_8, 3) /= 16 or
- Shift_Right_Arithmetic(TC_Val_Unsigned_8, 5) /= 64 or
- Shift_Right_Arithmetic(TC_Val_Unsigned_8, 8) /= 0 or
- Shift_Right_Arithmetic(TC_Val_Unsigned_8, 0) /= TC_Val_Unsigned_8
- then
- Report.Failed
- ("Incorrect result from LE Shift_Right_Arithmetic - 2");
- end if;
-
- TC_Val_Unsigned_8 := 64;
- if Shift_Right_Arithmetic(TC_Val_Unsigned_8, Amount => 1) /= 128 or
- Shift_Right_Arithmetic(TC_Val_Unsigned_8, 3) /= 0
- then
- Report.Failed
- ("Incorrect result from LE Shift_Right_Arithmetic - 3");
- end if;
-
- -- Case where the parameter Value is greater than or equal to
- -- one half of the modulus. One bits will be shifted in.
-
- TC_Amount := 1;
- TC_Val_Unsigned_8 := 128; -- One half of modulus.
- TC_Result_Unsigned_8 := Shift_Right_Arithmetic(TC_Val_Unsigned_8,
- Amount => TC_Amount);
-
- if TC_Result_Unsigned_8 /= 3 then
- Report.Failed
- ("Incorrect result from LE Shift_Right_Arithmetic - 4");
- end if;
-
- TC_Amount := 1;
- TC_Val_Unsigned_8 := 129; -- Greater than one half of modulus.
- TC_Result_Unsigned_8 := Shift_Right_Arithmetic(TC_Val_Unsigned_8,
- Amount => TC_Amount);
-
- if TC_Result_Unsigned_8 /= 3 then
- Report.Failed
- ("Incorrect result from LE Shift_Right_Arithmetic - 5");
- end if;
-
- TC_Val_Unsigned_8 := 135; -- Greater than one half of modulus.
- if Shift_Right_Arithmetic(TC_Val_Unsigned_8, 2) /= 31 or
- Shift_Right_Arithmetic(TC_Val_Unsigned_8, 3) /= 63 or
- Shift_Right_Arithmetic(TC_Val_Unsigned_8, 5) /= Unsigned_8'Last or
- Shift_Right_Arithmetic(TC_Val_Unsigned_8, 7) /= Unsigned_8'Last or
- Shift_Right_Arithmetic(TC_Val_Unsigned_8, 0) /= TC_Val_Unsigned_8
- then
- Report.Failed
- ("Incorrect result from LE Shift_Right_Arithmetic - 6");
- end if;
-
- TC_Val_Unsigned_8 := Unsigned_8'Last;
- if Shift_Right_Arithmetic(TC_Val_Unsigned_8, 1) /=
- Unsigned_8'Last
- then
- Report.Failed
- ("Incorrect result from LE Shift_Right_Arithmetic - 7");
- end if;
-
- end if;
-
-
-
- -- Function Rotate_Left.
-
- if Big_Endian then -- High-order first bit ordering.
-
- TC_Amount := 1;
- TC_Val_Unsigned_8 := 129;
- TC_Result_Unsigned_8 := Rotate_Left(Value => TC_Val_Unsigned_8,
- Amount => TC_Amount);
- if TC_Result_Unsigned_8 /= 3 then
- Report.Failed("Incorrect result from BE Rotate_Left - 1");
- end if;
-
- if Rotate_Left(TC_Val_Unsigned_8, 2) /= 6 or
- Rotate_Left(TC_Val_Unsigned_8, 3) /= 12 or
- Rotate_Left(TC_Val_Unsigned_8, 5) /= 48 or
- Rotate_Left(TC_Val_Unsigned_8, 8) /= 129 or
- Rotate_Left(TC_Val_Unsigned_8, 0) /= TC_Val_Unsigned_8
- then
- Report.Failed("Incorrect result from BE Rotate_Left - 2");
- end if;
-
- TC_Val_Unsigned_8 := 1;
- if Rotate_Left(Value => TC_Val_Unsigned_8, Amount => 1) /= 2 or
- Rotate_Left(TC_Val_Unsigned_8, Amount => 3) /= 8
- then
- Report.Failed("Incorrect result from BE Rotate_Left - 3");
- end if;
-
- TC_Val_Unsigned_8 := 82;
- if Rotate_Left(TC_Val_Unsigned_8, Amount => 4) /= 37 or
- Rotate_Left(Rotate_Left(TC_Val_Unsigned_8, 7), 1) /= 82
- then
- Report.Failed("Incorrect result from BE Rotate_Left - 4");
- end if;
-
- else -- Low-order first bit ordering.
-
- TC_Amount := 1;
- TC_Val_Unsigned_8 := 1;
- TC_Result_Unsigned_8 := Rotate_Left(TC_Val_Unsigned_8, TC_Amount);
-
- if TC_Result_Unsigned_8 /= 128 then
- Report.Failed("Incorrect result from LE Rotate_Left - 1");
- end if;
-
- TC_Val_Unsigned_8 := 15;
- if Rotate_Left(TC_Val_Unsigned_8, 2) /= 195 or
- Rotate_Left(TC_Val_Unsigned_8, 3) /= 225 or
- Rotate_Left(TC_Val_Unsigned_8, 5) /= 120 or
- Rotate_Left(TC_Val_Unsigned_8, 8) /= TC_Val_Unsigned_8 or
- Rotate_Left(TC_Val_Unsigned_8, 0) /= TC_Val_Unsigned_8
- then
- Report.Failed("Incorrect result from LE Rotate_Left - 2");
- end if;
-
- TC_Val_Unsigned_8 := Unsigned_8'Last;
- if Rotate_Left(TC_Val_Unsigned_8, 1) /= Unsigned_8'Last then
- Report.Failed("Incorrect result from LE Rotate_Left - 3");
- end if;
-
- TC_Val_Unsigned_8 := 12;
- if Rotate_Left(TC_Val_Unsigned_8, 1) /= 6 or
- Rotate_Left(TC_Val_Unsigned_8, 3) /= 129
- then
- Report.Failed("Incorrect result from LE Rotate_Left - 4");
- end if;
-
- TC_Val_Unsigned_8 := 129;
- if Rotate_Left(TC_Val_Unsigned_8, 4) /= 24 or
- Rotate_Left(Rotate_Left(TC_Val_Unsigned_8, 7), 1) /= 129
- then
- Report.Failed("Incorrect result from LE Rotate_Left - 5");
- end if;
-
- end if;
-
-
-
- -- Function Rotate_Right.
-
- if Big_Endian then -- High-order first bit ordering.
-
- TC_Amount := 1;
- TC_Val_Unsigned_8 := 1;
- TC_Result_Unsigned_8 := Rotate_Right(TC_Val_Unsigned_8, TC_Amount);
-
- if TC_Result_Unsigned_8 /= 128 then
- Report.Failed("Incorrect result from BE Rotate_Right - 1");
- end if;
-
- TC_Val_Unsigned_8 := 15;
- if Rotate_Right(TC_Val_Unsigned_8, 2) /= 195 or
- Rotate_Right(TC_Val_Unsigned_8, 3) /= 225 or
- Rotate_Right(TC_Val_Unsigned_8, 5) /= 120 or
- Rotate_Right(TC_Val_Unsigned_8, 8) /= TC_Val_Unsigned_8 or
- Rotate_Right(TC_Val_Unsigned_8, 0) /= TC_Val_Unsigned_8
- then
- Report.Failed("Incorrect result from BE Rotate_Right - 2");
- end if;
-
- TC_Val_Unsigned_8 := Unsigned_8'Last;
- if Rotate_Right(TC_Val_Unsigned_8, 1) /= Unsigned_8'Last then
- Report.Failed("Incorrect result from BE Rotate_Right - 3");
- end if;
-
- TC_Val_Unsigned_8 := 12;
- if Rotate_Right(TC_Val_Unsigned_8, 1) /= 6 or
- Rotate_Right(TC_Val_Unsigned_8, 3) /= 129
- then
- Report.Failed("Incorrect result from BE Rotate_Right - 4");
- end if;
-
- TC_Val_Unsigned_8 := 129;
- if Rotate_Right(TC_Val_Unsigned_8, 4) /= 24 or
- Rotate_Right(Rotate_Right(TC_Val_Unsigned_8, 7), 1) /= 129
- then
- Report.Failed("Incorrect result from BE Rotate_Right - 5");
- end if;
-
- else -- Low-order first bit ordering.
-
- TC_Amount := 1;
- TC_Val_Unsigned_8 := 129;
- TC_Result_Unsigned_8 := Rotate_Right(Value => TC_Val_Unsigned_8,
- Amount => TC_Amount);
- if TC_Result_Unsigned_8 /= 3 then
- Report.Failed("Incorrect result from LE Rotate_Right - 1");
- end if;
-
- if Rotate_Right(TC_Val_Unsigned_8, 2) /= 6 or
- Rotate_Right(TC_Val_Unsigned_8, 3) /= 12 or
- Rotate_Right(TC_Val_Unsigned_8, 5) /= 48 or
- Rotate_Right(TC_Val_Unsigned_8, 8) /= 129 or
- Rotate_Right(TC_Val_Unsigned_8, 0) /= TC_Val_Unsigned_8
- then
- Report.Failed("Incorrect result from LE Rotate_Right - 2");
- end if;
-
- TC_Val_Unsigned_8 := 1;
- if Rotate_Right(Value => TC_Val_Unsigned_8, Amount => 1) /= 2 or
- Rotate_Right(TC_Val_Unsigned_8, Amount => 3) /= 8
- then
- Report.Failed("Incorrect result from LE Rotate_Right - 3");
- end if;
-
- TC_Val_Unsigned_8 := 82;
- if Rotate_Right(TC_Val_Unsigned_8, Amount => 4) /= 37 or
- Rotate_Right(Rotate_Right(TC_Val_Unsigned_8, 7), 1) /= 82
- then
- Report.Failed("Incorrect result from LE Rotate_Right - 4");
- end if;
-
- end if;
-
-
-
- -- Tests of Rotate_Left and Rotate_Right in combination.
-
- if Big_Endian then -- High-order first bit ordering.
-
- TC_Val_Unsigned_8 := 17;
-
- if Rotate_Left(Rotate_Right(TC_Val_Unsigned_8, 2), 2) /=
- TC_Val_Unsigned_8 or
- Rotate_Left(Rotate_Right(TC_Val_Unsigned_8, 1), 3) /= 68 or
- Rotate_Right(Rotate_Left(TC_Val_Unsigned_8, 3), 7) /= 17 or
- Rotate_Right(Rotate_Left(TC_Val_Unsigned_8, 2), 8) /= 68
- then
- Report.Failed("Incorrect result from BE Rotate_Left - " &
- "Rotate_Right functions used in combination");
- end if;
-
- else -- Low-order first bit ordering.
-
- TC_Val_Unsigned_8 := 4;
-
- if Rotate_Left(Rotate_Right(TC_Val_Unsigned_8, 2), 2) /=
- TC_Val_Unsigned_8 or
- Rotate_Left(Rotate_Right(TC_Val_Unsigned_8, 1), 3) /= 1 or
- Rotate_Right(Rotate_Left(TC_Val_Unsigned_8, 3), 7) /= 64 or
- Rotate_Right(Rotate_Left(TC_Val_Unsigned_8, 2), 8) /= 1
- then
- Report.Failed("Incorrect result from LE Rotate_Left - " &
- "Rotate_Right functions used in combination");
- end if;
-
- end if;
-
- exception
- when The_Error : others =>
- Report.Failed ("The following exception was raised in the " &
- "Test_Block: " & Exception_Name(The_Error));
- end Test_Block;
-
- Report.Result;
-
-end CXB2001;
diff --git a/gcc/testsuite/ada/acats/tests/cxb/cxb2002.a b/gcc/testsuite/ada/acats/tests/cxb/cxb2002.a
deleted file mode 100644
index 945722295e7..00000000000
--- a/gcc/testsuite/ada/acats/tests/cxb/cxb2002.a
+++ /dev/null
@@ -1,259 +0,0 @@
--- CXB2002.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that subprograms Shift_Left, Shift_Right,
--- Shift_Right_Arithmetic, Rotate_Left, and Rotate_Right are available
--- and produce correct results for values of signed and modular
--- integer types of 16 bits.
---
--- TEST DESCRIPTION:
--- This test uses the shift and rotate functions of package Interfaces
--- with a modular type representative of 16 bits. The functions
--- are used as the right hand of assignment statements, as part of
--- conditional statements, and as arguments in other function calls.
---
--- APPLICABILITY CRITERIA:
--- This test is applicable to all implementations that support signed
--- and modular integer types of 16 bits.
---
---
--- CHANGE HISTORY:
--- 21 Aug 95 SAIC Initial prerelease version.
--- 07 May 96 SAIC Incorporated reviewer comments for ACVC 2.1.
--- 26 Oct 96 SAIC Removed subtests based on Big/Little Endian.
--- 17 Feb 97 PWB.CTA Corrected "-" to "+" in parenthesized expressions.
---!
-
-with Report;
-with Interfaces;
-with Ada.Exceptions;
-
-procedure CXB2002 is
-begin
-
- Report.Test ("CXB2002",
- "Check that subprograms Shift_Left, Shift_Right, " &
- "Shift_Right_Arithmetic, Rotate_Left, and Rotate_Right " &
- "produce correct results for values of signed and " &
- "modular integer types of 16 bits");
-
- Test_Block:
- declare
-
- use Ada.Exceptions;
- use Interfaces;
-
- TC_Amount : Natural := Natural'First;
-
- -- Range of type Unsigned_16 is 0..65535 (0..Modulus-1).
- TC_Val_Unsigned_16,
- TC_Result_Unsigned_16 : Unsigned_16 := Unsigned_16'First;
-
- begin
-
- -- Note: The shifting and rotating subprograms operate on a bit-by-bit
- -- basis, using the binary representation of the value of the
- -- operands to yield a binary representation for the result.
-
- -- Function Shift_Left.
-
- TC_Amount := 3;
- TC_Val_Unsigned_16 := Unsigned_16'Last; -- 65535.
- TC_Result_Unsigned_16 := Shift_Left(TC_Val_Unsigned_16, TC_Amount);
-
- if TC_Result_Unsigned_16 /= Unsigned_16'Last - (2**0 + 2**1 + 2**2)
- then
- Report.Failed("Incorrect result from Shift_Left - 1");
- end if;
-
- if Shift_Left(TC_Val_Unsigned_16, 0) /= Unsigned_16'Last or
- Shift_Left(TC_Val_Unsigned_16, 5) /=
- Unsigned_16'Last - (2**0 + 2**1 + 2**2 + 2**3 +2**4) or
- Shift_Left(TC_Val_Unsigned_16, 16) /= 0
- then
- Report.Failed("Incorrect result from Shift_Left - 2");
- end if;
-
-
- -- Function Shift_Right.
-
- TC_Amount := 3;
- TC_Val_Unsigned_16 := Unsigned_16'Last; -- 65535.
- TC_Result_Unsigned_16 := Shift_Right(Value => TC_Val_Unsigned_16,
- Amount => TC_Amount);
-
- if TC_Result_Unsigned_16 /= Unsigned_16'Last-(2**15 + 2**14 + 2**13)
- then
- Report.Failed("Incorrect result from Shift_Right - 1");
- end if;
-
- if Shift_Right(TC_Val_Unsigned_16, 0) /= Unsigned_16'Last or
- Shift_Right(TC_Val_Unsigned_16, 5) /=
- Unsigned_16'Last-(2**15 + 2**14 + 2**13 + 2**12 + 2**11) or
- Shift_Right(TC_Val_Unsigned_16, 16) /= 0
- then
- Report.Failed("Incorrect result from Shift_Right - 2");
- end if;
-
-
- -- Tests of Shift_Left and Shift_Right in combination.
-
- TC_Val_Unsigned_16 := Unsigned_16'Last;
-
- if Shift_Left(Shift_Right(TC_Val_Unsigned_16, 4), 4) /=
- Unsigned_16'Last-(2**0 + 2**1 + 2**2 + 2**3) or
- Shift_Left(Shift_Right(TC_Val_Unsigned_16, 1), 3) /=
- Unsigned_16'Last-(2**0 + 2**1 + 2**2) or
- Shift_Right(Shift_Left(TC_Val_Unsigned_16, 2), 4) /=
- Unsigned_16'Last-(2**15+ 2**14 + 2**13 + 2**12) or
- Shift_Right(Shift_Left(TC_Val_Unsigned_16, 2), 16) /= 0
- then
- Report.Failed("Incorrect result from Shift_Left - " &
- "Shift_Right functions used in combination");
- end if;
-
-
- -- Function Shift_Right_Arithmetic.
-
- -- Case where the parameter Value is less than
- -- one half of the modulus. Zero bits will be shifted in.
- -- Modulus of type Unsigned_16 is 2**16; one half is 2**15.
-
- TC_Amount := 3;
- TC_Val_Unsigned_16 := 2**15 - 1; -- Less than one half of modulus.
- TC_Result_Unsigned_16 := Shift_Right_Arithmetic(TC_Val_Unsigned_16,
- TC_Amount);
- if TC_Result_Unsigned_16 /=
- TC_Val_Unsigned_16 - (2**14 + 2**13 + 2**12)
- then
- Report.Failed
- ("Incorrect result from Shift_Right_Arithmetic - 1");
- end if;
-
- if Shift_Right_Arithmetic(TC_Val_Unsigned_16, 0) /=
- TC_Val_Unsigned_16 or
- Shift_Right_Arithmetic(TC_Val_Unsigned_16, 5) /=
- TC_Val_Unsigned_16 - (2**14 + 2**13 + 2**12 + 2**11 + 2**10) or
- Shift_Right_Arithmetic(TC_Val_Unsigned_16, 16) /= 0
- then
- Report.Failed
- ("Incorrect result from Shift_Right_Arithmetic - 2");
- end if;
-
- -- Case where the parameter Value is greater than or equal to
- -- one half of the modulus. One bits will be shifted in.
-
- TC_Amount := 1;
- TC_Val_Unsigned_16 := 2**15; -- One half of modulus.
- TC_Result_Unsigned_16 := Shift_Right_Arithmetic(TC_Val_Unsigned_16,
- TC_Amount);
- if TC_Result_Unsigned_16 /= TC_Val_Unsigned_16 + 2**14 then
- Report.Failed
- ("Incorrect result from Shift_Right_Arithmetic - 3");
- end if;
-
- TC_Amount := 1;
- TC_Val_Unsigned_16 := 2**15 + 1; -- Greater than half of modulus.
- TC_Result_Unsigned_16 := Shift_Right_Arithmetic(TC_Val_Unsigned_16,
- TC_Amount);
- if TC_Result_Unsigned_16 /= TC_Val_Unsigned_16 + 2**14 - 2**0 then
- Report.Failed
- ("Incorrect result from Shift_Right_Arithmetic - 4");
- end if;
-
- if Shift_Right_Arithmetic(TC_Val_Unsigned_16, 0) /=
- TC_Val_Unsigned_16 or
- Shift_Right_Arithmetic(TC_Val_Unsigned_16, 4) /=
- TC_Val_Unsigned_16 - 2**0 + 2**14 + 2**13 + 2**12 + 2**11 or
- Shift_Right_Arithmetic(TC_Val_Unsigned_16, 16) /= Unsigned_16'Last
- then
- Report.Failed
- ("Incorrect result from Shift_Right_Arithmetic - 5");
- end if;
-
-
- -- Function Rotate_Left.
-
- TC_Amount := 3;
- TC_Val_Unsigned_16 := Unsigned_16'Last; -- 65535.
- TC_Result_Unsigned_16 := Rotate_Left(Value => TC_Val_Unsigned_16,
- Amount => TC_Amount);
- if TC_Result_Unsigned_16 /= Unsigned_16'Last then
- Report.Failed("Incorrect result from Rotate_Left - 1");
- end if;
-
- TC_Val_Unsigned_16 := 2**15 + 2**14 + 2**1 + 2**0;
- if Rotate_Left(TC_Val_Unsigned_16, 0) /=
- 2**15 + 2**14 + 2**1 + 2**0 or
- Rotate_Left(TC_Val_Unsigned_16, 5) /=
- 2**6 + 2**5 + 2**4 + 2**3 or
- Rotate_Left(TC_Val_Unsigned_16, 16) /= TC_Val_Unsigned_16
- then
- Report.Failed("Incorrect result from Rotate_Left - 2");
- end if;
-
-
- -- Function Rotate_Right.
-
- TC_Amount := 1;
- TC_Val_Unsigned_16 := 2**1 + 2**0;
- TC_Result_Unsigned_16 := Rotate_Right(Value => TC_Val_Unsigned_16,
- Amount => TC_Amount);
- if TC_Result_Unsigned_16 /= 2**15 + 2**0 then
- Report.Failed("Incorrect result from Rotate_Right - 1");
- end if;
-
- if Rotate_Right(TC_Val_Unsigned_16, 0) /= 2**1 + 2**0 or
- Rotate_Right(TC_Val_Unsigned_16, 5) /= 2**12 + 2**11 or
- Rotate_Right(TC_Val_Unsigned_16, 16) /= 2**1 + 2**0
- then
- Report.Failed("Incorrect result from Rotate_Right - 2");
- end if;
-
-
- -- Tests of Rotate_Left and Rotate_Right in combination.
-
- TC_Val_Unsigned_16 := 32769;
-
- if Rotate_Left(Rotate_Right(TC_Val_Unsigned_16, 4), 3) /= 49152 or
- Rotate_Left(Rotate_Right(TC_Val_Unsigned_16, 1), 3) /= 6 or
- Rotate_Right(Rotate_Left(TC_Val_Unsigned_16, 3), 7) /= 6144 or
- Rotate_Right(Rotate_Left(TC_Val_Unsigned_16, 1), 16) /= 3
- then
- Report.Failed("Incorrect result from Rotate_Left - " &
- "Rotate_Right functions used in combination");
- end if;
-
-
- exception
- when The_Error : others =>
- Report.Failed ("The following exception was raised in the " &
- "Test_Block: " & Exception_Name(The_Error));
- end Test_Block;
-
- Report.Result;
-
-end CXB2002;
diff --git a/gcc/testsuite/ada/acats/tests/cxb/cxb2003.a b/gcc/testsuite/ada/acats/tests/cxb/cxb2003.a
deleted file mode 100644
index ec3998ad875..00000000000
--- a/gcc/testsuite/ada/acats/tests/cxb/cxb2003.a
+++ /dev/null
@@ -1,255 +0,0 @@
--- CXB2003.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that subprograms Shift_Left, Shift_Right,
--- Shift_Right_Arithmetic, Rotate_Left, and Rotate_Right are available
--- and produce correct results for values of signed and modular
--- integer types of 32 bits.
---
--- TEST DESCRIPTION:
--- This test uses the shift and rotate functions of package Interfaces
--- with a modular type representative of 32 bits. The functions
--- are used as the right hand of assignment statements, as part of
--- conditional statements, and as arguments in other function calls.
---
--- APPLICABILITY CRITERIA:
--- This test is applicable to all implementations that support signed
--- and modular integer types of 32 bits.
---
---
--- CHANGE HISTORY:
--- 23 Aug 95 SAIC Initial prerelease version.
--- 07 May 96 SAIC Incorporated reviewer comments for ACVC 2.1.
--- 26 Oct 96 SAIC Removed all references to Big/Little endian.
---
---!
-
-with Report;
-with Interfaces;
-with Ada.Exceptions;
-
-procedure CXB2003 is
-begin
-
- Report.Test ("CXB2003",
- "Check that subprograms Shift_Left, Shift_Right, " &
- "Shift_Right_Arithmetic, Rotate_Left, and Rotate_Right " &
- "are available and produce correct results");
-
- Test_Block:
- declare
-
- use Interfaces;
- use Ada.Exceptions;
-
- TC_Amount : Natural := Natural'First;
-
- -- Range of type Unsigned_32 is 0..(2**32)-1 (0..Modulus-1).
- TC_Val_Unsigned_32,
- TC_Result_Unsigned_32 : Unsigned_32 := Unsigned_32'First;
-
- begin
-
- -- Note: The shifting and rotating subprograms operate on a bit-by-bit
- -- basis, using the binary representation of the value of the
- -- operands to yield a binary representation for the result.
-
-
- -- Function Shift_Left.
-
- TC_Amount := 2;
- TC_Val_Unsigned_32 := Unsigned_32'Last;
- TC_Result_Unsigned_32 := Shift_Left(TC_Val_Unsigned_32, TC_Amount);
-
- if TC_Result_Unsigned_32 /= Unsigned_32'Last - (2**0 + 2**1) then
- Report.Failed("Incorrect result from Shift_Left - 1");
- end if;
-
- TC_Result_Unsigned_32 := Unsigned_32'Last - (2**0 + 2**1 + 2**2 +
- 2**3 + 2**4);
- if Shift_Left(TC_Val_Unsigned_32, 5) /= TC_Result_Unsigned_32 or
- Shift_Left(TC_Val_Unsigned_32, 0) /= Unsigned_32'Last
- then
- Report.Failed("Incorrect result from Shift_Left - 2");
- end if;
-
-
- -- Function Shift_Right.
-
- TC_Amount := 3;
- TC_Val_Unsigned_32 := Unsigned_32'Last;
- TC_Result_Unsigned_32 := Shift_Right(Value => TC_Val_Unsigned_32,
- Amount => TC_Amount);
- if TC_Result_Unsigned_32 /=
- Unsigned_32'Last - (2**31 + 2**30 + 2**29)
- then
- Report.Failed("Incorrect result from Shift_Right - 1");
- end if;
-
- if Shift_Right(TC_Val_Unsigned_32, 0) /= Unsigned_32'Last or
- Shift_Right(TC_Val_Unsigned_32, 2) /= Unsigned_32'Last -
- (2**31 + 2**30)
- then
- Report.Failed("Incorrect result from Shift_Right - 2");
- end if;
-
-
- -- Tests of Shift_Left and Shift_Right in combination.
-
- TC_Val_Unsigned_32 := Unsigned_32'Last;
-
- if Shift_Left(Shift_Right(TC_Val_Unsigned_32, 4), 4) /=
- Unsigned_32'Last - (2**0 + 2**1 + 2**2 + 2**3) or
- Shift_Left(Shift_Right(TC_Val_Unsigned_32, 3), 1) /=
- Unsigned_32'Last - (2**31 + 2**30 + 2**0) or
- Shift_Left(Shift_Right(TC_Val_Unsigned_32, 5), 3) /=
- Unsigned_32'Last - (2**31 + 2**30 + 2**2 + 2**1 + 2**0) or
- Shift_Right(Shift_Left(TC_Val_Unsigned_32, 2), 1) /=
- Unsigned_32'Last - (2**31 + 2**0)
- then
- Report.Failed("Incorrect result from Shift_Left - " &
- "Shift_Right functions used in combination");
- end if;
-
-
- -- Function Shift_Right_Arithmetic.
-
- -- Case where the parameter Value is less than
- -- one half of the modulus. Zero bits will be shifted in.
-
- TC_Amount := 3;
- TC_Val_Unsigned_32 := 2**15 + 2**10 + 2**1;
- TC_Result_Unsigned_32 := Shift_Right_Arithmetic(TC_Val_Unsigned_32,
- TC_Amount);
- if TC_Result_Unsigned_32 /= (2**12 + 2**7) then
- Report.Failed
- ("Incorrect result from Shift_Right_Arithmetic - 1");
- end if;
-
- if Shift_Right_Arithmetic(TC_Val_Unsigned_32, 0) /=
- TC_Val_Unsigned_32 or
- Shift_Right_Arithmetic(TC_Val_Unsigned_32, 5) /=
- (2**10 + 2**5)
- then
- Report.Failed
- ("Incorrect result from Shift_Right_Arithmetic - 2");
- end if;
-
- -- Case where the parameter Value is greater than or equal to
- -- one half of the modulus. One bits will be shifted in.
-
- TC_Amount := 1;
- TC_Val_Unsigned_32 := 2**31; -- One half of modulus
- TC_Result_Unsigned_32 := Shift_Right_Arithmetic(TC_Val_Unsigned_32,
- TC_Amount);
- if TC_Result_Unsigned_32 /= (2**31 + 2**30) then
- Report.Failed
- ("Incorrect result from Shift_Right_Arithmetic - 3");
- end if;
-
- TC_Amount := 1;
- TC_Val_Unsigned_32 := (2**31 + 2**1);
- TC_Result_Unsigned_32 := Shift_Right_Arithmetic(TC_Val_Unsigned_32,
- TC_Amount);
- if TC_Result_Unsigned_32 /= (2**31 + 2**30 + 2**0) then
- Report.Failed
- ("Incorrect result from Shift_Right_Arithmetic - 4");
- end if;
-
- if Shift_Right_Arithmetic(TC_Val_Unsigned_32, 0) /=
- TC_Val_Unsigned_32 or
- Shift_Right_Arithmetic(TC_Val_Unsigned_32, 3) /=
- (2**31 + 2**30 + 2**29 + 2**28)
- then
- Report.Failed
- ("Incorrect result from Shift_Right_Arithmetic - 5");
- end if;
-
-
- -- Function Rotate_Left.
-
- TC_Amount := 3;
- TC_Val_Unsigned_32 := Unsigned_32'Last;
- TC_Result_Unsigned_32 := Rotate_Left(Value => TC_Val_Unsigned_32,
- Amount => TC_Amount);
- if TC_Result_Unsigned_32 /= Unsigned_32'Last then
- Report.Failed("Incorrect result from Rotate_Left - 1");
- end if;
-
- TC_Val_Unsigned_32 := 2**31 + 2**30;
- if Rotate_Left(TC_Val_Unsigned_32, 1) /= (2**31 + 2**0) or
- Rotate_Left(TC_Val_Unsigned_32, 5) /= (2**4 + 2**3) or
- Rotate_Left(TC_Val_Unsigned_32, 32) /= TC_Val_Unsigned_32
- then
- Report.Failed("Incorrect result from Rotate_Left - 2");
- end if;
-
-
- -- Function Rotate_Right.
-
- TC_Amount := 2;
- TC_Val_Unsigned_32 := (2**1 + 2**0);
- TC_Result_Unsigned_32 := Rotate_Right(Value => TC_Val_Unsigned_32,
- Amount => TC_Amount);
- if TC_Result_Unsigned_32 /= (2**31 + 2**30) then
- Report.Failed("Incorrect result from Rotate_Right - 1");
- end if;
-
- if Rotate_Right(TC_Val_Unsigned_32, 3) /= (2**30 + 2**29) or
- Rotate_Right(TC_Val_Unsigned_32, 6) /= (2**27 + 2**26) or
- Rotate_Right(TC_Val_Unsigned_32, 32) /= (2**1 + 2**0)
- then
- Report.Failed("Incorrect result from Rotate_Right - 2");
- end if;
-
-
- -- Tests of Rotate_Left and Rotate_Right in combination.
-
- TC_Val_Unsigned_32 := (2**31 + 2**15 + 2**3);
-
- if Rotate_Left(Rotate_Right(TC_Val_Unsigned_32, 4), 3) /=
- (2**30 + 2**14 + 2**2) or
- Rotate_Left(Rotate_Right(TC_Val_Unsigned_32, 1), 3) /=
- (2**17 + 2**5 + 2**1) or
- Rotate_Right(Rotate_Left(TC_Val_Unsigned_32, 3), 7) /=
- (2**31 + 2**27 + 2**11) or
- Rotate_Right(Rotate_Left(TC_Val_Unsigned_32, 1), 32) /=
- (2**16 + 2**4 + 2**0)
- then
- Report.Failed("Incorrect result from Rotate_Left - " &
- "Rotate_Right functions used in combination");
- end if;
-
-
- exception
- when The_Error : others =>
- Report.Failed ("The following exception was raised in the " &
- "Test_Block: " & Exception_Name(The_Error));
- end Test_Block;
-
- Report.Result;
-
-end CXB2003;
diff --git a/gcc/testsuite/ada/acats/tests/cxb/cxb3001.a b/gcc/testsuite/ada/acats/tests/cxb/cxb3001.a
deleted file mode 100644
index 4d79b24e1f3..00000000000
--- a/gcc/testsuite/ada/acats/tests/cxb/cxb3001.a
+++ /dev/null
@@ -1,179 +0,0 @@
--- CXB3001.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that the specifications of the package Interfaces.C are
--- available for use.
---
--- TEST DESCRIPTION:
--- This test verifies that the types and subprograms specified for the
--- interface are present. It just checks for the presence of
--- the subprograms. Other tests are designed to exercise the interface.
---
--- APPLICABILITY CRITERIA:
--- If an implementation provides package Interfaces.C, this test
--- must compile, execute, and report "PASSED".
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 15 Nov 95 SAIC Corrected To_C parameter list for ACVC 2.0.1.
--- 28 Feb 96 SAIC Added applicability criteria.
---
---!
-
-with Report;
-with Interfaces.C; -- N/A => ERROR
-
-procedure CXB3001 is
- package C renames Interfaces.C;
- use type C.signed_char;
- use type C.unsigned_char;
- use type C.char;
-
-begin
-
- Report.Test ("CXB3001", "Check the specification of Interfaces.C");
-
- declare -- encapsulate the test
-
-
- tst_CHAR_BIT : constant := C.CHAR_BIT;
- tst_SCHAR_MIN : constant := C.SCHAR_MIN;
- tst_SCHAR_MAX : constant := C.SCHAR_MAX;
- tst_UCHAR_MAX : constant := C.UCHAR_MAX;
-
- -- Signed and Unsigned Integers
-
- tst_int : C.int := C.int'first;
- tst_short : C.short := C.short'first;
- tst_long : C.long := C.long'first;
-
- tst_signed_char_min : C.signed_char := C.signed_char'first;
- tst_signed_char_max : C.signed_char := C.signed_char'last;
-
- tst_unsigned : C.unsigned;
- tst_unsigned_short : C.unsigned_short;
- tst_unsigned_long : C.unsigned_long;
-
- tst_unsigned_char : C.unsigned_char;
- tst_plain_char : C.plain_char;
-
- tst_ptrdiff_t : C.ptrdiff_t;
- tst_size_t : C.size_t;
-
- -- Floating-Point
-
- tst_C_float : C.C_float;
- tst_double : C.double;
- tst_long_double : C.long_double;
-
- -- Characters and Strings
-
- tst_char : C.char;
- tst_nul : C.char := C.nul;
-
- -- Collect all the subprogram calls such that they are compiled
- -- but not executed
- --
- procedure Collect_All_Calls is
-
- CAC_char : C.char;
- CAC_Character : Character;
- CAC_String : string (1..5);
- CAC_Boolean : Boolean := false;
- CAC_char_array : C.char_array(1..5);
- CAC_Integer : integer;
- CAC_Natural : natural;
- CAC_wchar_t : C.wchar_t;
- CAC_Wide_Character : Wide_Character;
- CAC_wchar_array : C.wchar_array(1..5);
- CAC_Wide_String : Wide_String(1..5);
- CAC_size_t : C.size_t;
-
- begin
-
- CAC_char := C.To_C (CAC_Character);
- CAC_Character := C.To_Ada (CAC_char);
-
- CAC_char_array := C.To_C (CAC_String, CAC_Boolean);
- CAC_String := C.To_Ada (CAC_char_array, CAC_Boolean);
-
- -- This call is out of LRM order so that we can use the
- -- array initialized above
- CAC_Boolean := C.Is_Nul_Terminated (CAC_char_array);
-
- C.To_C (CAC_String, CAC_char_array, CAC_size_t, CAC_Boolean);
- C.To_Ada (CAC_char_array, CAC_String, CAC_Natural, CAC_Boolean);
-
- CAC_wchar_t := C.To_C (CAC_Wide_Character);
- CAC_Wide_Character := C.To_Ada (CAC_wchar_t);
- CAC_wchar_t := C.wide_nul;
-
- CAC_wchar_array := C.To_C (CAC_Wide_String, CAC_Boolean);
- CAC_Wide_String := C.To_Ada (CAC_wchar_array, CAC_Boolean);
-
- -- This call is out of LRM order so that we can use the
- -- array initialized above
- CAC_Boolean := C.Is_Nul_Terminated (CAC_wchar_array);
-
- C.To_C (CAC_Wide_String, CAC_wchar_array, CAC_size_t, CAC_Boolean);
- C.To_Ada (CAC_wchar_array, CAC_Wide_String, CAC_Natural, CAC_Boolean);
-
- raise C.Terminator_Error;
-
- end Collect_All_Calls;
-
-
-
- begin -- encapsulation
-
- if tst_signed_char_min /= C.SCHAR_MIN then
- Report.Failed ("tst_signed_char_min is incorrect");
- end if;
- if tst_signed_char_max /= C.SCHAR_MAX then
- Report.Failed ("tst_signed_char_max is incorrect");
- end if;
- if C.signed_char'Size /= C.CHAR_BIT then
- Report.Failed ("C.signed_char'Size is incorrect");
- end if;
-
- if C.unsigned_char'first /= 0 or
- C.unsigned_char'last /= C.UCHAR_MAX or
- C.unsigned_char'size /= C.CHAR_BIT then
-
- Report.Failed ("unsigned_char is incorrectly defined");
-
- end if;
-
- if tst_nul /= C.char'first then
- Report.Failed ("tst_nul is incorrect");
- end if;
-
- end; -- encapsulation
-
- Report.Result;
-
-end CXB3001;
diff --git a/gcc/testsuite/ada/acats/tests/cxb/cxb3002.a b/gcc/testsuite/ada/acats/tests/cxb/cxb3002.a
deleted file mode 100644
index b543d467c46..00000000000
--- a/gcc/testsuite/ada/acats/tests/cxb/cxb3002.a
+++ /dev/null
@@ -1,158 +0,0 @@
--- CXB3002.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that the specifications of the package Interfaces.C.Strings
--- are available for use.
---
--- TEST DESCRIPTION:
--- This test verifies that the types and subprograms specified for the
--- interface are present
---
--- APPLICABILITY CRITERIA:
--- If an implementation provides packages Interfaces.C and
--- Interfaces.C.Strings, this test must compile, execute, and
--- report "PASSED".
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 28 Feb 96 SAIC Added applicability criteria.
---
---!
-
-with Report;
-with Interfaces.C; -- N/A => ERROR
-with Interfaces.C.Strings; -- N/A => ERROR
-
-procedure CXB3002 is
- package Strings renames Interfaces.C.Strings;
- package C renames Interfaces.C;
-
-begin
-
- Report.Test ("CXB3002", "Check the specification of Interfaces.C.Strings");
-
-
- declare -- encapsulate the test
-
- TC_Int_1 : integer := 1;
- TC_Int_2 : integer := 1;
- TC_String : String := "ABCD";
- TC_Boolean : Boolean := true;
- TC_char_array : C.char_array (1..5);
- TC_size_t : C.size_t := C.size_t'first;
-
-
- -- Note In all of the following the Strings spec. being tested
- -- is shown in comment lines
- --
- -- type char_array_access is access all char_array;
- TST_char_array_access : Strings.char_array_access :=
- new Interfaces.C.char_array (1..5);
-
- -- type chars_ptr is private;
- -- Null_Ptr : constant chars_ptr;
- TST_chars_ptr : Strings.chars_ptr := Strings.Null_ptr;
-
- -- type chars_ptr_array is array (size_t range <>) of chars_ptr;
- TST_chars_ptr_array : Strings.chars_ptr_array(1..5);
-
- begin -- encapsulation
-
- -- Arrange that the calls to the subprograms are compiled but
- -- not executed
- --
- if not Report.Equal ( TC_Int_1, TC_Int_2 ) then
-
- -- function To_Chars_Ptr (Item : in char_array_access;
- -- Nul_Check : in Boolean := False)
- -- return chars_ptr;
- TST_chars_ptr := Strings.To_Chars_Ptr
- (TST_char_array_access, TC_Boolean);
-
- -- This one is out of LRM order so that we can "initialize"
- -- TC_char_array for the "in" parameter of the next one
- --
- -- function Value (Item : in chars_ptr) return char_array;
- TC_char_array := Strings.Value (TST_chars_ptr);
-
- -- function New_Char_Array (Chars : in char_array)
- -- return chars_ptr;
- TST_chars_ptr := Strings.New_Char_Array (TC_char_array);
-
- -- function New_String (Str : in String) return chars_ptr;
- TST_chars_ptr := Strings.New_String ("TEST STRING");
-
- -- procedure Free (Item : in out chars_ptr);
- Strings.Free (TST_chars_ptr);
-
- -- function Value (Item : in chars_ptr; Length : in size_t)
- -- return char_array;
- TC_char_array := Strings.Value (TST_chars_ptr, TC_size_t);
-
- -- Use Report.Comment as a known procedure which takes a string as
- -- a parameter (this does not actually get output)
- -- function Value (Item : in chars_ptr) return String;
- Report.Comment ( Strings.Value (TST_chars_ptr) );
-
- -- function Value (Item : in chars_ptr; Length : in size_t)
- -- return String;
- TC_String := Strings.Value (TST_chars_ptr, TC_size_t);
-
- -- function Strlen (Item : in chars_ptr) return size_t;
- TC_size_t := Strings.Strlen (TST_chars_ptr);
-
- -- procedure Update (Item : in chars_ptr;
- -- Offset : in size_t;
- -- Chars : in char_array;
- -- Check : in Boolean := True);
- Strings.Update (TST_chars_ptr, TC_size_t, TC_char_array, TC_Boolean);
-
- -- procedure Update (Item : in chars_ptr;
- -- Offset : in size_t;
- -- Str : in String;
- -- Check : in Boolean := True);
- Strings.Update (TST_chars_ptr, TC_size_t, TC_String, TC_Boolean);
-
- -- Update_Error : exception;
- raise Strings.Update_Error;
-
- end if;
-
- if not Report.Equal ( TC_Int_2, TC_Int_1 ) then
-
- -- This exception is out of LRM presentation order to avoid
- -- compiler warnings about unreachable code
- -- Dereference_Error : exception;
- raise Strings.Dereference_Error;
-
- end if;
-
- end; -- encapsulation
-
- Report.Result;
-
-end CXB3002;
diff --git a/gcc/testsuite/ada/acats/tests/cxb/cxb3003.a b/gcc/testsuite/ada/acats/tests/cxb/cxb3003.a
deleted file mode 100644
index c395837489d..00000000000
--- a/gcc/testsuite/ada/acats/tests/cxb/cxb3003.a
+++ /dev/null
@@ -1,167 +0,0 @@
--- CXB3003.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that the specifications of the package Interfaces.C.Pointers
--- are available for use.
---
--- TEST DESCRIPTION:
--- This test verifies that the types and subprograms specified for the
--- interface are present
---
--- APPLICABILITY CRITERIA:
--- If an implementation provides package Interfaces.C.Pointers, this
--- test must compile, execute, and report "PASSED".
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 28 Feb 96 SAIC Added applicability criteria.
---
---!
-
-with Report;
-with Interfaces.C.Pointers; -- N/A => ERROR
-
-procedure CXB3003 is
- package C renames Interfaces.C;
-
- package Test_Ptrs is new C.Pointers
- (Index => C.size_t,
- Element => C.Char,
- Element_Array => C.Char_Array,
- Default_Terminator => C.Nul);
-
-begin
-
- Report.Test ("CXB3003", "Check the specification of Interfaces.C.Pointers");
-
-
- declare -- encapsulate the test
-
- TC_Int : integer := 1;
-
- -- Note: In all of the following the Pointers spec. being tested
- -- is shown in comments
- --
- -- type Pointer is access all Element;
- subtype TST_Pointer_Type is Test_Ptrs.Pointer;
-
- TST_Element : C.Char := C.Char'First;
- TST_Pointer : TST_Pointer_Type := null;
- TST_Pointer_2 : TST_Pointer_Type := null;
- TST_Array : C.char_array (1..5);
- TST_Index : C.ptrdiff_t := C.ptrdiff_t'First;
-
- begin -- encapsulation
-
- -- Arrange that the calls to the subprograms are compiled but
- -- not executed
- --
- if not Report.Equal ( TC_Int, TC_Int ) then
-
-
- -- function Value (Ref : in Pointer;
- -- Terminator : in Element := Default_Terminator)
- -- return Element_Array;
-
- TST_Array := Test_Ptrs.Value ( TST_Pointer ); -- default
- TST_Array := Test_Ptrs.Value ( TST_Pointer, TST_Element );
-
- -- function Value (Ref : in Pointer; Length : in ptrdiff_t)
- -- return Element_Array;
-
- TST_Array := Test_Ptrs.Value (TST_Pointer, TST_Index);
-
- --
- -- -- C-style Pointer arithmetic
- --
- -- function "+" (Left : in Pointer; Right : in ptrdiff_t)
- -- return Pointer;
- TST_Pointer := Test_Ptrs."+" (TST_Pointer, TST_Index);
-
- -- function "+" (Left : in Ptrdiff_T; Right : in Pointer)
- -- return Pointer;
- TST_Pointer := Test_Ptrs."+" (TST_Index, TST_Pointer);
-
- -- function "-" (Left : in Pointer; Right : in ptrdiff_t)
- -- return Pointer;
- TST_Pointer := Test_Ptrs."-" (TST_Pointer, TST_Index);
-
- -- function "-" (Left : in Pointer; Right : in Pointer)
- -- return ptrdiff_t;
- TST_Index := Test_Ptrs."-" (TST_Pointer, TST_Pointer);
-
- -- procedure Increment (Ref : in out Pointer);
- Test_Ptrs.Increment (TST_Pointer);
-
- -- procedure Decrement (Ref : in out Pointer);
- Test_Ptrs.Decrement (TST_Pointer);
-
- -- function Virtual_Length
- -- ( Ref : in Pointer;
- -- Terminator : in Element := Default_Terminator)
- -- return ptrdiff_t;
- TST_Index := Test_Ptrs.Virtual_Length (TST_Pointer);
- TST_Index := Test_Ptrs.Virtual_Length (TST_Pointer, TST_Element);
-
- -- procedure Copy_Terminated_Array
- -- (Source : in Pointer;
- -- Target : in Pointer;
- -- Limit : in ptrdiff_t := ptrdiff_t'Last;
- -- Terminator : in Element := Default_Terminator);
-
- Test_Ptrs.Copy_Terminated_Array (TST_Pointer, TST_Pointer_2);
-
- Test_Ptrs.Copy_Terminated_Array (TST_Pointer,
- TST_Pointer_2,
- TST_Index);
-
- Test_Ptrs.Copy_Terminated_Array (TST_Pointer,
- TST_Pointer_2,
- TST_Index,
- TST_Element);
-
-
- -- procedure Copy_Array
- -- (Source : in Pointer;
- -- Target : in Pointer;
- -- Length : in ptrdiff_t);
-
- Test_Ptrs.Copy_Array (TST_Pointer, TST_Pointer_2, TST_Index);
-
- -- This is out of LRM order to avoid complaints from compilers
- -- about inaccessible code
- -- Pointer_Error : exception;
-
- raise Test_Ptrs.Pointer_Error;
-
- end if;
-
- end; -- encapsulation
-
- Report.Result;
-
-end CXB3003;
diff --git a/gcc/testsuite/ada/acats/tests/cxb/cxb3005.a b/gcc/testsuite/ada/acats/tests/cxb/cxb3005.a
deleted file mode 100644
index 30b94053598..00000000000
--- a/gcc/testsuite/ada/acats/tests/cxb/cxb3005.a
+++ /dev/null
@@ -1,396 +0,0 @@
--- CXB3005.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that the procedure To_C converts the character elements of
--- a string parameter into char elements of the char_array parameter
--- Target, with nul termination if parameter Append_Nul is true.
---
--- Check that the out parameter Count of procedure To_C is set to the
--- appropriate value for both the nul/no nul terminated cases.
---
--- Check that Constraint_Error is propagated by procedure To_C if the
--- length of the char_array parameter Target is not sufficient to
--- hold the converted string value.
---
--- Check that the Procedure To_Ada converts char elements of the
--- char_array parameter Item to the corresponding character elements
--- of string out parameter Target.
---
--- Check that Constraint_Error is propagated by Procedure To_Ada if the
--- length of string parameter Target is not long enough to hold the
--- converted char_array value.
---
--- Check that Terminator_Error is propagated by Procedure To_Ada if the
--- parameter Trim_Nul is set to True, but the actual Item parameter
--- contains no nul char.
---
--- TEST DESCRIPTION:
--- This test uses a variety of String, and char_array objects to test
--- versions of the To_C and To_Ada procedures.
---
--- This test assumes that the following characters are all included
--- in the implementation defined type Interfaces.C.char:
--- ' ', 'a'..'z', 'A'..'Z', '0'..'9', and '-'.
---
--- APPLICABILITY CRITERIA:
--- This test is applicable to all implementations that provide
--- package Interfaces.C. If an implementation provides
--- package Interfaces.C, this test must compile, execute, and
--- report "PASSED".
---
--- CHANGE HISTORY:
--- 01 Sep 95 SAIC Initial prerelease version.
--- 09 May 96 SAIC Incorporated reviewer comments for ACVC 2.1.
--- 26 Oct 96 SAIC Incorporated reviewer comments.
--- 14 Sep 99 RLB Removed incorrect and unnecessary
--- Unchecked_Conversion.
---
---!
-
-with Report;
-with Interfaces.C; -- N/A => ERROR
-with Ada.Characters.Latin_1;
-with Ada.Exceptions;
-with Ada.Strings.Fixed;
-
-procedure CXB3005 is
-begin
-
- Report.Test ("CXB3005", "Check that the procedures To_C and To_Ada " &
- "produce correct results");
- Test_Block:
- declare
-
- use Interfaces, Interfaces.C;
- use Ada.Characters;
- use Ada.Exceptions;
- use Ada.Strings.Fixed;
-
- TC_Short_String : String(1..4) := (others => 'x');
- TC_String : String(1..8) := (others => 'y');
- TC_char_array : char_array(0..7) := (others => char'Last);
- TC_size_t_Count : size_t := size_t'First;
- TC_Natural_Count : Natural := Natural'First;
-
-
- -- We can use the character forms of To_Ada and To_C here to check
- -- the results; they were tested in CXB3004. We give them different
- -- names to avoid confusion below.
-
- function Character_to_char (Source : in Character) return char
- renames To_C;
- function char_to_Character (Source : in char) return Character
- renames To_Ada;
-
- begin
-
- -- Check that the procedure To_C converts the character elements of
- -- a string parameter into char elements of char_array out parameter
- -- Target.
- --
- -- Case of nul termination.
-
- TC_String(1..6) := "abcdef";
-
- To_C (Item => TC_String(1..6), -- Source slice of length 6.
- Target => TC_char_array, -- Length 8 will accommodate nul.
- Count => TC_size_t_Count,
- Append_Nul => True);
-
- -- Check that the out parameter Count is set to the appropriate value
- -- for the nul terminated case.
-
- if TC_size_t_Count /= 7 then
- Report.Failed("Incorrect setting of out parameter Count by " &
- "Procedure To_C when Append_Nul => True");
- end if;
-
- for i in 1..TC_size_t_Count-1 loop
- if char_to_Character(TC_char_array(i-1)) /= TC_String(Integer(i))
- then
- Report.Failed("Incorrect result from Procedure To_C when " &
- "checking individual char values, case of " &
- "Append_Nul => True; " &
- "char position = " & Integer'Image(Integer(i)));
- end if;
- end loop;
-
- if not Is_Nul_Terminated(TC_char_array) then
- Report.Failed("No nul char appended to the char_array result " &
- "from Procedure To_C when Append_Nul => True");
- end if;
-
- if TC_char_array(0..6) /= To_C("abcdef", True) then
- Report.Failed("Incorrect result from Procedure To_C when " &
- "directly comparing char_array results, case " &
- "of Append_Nul => True");
- end if;
-
-
- -- Check Procedure To_C with no nul termination.
-
- TC_char_array := (others => Character_to_char('M')); -- Reinitialize.
- TC_String(1..4) := "WXYZ";
-
- To_C (Item => TC_String(1..4), -- Source slice of length 4.
- Target => TC_char_array,
- Count => TC_size_t_Count,
- Append_Nul => False);
-
- -- Check that the out parameter Count is set to the appropriate value
- -- for the non-nul terminated case.
-
- if TC_size_t_Count /= 4 then
- Report.Failed("Incorrect setting of out parameter Count by " &
- "Procedure To_C when Append_Nul => False");
- end if;
-
- for i in 1..TC_size_t_Count loop
- if char_to_Character(TC_char_array(i-1)) /= TC_String(Integer(i))
- then
- Report.Failed("Incorrect result from Procedure To_C when " &
- "checking individual char values, case of " &
- "Append_Nul => False; " &
- "char position = " & Integer'Image(Integer(i)));
- end if;
- end loop;
-
- if Is_Nul_Terminated(TC_char_array) then
- Report.Failed("The nul char was appended to the char_array " &
- "result of Procedure To_C when Append_Nul => False");
- end if;
-
- if TC_char_array(0..3) /= To_C("WXYZ", False) then
- Report.Failed("Incorrect result from Procedure To_C when " &
- "directly comparing char_array results, case " &
- "of Append_Nul => False");
- end if;
-
-
-
- -- Check that Constraint_Error is raised by procedure To_C if the
- -- length of the target char_array parameter is not sufficient to
- -- hold the converted string value (plus nul if Append_Nul is True).
-
- begin
- To_C("A string too long",
- TC_char_array,
- TC_size_t_Count,
- Append_Nul => True);
-
- Report.Failed("Constraint_Error not raised when the Target " &
- "parameter of Procedure To_C is not long enough " &
- "to hold the converted string");
- Report.Comment(char_to_Character(TC_char_array(0)) &
- " printed to defeat optimization");
- exception
- when Constraint_Error => null; -- OK, expected exception.
- when others =>
- Report.Failed("Incorrect exception raised by Procedure " &
- "To_C when the Target parameter is not long " &
- "enough to contain the char_array result");
- end;
-
-
-
- -- Check that the procedure To_Ada converts char elements of the
- -- char_array parameter Item to the corresponding character elements
- -- of string out parameter Target, with result string length based on
- -- the Trim_Nul parameter.
- --
- -- Case of appended nul char on the char_array In parameter.
-
- TC_char_array := To_C ("ACVC-95", Append_Nul => True); -- 8 total chars.
- TC_String := (others => '*'); -- Reinitialize.
-
- To_Ada (Item => TC_char_array,
- Target => TC_String,
- Count => TC_Natural_Count,
- Trim_Nul => False);
-
- if TC_Natural_Count /= 8 then
- Report.Failed("Incorrect value returned in out parameter Count " &
- "by Procedure To_Ada, case of Trim_Nul => False");
- end if;
-
- for i in 1..TC_Natural_Count loop
- if Character_to_char(TC_String(i)) /= TC_char_array(size_t(i-1))
- then
- Report.Failed("Incorrect result from Procedure To_Ada when " &
- "checking individual char values, case of " &
- "Trim_Nul => False, when a nul is present in " &
- "the char_array input parameter; " &
- "position = " & Integer'Image(Integer(i)));
- end if;
- end loop;
-
- if TC_String(TC_Natural_Count) /= Latin_1.Nul then
- Report.Failed("Last character of String result of Procedure " &
- "To_Ada is not Nul, even though a nul was present " &
- "in the char_array argument, and the Trim_Nul " &
- "parameter was set to False");
- end if;
-
-
- TC_char_array(0..3) := To_C ("XYz", Append_Nul => True); -- 4 chars.
- TC_String := (others => '*'); -- Reinit.
-
- To_Ada (Item => TC_char_array,
- Target => TC_String,
- Count => TC_Natural_Count,
- Trim_Nul => True);
-
- if TC_Natural_Count /= 3 then
- Report.Failed("Incorrect value returned in out parameter Count " &
- "by Procedure To_Ada, case of Trim_Nul => True");
- end if;
-
- for i in 1..TC_Natural_Count loop
- if Character_to_char(TC_String(i)) /= TC_char_array(size_t(i-1))
- then
- Report.Failed("Incorrect result from Procedure To_Ada when " &
- "checking individual char values, case of " &
- "Trim_Nul => True, when a nul is present in " &
- "the char_array input parameter; " &
- "position = " & Integer'Image(Integer(i)));
- end if;
- end loop;
-
- if TC_String(TC_Natural_Count) = Latin_1.Nul then
- Report.Failed("Last character of String result of Procedure " &
- "To_Ada is Nul, even though the Trim_Nul " &
- "parameter was set to True");
- end if;
-
- -- Check that TC_String(TC_Natural_Count+1) is unchanged by procedure
- -- To_Ada.
-
- if TC_String(TC_Natural_Count+1) /= '*' then
- Report.Failed("Incorrect modification to TC_String at position " &
- Integer'Image(TC_Natural_Count+1) & " expected = " &
- "*, found = " & TC_String(TC_Natural_Count+1));
- end if;
-
-
- -- Case of no nul char being present in the char_array argument.
-
- TC_char_array := To_C ("ABCDWXYZ", Append_Nul => False);
- TC_String := (others => '*'); -- Reinitialize.
-
- To_Ada (Item => TC_char_array,
- Target => TC_String,
- Count => TC_Natural_Count,
- Trim_Nul => False);
-
- if TC_Natural_Count /= 8 then
- Report.Failed("Incorrect value returned in out parameter Count " &
- "by Procedure To_Ada, case of Trim_Nul => False, " &
- "with no nul char present in the parameter Item");
- end if;
-
- for i in 1..TC_Natural_Count loop
- if Character_to_char(TC_String(i)) /= TC_char_array(size_t(i-1))
- then
- Report.Failed("Incorrect result from Procedure To_Ada when " &
- "checking individual char values, case of " &
- "Trim_Nul => False, when a nul is not present " &
- "in the char_array input parameter; " &
- "position = " & Integer'Image(Integer(i)));
- end if;
- end loop;
-
- if TC_String(TC_Natural_Count) = Latin_1.Nul then
- Report.Failed("Last character of String result of Procedure " &
- "To_Ada is Nul, even though the nul char was " &
- "not present in the parameter Item, with the " &
- "parameter Trim_Nul => False");
- end if;
-
-
-
- -- Check that the Procedure To_Ada raises Terminator_Error if the
- -- parameter Trim_Nul is set to True, but the actual Item parameter
- -- does not contain the nul char.
-
- begin
- TC_char_array := To_C ("ABCDWXYZ", Append_Nul => False);
- TC_String := (others => '*');
-
- To_Ada(TC_char_array,
- TC_String,
- Count => TC_Natural_Count,
- Trim_Nul => True);
-
- Report.Failed("Terminator_Error not raised when Item " &
- "parameter of To_Ada does not contain the " &
- "nul char, but parameter Trim_Nul => True");
- Report.Comment(TC_String & " printed to defeat optimization");
- exception
- when Terminator_Error => null; -- OK, expected exception.
- when others =>
- Report.Failed("Incorrect exception raised by Procedure " &
- "To_Ada when the Item parameter does not " &
- "contain the nul char, but parameter " &
- "Trim_Nul => True");
- end;
-
-
-
- -- Check that Constraint_Error is propagated by procedure To_Ada if the
- -- length of string parameter Target is not long enough to hold the
- -- converted char_array value (plus nul if Trim_Nul is False).
-
- begin
- TC_char_array(0..4) := To_C ("ABCD", Append_Nul => True);
-
- To_Ada(TC_char_array(0..4), -- 4 chars plus nul char.
- TC_Short_String, -- Length of 4.
- Count => TC_Natural_Count,
- Trim_Nul => False);
-
- Report.Failed("Constraint_Error not raised when string " &
- "parameter Target of Procedure To_Ada is not " &
- "long enough to hold the converted chars");
- Report.Comment(TC_Short_String & " printed to defeat optimization");
- exception
- when Constraint_Error => null; -- OK, expected exception.
- when others =>
- Report.Failed("Incorrect exception raised by Procedure " &
- "To_Ada when string parameter Target is " &
- "not long enough to hold the converted chars");
- end;
-
-
-
- exception
- when The_Error : others =>
- Report.Failed ("The following exception was raised in the " &
- "Test_Block: " & Exception_Name(The_Error));
- end Test_Block;
-
- Report.Result;
-
-end CXB3005;
diff --git a/gcc/testsuite/ada/acats/tests/cxb/cxb3007.a b/gcc/testsuite/ada/acats/tests/cxb/cxb3007.a
deleted file mode 100644
index 3837e0bae1f..00000000000
--- a/gcc/testsuite/ada/acats/tests/cxb/cxb3007.a
+++ /dev/null
@@ -1,408 +0,0 @@
--- CXB3007.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that the procedure To_C converts the Wide_Character elements
--- of a Wide_String parameter into wchar_t elements of the wchar_array
--- parameter Target, with wide_nul termination if parameter Append_Nul
--- is true.
---
--- Check that the out parameter Count of procedure To_C is set to the
--- appropriate value for both the wide_nul/no wide_nul terminated cases.
---
--- Check that Constraint_Error is propagated by procedure To_C if the
--- length of the wchar_array parameter Target is not sufficient to
--- hold the converted Wide_String value.
---
--- Check that the Procedure To_Ada converts wchar_t elements of the
--- wchar_array parameter Item to the corresponding Wide_Character
--- elements of Wide_String out parameter Target.
---
--- Check that Constraint_Error is propagated by Procedure To_Ada if the
--- length of Wide_String parameter Target is not long enough to hold the
--- converted wchar_array value.
---
--- Check that Terminator_Error is propagated by Procedure To_Ada if the
--- parameter Trim_Nul is set to True, but the actual Item parameter
--- contains no wide_nul wchar_t.
---
--- TEST DESCRIPTION:
--- This test uses a variety of Wide_String, and wchar_array objects to
--- test versions of the To_C and To_Ada procedures.
---
--- This test assumes that the following characters are all included
--- in the implementation defined type Interfaces.C.wchar_t:
--- ' ', 'a'..'z', 'A'..'Z', and '-'.
---
--- APPLICABILITY CRITERIA:
--- This test is applicable to all implementations that provide
--- package Interfaces.C. If an implementation provides
--- package Interfaces.C, this test must compile, execute, and
--- report "PASSED".
---
--- CHANGE HISTORY:
--- 01 Sep 95 SAIC Initial prerelease version.
--- 09 May 96 SAIC Incorporated reviewer comments for ACVC 2.1.
--- 26 Oct 96 SAIC Incorporated reviewer comments.
--- 14 Sep 99 RLB Removed incorrect and unnecessary
--- Unchecked_Conversion.
---
---!
-
-with Report;
-with Interfaces.C; -- N/A => ERROR
-with Ada.Characters.Latin_1;
-with Ada.Characters.Handling;
-with Ada.Exceptions;
-with Ada.Strings.Wide_Fixed;
-
-procedure CXB3007 is
-begin
-
- Report.Test ("CXB3007", "Check that the procedures To_C and To_Ada " &
- "for wide strings produce correct results");
- Test_Block:
- declare
-
- use Interfaces, Interfaces.C;
- use Ada.Characters, Ada.Characters.Handling;
- use Ada.Exceptions;
- use Ada.Strings.Wide_Fixed;
-
- TC_Short_Wide_String : Wide_String(1..4) :=
- (others => Wide_Character'First);
- TC_Wide_String : Wide_String(1..8) :=
- (others => Wide_Character'First);
- TC_wchar_array : wchar_array(0..7) := (others => wchar_t'First);
- TC_size_t_Count : size_t := size_t'First;
- TC_Natural_Count : Natural := Natural'First;
-
-
- -- We can use the wide character forms of To_Ada and To_C here to check
- -- the results; they were tested in CXB3006. We give them different
- -- names to avoid confusion below.
-
- function Wide_Character_to_wchar_t (Source : in Wide_Character)
- return wchar_t renames To_C;
- function wchar_t_to_Wide_Character (Source : in wchar_t)
- return Wide_Character renames To_Ada;
-
- begin
-
- -- Check that the procedure To_C converts the Wide_Character elements
- -- of a Wide_String parameter into wchar_t elements of wchar_array out
- -- parameter Target.
- --
- -- Case of wide_nul termination.
-
- TC_Wide_String(1..6) := "abcdef";
-
- To_C (Item => TC_Wide_String(1..6), -- Source slice of length 6.
- Target => TC_wchar_array,
- Count => TC_size_t_Count,
- Append_Nul => True);
-
- -- Check that the out parameter Count is set to the appropriate value
- -- for the wide_nul terminated case.
-
- if TC_size_t_Count /= 7 then
- Report.Failed("Incorrect setting of out parameter Count by " &
- "Procedure To_C when Append_Nul => True");
- end if;
-
- for i in 1..TC_size_t_Count-1 loop
- if wchar_t_to_Wide_Character(TC_wchar_array(i-1)) /=
- TC_Wide_String(Integer(i))
- then
- Report.Failed("Incorrect result from Procedure To_C when " &
- "checking individual wchar_t values, case of " &
- "Append_Nul => True; " &
- "wchar_t position = " & Integer'Image(Integer(i)));
- end if;
- end loop;
-
- if not Is_Nul_Terminated(TC_wchar_array) then
- Report.Failed("No wide_nul wchar_t appended to the wchar_array " &
- "result from Procedure To_C when Append_Nul => True");
- end if;
-
- if TC_wchar_array(0..6) /= To_C("abcdef", True) then
- Report.Failed("Incorrect result from Procedure To_C when " &
- "directly comparing wchar_array results, case " &
- "of Append_Nul => True");
- end if;
-
-
- -- Check Procedure To_C with no wide_nul termination.
-
- TC_wchar_array := (others => Wide_Character_to_wchar_t('M'));
- TC_Wide_String(1..4) := "WXYZ";
-
- To_C (Item => TC_Wide_String(1..4), -- Source slice of length 4.
- Target => TC_wchar_array,
- Count => TC_size_t_Count,
- Append_Nul => False);
-
- -- Check that the out parameter Count is set to the appropriate value
- -- for the non-wide_nul terminated case.
-
- if TC_size_t_Count /= 4 then
- Report.Failed("Incorrect setting of out parameter Count by " &
- "Procedure To_C when Append_Nul => False");
- end if;
-
- for i in 1..TC_size_t_Count loop
- if wchar_t_to_Wide_Character(TC_wchar_array(i-1)) /=
- TC_Wide_String(Integer(i))
- then
- Report.Failed("Incorrect result from Procedure To_C when " &
- "checking individual wchar_t values, case of " &
- "Append_Nul => False; " &
- "wchar_t position = " & Integer'Image(Integer(i)));
- end if;
- end loop;
-
- if Is_Nul_Terminated(TC_wchar_array) then
- Report.Failed
- ("The wide_nul wchar_t was appended to the wchar_array " &
- "result of Procedure To_C when Append_Nul => False");
- end if;
-
- if TC_wchar_array(0..3) /= To_C("WXYZ", False) then
- Report.Failed("Incorrect result from Procedure To_C when " &
- "directly comparing wchar_array results, case " &
- "of Append_Nul => False");
- end if;
-
-
-
- -- Check that Constraint_Error is raised by procedure To_C if the
- -- length of the target wchar_array parameter is not sufficient to
- -- hold the converted Wide_String value (plus wide_nul if Append_Nul
- -- is True).
-
- TC_wchar_array := (others => wchar_t'First);
- begin
- To_C("A string too long",
- TC_wchar_array,
- TC_size_t_Count,
- Append_Nul => True);
-
- Report.Failed("Constraint_Error not raised when the Target " &
- "parameter of Procedure To_C is not long enough " &
- "to hold the converted Wide_String");
- Report.Comment
- (To_Character(wchar_t_to_Wide_Character(TC_wchar_array(0))) &
- " printed to defeat optimization");
- exception
- when Constraint_Error => null; -- OK, expected exception.
- when others =>
- Report.Failed("Incorrect exception raised by Procedure " &
- "To_C when the Target parameter is not long " &
- "enough to contain the wchar_array result");
- end;
-
-
-
- -- Check that the procedure To_Ada converts wchar_t elements of the
- -- wchar_array parameter Item to the corresponding Wide_Character
- -- elements of Wide_String out parameter Target, with result wide
- -- string length based on the Trim_Nul parameter.
- --
- -- Case of appended wide_nul wchar_t on the wchar_array In parameter.
-
- TC_wchar_array :=
- To_C ("ACVC-95", Append_Nul => True); -- 8 total chars.
-
- To_Ada (Item => TC_wchar_array,
- Target => TC_Wide_String,
- Count => TC_Natural_Count,
- Trim_Nul => False);
-
- if TC_Natural_Count /= 8 then
- Report.Failed("Incorrect value returned in out parameter Count " &
- "by Procedure To_Ada, case of Trim_Nul => False");
- end if;
-
- for i in 1..TC_Natural_Count loop
- if Wide_Character_to_wchar_t(TC_Wide_String(i)) /=
- TC_wchar_array(size_t(i-1))
- then
- Report.Failed("Incorrect result from Procedure To_Ada when " &
- "checking individual wchar_t values, case of " &
- "Trim_Nul => False, when a wide_nul is present " &
- "in the wchar_array input parameter; " &
- "position = " & Integer'Image(Integer(i)));
- end if;
- end loop;
-
- if TC_Wide_String(TC_Natural_Count) /= To_Wide_Character(Latin_1.Nul)
- then
- Report.Failed("Last Wide_Character of Wide_String result of " &
- "Procedure To_Ada is not Nul, even though a " &
- "wide_nul was present in the wchar_array argument, " &
- "and the Trim_Nul parameter was set to False");
- end if;
-
-
- TC_Wide_String := (others => Wide_Character'First);
- TC_wchar_array(0..3) := To_C ("XYz", Append_Nul => True); -- 4 chars.
-
- To_Ada (Item => TC_wchar_array,
- Target => TC_Wide_String,
- Count => TC_Natural_Count,
- Trim_Nul => True);
-
- if TC_Natural_Count /= 3 then
- Report.Failed("Incorrect value returned in out parameter Count " &
- "by Procedure To_Ada, case of Trim_Nul => True");
- end if;
-
- for i in 1..TC_Natural_Count loop
- if Wide_Character_to_wchar_t(TC_Wide_String(i)) /=
- TC_wchar_array(size_t(i-1))
- then
- Report.Failed("Incorrect result from Procedure To_Ada when " &
- "checking individual wchar_t values, case of " &
- "Trim_Nul => True, when a wide_nul is present " &
- "in the wchar_array input parameter; " &
- "position = " & Integer'Image(Integer(i)));
- end if;
- end loop;
-
- if TC_Wide_String(TC_Natural_Count) = To_Wide_Character(Latin_1.Nul)
- then
- Report.Failed("Last Wide_Character of Wide_String result of " &
- "Procedure To_Ada is Nul, even though the " &
- "Trim_Nul parameter was set to True");
- end if;
-
- if TC_Wide_String(TC_Natural_Count+1) /= Wide_Character'First then
- Report.Failed("Incorrect replacement from To_Ada");
- end if;
-
-
- -- Case of no wide_nul wchar_t present in the wchar_array argument.
-
- TC_Wide_String := (others => Wide_Character'First);
- TC_wchar_array := To_C ("ABCDWXYZ", Append_Nul => False);
-
- To_Ada (Item => TC_wchar_array,
- Target => TC_Wide_String,
- Count => TC_Natural_Count,
- Trim_Nul => False);
-
- if TC_Natural_Count /= 8 then
- Report.Failed("Incorrect value returned in out parameter Count " &
- "by Procedure To_Ada, case of Trim_Nul => False, " &
- "with no wide_nul wchar_t present in the parameter " &
- "Item");
- end if;
-
- for i in 1..TC_Natural_Count loop
- if Wide_Character_to_wchar_t(TC_Wide_String(i)) /=
- TC_wchar_array(size_t(i-1))
- then
- Report.Failed("Incorrect result from Procedure To_Ada when " &
- "checking individual wchar_t values, case of " &
- "Trim_Nul => False, when a wide_nul is not " &
- "present in the wchar_array input parameter; " &
- "position = " & Integer'Image(Integer(i)));
- end if;
- end loop;
-
- if TC_Wide_String(TC_Natural_Count) = To_Wide_Character(Latin_1.Nul)
- then
- Report.Failed("Last Wide_Character of Wide_String result of " &
- "Procedure To_Ada is Nul, even though the wide_nul " &
- "wchar_t was not present in the parameter Item, " &
- "with the parameter Trim_Nul => False");
- end if;
-
-
-
- -- Check that the Procedure To_Ada raises Terminator_Error if the
- -- parameter Trim_Nul is set to True, but the actual Item parameter
- -- does not contain the wide_nul wchar_t.
-
- begin
- TC_Wide_String := (others => Wide_Character'First);
- TC_wchar_array := To_C ("ABCDWXYZ", Append_Nul => False);
-
- To_Ada(TC_wchar_array,
- TC_Wide_String,
- Count => TC_Natural_Count,
- Trim_Nul => True);
-
- Report.Failed("Terminator_Error not raised when Item " &
- "parameter of To_Ada does not contain the " &
- "wide_nul wchar_t, but parameter Trim_Nul => True");
- Report.Comment(To_String(TC_Wide_String) &
- " printed to defeat optimization");
- exception
- when Terminator_Error => null; -- OK, expected exception.
- when others =>
- Report.Failed("Incorrect exception raised by Procedure " &
- "To_Ada when the Item parameter does not " &
- "contain the wide_nul wchar_t, but parameter " &
- "Trim_Nul => True");
- end;
-
-
-
- -- Check that Constraint_Error is propagated by procedure To_Ada if the
- -- length of Wide_String parameter Target is not long enough to hold the
- -- converted wchar_array value (plus wide_nul if Trim_Nul is False).
-
- begin
- TC_wchar_array(0..4) := To_C ("ABCD", Append_Nul => True);
-
- To_Ada(TC_wchar_array(0..4),
- TC_Short_Wide_String, -- Length of 4.
- Count => TC_Natural_Count,
- Trim_Nul => False);
-
- Report.Failed("Constraint_Error not raised when Wide_String " &
- "parameter Target of Procedure To_Ada is not " &
- "long enough to hold the converted wchar_ts");
- Report.Comment(To_String(TC_Short_Wide_String) &
- " printed to defeat optimization");
- exception
- when Constraint_Error => null; -- OK, expected exception.
- when others =>
- Report.Failed("Incorrect exception raised by Procedure " &
- "To_Ada when Wide_String parameter Target is " &
- "not long enough to hold the converted wchar_ts");
- end;
-
- exception
- when The_Error : others =>
- Report.Failed ("The following exception was raised in the " &
- "Test_Block: " & Exception_Name(The_Error));
- end Test_Block;
-
- Report.Result;
-
-end CXB3007;
diff --git a/gcc/testsuite/ada/acats/tests/cxb/cxb3008.a b/gcc/testsuite/ada/acats/tests/cxb/cxb3008.a
deleted file mode 100644
index 9df19d814c3..00000000000
--- a/gcc/testsuite/ada/acats/tests/cxb/cxb3008.a
+++ /dev/null
@@ -1,226 +0,0 @@
--- CXB3008.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that functions imported from the C language <string.h> and
--- <stdlib.h> libraries can be called from an Ada program.
---
--- TEST DESCRIPTION:
--- This test checks that C language functions from the <string.h> and
--- <stdlib.h> libraries can be used as completions of Ada subprograms.
--- A pragma Import with convention identifier "C" is used to complete
--- the Ada subprogram specifications.
--- The three subprogram cases tested are as follows:
--- 1) A C function that returns an int value (strcpy) is used as the
--- completion of an Ada procedure specification. The return value
--- is discarded; parameter modification is the desired effect.
--- 2) A C function that returns an int value (strlen) is used as the
--- completion of an Ada function specification.
--- 3) A C function that returns a double value (strtod) is used as the
--- completion of an Ada function specification.
---
--- This test assumes that the following characters are all included
--- in the implementation defined type Interfaces.C.char:
--- ' ', 'a'..'z', 'A'..'Z', '0'..'9', and '$'.
---
--- APPLICABILITY CRITERIA:
--- This test is applicable to all implementations that provide
--- packages Interfaces.C and Interfaces.C.Strings. If an
--- implementation provides these packages, this test must compile,
--- execute, and report "PASSED".
---
--- SPECIAL REQUIREMENTS:
--- The C language library functions used by this test must be
--- available for importing into the test.
---
---
--- CHANGE HISTORY:
--- 12 Oct 95 SAIC Initial prerelease version.
--- 09 May 96 SAIC Incorporated reviewer comments for ACVC 2.1.
--- 01 DEC 97 EDS Replaced all references of C function atof with
--- C function strtod.
--- 29 JUN 98 EDS Give Ada function corresponding to strtod a
--- second parameter.
---!
-
-with Report;
-with Ada.Exceptions;
-with Interfaces.C; -- N/A => ERROR
-with Interfaces.C.Strings; -- N/A => ERROR
-with Interfaces.C.Pointers;
-
-procedure CXB3008 is
-begin
-
- Report.Test ("CXB3008", "Check that functions imported from the " &
- "C language predefined libraries can be " &
- "called from an Ada program");
-
- Test_Block:
- declare
-
- package IC renames Interfaces.C;
- package ICS renames Interfaces.C.Strings;
- package ICP is new Interfaces.C.Pointers
- ( Index => IC.size_t,
- Element => IC.char,
- Element_Array => IC.char_array,
- Default_Terminator => IC.nul );
- use Ada.Exceptions;
-
- use type IC.char;
- use type IC.char_array;
- use type IC.size_t;
- use type IC.double;
-
- -- The String_Copy procedure copies the string pointed to by Source,
- -- including the terminating nul char, into the char_array pointed
- -- to by Target.
-
- procedure String_Copy (Target : out IC.char_array;
- Source : in IC.char_array);
-
- -- The String_Length function returns the length of the nul-terminated
- -- string pointed to by The_String. The nul is not included in
- -- the count.
-
- function String_Length (The_String : in IC.char_array)
- return IC.size_t;
-
- -- The String_To_Double function converts the char_array pointed to
- -- by The_String into a double value returned through the function
- -- name. The_String must contain a valid floating-point number; if
- -- not, the value returned is zero.
-
--- type Acc_ptr is access IC.char_array;
- function String_To_Double (The_String : in IC.char_array ;
- End_Ptr : ICP.Pointer := null)
- return IC.double;
-
-
- -- Use the <string.h> strcpy function as a completion to the procedure
- -- specification. Note that the Ada interface to this C function is
- -- in the form of a procedure (C function return value is not used).
-
- pragma Import (C, String_Copy, "strcpy");
-
- -- Use the <string.h> strlen function as a completion to the
- -- String_Length function specification.
-
- pragma Import (C, String_Length, "strlen");
-
- -- Use the <stdlib.h> strtod function as a completion to the
- -- String_To_Double function specification.
-
- pragma Import (C, String_To_Double, "strtod");
-
-
- TC_String : constant String := "Just a Test";
- Char_Source : IC.char_array(0..30);
- Char_Target : IC.char_array(0..30);
- Double_Result : IC.double;
- Source_Ptr,
- Target_Ptr : ICS.chars_ptr;
-
- begin
-
- -- Check that the imported version of C function strcpy produces
- -- the correct results.
-
- Char_Source(0..21) := "Test of Pragma Import" & IC.nul;
-
- String_Copy(Char_Target, Char_Source);
-
- if Char_Target(0..21) /= Char_Source(0..21) then
- Report.Failed("Incorrect result from the imported version of " &
- "strcpy - 1");
- end if;
-
- if String_Length(Char_Target) /= 21 then
- Report.Failed("Incorrect result from the imported version of " &
- "strlen - 1");
- end if;
-
- Char_Source(0) := IC.nul;
-
- String_Copy(Char_Target, Char_Source);
-
- if Char_Target(0) /= Char_Source(0) then
- Report.Failed("Incorrect result from the imported version of " &
- "strcpy - 2");
- end if;
-
- if String_Length(Char_Target) /= 0 then
- Report.Failed("Incorrect result from the imported version of " &
- "strlen - 2");
- end if;
-
- -- The following chars_ptr designates a char_array of 12 chars
- -- (including the terminating nul char).
- Source_Ptr := ICS.New_Char_Array(IC.To_C(TC_String));
-
- String_Copy(Char_Target, ICS.Value(Source_Ptr));
-
- Target_Ptr := ICS.New_Char_Array(Char_Target);
-
- if ICS.Value(Target_Ptr) /= TC_String then
- Report.Failed("Incorrect result from the imported version of " &
- "strcpy - 3");
- end if;
-
- if String_Length(ICS.Value(Target_Ptr)) /= TC_String'Length then
- Report.Failed("Incorrect result from the imported version of " &
- "strlen - 3");
- end if;
-
-
- Char_Source(0..9) := "100.00only";
-
- Double_Result := String_To_Double(Char_Source);
-
- Char_Source(0..13) := "5050.00$$$$$$$";
-
- if Double_Result + String_To_Double(Char_Source) /= 5150.00 then
- Report.Failed("Incorrect result returned from the imported " &
- "version of function strtod - 1");
- end if;
-
- Char_Source(0..9) := "xxx$10.00x"; -- String doesn't contain a
- -- valid floating point value.
- if String_To_Double(Char_Source) /= 0.0 then
- Report.Failed("Incorrect result returned from the imported " &
- "version of function strtod - 2");
- end if;
-
-
- exception
- when The_Error : others =>
- Report.Failed ("The following exception was raised in the " &
- "Test_Block: " & Exception_Name(The_Error));
- end Test_Block;
-
- Report.Result;
-
-end CXB3008;
diff --git a/gcc/testsuite/ada/acats/tests/cxb/cxb3009.a b/gcc/testsuite/ada/acats/tests/cxb/cxb3009.a
deleted file mode 100644
index 3ea5a620442..00000000000
--- a/gcc/testsuite/ada/acats/tests/cxb/cxb3009.a
+++ /dev/null
@@ -1,305 +0,0 @@
--- CXB3009.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that the function To_Chars_Ptr will return a Null_Ptr value
--- when the parameter Item is null. If the parameter Item is not null,
--- and references a chars_array object that does contain the char nul,
--- and parameter Nul_Check is True, check that To_Chars_Ptr performs a
--- pointer conversion from char_array_access type to chars_ptr type.
--- Check that if parameter Item is not null, and references a
--- chars_array object that does not contain nul, and parameter Nul_Check
--- is True, the To_Chars_Ptr function will propagate Terminator_Error.
--- Check that if parameter Item is not null, and parameter Nul_Check
--- is False, check that To_Chars_Ptr performs a pointer conversion from
--- char_array_access type to chars_ptr type.
---
--- Check that the New_Char_Array function will return a chars_ptr type
--- pointer to an allocated object that has been initialized with
--- the value of parameter Chars.
---
--- Check that the function New_String returns a chars_ptr initialized
--- to a nul-terminated string having the value of the Str parameter.
---
--- TEST DESCRIPTION:
--- This test uses a variety of of string, char_array,
--- char_array_access and char_ptr values in order to validate the
--- functions under test, and results are compared for both length
--- and content.
---
--- This test assumes that the following characters are all included
--- in the implementation defined type Interfaces.C.char:
--- ' ', 'a'..'z', and 'A'.. 'Z'.
---
--- APPLICABILITY CRITERIA:
--- This test is applicable to all implementations that provide
--- package Interfaces.C.Strings. If an implementation provides
--- package Interfaces.C.Strings, this test must compile, execute, and
--- report "PASSED".
---
---
--- CHANGE HISTORY:
--- 20 Sep 95 SAIC Initial prerelease version.
--- 09 May 96 SAIC Incorporated reviewer comments for ACVC 2.1.
--- 01 DEC 97 EDS Remove incorrect block of code (previously
--- lines 264-287)
--- 14 Sep 99 RLB Added check for behavior of To_Chars_Ptr when
--- Nul_Check => False. (From Technical
--- Corrigendum 1).
---!
-
-with Report;
-with Interfaces.C.Strings; -- N/A => ERROR
-with Ada.Characters.Latin_1;
-with Ada.Exceptions;
-with Ada.Strings.Fixed;
-
-procedure CXB3009 is
-begin
-
- Report.Test ("CXB3009", "Check that functions To_Chars_Ptr, " &
- "New_Chars_Array, and New_String produce " &
- "correct results");
-
- Test_Block:
- declare
-
- package IC renames Interfaces.C;
- package ICS renames Interfaces.C.Strings;
- use Ada.Exceptions;
-
- use type IC.char_array;
- use type IC.size_t;
- use type ICS.chars_ptr;
-
- Null_Char_Array_Access : constant ICS.char_array_access := null;
-
- Test_String : constant String := "Test String";
- String_With_nul : String(1..6) := "Addnul";
- String_Without_nul : String(1..6) := "No nul";
-
- Char_Array_With_nul : IC.char_array(0..6) :=
- IC.To_C(String_With_nul, True);
- Char_Array_Without_nul : IC.char_array(0..5) :=
- IC.To_C(String_Without_nul, False);
- Char_Array_W_nul_Ptr : ICS.char_array_access :=
- new IC.char_array'(Char_Array_With_nul);
- Char_Array_WO_nul_Ptr : ICS.char_array_access :=
- new IC.char_array'(Char_Array_Without_nul);
-
- TC_chars_ptr : ICS.chars_ptr;
-
- TC_size_t : IC.size_t := IC.size_t'First;
-
-
- begin
-
- -- Check that the function To_Chars_Ptr will return a Null_Ptr value
- -- when the parameter Item is null.
-
- if ICS.To_Chars_Ptr(Item => Null_Char_Array_Access,
- Nul_Check => False) /= ICS.Null_Ptr or
- ICS.To_Chars_Ptr(Null_Char_Array_Access,
- Nul_Check => True) /= ICS.Null_Ptr or
- ICS.To_Chars_Ptr(Null_Char_Array_Access) /= ICS.Null_Ptr
- then
- Report.Failed("Incorrect result from function To_Chars_Ptr " &
- "with parameter Item being a null value");
- end if;
-
-
- -- Check that if the parameter Item is not null, and references a
- -- chars_array object that does contain the nul char, and parameter
- -- Nul_Check is True, function To_Chars_Ptr performs a pointer
- -- conversion from char_array_access type to chars_ptr type.
-
- begin
- TC_chars_ptr := ICS.To_Chars_Ptr(Item => Char_Array_W_nul_Ptr,
- Nul_Check => True);
-
- if ICS.Value(TC_chars_ptr) /= String_With_nul or
- ICS.Value(TC_chars_ptr) /= Char_Array_With_nul
- then
- Report.Failed("Incorrect result from function To_Chars_Ptr " &
- "with parameter Item being non-null and " &
- "containing the nul char");
- end if;
- exception
- when IC.Terminator_Error =>
- Report.Failed("Terminator_Error raised during the validation " &
- "of Function To_Chars_Ptr");
- when others =>
- Report.Failed("Unexpected exception raised during the " &
- "validation of Function To_Chars_Ptr");
- end;
-
- -- Check that if parameter Item is not null, and references a
- -- chars_array object that does not contain nul, and parameter
- -- Nul_Check is True, the To_Chars_Ptr function will propagate
- -- Terminator_Error.
-
- begin
- TC_chars_ptr := ICS.To_Chars_Ptr(Char_Array_WO_nul_Ptr, True);
- Report.Failed("Terminator_Error was not raised by function " &
- "To_Chars_Ptr when given a parameter Item that " &
- "is non-null, and does not contain the nul " &
- "char, but parameter Nul_Check is True");
- TC_size_t := ICS.Strlen(TC_chars_ptr); -- Use TC_chars_ptr to
- -- defeat optimization;
- exception
- when IC.Terminator_Error => null; -- Expected exception.
- when others =>
- Report.Failed("Incorrect exception raised when function " &
- "To_Chars_Ptr is given a parameter Item that " &
- "is non-null, and does not contain the nul " &
- "char, but parameter Nul_Check is True");
- end;
-
- -- Check that if the parameter Item is not null, and parameter
- -- Nul_Check is False, function To_Chars_Ptr performs a pointer
- -- conversion from char_array_access type to chars_ptr type.
-
- begin
- TC_chars_ptr := ICS.To_Chars_Ptr(Item => Char_Array_WO_nul_Ptr,
- Nul_Check => False);
-
- if ICS.Value(TC_chars_ptr, 6) /= String_Without_nul or
- ICS.Value(TC_chars_ptr, 6) /= Char_Array_Without_nul
- then
- Report.Failed("Incorrect result from function To_Chars_Ptr " &
- "with parameter Item being non-null and " &
- "Nul_Check False");
- end if;
- exception
- when IC.Terminator_Error =>
- Report.Failed("Terminator_Error raised during the validation " &
- "of Function To_Chars_Ptr");
- when others =>
- Report.Failed("Unexpected exception raised during the " &
- "validation of Function To_Chars_Ptr");
- end;
-
-
- -- Check that the New_Char_Array function will return a chars_ptr type
- -- pointer to an allocated object that has been initialized with
- -- the value of parameter Chars.
- TC_chars_ptr := ICS.New_String("");
- ICS.Free(TC_chars_ptr); -- Reset the chars_ptr to Null_Ptr;
-
- if TC_chars_ptr /= ICS.Null_Ptr then
- Report.Failed("Reset of TC_chars_ptr to Null not successful - 1");
- end if;
-
- TC_chars_ptr := ICS.New_Char_Array(Chars => Char_Array_With_nul);
-
- if TC_chars_ptr = ICS.Null_Ptr then -- Check allocation.
- Report.Failed
- ("No allocation took place in call to New_Char_Array " &
- "with a non-null char_array parameter containing a " &
- "terminating nul char");
- end if;
-
- -- Length of allocated array is determined using Strlen since array
- -- is nul terminated. Contents of array are validated using Value.
-
- if ICS.Value (TC_chars_ptr, Length => 7) /= Char_Array_With_nul or
- ICS.Strlen(Item => TC_chars_ptr) /= 6
- then
- Report.Failed
- ("Incorrect length of allocated char_array resulting " &
- "from call of New_Char_Array with a non-null " &
- "char_array parameter containing a terminating nul char");
- end if;
-
- ICS.Free(TC_chars_ptr); -- Reset the chars_ptr to Null_Ptr;
- if TC_chars_ptr /= ICS.Null_Ptr then
- Report.Failed("Reset of TC_chars_ptr to Null not successful - 2");
- end if;
-
- TC_chars_ptr := ICS.New_Char_Array(Chars => Char_Array_Without_nul);
-
- if TC_chars_ptr = ICS.Null_Ptr then -- Check allocation.
- Report.Failed
- ("No allocation took place in call to New_Char_Array " &
- "with a non-null char_array parameter that did not " &
- "contain a terminating nul char");
- end if;
-
- -- Function Value is used with the total length of the
- -- Char_Array_Without_nul as a parameter to verify the allocation.
-
- if ICS.Value(Item => TC_chars_ptr, Length => 6) /=
- Char_Array_Without_nul or
- ICS.Strlen(Item => TC_chars_ptr) /= 6
- then
- Report.Failed("Incorrect length of allocated char_array " &
- "resulting from call of New_Char_Array with " &
- "a non-null char_array parameter that did not " &
- "contain a terminating nul char");
- end if;
-
-
- -- Check that the function New_String returns a chars_ptr specifying
- -- an allocated object initialized to the value of parameter Str.
-
- ICS.Free(TC_chars_ptr); -- Reset the chars_ptr to Null_Ptr;
- if TC_chars_ptr /= ICS.Null_Ptr then
- Report.Failed("Reset of TC_chars_ptr to Null not successful - 3");
- end if;
-
- TC_chars_ptr := ICS.New_String(Str => Test_String);
-
- if ICS.Value(TC_chars_ptr) /= Test_String or
- ICS.Value(ICS.New_Char_Array(IC.To_C(Test_String,True))) /=
- Test_String
- then
- Report.Failed("Incorrect allocation resulting from function " &
- "New_String with a string parameter value");
- end if;
-
- ICS.Free(TC_chars_ptr); -- Reset the chars_ptr to Null_Ptr;
- if TC_chars_ptr /= ICS.Null_Ptr then
- Report.Failed("Reset of TC_chars_ptr to Null not successful - 4");
- end if;
-
- if ICS.Value(ICS.New_String(String_Without_nul)) /=
- String_Without_nul or
- ICS.Value(ICS.New_Char_Array(IC.To_C(String_Without_nul,False))) /=
- String_Without_nul
- then
- Report.Failed("Incorrect allocation resulting from function " &
- "New_String with parameter value String_Without_nul");
- end if;
-
-
- exception
- when The_Error : others =>
- Report.Failed ("The following exception was raised in the " &
- "Test_Block: " & Exception_Name(The_Error));
- end Test_Block;
-
- Report.Result;
-
-end CXB3009;
diff --git a/gcc/testsuite/ada/acats/tests/cxb/cxb3010.a b/gcc/testsuite/ada/acats/tests/cxb/cxb3010.a
deleted file mode 100644
index 25305b22fd0..00000000000
--- a/gcc/testsuite/ada/acats/tests/cxb/cxb3010.a
+++ /dev/null
@@ -1,320 +0,0 @@
--- CXB3010.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that the Procedure Free resets the parameter Item to
--- Null_Ptr. Check that Free has no effect if Item is Null_Ptr.
---
--- Check that the version of Function Value with a chars_ptr parameter
--- returning a char_array result returns the prefix of an array of
--- chars.
---
--- Check that the version of Function Value with a chars_ptr parameter
--- and a size_t parameter returning a char_array result returns
--- the shorter of:
--- 1) the first size_t number of characters, or
--- 2) the characters up to and including the first nul.
---
--- Check that both of the above versions of Function Value propagate
--- Dereference_Error if the Item parameter is Null_Ptr.
---
--- TEST DESCRIPTION:
--- This test validates the Procedure Free and two versions of Function
--- Value. A variety of char_array and char_ptr values are provided as
--- input, and results are compared for both length and content.
---
--- This test assumes that the following characters are all included
--- in the implementation defined type Interfaces.C.char:
--- ' ', 'a'..'z', and 'A'..'Z'.
---
--- APPLICABILITY CRITERIA:
--- This test is applicable to all implementations that provide
--- package Interfaces.C.Strings. If an implementation provides
--- package Interfaces.C.Strings, this test must compile, execute,
--- and report "PASSED".
---
---
--- CHANGE HISTORY:
--- 27 Sep 95 SAIC Initial prerelease version.
--- 13 May 96 SAIC Incorporated reviewer comments for ACVC 2.1.
--- 26 Oct 96 SAIC Incorporated reviewer comments.
--- 01 DEC 97 EDS Replicate line 199 at line 256, to ensure that
--- TC_chars_ptr has a valid pointer.
--- 08 JUL 99 RLB Added a test case to check that Value raises
--- Constraint_Error when Length = 0. (From Technical
--- Corrigendum 1).
--- 25 JAN 01 RLB Repaired previous test case to avoid raising
--- Constraint_Error in test case code.
--- 26 JAN 01 RLB Added an Ident_Int to the test case to prevent
--- optimization.
-
---!
-
-with Report;
-with Interfaces.C.Strings; -- N/A => ERROR
-
-procedure CXB3010 is
-begin
-
- Report.Test ("CXB3010", "Check that Procedure Free and versions of " &
- "Function Value produce correct results");
-
- Test_Block:
- declare
-
- package IC renames Interfaces.C;
- package ICS renames Interfaces.C.Strings;
-
- use type IC.char_array;
- use type IC.size_t;
- use type ICS.chars_ptr;
- use type IC.char;
-
- Null_Char_Array_Access : constant ICS.char_array_access := null;
-
- TC_String_1 : constant String := "Nonul";
- TC_String_2 : constant String := "AbCdE";
- TC_Blank_String : constant String(1..5) := (others => ' ');
-
- -- The initialization of the following char_array objects
- -- includes the appending of a terminating nul char, in order to
- -- prevent the erroneous execution of Function Value.
-
- TC_char_array : IC.char_array :=
- IC.To_C(TC_Blank_String, True);
- TC_char_array_1 : constant IC.char_array :=
- IC.To_C(TC_String_1, True);
- TC_char_array_2 : constant IC.char_array :=
- IC.To_C(TC_String_2, True);
- TC_Blank_char_array : constant IC.char_array :=
- IC.To_C(TC_Blank_String, True);
-
- -- This chars_ptr is initialized via the use of New_Chars_Array to
- -- avoid erroneous execution of procedure Free.
- TC_chars_ptr : ICS.chars_ptr :=
- ICS.New_Char_Array(TC_Blank_char_array);
-
- begin
-
- -- Check that the Procedure Free resets the parameter Item
- -- to Null_Ptr.
-
- if TC_chars_ptr = ICS.Null_Ptr then
- Report.Failed("TC_chars_ptr is currently null; it should not be " &
- "null since it was given default initialization");
- end if;
-
- ICS.Free(TC_chars_ptr);
-
- if TC_chars_ptr /= ICS.Null_Ptr then
- Report.Failed("TC_chars_ptr was not set to Null_Ptr by " &
- "Procedure Free");
- end if;
-
- -- Check that Free has no effect if Item is Null_Ptr.
-
- begin
- TC_chars_ptr := ICS.Null_Ptr; -- Ensure pointer is null.
- ICS.Free(TC_chars_ptr);
- if TC_chars_ptr /= ICS.Null_Ptr then
- Report.Failed("TC_chars_ptr was set to a non-Null_Ptr value " &
- "by Procedure Free. It was provided as a null " &
- "parameter to Free, and there should have been " &
- "no effect from a call to Procedure Free");
- end if;
- exception
- when others =>
- Report.Failed("Unexpected exception raised by Procedure Free " &
- "when parameter Item is Null_Ptr");
- end;
-
-
- -- Check that the version of Function Value with a chars_ptr parameter
- -- that returns a char_array result returns an array of chars (up to
- -- and including the first nul).
-
- TC_chars_ptr := ICS.New_Char_Array(TC_char_array_1);
- TC_char_array := ICS.Value(Item => TC_chars_ptr);
-
- if TC_char_array /= TC_char_array_1 or
- IC.To_Ada(TC_char_array, True) /= IC.To_Ada(TC_char_array_1)
- then
- Report.Failed("Incorrect result from Function Value - 1");
- end if;
-
- TC_chars_ptr := ICS.New_Char_Array(TC_char_array_2);
- TC_char_array := ICS.Value(Item => TC_chars_ptr);
-
- if TC_char_array /= TC_char_array_2 or
- IC.To_Ada(TC_char_array, True) /= IC.To_Ada(TC_char_array_2)
- then
- Report.Failed("Incorrect result from Function Value - 2");
- end if;
-
- if ICS.Value(Item => ICS.New_String("A little longer string")) /=
- IC.To_C("A little longer string")
- then
- Report.Failed("Incorrect result from Function Value - 3");
- end if;
-
-
- -- Check that the version of Function Value with a chars_ptr parameter
- -- and a size_t parameter that returns a char_array result returns
- -- the shorter of:
- -- 1) the first size_t number of characters, or
- -- 2) the characters up to and including the first nul.
-
- -- Case 1: the first size_t number of characters (less than the
- -- total length).
-
- begin
- TC_chars_ptr := ICS.New_Char_Array(TC_char_array_1);
- TC_char_array(0..2) := ICS.Value(Item => TC_chars_ptr, Length => 3);
-
- if TC_char_array(0..2) /= TC_char_array_1(0..2)
- then
- Report.Failed
- ("Incorrect result from Function Value with Length " &
- "parameter - 1");
- end if;
- exception
- when others =>
- Report.Failed("Exception raised during Case 1 evaluation");
- end;
-
- -- Case 2: the characters up to and including the first nul.
-
- TC_chars_ptr := ICS.New_Char_Array(TC_char_array_2);
-
- -- The length supplied as a parameter exceeds the total length of
- -- TC_char_array_2. The result should be the entire TC_char_array_2
- -- including the terminating nul.
-
- TC_char_array := ICS.Value(Item => TC_chars_ptr, Length => 7);
-
- if TC_char_array /= TC_char_array_2 or
- IC.To_Ada(TC_char_array) /= IC.To_Ada(TC_char_array_2) or
- not (IC.Is_Nul_Terminated(TC_char_array))
- then
- Report.Failed("Incorrect result from Function Value with Length " &
- "parameter - 2");
- end if;
-
-
- -- Check that both of the above versions of Function Value propagate
- -- Dereference_Error if the Item parameter is Null_Ptr.
-
- declare
-
- -- Declare a dummy function to demonstrate one way that a chars_ptr
- -- variable could inadvertantly be set to Null_Ptr prior to a call
- -- to Value (below).
- function Freedom (Condition : Boolean := False;
- Ptr : ICS.chars_ptr) return ICS.chars_ptr is
- Pointer : ICS.chars_ptr := Ptr;
- begin
- if Condition then
- ICS.Free(Pointer);
- else
- null; -- An activity that doesn't set the chars_ptr value to
- -- Null_Ptr.
- end if;
- return Pointer;
- end Freedom;
-
- begin
-
- begin
- TC_char_array := ICS.Value(Item => Freedom(True, TC_chars_ptr));
- Report.Failed
- ("Function Value (without Length parameter) did not " &
- "raise Dereference_Error when provided a null Item " &
- "parameter input value");
- if TC_char_array(0) = '6' then -- Defeat optimization.
- Report.Comment("Should never be printed");
- end if;
- exception
- when ICS.Dereference_Error => null; -- OK, expected exception.
- when others =>
- Report.Failed("Incorrect exception raised by Function Value " &
- "with Item parameter, when the Item parameter " &
- "is Null_Ptr");
- end;
-
- TC_chars_ptr := ICS.New_Char_Array(TC_char_array_2);
- begin
- TC_char_array := ICS.Value(Item => Freedom(True, TC_chars_ptr),
- Length => 4);
- Report.Failed
- ("Function Value (with Length parameter) did not " &
- "raise Dereference_Error when provided a null Item " &
- "parameter input value");
- if TC_char_array(0) = '6' then -- Defeat optimization.
- Report.Comment("Should never be printed");
- end if;
- exception
- when ICS.Dereference_Error => null; -- OK, expected exception.
- when others =>
- Report.Failed("Incorrect exception raised by Function Value " &
- "with both Item and Length parameters, when " &
- "the Item parameter is Null_Ptr");
- end;
- end;
-
- -- Check that Function Value with two parameters propagates
- -- Constraint_Error if Length is 0.
-
- begin
- TC_chars_ptr := ICS.New_Char_Array(TC_char_array_1);
- declare
- TC : IC.char_array := ICS.Value(Item => TC_chars_ptr, Length =>
- IC.Size_T(Report.Ident_Int(0)));
- begin
- Report.Failed
- ("Function Value (with Length parameter) did not " &
- "raise Constraint_Error when Length = 0");
- if TC'Length <= TC_char_array'Length then
- TC_char_array(1..TC'Length) := TC; -- Block optimization of TC.
- end if;
- end;
-
- Report.Failed
- ("Function Value (with Length parameter) did not " &
- "raise Constraint_Error when Length = 0");
- exception
- when Constraint_Error => null; -- OK, expected exception.
- when others =>
- Report.Failed("Incorrect exception raised by Function Value " &
- "with both Item and Length parameters, when " &
- "Length = 0");
- end;
-
- exception
- when others => Report.Failed ("Exception raised in Test_Block");
- end Test_Block;
-
- Report.Result;
-
-end CXB3010;
diff --git a/gcc/testsuite/ada/acats/tests/cxb/cxb3011.a b/gcc/testsuite/ada/acats/tests/cxb/cxb3011.a
deleted file mode 100644
index 6930407ec55..00000000000
--- a/gcc/testsuite/ada/acats/tests/cxb/cxb3011.a
+++ /dev/null
@@ -1,282 +0,0 @@
--- CXB3011.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that the version of Function Value with a chars_ptr parameter
--- that returns a String result returns an Ada string containing the
--- characters pointed to by the chars_ptr parameter, up to (but not
--- including) the terminating nul.
---
--- Check that the version of Function Value with a chars_ptr parameter
--- and a size_t parameter that returns a String result returns the
--- shorter of:
--- 1) a String of the first size_t number of characters, or
--- 2) a String of characters up to (but not including) the
--- terminating nul.
---
--- Check that the Function Strlen returns a size_t result that
--- corresponds to the number of chars in the array pointed to by Item,
--- up to but not including the terminating nul.
---
--- Check that both of the above versions of Function Value and
--- Function Strlen propagate Dereference_Error if the Item parameter
--- is Null_Ptr.
---
--- TEST DESCRIPTION:
--- This test validates two versions of Function Value, and the Function
--- Strlen. A series of char_ptr values are provided as input, and
--- results are compared for length or content.
---
--- This test assumes that the following characters are all included
--- in the implementation defined type Interfaces.C.char:
--- ' ', 'a'..'z', 'A'..'Z', '0'..'9', '*' and '.'.
---
--- APPLICABILITY CRITERIA:
--- This test is applicable to all implementations that provide
--- package Interfaces.C.Strings. If an implementation provides
--- package Interfaces.C.Strings, this test must compile, execute,
--- and report "PASSED".
---
---
--- CHANGE HISTORY:
--- 28 Sep 95 SAIC Initial prerelease version.
--- 13 May 96 SAIC Incorporated reviewer comments for ACVC 2.1.
--- 26 Oct 96 SAIC Incorporated reviewer comments.
---
---!
-
-with Report;
-with Ada.Characters.Latin_1;
-with Interfaces.C.Strings; -- N/A => ERROR
-
-procedure CXB3011 is
-begin
-
- Report.Test ("CXB3011", "Check that the two versions of Function Value " &
- "returning a String result, and the Function " &
- "Strlen, produce correct results");
-
- Test_Block:
- declare
-
- package IC renames Interfaces.C;
- package ICS renames Interfaces.C.Strings;
- package ACL1 renames Ada.Characters.Latin_1;
-
- use type IC.char_array;
- use type IC.size_t;
- use type ICS.chars_ptr;
-
- Null_Char_Array_Access : constant ICS.char_array_access := null;
-
- TC_String : String(1..5) := (others => 'X');
- TC_String_1 : constant String := "*.3*0";
- TC_String_2 : constant String := "Two";
- TC_String_3 : constant String := "Five5";
- TC_Blank_String : constant String(1..5) := (others => ' ');
-
- TC_char_array : IC.char_array :=
- IC.To_C(TC_Blank_String, True);
- TC_char_array_1 : constant IC.char_array :=
- IC.To_C(TC_String_1, True);
- TC_char_array_2 : constant IC.char_array :=
- IC.To_C(TC_String_2, True);
- TC_char_array_3 : constant IC.char_array :=
- IC.To_C(TC_String_3, True);
- TC_Blank_char_array : constant IC.char_array :=
- IC.To_C(TC_Blank_String, True);
-
- TC_chars_ptr : ICS.chars_ptr :=
- ICS.New_Char_Array(TC_Blank_char_array);
-
- TC_size_t : IC.size_t := IC.size_t'First;
-
-
- begin
-
- -- Check that the version of Function Value with a chars_ptr parameter
- -- that returns a String result returns an Ada string containing the
- -- characters pointed to by the chars_ptr parameter, up to (but not
- -- including) the terminating nul.
-
- TC_chars_ptr := ICS.New_Char_Array(TC_char_array_1);
- TC_String := ICS.Value(Item => TC_chars_ptr);
-
- if TC_String /= TC_String_1 or
- TC_String(TC_String'Last) = ACL1.NUL
- then
- Report.Failed("Incorrect result from Function Value - 1");
- end if;
-
- TC_chars_ptr := ICS.New_Char_Array(TC_char_array_2);
-
- if ICS.Value(Item => TC_chars_ptr) /=
- IC.To_Ada(ICS.Value(TC_chars_ptr), Trim_Nul => True)
- then
- Report.Failed("Incorrect result from Function Value - 2");
- end if;
-
- TC_chars_ptr := ICS.New_Char_Array(TC_char_array_3);
- TC_String := ICS.Value(TC_chars_ptr);
-
- if TC_String /= TC_String_3 or
- TC_String(TC_String'Last) = ACL1.NUL
- then
- Report.Failed("Incorrect result from Function Value - 3");
- end if;
-
-
- -- Check that the version of Function Value with a chars_ptr parameter
- -- and a size_t parameter that returns a String result returns the
- -- shorter of:
- -- 1) a String of the first size_t number of characters, or
- -- 2) a String of characters up to (but not including) the
- -- terminating nul.
- --
-
- -- Case 1 : Length parameter specifies a length shorter than total
- -- length.
-
- TC_chars_ptr := ICS.New_Char_Array(TC_char_array_1);
- TC_String := "XXXXX"; -- Reinitialize all characters in string.
- TC_String(1..5) := ICS.Value(Item => TC_chars_ptr, Length => 6);
-
- if TC_String(1..4) /= TC_String_1(1..4) or
- TC_String(TC_String'Last) = ACL1.NUL
- then
- Report.Failed("Incorrect result from Function Value - 4");
- end if;
-
- -- Case 2 : Length parameter specifies total length.
-
- TC_chars_ptr := ICS.New_Char_Array(TC_char_array_2);
-
- if ICS.Value(TC_chars_ptr, Length => 5) /=
- IC.To_Ada(ICS.Value(TC_chars_ptr), Trim_Nul => True)
- then
- Report.Failed("Incorrect result from Function Value - 5");
- end if;
-
- -- Case 3 : Length parameter specifies a length longer than total
- -- length.
-
- TC_chars_ptr := ICS.New_Char_Array(TC_char_array_3);
- TC_String := "XXXXX"; -- Reinitialize all characters in string.
- TC_String := ICS.Value(TC_chars_ptr, 7);
-
- if TC_String /= TC_String_3 or
- TC_String(TC_String'Last) = ACL1.NUL
- then
- Report.Failed("Incorrect result from Function Value - 6");
- end if;
-
-
- -- Check that the Function Strlen returns a size_t result that
- -- corresponds to the number of chars in the array pointed to by
- -- parameter Item, up to but not including the terminating nul.
-
- TC_chars_ptr := ICS.New_Char_Array(IC.To_C("A longer string value"));
- TC_size_t := ICS.Strlen(TC_chars_ptr);
-
- if TC_size_t /= 21 then
- Report.Failed("Incorrect result from Function Strlen - 1");
- end if;
-
- TC_chars_ptr := ICS.New_Char_Array(TC_char_array_2);
- TC_size_t := ICS.Strlen(TC_chars_ptr);
-
- if TC_size_t /= 3 then -- Nul not included in length.
- Report.Failed("Incorrect result from Function Strlen - 2");
- end if;
-
- TC_chars_ptr := ICS.New_Char_Array(IC.To_C(""));
- TC_size_t := ICS.Strlen(TC_chars_ptr);
-
- if TC_size_t /= 0 then
- Report.Failed("Incorrect result from Function Strlen - 3");
- end if;
-
-
- -- Check that both of the above versions of Function Value and
- -- function Strlen propagate Dereference_Error if the Item parameter
- -- is Null_Ptr.
-
- begin
- TC_chars_ptr := ICS.Null_Ptr;
- TC_String := ICS.Value(Item => TC_chars_ptr);
- Report.Failed("Function Value (without Length parameter) did not " &
- "raise Dereference_Error when provided a null Item " &
- "parameter input value");
- if TC_String(1) = '1' then -- Defeat optimization.
- Report.Comment("Should never be printed");
- end if;
- exception
- when ICS.Dereference_Error => null; -- OK, expected exception.
- when others =>
- Report.Failed("Incorrect exception raised by Function Value " &
- "with Item parameter, when the Item parameter " &
- "is Null_Ptr");
- end;
-
- begin
- TC_chars_ptr := ICS.Null_Ptr;
- TC_String := ICS.Value(Item => TC_chars_ptr, Length => 4);
- Report.Failed("Function Value (with Length parameter) did not " &
- "raise Dereference_Error when provided a null Item " &
- "parameter input value");
- if TC_String(1) = '1' then -- Defeat optimization.
- Report.Comment("Should never be printed");
- end if;
- exception
- when ICS.Dereference_Error => null; -- OK, expected exception.
- when others =>
- Report.Failed("Incorrect exception raised by Function Value " &
- "with both Item and Length parameters, when " &
- "the Item parameter is Null_Ptr");
- end;
-
- begin
- TC_chars_ptr := ICS.Null_Ptr;
- TC_size_t := ICS.Strlen(Item => TC_chars_ptr);
- Report.Failed("Function Strlen did not raise Dereference_Error" &
- "when provided a null Item parameter input value");
- if TC_size_t = 35 then -- Defeat optimization.
- Report.Comment("Should never be printed");
- end if;
- exception
- when ICS.Dereference_Error => null; -- OK, expected exception.
- when others =>
- Report.Failed("Incorrect exception raised by Function Strlen " &
- "when the Item parameter is Null_Ptr");
- end;
-
-
- exception
- when others => Report.Failed ("Exception raised in Test_Block");
- end Test_Block;
-
- Report.Result;
-
-end CXB3011;
diff --git a/gcc/testsuite/ada/acats/tests/cxb/cxb3012.a b/gcc/testsuite/ada/acats/tests/cxb/cxb3012.a
deleted file mode 100644
index 2f97e77871c..00000000000
--- a/gcc/testsuite/ada/acats/tests/cxb/cxb3012.a
+++ /dev/null
@@ -1,342 +0,0 @@
--- CXB3012.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that Procedure Update modifies the value pointed to by
--- the chars_ptr parameter Item, starting at the position
--- corresponding to parameter Offset, using the chars in
--- char_array parameter Chars.
---
--- Check that the version of Procedure Update with a String parameter
--- behaves in the manner described above, but with the character
--- values in the String overwriting the char values in Item.
---
--- Check that both of the above versions of Procedure Update will
--- propagate Update_Error if Check is True, and if the length of
--- the new chars in Chars, when overlaid starting from position
--- Offset, will overwrite the first nul in Item.
---
--- TEST DESCRIPTION:
--- This test checks two versions of Procedure Update. In the first
--- version of the procedure, the parameter Chars indicates a char_array
--- argument. These char_array parameters are provided through the use
--- of the To_C function (with String IN parameter), both with and
--- without a terminating nul. In the case below where a terminating nul
--- char is appended, the effect of "updating" the value pointed to by the
--- Item parameter will include its shortening, due to the insertion of
--- this additional nul in the middle of the char_array.
---
--- In the second version of Procedure Update evaluated here, the string
--- parameter Str is used to modify the char_array pointed to by Item.
---
--- Finally, both versions of the procedure are evaluated to ensure that
--- they propagate Update_Error and Dereference_Error under the proper
--- conditions.
---
--- This test assumes that the following characters are all included
--- in the implementation defined type Interfaces.C.char:
--- ' ', 'a'..'z', 'A'..'Z', '0'..'9', '-' and '.'.
---
--- APPLICABILITY CRITERIA:
--- This test is applicable to all implementations that provide
--- package Interfaces.C.Strings. If an implementation provides
--- package Interfaces.C.Strings, this test must compile, execute,
--- and report "PASSED".
---
---
--- CHANGE HISTORY:
--- 05 Oct 95 SAIC Initial prerelease version.
--- 13 May 96 SAIC Incorporated reviewer comments for ACVC 2.1.
--- 26 Oct 96 SAIC Incorporated reviewer comments.
--- 14 Sep 99 RLB Removed incorrect and unnecessary
--- Unchecked_Conversion. Added check for raising
--- of Dereference_Error for Update (From Technical
--- Corrigendum 1).
---
---!
-
-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_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 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.
-
- 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.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.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.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.Failed("Incorrect result from Procedure Update - 8");
- end if;
- 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/cxb3014.a b/gcc/testsuite/ada/acats/tests/cxb/cxb3014.a
deleted file mode 100644
index a9b386ffcfd..00000000000
--- a/gcc/testsuite/ada/acats/tests/cxb/cxb3014.a
+++ /dev/null
@@ -1,254 +0,0 @@
--- CXB3014.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that the Function Value with Pointer and Element
--- parameters will return an Element_Array result of correct size
--- and content (up to and including the first "terminator" Element).
---
--- Check that the Function Value with Pointer and Length parameters
--- will return an Element_Array result of appropriate size and content
--- (the first Length elements pointed to by the parameter Ref).
---
--- Check that both versions of Function Value will propagate
--- Interfaces.C.Strings.Dereference_Error when the value of
--- the Ref pointer parameter is null.
---
--- TEST DESCRIPTION:
--- This test tests that both versions of Function Value from the
--- generic package Interfaces.C.Pointers are available and produce
--- correct results. The generic package is instantiated with size_t,
--- char, char_array, and nul as actual parameters, and subtests are
--- performed on each of the Value functions resulting from this
--- instantiation.
--- For both function versions, a test is performed where a portion of
--- a char_array is to be returned as the function result. Likewise,
--- a test is performed where each version of the function returns the
--- entire char_array referenced by the in parameter Ref.
--- Finally, both versions of Function Value are called with a null
--- pointer reference, to ensure that Dereference_Error is raised in
--- this case.
---
--- This test assumes that the following characters are all included
--- in the implementation defined type Interfaces.C.char:
--- ' ', 'a'..'z', and 'A'..'Z'.
---
--- APPLICABILITY CRITERIA:
--- This test is applicable to all implementations that provide
--- packages Interfaces.C.Strings and Interfaces.C.Pointers. If an
--- implementation provides packages Interfaces.C.Strings and
--- Interfaces.C.Pointers, this test must compile, execute, and
--- report "PASSED".
---
---
--- CHANGE HISTORY:
--- 19 Oct 95 SAIC Initial prerelease version.
--- 13 May 96 SAIC Incorporated reviewer comments for ACVC 2.1.
--- 23 Oct 96 SAIC Incorporated reviewer comments.
---
---!
-
-with Report;
-with Interfaces.C.Strings; -- N/A => ERROR
-with Interfaces.C.Pointers; -- N/A => ERROR
-
-procedure CXB3014 is
-
-begin
-
- Report.Test ("CXB3014", "Check that versions of the Value function " &
- "from package Interfaces.C.Pointers produce " &
- "correct results");
-
- Test_Block:
- declare
-
- use type Interfaces.C.char, Interfaces.C.size_t;
-
- Char_a : constant Interfaces.C.char := 'a';
- Char_j : constant Interfaces.C.char := 'j';
- Char_z : constant Interfaces.C.char := 'z';
-
- subtype Lower_Case_chars is Interfaces.C.char range Char_a..Char_z;
- subtype Char_Range is Interfaces.C.size_t range 0..26;
-
- Local_nul : aliased Interfaces.C.char := Interfaces.C.nul;
- TC_Array_Size : Interfaces.C.size_t := 20;
-
- TC_String_1 : constant String := "abcdefghij";
- TC_String_2 : constant String := "abcdefghijklmnopqrstuvwxyz";
- TC_String_3 : constant String := "abcdefghijklmnopqrst";
- TC_String_4 : constant String := "abcdefghijklmnopqrstuvwxyz";
- TC_Blank_String : constant String := " ";
-
- TC_Char_Array : Interfaces.C.char_array(Char_Range) :=
- Interfaces.C.To_C(TC_String_2, True);
-
- TC_Char_Array_1 : Interfaces.C.char_array(0..9);
- TC_Char_Array_2 : Interfaces.C.char_array(Char_Range);
- TC_Char_Array_3 : Interfaces.C.char_array(0..TC_Array_Size-1);
- TC_Char_Array_4 : Interfaces.C.char_array(Char_Range);
-
- package Char_Pointers is new
- Interfaces.C.Pointers (Index => Interfaces.C.size_t,
- Element => Interfaces.C.char,
- Element_Array => Interfaces.C.char_array,
- Default_Terminator => Interfaces.C.nul);
-
- Char_Ptr : Char_Pointers.Pointer;
-
- use type Char_Pointers.Pointer;
-
- begin
-
- -- Check that the Function Value with Pointer and Terminator Element
- -- parameters will return an Element_Array result of appropriate size
- -- and content (up to and including the first "terminator" Element.)
-
- Char_Ptr := TC_Char_Array(0)'Access;
-
- -- Provide a new Terminator char in the call of Function Value.
- -- This call should return only a portion (the first 10 chars) of
- -- the referenced char_array, up to and including the char 'j'.
-
- TC_Char_Array_1 := Char_Pointers.Value(Ref => Char_Ptr,
- Terminator => Char_j);
-
- if Interfaces.C.To_Ada(TC_Char_Array_1, False) /= TC_String_1 or
- Interfaces.C.Is_Nul_Terminated(TC_Char_Array_1)
- then
- Report.Failed("Incorrect result from Function Value with Ref " &
- "and Terminator parameters, when supplied with " &
- "a non-default Terminator char");
- end if;
-
- -- Use the default Terminator char in the call of Function Value.
- -- This call should return the entire char_array, including the
- -- terminating nul char.
-
- TC_Char_Array_2 := Char_Pointers.Value(Char_Ptr);
-
- if Interfaces.C.To_Ada(TC_Char_Array_2, True) /= TC_String_2 or
- not Interfaces.C.Is_Nul_Terminated(TC_Char_Array_2)
- then
- Report.Failed("Incorrect result from Function Value with Ref " &
- "and Terminator parameters, when using the " &
- "default Terminator char");
- end if;
-
-
-
- -- Check that the Function Value with Pointer and Length parameters
- -- will return an Element_Array result of appropriate size and content
- -- (the first Length elements pointed to by the parameter Ref).
-
- -- This call should return only a portion (the first 20 chars) of
- -- the referenced char_array.
-
- TC_Char_Array_3 :=
- Char_Pointers.Value(Ref => Char_Ptr,
- Length => Interfaces.C.ptrdiff_t(TC_Array_Size));
-
- -- Verify the individual chars of the result.
- for i in 0..TC_Array_Size-1 loop
- if Interfaces.C.To_Ada(TC_Char_Array_3(i)) /=
- TC_String_3(Integer(i)+1)
- then
- Report.Failed("Incorrect result from Function Value with " &
- "Ref and Length parameters, when specifying " &
- "a length less than the full array size");
- exit;
- end if;
- end loop;
-
- -- This call should return the entire char_array, including the
- -- terminating nul char.
-
- TC_Char_Array_4 := Char_Pointers.Value(Char_Ptr, 27);
-
- if Interfaces.C.To_Ada(TC_Char_Array_4, True) /= TC_String_4 or
- not Interfaces.C.Is_Nul_Terminated(TC_Char_Array_4)
- then
- Report.Failed("Incorrect result from Function Value with Ref " &
- "and Length parameters, when specifying the " &
- "entire array size");
- end if;
-
-
-
- -- Check that both of the above versions of Function Value will
- -- propagate Interfaces.C.Strings.Dereference_Error when the value of
- -- the Ref Pointer parameter is null.
-
- Char_Ptr := null;
-
- begin
- TC_Char_Array_1 := Char_Pointers.Value(Ref => Char_Ptr,
- Terminator => Char_j);
- Report.Failed("Dereference_Error not raised by Function " &
- "Value with Terminator parameter, when " &
- "provided a null reference");
- -- Call Report.Comment to ensure that the assignment to
- -- TC_Char_Array_1 is not "dead", and therefore can not be
- -- optimized away.
- Report.Comment(Interfaces.C.To_Ada(TC_Char_Array_1, False));
- exception
- when Interfaces.C.Strings.Dereference_Error =>
- null; -- OK, expected exception.
- when others =>
- Report.Failed("Incorrect exception raised by Function " &
- "Value with Terminator parameter, when " &
- "provided a null reference");
- end;
-
-
- begin
- TC_Char_Array_3 :=
- Char_Pointers.Value(Char_Ptr,
- Interfaces.C.ptrdiff_t(TC_Array_Size));
- Report.Failed("Dereference_Error not raised by Function " &
- "Value with Length parameter, when provided " &
- "a null reference");
- -- Call Report.Comment to ensure that the assignment to
- -- TC_Char_Array_3 is not "dead", and therefore can not be
- -- optimized away.
- Report.Comment(Interfaces.C.To_Ada(TC_Char_Array_3, False));
- exception
- when Interfaces.C.Strings.Dereference_Error =>
- null; -- OK, expected exception.
- when others =>
- Report.Failed("Incorrect exception raised by Function " &
- "Value with Length parameter, when " &
- "provided a null reference");
- end;
-
-
- exception
- when others => Report.Failed ("Exception raised in Test_Block");
- end Test_Block;
-
- Report.Result;
-
-end CXB3014;
diff --git a/gcc/testsuite/ada/acats/tests/cxb/cxb3015.a b/gcc/testsuite/ada/acats/tests/cxb/cxb3015.a
deleted file mode 100644
index 24ec826fab9..00000000000
--- a/gcc/testsuite/ada/acats/tests/cxb/cxb3015.a
+++ /dev/null
@@ -1,520 +0,0 @@
--- CXB3015.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that the "+" and "-" functions with Pointer and ptrdiff_t
--- parameters that return Pointer values produce correct results,
--- based on the size of the array elements.
---
--- Check that the "-" function with two Pointer parameters that
--- returns a ptrdiff_t type parameter produces correct results,
--- based on the size of the array elements.
---
--- Check that each of the "+" and "-" functions above will
--- propagate Pointer_Error if a Pointer parameter is null.
---
--- Check that the Increment and Decrement procedures provide the
--- correct "pointer arithmetic" operations.
---
--- TEST DESCRIPTION:
--- This test checks that the functions "+" and "-", and the procedures
--- Increment and Decrement in the generic package Interfaces.C.Pointers
--- will allow the user to perform "pointer arithmetic" operations on
--- Pointer values.
--- Package Interfaces.C.Pointers is instantiated three times, for
--- short values, chars, and arrays of arrays. Pointers from each
--- instantiated package are then used to reference different elements
--- of array objects. Pointer arithmetic operations are performed on
--- these pointers, and the results of these operations are verified
--- against expected pointer positions along the referenced arrays.
--- The propagation of Pointer_Error is checked for when the function
--- Pointer parameter is null.
---
--- The following chart indicates the combinations of subprograms and
--- parameter types used in this test.
---
---
--- Short Char Array
--- --------------------------
--- "+" Pointer, ptrdiff_t | X | | X |
--- |--------------------------|
--- "+" ptrdiff_t, Pointer | X | | X |
--- |--------------------------|
--- "-" Pointer, ptrdiff_t | | X | X |
--- |--------------------------|
--- "-" Pointer, Pointer | | X | X |
--- |--------------------------|
--- Increment (Pointer) | X | | X |
--- |--------------------------|
--- Decrement (Pointer) | X | | X |
--- --------------------------
---
--- This test assumes that the following characters are all included
--- in the implementation defined type Interfaces.C.char:
--- ' ', and 'a'..'z'.
---
--- APPLICABILITY CRITERIA:
--- This test is applicable to all implementations that provide
--- package Interfaces.C.Pointers. If an implementation provides
--- package Interfaces.C.Pointers, this test must compile, execute, and
--- report "PASSED".
---
---
--- CHANGE HISTORY:
--- 26 Oct 95 SAIC Initial prerelease version.
--- 13 May 96 SAIC Incorporated reviewer comments for ACVC 2.1.
--- 26 Oct 96 SAIC Incorporated reviewer comments.
--- 06 Mar 00 RLB Repaired so that array of arrays component
--- type is statically constrained. (C does not have
--- an analog to an array of dynamically constrained
--- arrays.)
-
-with Report;
-with Ada.Exceptions;
-with Interfaces.C.Pointers; -- N/A => ERROR
-
-procedure CXB3015 is
-begin
-
- Report.Test ("CXB3015", "Check that +, -, Increment, and Decrement " &
- "subprograms in Package Interfaces.C.Pointers " &
- "produce correct results");
-
- Test_Block:
- declare
-
- use Ada.Exceptions;
- use type Interfaces.C.short;
- use type Interfaces.C.size_t, Interfaces.C.ptrdiff_t;
- use type Interfaces.C.char, Interfaces.C.char_array;
-
- TC_Count : Interfaces.C.size_t;
- TC_Increment : Interfaces.C.ptrdiff_t;
- TC_ptrdiff_t : Interfaces.C.ptrdiff_t;
- TC_Short : Interfaces.C.short := 0;
- TC_Verbose : Boolean := False;
- Constant_Min_Array_Size : constant Interfaces.C.size_t := 0;
- Constant_Max_Array_Size : constant Interfaces.C.size_t := 20;
- Min_Array_Size : Interfaces.C.size_t := Interfaces.C.size_t(
- Report.Ident_Int(Integer(Constant_Min_Array_Size)));
- Max_Array_Size : Interfaces.C.size_t := Interfaces.C.size_t(
- Report.Ident_Int(Integer(Constant_Max_Array_Size)));
- Min_size_t,
- Max_size_t : Interfaces.C.size_t;
- Short_Terminator : Interfaces.C.short := Interfaces.C.short'Last;
- Alphabet : constant String := "abcdefghijklmnopqrstuvwxyz";
-
-
- type Short_Array_Type is
- array (Interfaces.C.size_t range <>) of aliased Interfaces.C.short;
-
- type Constrained_Array_Type is
- array (Min_Array_Size..Max_Array_Size) of aliased Interfaces.C.short;
-
- type Static_Constrained_Array_Type is
- array (Constant_Min_Array_Size .. Constant_Max_Array_Size) of
- aliased Interfaces.C.short;
-
- type Array_of_Arrays_Type is
- array (Interfaces.C.size_t range <>) of aliased
- Static_Constrained_Array_Type;
-
-
- Short_Array : Short_Array_Type(Min_Array_Size..Max_Array_Size);
-
- Constrained_Array : Constrained_Array_Type;
-
- Terminator_Array : Static_Constrained_Array_Type :=
- (others => Short_Terminator);
-
- Ch_Array : Interfaces.C.char_array
- (0..Interfaces.C.size_t(Alphabet'Length)) :=
- Interfaces.C.To_C(Alphabet, True);
-
- Array_of_Arrays : Array_of_Arrays_Type
- (Min_Array_Size..Max_Array_Size);
-
-
- package Short_Pointers is new
- Interfaces.C.Pointers (Index => Interfaces.C.size_t,
- Element => Interfaces.C.short,
- Element_Array => Short_Array_Type,
- Default_Terminator => Short_Terminator);
-
- package Char_Pointers is new
- Interfaces.C.Pointers (Interfaces.C.size_t,
- Interfaces.C.char,
- Element_Array => Interfaces.C.char_array,
- Default_Terminator => Interfaces.C.nul);
-
- package Array_Pointers is new
- Interfaces.C.Pointers (Interfaces.C.size_t,
- Static_Constrained_Array_Type,
- Array_of_Arrays_Type,
- Terminator_Array);
-
-
- use Short_Pointers, Char_Pointers, Array_Pointers;
-
- Short_Ptr : Short_Pointers.Pointer := Short_Array(0)'Access;
- Char_Ptr : Char_Pointers.Pointer := Ch_Array(0)'Access;
- Start_Char_Ptr : Char_Pointers.Pointer := Ch_Array(1)'Access;
- End_Char_Ptr : Char_Pointers.Pointer := Ch_Array(10)'Access;
- Array_Ptr : Array_Pointers.Pointer := Array_of_Arrays(0)'Access;
- Start_Array_Ptr : Array_Pointers.Pointer := Array_of_Arrays(1)'Access;
- End_Array_Ptr : Array_Pointers.Pointer := Array_of_Arrays(10)'Access;
-
- begin
-
- -- Provide initial values for the arrays that hold short int values.
-
- for i in Min_Array_Size..Max_Array_Size-1 loop
- Short_Array(i) := Interfaces.C.short(i);
- for j in Min_Array_Size..Max_Array_Size loop
- -- Initialize this "array of arrays" so that element (i)(0)
- -- is different for each value of i.
- Array_of_Arrays(i)(j) := TC_Short;
- TC_Short := TC_Short + 1;
- end loop;
- end loop;
-
- -- Set the final element of each array object to be the "terminator"
- -- element used in the instantiations above.
-
- Short_Array(Max_Array_Size) := Short_Terminator;
- Array_of_Arrays(Max_Array_Size) := Terminator_Array;
-
- -- Check starting pointer positions.
-
- if Short_Ptr.all /= 0 or
- Char_Ptr.all /= Ch_Array(0) or
- Array_Ptr.all /= Array_of_Arrays(0)
- then
- Report.Failed("Incorrect initial value for the first " &
- "Short_Array, Ch_Array, or Array_of_Array values");
- end if;
-
-
- -- Check that both versions of the "+" function with Pointer and
- -- ptrdiff_t parameters, that return a Pointer value, produce correct
- -- results, based on the size of the array elements.
-
- for i in Min_Array_Size + 1 .. Max_Array_Size loop
-
- if Integer(i)/2*2 /= Integer(i) then -- Odd numbered loops.
- -- Pointer + ptrdiff_t, increment by 1.
- Short_Ptr := Short_Ptr + 1;
- else -- Even numbered loops.
- -- ptrdiff_t + Pointer, increment by 1.
- Short_Ptr := 1 + Short_Ptr;
- end if;
-
- if Short_Ptr.all /= Short_Array(i) then
- Report.Failed("Incorrect value returned following use " &
- "of the function +, incrementing by 1, " &
- "array position : " & Integer'Image(Integer(i)));
- if not TC_Verbose then
- exit;
- end if;
- end if;
- end loop;
-
- Array_Ptr := Array_of_Arrays(Min_Array_Size)'Access;
- TC_Count := Min_Array_Size;
- TC_Increment := 3;
- while TC_Count+Interfaces.C.size_t(TC_Increment) < Max_Array_Size loop
-
- if Integer(TC_Count)/2*2 /= Integer(TC_Count) then
- -- Odd numbered loops.
- -- Pointer + ptrdiff_t, increment by 3.
- Array_Ptr := Array_Pointers."+"(Array_Ptr, TC_Increment);
- else
- -- Odd numbered loops.
- -- ptrdiff_t + Pointer, increment by 3.
- Array_Ptr := Array_Pointers."+"(Left => TC_Increment,
- Right => Array_Ptr);
- end if;
-
- if Array_Ptr.all /=
- Array_of_Arrays(TC_Count+Interfaces.C.size_t(TC_Increment))
- then
- Report.Failed("Incorrect value returned following use " &
- "of the function +, incrementing by " &
- Integer'Image(Integer(TC_Increment)) &
- ", array position : " &
- Integer'Image(Integer(TC_Count) +
- Integer(TC_Increment)));
- if not TC_Verbose then
- exit;
- end if;
- end if;
-
- TC_Count := TC_Count + Interfaces.C.size_t(TC_Increment);
- end loop;
-
-
-
- -- Check that the "-" function with Pointer and ptrdiff_t parameters,
- -- that returns a Pointer result, produces correct results, based
- -- on the size of the array elements.
-
- -- Set the pointer to the last element in the char_array, which is a
- -- nul char.
- Char_Ptr := Ch_Array(Interfaces.C.size_t(Alphabet'Length))'Access;
-
- if Char_Ptr.all /= Interfaces.C.nul then
- Report.Failed("Incorrect initial value for the last " &
- "Ch_Array value");
- end if;
-
- Min_size_t := 1;
- Max_size_t := Interfaces.C.size_t(Alphabet'Length);
-
- for i in reverse Min_size_t..Max_size_t loop
-
- -- Subtract 1 from the pointer; it should now point to the previous
- -- element in the array.
- Char_Ptr := Char_Ptr - 1;
-
- if Char_Ptr.all /= Ch_Array(i-1) then
- Report.Failed("Incorrect value returned following use " &
- "of the function '-' with char element values, " &
- "array position : " & Integer'Image(Integer(i-1)));
- if not TC_Verbose then
- exit;
- end if;
- end if;
- end loop;
-
- Array_Ptr := Array_of_Arrays(Max_Array_Size)'Access;
- TC_Count := Max_Array_Size;
- TC_Increment := 3;
- while TC_Count > Min_Array_Size+Interfaces.C.size_t(TC_Increment) loop
-
- -- Decrement the pointer by 3.
- Array_Ptr := Array_Pointers."-"(Array_Ptr, Right => 3);
-
- if Array_Ptr.all /=
- Array_of_Arrays(TC_Count - Interfaces.C.size_t(TC_Increment))
- then
- Report.Failed("Incorrect value returned following use " &
- "of the function -, decrementing by " &
- Integer'Image(Integer(TC_Increment)) &
- ", array position : " &
- Integer'Image(Integer(TC_Count-3)));
- if not TC_Verbose then
- exit;
- end if;
- end if;
-
- TC_Count := TC_Count - Interfaces.C.size_t(TC_Increment);
- end loop;
-
-
-
- -- Check that the "-" function with two Pointer parameters, that
- -- returns a ptrdiff_t type result, produces correct results,
- -- based on the size of the array elements.
-
- TC_ptrdiff_t := 9;
- if Char_Pointers."-"(Left => End_Char_Ptr,
- Right => Start_Char_Ptr) /= TC_ptrdiff_t
- then
- Report.Failed("Incorrect result from pointer-pointer " &
- "subtraction - 1");
- end if;
-
- Start_Char_Ptr := Ch_Array(1)'Access;
- End_Char_Ptr := Ch_Array(25)'Access;
-
- TC_ptrdiff_t := 24;
- if Char_Pointers."-"(End_Char_Ptr,
- Right => Start_Char_Ptr) /= TC_ptrdiff_t
- then
- Report.Failed("Incorrect result from pointer-pointer " &
- "subtraction - 2");
- end if;
-
- TC_ptrdiff_t := 9;
- if Array_Pointers."-"(End_Array_Ptr,
- Start_Array_Ptr) /= TC_ptrdiff_t
- then
- Report.Failed("Incorrect result from pointer-pointer " &
- "subtraction - 3");
- end if;
-
- Start_Array_Ptr := Array_of_Arrays(Min_Array_Size)'Access;
- End_Array_Ptr := Array_of_Arrays(Max_Array_Size)'Access;
-
- TC_ptrdiff_t := Interfaces.C.ptrdiff_t(Max_Array_Size) -
- Interfaces.C.ptrdiff_t(Min_Array_Size);
- if End_Array_Ptr - Start_Array_Ptr /= TC_ptrdiff_t then
- Report.Failed("Incorrect result from pointer-pointer " &
- "subtraction - 4");
- end if;
-
-
-
- -- Check that the Increment procedure produces correct results,
- -- based upon the size of the array elements.
-
- Short_Ptr := Short_Array(0)'Access;
-
- for i in Min_Array_Size + 1 .. Max_Array_Size loop
- -- Increment the value of the Pointer; it should now point
- -- to the next element in the array.
- Increment(Ref => Short_Ptr);
-
- if Short_Ptr.all /= Short_Array(i) then
- Report.Failed("Incorrect value returned following use " &
- "of the Procedure Increment on pointer to an " &
- "array of short values, array position : " &
- Integer'Image(Integer(i)));
- if not TC_Verbose then
- exit;
- end if;
- end if;
- end loop;
-
- Array_Ptr := Array_of_Arrays(0)'Access;
-
- for i in Min_Array_Size + 1 .. Max_Array_Size loop
- -- Increment the value of the Pointer; it should now point
- -- to the next element in the array.
- Increment(Array_Ptr);
-
- if Array_Ptr.all /= Array_of_Arrays(i) then
- Report.Failed("Incorrect value returned following use " &
- "of the Procedure Increment on an array of " &
- "arrays, array position : " &
- Integer'Image(Integer(i)));
- if not TC_Verbose then
- exit;
- end if;
- end if;
- end loop;
-
-
- -- Check that the Decrement procedure produces correct results,
- -- based upon the size of the array elements.
-
- Short_Ptr := Short_Array(Max_Array_Size)'Access;
-
- for i in reverse Min_Array_Size .. Max_Array_Size - 1 loop
- -- Decrement the value of the Pointer; it should now point
- -- to the previous element in the array.
- Decrement(Ref => Short_Ptr);
-
- if Short_Ptr.all /= Short_Array(i) then
- Report.Failed("Incorrect value returned following use " &
- "of the Procedure Decrement on pointer to an " &
- "array of short values, array position : " &
- Integer'Image(Integer(i)));
- if not TC_Verbose then
- exit;
- end if;
- end if;
- end loop;
-
- Array_Ptr := Array_of_Arrays(Max_Array_Size)'Access;
-
- for i in reverse Min_Array_Size .. Max_Array_Size - 1 loop
- -- Decrement the value of the Pointer; it should now point
- -- to the previous array element.
- Decrement(Array_Ptr);
-
- if Array_Ptr.all /= Array_of_Arrays(i) then
- Report.Failed("Incorrect value returned following use " &
- "of the Procedure Decrement on an array of " &
- "arrays, array position : " &
- Integer'Image(Integer(i)));
- if not TC_Verbose then
- exit;
- end if;
- end if;
- end loop;
-
-
-
- -- Check that each of the "+" and "-" functions above will
- -- propagate Pointer_Error if a Pointer parameter is null.
-
- begin
- Short_Ptr := null;
- Short_Ptr := Short_Ptr + 4;
- Report.Failed("Pointer_Error not raised by Function + when " &
- "the Pointer parameter is null");
- if Short_Ptr /= null then -- To avoid optimization.
- Report.Comment("This should never be printed");
- end if;
- exception
- when Short_Pointers.Pointer_Error => null; -- OK, expected exception.
- when others =>
- Report.Failed("Unexpected exception raised by Function + " &
- "when the Pointer parameter is null");
- end;
-
-
- begin
- Char_Ptr := null;
- Char_Ptr := Char_Ptr - 1;
- Report.Failed("Pointer_Error not raised by Function - when " &
- "the Pointer parameter is null");
- if Char_Ptr /= null then -- To avoid optimization.
- Report.Comment("This should never be printed");
- end if;
- exception
- when Char_Pointers.Pointer_Error => null; -- OK, expected exception.
- when others =>
- Report.Failed("Unexpected exception raised by Function - " &
- "when the Pointer parameter is null");
- end;
-
-
- begin
- Array_Ptr := null;
- Decrement(Array_Ptr);
- Report.Failed("Pointer_Error not raised by Procedure Decrement " &
- "when the Pointer parameter is null");
- if Array_Ptr /= null then -- To avoid optimization.
- Report.Comment("This should never be printed");
- end if;
- exception
- when Array_Pointers.Pointer_Error => null; -- OK, expected exception.
- when others =>
- Report.Failed("Unexpected exception raised by Procedure " &
- "Decrement when the Pointer parameter is null");
- end;
-
-
- exception
- when The_Error : others =>
- Report.Failed ("The following exception was raised in the " &
- "Test_Block: " & Exception_Name(The_Error));
- end Test_Block;
-
- Report.Result;
-
-end CXB3015;
diff --git a/gcc/testsuite/ada/acats/tests/cxb/cxb3016.a b/gcc/testsuite/ada/acats/tests/cxb/cxb3016.a
deleted file mode 100644
index 362a062ad22..00000000000
--- a/gcc/testsuite/ada/acats/tests/cxb/cxb3016.a
+++ /dev/null
@@ -1,516 +0,0 @@
--- CXB3016.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that function Virtual_Length returns the number of elements
--- in the array referenced by the Pointer parameter Ref, up to (but
--- not including) the (first) instance of the element specified in
--- the Terminator parameter.
---
--- Check that the procedure Copy_Terminated_Array copies the array of
--- elements referenced by Pointer parameter Source, into the array
--- pointed to by parameter Target, based on which of the following
--- two scenarios occurs first:
--- 1) copying the Terminator element, or
--- 2) copying the number of elements specified in parameter Limit.
---
--- Check that procedure Copy_Terminated_Array will propagate
--- Dereference_Error if either the Source or Target parameter is null.
---
--- Check that procedure Copy_Array will copy an array of elements
--- of length specified in parameter Length, referenced by the
--- Pointer parameter Source, into the array pointed to by parameter
--- Target.
---
--- Check that procedure Copy_Array will propagate Dereference_Error
--- if either the Source or Target parameter is null.
---
--- TEST DESCRIPTION:
--- This test checks that the function Virtual_Length and the procedures
--- Copy_Terminated_Array and Copy_Array in the generic package
--- Interfaces.C.Pointers will allow the user to manipulate arrays of
--- char and short values through the pointers that reference the
--- arrays.
---
--- Package Interfaces.C.Pointers is instantiated twice, once for
--- short values and once for chars. Pointers from each instantiated
--- package are then used to reference arrays of the appropriate
--- element type. The subprograms under test are used to determine the
--- length, and to copy, either portions or the entire content of the
--- arrays. The results of these operations are then compared against
--- expected results.
---
--- The propagation of Dereference_Error is checked for when either
--- of the two procedures is supplied with a null Pointer parameter.
---
--- This test assumes that the following characters are all included
--- in the implementation defined type Interfaces.C.char:
--- ' ', and 'a'..'z'.
---
--- APPLICABILITY CRITERIA:
--- This test is applicable to all implementations that provide
--- packages Interfaces.C, Interfaces.C.Strings, and
--- Interfaces.C.Pointers. If an implementation provides these packages,
--- this test must compile, execute, and report "PASSED".
---
---
--- CHANGE HISTORY:
--- 01 Feb 96 SAIC Initial release for 2.1
--- 13 May 96 SAIC Incorporated reviewer comments for ACVC 2.1.
--- 26 Oct 96 SAIC Incorporated reviewer comments.
--- 26 Feb 97 PWB.CTA Moved code using null pointer to avoid errors
---!
-
-with Report;
-with Ada.Exceptions;
-with Interfaces.C; -- N/A => ERROR
-with Interfaces.C.Pointers; -- N/A => ERROR
-with Interfaces.C.Strings; -- N/A => ERROR
-
-procedure CXB3016 is
-begin
-
- Report.Test ("CXB3016", "Check that subprograms Virtual_Length, " &
- "Copy_Terminated_Array, and Copy_Array " &
- "produce correct results");
-
- Test_Block:
- declare
-
- use Ada.Exceptions;
- use Interfaces.C.Strings;
-
- use type Interfaces.C.char,
- Interfaces.C.char_array,
- Interfaces.C.ptrdiff_t,
- Interfaces.C.short,
- Interfaces.C.size_t;
-
- TC_char : Interfaces.C.char := 'a';
- TC_ptrdiff_t : Interfaces.C.ptrdiff_t;
- TC_Short : Interfaces.C.short := 0;
- Min_Array_Size : Interfaces.C.size_t := 0;
- Max_Array_Size : Interfaces.C.size_t := 20;
- Short_Terminator : Interfaces.C.short := Interfaces.C.short'Last;
- Alphabet : constant String := "abcdefghijklmnopqrstuvwxyz";
- Blank_String : constant String := " ";
-
- type Short_Array_Type is
- array (Interfaces.C.size_t range <>) of aliased Interfaces.C.short;
-
- Ch_Array : Interfaces.C.char_array
- (0..Interfaces.C.size_t(Alphabet'Length)) :=
- Interfaces.C.To_C(Alphabet, True);
-
- TC_Ch_Array : Interfaces.C.char_array
- (0..Interfaces.C.size_t(Blank_String'Length)) :=
- Interfaces.C.To_C(Blank_String, True);
-
- Short_Array : Short_Array_Type(Min_Array_Size..Max_Array_Size);
- TC_Short_Array : Short_Array_Type(Min_Array_Size..Max_Array_Size);
-
-
- package Char_Pointers is new
- Interfaces.C.Pointers (Index => Interfaces.C.size_t,
- Element => Interfaces.C.char,
- Element_Array => Interfaces.C.char_array,
- Default_Terminator => Interfaces.C.nul);
-
- package Short_Pointers is new
- Interfaces.C.Pointers (Index => Interfaces.C.size_t,
- Element => Interfaces.C.short,
- Element_Array => Short_Array_Type,
- Default_Terminator => Short_Terminator);
-
- use Short_Pointers, Char_Pointers;
-
- Short_Ptr : Short_Pointers.Pointer := Short_Array(0)'Access;
- TC_Short_Ptr : Short_Pointers.Pointer := TC_Short_Array(0)'Access;
- Char_Ptr : Char_Pointers.Pointer := Ch_Array(0)'Access;
- TC_Char_Ptr : Char_Pointers.Pointer := TC_Ch_Array(0)'Access;
-
- begin
-
- -- Provide initial values for the array that holds short int values.
-
- for i in Min_Array_Size..Max_Array_Size loop
- Short_Array(i) := Interfaces.C.short(i);
- TC_Short_Array(i) := 100;
- end loop;
-
- -- Set the final element of the short array object to be the "terminator"
- -- element used in the instantiation above.
-
- Short_Array(Max_Array_Size) := Short_Terminator;
-
- -- Check starting pointer positions.
-
- if Short_Ptr.all /= 0 or
- Char_Ptr.all /= Ch_Array(0)
- then
- Report.Failed("Incorrect initial value for the first " &
- "Char_Array or Short_Array values");
- end if;
-
-
-
- -- Check that function Virtual_Length returns the number of elements
- -- in the array referenced by the Pointer parameter Ref, up to (but
- -- not including) the (first) instance of the element specified in
- -- the Terminator parameter.
-
- TC_char := 'j';
-
- TC_ptrdiff_t := Char_Pointers.Virtual_Length(Ref => Char_Ptr,
- Terminator => TC_char);
- if TC_ptrdiff_t /= 9 then
- Report.Failed("Incorrect result from function Virtual_Length " &
- "with Char_ptr parameter - 1");
- end if;
-
- TC_char := Interfaces.C.nul;
-
- TC_ptrdiff_t := Char_Pointers.Virtual_Length(Char_Ptr,
- Terminator => TC_char);
- if TC_ptrdiff_t /= Interfaces.C.ptrdiff_t(Alphabet'Length) then
- Report.Failed("Incorrect result from function Virtual_Length " &
- "with Char_ptr parameter - 2");
- end if;
-
- TC_Short := 10;
-
- TC_ptrdiff_t := Short_Pointers.Virtual_Length(Short_Ptr, TC_Short);
-
- if TC_ptrdiff_t /= 10 then
- Report.Failed("Incorrect result from function Virtual_Length " &
- "with Short_ptr parameter - 1");
- end if;
-
- -- Replace an element of the Short_Array with the element used as the
- -- terminator of the entire array; now there are two occurrences of the
- -- terminator element in the array. The call to Virtual_Length should
- -- return the number of array elements prior to the first terminator.
-
- Short_Array(5) := Short_Terminator;
-
- if Short_Pointers.Virtual_Length(Short_Ptr, Short_Terminator) /= 5
- then
- Report.Failed("Incorrect result from function Virtual_Length " &
- "with Short_ptr parameter - 2");
- end if;
-
-
-
- -- Check that the procedure Copy_Terminated_Array copies the array of
- -- elements referenced by Pointer parameter Source, into the array
- -- pointed to by parameter Target, based on which of the following
- -- two scenarios occurs first:
- -- 1) copying the Terminator element, or
- -- 2) copying the number of elements specified in parameter Limit.
- -- Note: Terminator element must be copied to Target, as well as
- -- all array elements prior to the terminator element.
-
- if TC_Ch_Array = Ch_Array then
- Report.Failed("The two char arrays are equivalent prior to the " &
- "call to Copy_Terminated_Array - 1");
- end if;
-
-
- -- Case 1: Copying the Terminator Element. (Default terminator)
-
- Char_Pointers.Copy_Terminated_Array(Source => Char_Ptr,
- Target => TC_Char_Ptr);
-
- if TC_Ch_Array /= Ch_Array then
- Report.Failed("The two char arrays are not equal following the " &
- "call to Copy_Terminated_Array, case of copying " &
- "the Terminator Element, using default terminator");
- end if;
-
- -- Reset the Target Pointer array.
-
- TC_Ch_Array := Interfaces.C.To_C(Blank_String, True);
- TC_Char_Ptr := TC_Ch_Array(0)'Access;
-
- if TC_Ch_Array = Ch_Array then
- Report.Failed("The two char arrays are equivalent prior to the " &
- "call to Copy_Terminated_Array - 2");
- end if;
-
-
- -- Case 2: Copying the Terminator Element. (Non-Default terminator)
-
- TC_char := 'b'; -- Second char in char_array pointed to by Char_Ptr
- Char_Pointers.Copy_Terminated_Array(Source => Char_Ptr,
- Target => TC_Char_Ptr,
- Terminator => TC_char);
-
- if TC_Ch_Array(0) /= Ch_Array(0) or -- Initial value modified.
- TC_Ch_Array(1) /= Ch_Array(1) or -- Initial value modified.
- TC_Ch_Array(2) = Ch_Array(2) or -- Initial value not modified.
- TC_Ch_Array(5) = Ch_Array(5) or -- Initial value not modified.
- TC_Ch_Array(15) = Ch_Array(15) or -- Initial value not modified.
- TC_Ch_Array(25) = Ch_Array(25) -- Initial value not modified.
- then
- Report.Failed("The appropriate portions of the two char arrays " &
- "are not equal following the call to " &
- "Copy_Terminated_Array, case of copying the " &
- "Terminator Element, using non-default terminator");
- end if;
-
-
- if TC_Short_Array = Short_Array then
- Report.Failed("The two short int arrays are equivalent prior " &
- "to the call to Copy_Terminated_Array - 1");
- end if;
-
- Short_Pointers.Copy_Terminated_Array(Source => Short_Ptr,
- Target => TC_Short_Ptr,
- Terminator => 2);
-
- if TC_Short_Array(0) /= Short_Array(0) or
- TC_Short_Array(1) /= Short_Array(1) or
- TC_Short_Array(2) /= Short_Array(2) or
- TC_Short_Array(3) /= 100 -- Initial value not modified.
- then
- Report.Failed("The appropriate portions of the two short int " &
- "arrays are not equal following the call to " &
- "Copy_Terminated_Array, case of copying the " &
- "Terminator Element, using non-default terminator");
- end if;
-
-
- -- Case 3: Copying the number of elements specified in parameter Limit.
-
- if TC_Short_Array = Short_Array then
- Report.Failed("The two short int arrays are equivalent prior " &
- "to the call to Copy_Terminated_Array - 2");
- end if;
-
- TC_ptrdiff_t := 5;
-
- Short_Pointers.Copy_Terminated_Array(Source => Short_Ptr,
- Target => TC_Short_Ptr,
- Limit => TC_ptrdiff_t,
- Terminator => Short_Terminator);
-
- if TC_Short_Array(0) /= Short_Array(0) or
- TC_Short_Array(1) /= Short_Array(1) or
- TC_Short_Array(2) /= Short_Array(2) or
- TC_Short_Array(3) /= Short_Array(3) or
- TC_Short_Array(4) /= Short_Array(4) or
- TC_Short_Array(5) /= 100 -- Initial value not modified.
- then
- Report.Failed("The appropriate portions of the two Short arrays " &
- "are not equal following the call to " &
- "Copy_Terminated_Array, case of copying the number " &
- "of elements specified in parameter Limit");
- end if;
-
-
- -- Case 4: Copying the number of elements specified in parameter Limit,
- -- which also happens to be the number of elements up to and
- -- including the first terminator.
-
- -- Reset initial values for the array that holds short int values.
-
- for i in Min_Array_Size..Max_Array_Size loop
- Short_Array(i) := Interfaces.C.short(i);
- TC_Short_Array(i) := 100;
- end loop;
-
- if TC_Short_Array = Short_Array then
- Report.Failed("The two short int arrays are equivalent prior " &
- "to the call to Copy_Terminated_Array - 3");
- end if;
-
- TC_ptrdiff_t := 3; -- Specifies three elements to be copied.
- Short_Terminator := 2; -- Value held in Short_Array third element,
- -- will serve as the "terminator" element.
-
- Short_Pointers.Copy_Terminated_Array(Source => Short_Ptr,
- Target => TC_Short_Ptr,
- Limit => TC_ptrdiff_t,
- Terminator => Short_Terminator);
-
- if TC_Short_Array(0) /= Short_Array(0) or -- First element copied.
- TC_Short_Array(1) /= Short_Array(1) or -- Second element copied.
- TC_Short_Array(2) /= Short_Array(2) or -- Third element copied.
- TC_Short_Array(3) /= 100 -- Initial value of fourth element
- then -- not modified.
- Report.Failed("The appropriate portions of the two Short arrays " &
- "are not equal following the call to " &
- "Copy_Terminated_Array, case of copying the number " &
- "of elements specified in parameter " &
- "Limit, which also happens to be the number of " &
- "elements up to and including the first terminator");
- end if;
-
-
-
- -- Check that procedure Copy_Terminated_Array will propagate
- -- Dereference_Error if either the Source or Target parameter is null.
-
- Char_Ptr := null;
- begin
- Char_Pointers.Copy_Terminated_Array(Char_Ptr, TC_Char_Ptr);
- Report.Failed("Dereference_Error not raised by call to " &
- "Copy_Terminated_Array with null Source parameter");
- if TC_Char_Ptr = null then -- To avoid optimization.
- Report.Comment("This should never be printed");
- end if;
- exception
- when Dereference_Error => null; -- OK, expected exception.
- when others =>
- Report.Failed("Incorrect exception raised by call to " &
- "Copy_Terminated_Array with null Source parameter");
- end;
-
- TC_Short_Ptr := null;
- begin
- Short_Pointers.Copy_Terminated_Array(Short_Ptr, TC_Short_Ptr);
- Report.Failed("Dereference_Error not raised by call to " &
- "Copy_Terminated_Array with null Target parameter");
- if Short_Ptr = null then -- To avoid optimization.
- Report.Comment("This should never be printed");
- end if;
- exception
- when Dereference_Error => null; -- OK, expected exception.
- when others =>
- Report.Failed("Incorrect exception raised by call to " &
- "Copy_Terminated_Array with null Target parameter");
- end;
-
-
-
- -- Check that the procedure Copy_Array will copy the array of
- -- elements of length specified in parameter Length, referenced by
- -- the Pointer parameter Source, into the array pointed to by
- -- parameter Target.
-
- -- Reinitialize Target arrays prior to test cases below.
-
- TC_Ch_Array := Interfaces.C.To_C(Blank_String, True);
-
- for i in Min_Array_Size..Max_Array_Size loop
- TC_Short_Array(i) := 100;
- end loop;
-
- Char_Ptr := Ch_Array(0)'Access;
- TC_Char_Ptr := TC_Ch_Array(0)'Access;
- Short_Ptr := Short_Array(0)'Access;
- TC_Short_Ptr := TC_Short_Array(0)'Access;
-
- TC_ptrdiff_t := 4;
-
- Char_Pointers.Copy_Array(Source => Char_Ptr,
- Target => TC_Char_Ptr,
- Length => TC_ptrdiff_t);
-
- if TC_Ch_Array(0) /= Ch_Array(0) or
- TC_Ch_Array(1) /= Ch_Array(1) or
- TC_Ch_Array(2) /= Ch_Array(2) or
- TC_Ch_Array(3) /= Ch_Array(3) or
- TC_Ch_Array(4) = Ch_Array(4)
- then
- Report.Failed("Incorrect result from Copy_Array when using " &
- "char pointer arguments, partial array copied");
- end if;
-
-
- TC_ptrdiff_t := Interfaces.C.ptrdiff_t(Max_Array_Size) + 1;
-
- Short_Pointers.Copy_Array(Short_Ptr, TC_Short_Ptr, TC_ptrdiff_t);
-
- if TC_Short_Array /= Short_Array then
- Report.Failed("Incorrect result from Copy_Array when using Short " &
- "pointer arguments, entire array copied");
- end if;
-
-
-
- -- Check that procedure Copy_Array will propagate Dereference_Error
- -- if either the Source or Target parameter is null.
-
- Char_Ptr := null;
- begin
- Char_Pointers.Copy_Array(Char_Ptr, TC_Char_Ptr, TC_ptrdiff_t);
- Report.Failed("Dereference_Error not raised by call to " &
- "Copy_Array with null Source parameter");
- if TC_Char_Ptr = null then -- To avoid optimization.
- Report.Comment("This should never be printed");
- end if;
- exception
- when Dereference_Error => null; -- OK, expected exception.
- when others =>
- Report.Failed("Incorrect exception raised by call to " &
- "Copy_Array with null Source parameter");
- end;
-
- TC_Short_Ptr := null;
- begin
- Short_Pointers.Copy_Array(Short_Ptr, TC_Short_Ptr, TC_ptrdiff_t);
- Report.Failed("Dereference_Error not raised by call to " &
- "Copy_Array with null Target parameter");
- if Short_Ptr = null then -- To avoid optimization.
- Report.Comment("This should never be printed");
- end if;
- exception
- when Dereference_Error => null; -- OK, expected exception.
- when others =>
- Report.Failed("Incorrect exception raised by call to " &
- "Copy_Array with null Target parameter");
- end;
-
-
- -- Check that function Virtual_Length will propagate Dereference_Error
- -- if the Source parameter is null.
-
- Char_Ptr := null;
- begin
- TC_ptrdiff_t := Char_Pointers.Virtual_Length(Char_Ptr,
- Terminator => TC_char);
- Report.Failed("Dereference_Error not raised by call to " &
- "Virtual_Length with null Source parameter");
- if TC_ptrdiff_t = 100 then -- To avoid optimization.
- Report.Comment("This should never be printed");
- end if;
- exception
- when Dereference_Error => null; -- OK, expected exception.
- when others =>
- Report.Failed("Incorrect exception raised by call to " &
- "Virtual_Length with null Source parameter");
- end;
-
-
- exception
- when The_Error : others =>
- Report.Failed ("The following exception was raised in the " &
- "Test_Block: " & Exception_Name(The_Error));
- end Test_Block;
-
- Report.Result;
-
-end CXB3016;
diff --git a/gcc/testsuite/ada/acats/tests/cxb/cxb4001.a b/gcc/testsuite/ada/acats/tests/cxb/cxb4001.a
deleted file mode 100644
index 0c9ab1a6279..00000000000
--- a/gcc/testsuite/ada/acats/tests/cxb/cxb4001.a
+++ /dev/null
@@ -1,230 +0,0 @@
--- CXB4001.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that the specifications of the package Interfaces.COBOL
--- are available for use
---
--- TEST DESCRIPTION:
--- This test verifies that the type and the subprograms specified for
--- the interface are present.
---
--- APPLICABILITY CRITERIA:
--- This test is applicable to all implementations that provide
--- package Interfaces.COBOL. If an implementation provides
--- package Interfaces.COBOL, this test must compile, execute, and
--- report "PASSED".
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 15 Nov 95 SAIC Corrected visibility errors for ACVC 2.0.1.
--- 28 Feb 96 SAIC Added applicability criteria.
--- 27 Oct 96 SAIC Incorporated reviewer comments.
--- 01 DEC 97 EDS Change "To_Comp" to "To_Binary".
---!
-
-with Report;
-with Interfaces.COBOL; -- N/A => ERROR
-
-procedure CXB4001 is
-
- package COBOL renames Interfaces.COBOL;
- use type COBOL.Byte;
- use type COBOL.Decimal_Element;
-
-begin
-
- Report.Test ("CXB4001", "Check the specification of Interfaces.COBOL");
-
-
- declare -- encapsulate the test
-
- -- Types and operations for internal data representations
-
- TST_Floating : COBOL.Floating;
- TST_Long_Floating : COBOL.Long_Floating;
-
- TST_Binary : COBOL.Binary;
- TST_Long_Binary : COBOL.Long_Binary;
-
- TST_Max_Digits_Binary : constant := COBOL.Max_Digits_Binary;
- TST_Max_Digits_Long_Binary : constant := COBOL.Max_Digits_Long_Binary;
-
- TST_Decimal_Element : COBOL.Decimal_Element;
-
- TST_Packed_Decimal : COBOL.Packed_Decimal (1..5) :=
- (others => COBOL.Decimal_Element'First);
-
- -- initialize it so it can reasonably be used later
- TST_COBOL_Character : COBOL.COBOL_Character :=
- COBOL.COBOL_Character'First;
-
- TST_Ada_To_COBOL : COBOL.COBOL_Character :=
- COBOL.Ada_To_COBOL (Character'First);
-
- TST_COBOL_To_Ada : Character :=
- COBOL.COBOL_To_Ada (COBOL.COBOL_Character'First);
-
- -- assignment to make sure it is an array of COBOL_Character
- TST_Alphanumeric : COBOL.Alphanumeric (1..5) :=
- (others => TST_COBOL_Character);
-
-
- -- assignment to make sure it is an array of COBOL_Character
- TST_Numeric : COBOL.Numeric (1..5) := (others => TST_COBOL_Character);
-
-
- procedure Collect_All_Calls is
-
- CAC_Alphanumeric : COBOL.Alphanumeric(1..5) :=
- COBOL.To_COBOL("abcde");
- CAC_String : String (1..5) := "vwxyz";
- CAC_Natural : natural := 0;
-
- begin
-
- CAC_Alphanumeric := COBOL.To_COBOL (CAC_String);
- CAC_String := COBOL.To_Ada (CAC_Alphanumeric);
-
- COBOL.To_COBOL (CAC_String, CAC_Alphanumeric, CAC_Natural);
- COBOL.To_Ada (CAC_Alphanumeric, CAC_String, CAC_Natural);
-
- raise COBOL.Conversion_Error;
-
- end Collect_All_Calls;
-
-
-
- -- Formats for COBOL data representations
-
- TST_Unsigned : COBOL.Display_Format := COBOL.Unsigned;
- TST_Leading_Separate : COBOL.Display_Format := COBOL.Leading_Separate;
- TST_Trailing_Separate : COBOL.Display_Format := COBOL.Trailing_Separate;
- TST_Leading_Nonseparate : COBOL.Display_Format :=
- COBOL.Leading_Nonseparate;
- TST_Trailing_Nonseparate : COBOL.Display_Format :=
- COBOL.Trailing_Nonseparate;
-
-
- TST_High_Order_First : COBOL.Binary_Format := COBOL.High_Order_First;
- TST_Low_Order_First : COBOL.Binary_Format := COBOL.Low_Order_First;
- TST_Native_Binary : COBOL.Binary_Format := COBOL.Native_Binary;
-
-
- TST_Packed_Unsigned : COBOL.Packed_Format := COBOL.Packed_Unsigned;
- TST_Packed_Signed : COBOL.Packed_Format := COBOL.Packed_Signed;
-
-
- -- Types for external representation of COBOL binary data
-
- TST_Byte_Array : COBOL.Byte_Array(1..5) := (others => COBOL.Byte'First);
-
- -- Now instantiate one version of the generic
- --
- type bx4001_Decimal is delta 0.1 digits 5;
- package bx4001_conv is new COBOL.Decimal_Conversions (bx4001_Decimal);
-
- procedure Collect_All_Generic_Calls is
- CAGC_natural : natural;
- CAGC_Display_Format : COBOL.Display_Format;
- CAGC_Boolean : Boolean;
- CAGC_Numeric : COBOL.Numeric(1..5);
- CAGC_Num : bx4001_Decimal;
- CAGC_Packed_Decimal : COBOL.Packed_Decimal (1..5);
- CAGC_Packed_Format : COBOL.Packed_Format;
- CAGC_Byte_Array : COBOL.Byte_Array (1..5);
- CAGC_Binary_Format : COBOL.Binary_Format;
- CAGC_Binary : COBOL.Binary;
- CAGC_Long_Binary : COBOL.Long_Binary;
- begin
-
- -- Display Formats: data values are represented as Numeric
-
- CAGC_Boolean := bx4001_conv.Valid (CAGC_Numeric, CAGC_Display_Format);
- CAGC_Natural := bx4001_conv.Length (CAGC_Display_Format);
-
- CAGC_Num := bx4001_conv.To_Decimal
- (CAGC_Numeric, CAGC_Display_Format);
- CAGC_Numeric := bx4001_conv.To_Display
- (CAGC_Num, CAGC_Display_Format);
-
-
- -- Packed Formats: data values are represented as Packed_Decimal
-
- CAGC_Boolean := bx4001_conv.Valid
- (CAGC_Packed_Decimal, CAGC_Packed_Format);
-
- CAGC_Natural := bx4001_conv.Length (CAGC_Packed_Format);
-
- CAGC_Num := bx4001_conv.To_Decimal
- (CAGC_Packed_Decimal, CAGC_Packed_Format);
-
- CAGC_Packed_Decimal := bx4001_conv.To_Packed
- (CAGC_Num, CAGC_Packed_Format);
-
-
- -- Binary Formats: external data values are represented as
- -- Byte_Array
-
- CAGC_Boolean := bx4001_conv.Valid
- (CAGC_Byte_Array, CAGC_Binary_Format);
-
- CAGC_Natural := bx4001_conv.Length (CAGC_Binary_Format);
- CAGC_Num := bx4001_conv.To_Decimal
- (CAGC_Byte_Array, CAGC_Binary_Format);
-
- CAGC_Byte_Array := bx4001_conv.To_Binary (CAGC_Num, CAGC_Binary_Format);
-
-
- -- Internal Binary formats: data values are of type
- -- Binary/Long_Binary
-
- CAGC_Num := bx4001_conv.To_Decimal (CAGC_Binary);
- CAGC_Num := bx4001_conv.To_Decimal (CAGC_Long_Binary);
-
- CAGC_Binary := bx4001_conv.To_Binary (CAGC_Num);
- CAGC_Long_Binary := bx4001_conv.To_Long_Binary (CAGC_Num);
-
-
- end Collect_All_Generic_Calls;
-
-
- begin -- encapsulation
-
- if COBOL.Byte'First /= 0 or
- COBOL.Byte'Last /= (2 ** COBOL.COBOL_Character'Size) - 1 then
- Report.Failed ("Byte is incorrectly defined");
- end if;
-
- if COBOL.Decimal_Element'First /= 0 then
- Report.Failed ("Decimal_Element is incorrectly defined");
- end if;
-
- end; -- encapsulation
-
- Report.Result;
-
-end CXB4001;
diff --git a/gcc/testsuite/ada/acats/tests/cxb/cxb4002.a b/gcc/testsuite/ada/acats/tests/cxb/cxb4002.a
deleted file mode 100644
index e3934a5ef33..00000000000
--- a/gcc/testsuite/ada/acats/tests/cxb/cxb4002.a
+++ /dev/null
@@ -1,308 +0,0 @@
--- CXB4002.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that the procedure To_COBOL converts the character elements
--- of the String parameter Item into COBOL_Character elements of the
--- Alphanumeric type parameter Target, using the Ada_to_COBOL mapping
--- as the basis of conversion.
--- Check that the parameter Last contains the index of the last element
--- of parameter Target that was assigned by To_COBOL.
---
--- Check that Constraint_Error is propagated by procedure To_COBOL
--- when the length of String parameter Item exceeds the length of
--- Alphanumeric parameter Target.
---
--- Check that the procedure To_Ada converts the COBOL_Character
--- elements of the Alphanumeric parameter Item into Character elements
--- of the String parameter Target, using the COBOL_to_Ada mapping array
--- as the basis of conversion.
--- Check that the parameter Last contains the index of the last element
--- of parameter Target that was assigned by To_Ada.
---
--- Check that Constraint_Error is propagated by procedure To_Ada when
--- the length of Alphanumeric parameter Item exceeds the length of
--- String parameter Target.
---
--- TEST DESCRIPTION:
--- This test checks that the procedures To_COBOL and To_Ada produce
--- the correct results, based on a variety of parameter input values.
---
--- In the first series of subtests, the Out parameter results of
--- procedure To_COBOL are compared against expected results,
--- which includes (in the parameter Last) the index in Target of the
--- last element assigned. The situation where procedure To_COBOL raises
--- Constraint_Error (when Item'Length exceeds Target'Length) is also
--- verified.
---
--- In the second series of subtests, the Out parameter results of
--- procedure To_Ada are verified, in a similar manner as is done for
--- procedure To_COBOL. The case of procedure To_Ada raising
--- Constraint_Error is also verified.
---
--- This test assumes that the following characters are all included
--- in the implementation defined type Interfaces.COBOL.COBOL_Character:
--- ' ', 'a'..'z', 'A'..'Z', '0'..'9', '*', '$', '-', '_', and '#'.
---
--- APPLICABILITY CRITERIA:
--- This test is applicable to all implementations that provide
--- package Interfaces.COBOL. If an implementation provides
--- package Interfaces.COBOL, this test must compile, execute, and
--- report "PASSED".
---
---
--- CHANGE HISTORY:
--- 12 Jan 96 SAIC Initial prerelease version.
--- 30 May 96 SAIC Added applicability criteria for ACVC 2.1.
--- 27 Oct 96 SAIC Incorporated reviewer comments.
---
---!
-
-with Report;
-with Ada.Strings.Bounded;
-with Ada.Strings.Unbounded;
-with Interfaces.COBOL; -- N/A => ERROR
-
-procedure CXB4002 is
-begin
-
- Report.Test ("CXB4002", "Check that the procedures To_COBOL and " &
- "To_Ada produce correct results");
-
- Test_Block:
- declare
-
- package Bnd is new Ada.Strings.Bounded.Generic_Bounded_Length(10);
- package Unb renames Ada.Strings.Unbounded;
-
- use Interfaces;
- use Bnd, Unb;
- use type Interfaces.COBOL.Alphanumeric;
-
-
- Alphanumeric_1 : COBOL.Alphanumeric(1..1) := " ";
- Alphanumeric_5 : COBOL.Alphanumeric(1..5) := " ";
- Alphanumeric_10 : COBOL.Alphanumeric(1..10) := " ";
- Alphanumeric_20 : COBOL.Alphanumeric(1..20) := " ";
- TC_Alphanumeric_1 : COBOL.Alphanumeric(1..1) := "A";
- TC_Alphanumeric_5 : COBOL.Alphanumeric(1..5) := "ab*de";
- TC_Alphanumeric_10 : COBOL.Alphanumeric(1..10) := "$1a2b3C4D5";
- TC_Alphanumeric_20 : COBOL.Alphanumeric(1..20) := "1234-ABCD_6789#fghij";
-
- Bnd_String : Bnd.Bounded_String :=
- Bnd.To_Bounded_String(" ");
- TC_Bnd_String : Bounded_String :=
- To_Bounded_String("$1a2b3C4D5");
-
- Unb_String : Unb.Unbounded_String :=
- Unb.To_Unbounded_String(" ");
- TC_Unb_String : Unbounded_String :=
- To_Unbounded_String("ab*de");
-
- String_1 : String(1..1) := " ";
- String_5 : String(1..5) := " ";
- String_10 : String(1..10) := " ";
- String_20 : String(1..20) := " ";
- TC_String_1 : String(1..1) := "A";
- TC_String_20 : String(1..20) := "1234-ABCD_6789#fghij";
-
- TC_Alphanumeric : constant COBOL.Alphanumeric := ""; -- null array.
- TC_String : constant String := ""; -- null string.
- TC_Natural : Natural := 0;
-
-
- begin
-
- -- Check that the procedure To_COBOL converts the character elements
- -- of the String parameter Item into COBOL_Character elements of the
- -- Alphanumeric type parameter Target, using the Ada_to_COBOL mapping
- -- as the basis of conversion.
- -- Check that the parameter Last contains the index of the last element
- -- of parameter Target that was assigned by To_COBOL.
-
- COBOL.To_COBOL(Item => TC_String_1,
- Target => Alphanumeric_1,
- Last => TC_Natural);
-
- if Alphanumeric_1 /= TC_Alphanumeric_1 or
- TC_Natural /= TC_Alphanumeric_1'Length or
- TC_Natural /= 1
- then
- Report.Failed("Incorrect result from procedure To_COBOL - 1");
- end if;
-
- COBOL.To_COBOL(To_String(TC_Unb_String),
- Target => Alphanumeric_5,
- Last => TC_Natural);
-
- if Alphanumeric_5 /= TC_Alphanumeric_5 or
- TC_Natural /= TC_Alphanumeric_5'Length or
- TC_Natural /= 5
- then
- Report.Failed("Incorrect result from procedure To_COBOL - 2");
- end if;
-
- COBOL.To_COBOL(To_String(TC_Bnd_String),
- Alphanumeric_10,
- Last => TC_Natural);
-
- if Alphanumeric_10 /= TC_Alphanumeric_10 or
- TC_Natural /= TC_Alphanumeric_10'Length or
- TC_Natural /= 10
- then
- Report.Failed("Incorrect result from procedure To_COBOL - 3");
- end if;
-
- COBOL.To_COBOL(TC_String_20,
- Alphanumeric_20,
- TC_Natural);
-
- if Alphanumeric_20 /= TC_Alphanumeric_20 or
- TC_Natural /= TC_Alphanumeric_20'Length or
- TC_Natural /= 20
- then
- Report.Failed("Incorrect result from procedure To_COBOL - 4");
- end if;
-
- COBOL.To_COBOL(Item => TC_String, -- null string
- Target => Alphanumeric_1,
- Last => TC_Natural);
-
- if TC_Natural /= 0 then
- Report.Failed("Incorrect result from procedure To_COBOL, value " &
- "returned in parameter Last should be zero, since " &
- "parameter Item is null array");
- end if;
-
-
-
- -- Check that Constraint_Error is propagated by procedure To_COBOL
- -- when the length of String parameter Item exceeds the length of
- -- Alphanumeric parameter Target.
-
- begin
-
- COBOL.To_COBOL(Item => TC_String_20,
- Target => Alphanumeric_10,
- Last => TC_Natural);
- Report.Failed("Constraint_Error not raised by procedure To_COBOL " &
- "when Item'Length exceeds Target'Length");
- exception
- when Constraint_Error => null; -- OK, expected exception.
- when others =>
- Report.Failed("Incorrect exception raised by procedure To_COBOL " &
- "when Item'Length exceeds Target'Length");
- end;
-
-
- -- Check that the procedure To_Ada converts the COBOL_Character
- -- elements of the Alphanumeric parameter Item into Character elements
- -- of the String parameter Target, using the COBOL_to_Ada mapping array
- -- as the basis of conversion.
- -- Check that the parameter Last contains the index of the last element
- -- of parameter Target that was assigned by To_Ada.
-
- COBOL.To_Ada(Item => TC_Alphanumeric_1,
- Target => String_1,
- Last => TC_Natural);
-
- if String_1 /= TC_String_1 or
- TC_Natural /= TC_String_1'Length or
- TC_Natural /= 1
- then
- Report.Failed("Incorrect result from procedure To_Ada - 1");
- end if;
-
- COBOL.To_Ada(TC_Alphanumeric_5,
- Target => String_5,
- Last => TC_Natural);
-
- if String_5 /= To_String(TC_Unb_String) or
- TC_Natural /= Length(TC_Unb_String) or
- TC_Natural /= 5
- then
- Report.Failed("Incorrect result from procedure To_Ada - 2");
- end if;
-
- COBOL.To_Ada(TC_Alphanumeric_10,
- String_10,
- Last => TC_Natural);
-
- if String_10 /= To_String(TC_Bnd_String) or
- TC_Natural /= Length(TC_Bnd_String) or
- TC_Natural /= 10
- then
- Report.Failed("Incorrect result from procedure To_Ada - 3");
- end if;
-
- COBOL.To_Ada(TC_Alphanumeric_20,
- String_20,
- TC_Natural);
-
- if String_20 /= TC_String_20 or
- TC_Natural /= TC_String_20'Length or
- TC_Natural /= 20
- then
- Report.Failed("Incorrect result from procedure To_Ada - 4");
- end if;
-
- COBOL.To_Ada(Item => TC_Alphanumeric, -- null array.
- Target => String_20,
- Last => TC_Natural);
-
- if TC_Natural /= 0 then
- Report.Failed("Incorrect result from procedure To_Ada, value " &
- "returned in parameter Last should be zero, since " &
- "parameter Item is null array");
- end if;
-
-
-
- -- Check that Constraint_Error is propagated by procedure To_Ada when
- -- the length of Alphanumeric parameter Item exceeds the length of
- -- String parameter Target.
-
- begin
-
- COBOL.To_Ada(Item => TC_Alphanumeric_10,
- Target => String_5,
- Last => TC_Natural);
- Report.Failed("Constraint_Error not raised by procedure To_Ada " &
- "when Item'Length exceeds Target'Length");
- exception
- when Constraint_Error => null; -- OK, expected exception.
- when others =>
- Report.Failed("Incorrect exception raised by procedure To_Ada " &
- "when Item'Length exceeds Target'Length");
- end;
-
-
- exception
- when others => Report.Failed ("Exception raised in Test_Block");
- end Test_Block;
-
- Report.Result;
-
-end CXB4002;
diff --git a/gcc/testsuite/ada/acats/tests/cxb/cxb4003.a b/gcc/testsuite/ada/acats/tests/cxb/cxb4003.a
deleted file mode 100644
index 609dabc5089..00000000000
--- a/gcc/testsuite/ada/acats/tests/cxb/cxb4003.a
+++ /dev/null
@@ -1,310 +0,0 @@
--- CXB4003.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that function Valid, with the Display_Format parameter
--- set to Unsigned, will return True if Numeric parameter Item
--- comprises one or more decimal digit characters; check that it
--- returns False if the parameter Item is otherwise comprised.
---
--- Check that function Valid, with Display_Format parameter set to
--- Leading_Separate, will return True if Numeric parameter Item
--- comprises a single occurrence of a Plus_Sign or Minus_Sign
--- character, and then by one or more decimal digit characters;
--- check that it returns False if the parameter Item is otherwise
--- comprised.
---
--- Check that function Valid, with Display_Format parameter set to
--- Trailing_Separate, will return True if Numeric parameter Item
--- comprises one or more decimal digit characters, and then by a
--- single occurrence of the Plus_Sign or Minus_Sign character;
--- check that it returns False if the parameter Item is otherwise
--- comprised.
---
--- TEST DESCRIPTION:
--- This test checks that a version of function Valid, from an instance
--- of the generic package Decimal_Conversions, will produce correct
--- results based on the particular Numeric and Display_Format
--- parameters provided. Arrays of both valid and invalid Numeric
--- data items have been created to correspond to a particular
--- value of Display_Format. The result of the function is compared
--- against the expected result for each appropriate combination of
--- Numeric and Display_Format parameter.
--- This test assumes that the following characters are all included
--- in the implementation defined type Interfaces.COBOL.COBOL_Character:
--- ' ', 'A'..'Z', '+', '-', '.', '$'.
---
--- APPLICABILITY CRITERIA:
--- This test is applicable to all implementations that provide
--- package Interfaces.COBOL. If an implementation provides
--- package Interfaces.COBOL, this test must compile, execute, and
--- report "PASSED".
---
---
---
--- CHANGE HISTORY:
--- 18 Jan 96 SAIC Initial version for 2.1.
--- 30 May 96 SAIC Incorporated reviewer comments for ACVC 2.1.
--- 27 Oct 96 SAIC Incorporated reviewer comments.
---
---!
-
-with Report;
-with Ada.Exceptions;
-with Interfaces.COBOL; -- N/A => ERROR
-
-procedure CXB4003 is
-begin
-
- Report.Test ("CXB4003", "Check that function Valid, with various " &
- "Display_Format parameters, produces correct " &
- "results");
-
- Test_Block:
- declare
-
- use Interfaces;
- use Ada.Exceptions;
-
- type A_Numeric_Type is delta 0.01 digits 16;
- type Numeric_Access is access COBOL.Numeric;
- type Numeric_Items_Type is array(Integer range <>) of Numeric_Access;
-
- package Display_Format is
- new COBOL.Decimal_Conversions(Num => A_Numeric_Type);
-
-
- Number_Of_Valid_Unsigned_Items : constant := 5;
- Number_Of_Invalid_Unsigned_Items : constant := 21;
- Number_Of_Valid_Leading_Separate_Items : constant := 5;
- Number_Of_Invalid_Leading_Separate_Items : constant := 23;
- Number_Of_Valid_Trailing_Separate_Items : constant := 5;
- Number_Of_Invalid_Trailing_Separate_Items : constant := 22;
-
- Valid_Unsigned_Items :
- Numeric_Items_Type(1..Number_Of_Valid_Unsigned_Items) :=
- (new COBOL.Numeric'("0"),
- new COBOL.Numeric'("1"),
- new COBOL.Numeric'("0000000001"),
- new COBOL.Numeric'("1234567890123456"),
- new COBOL.Numeric'("0000"));
-
- Invalid_Unsigned_Items :
- Numeric_Items_Type(1..Number_Of_Invalid_Unsigned_Items) :=
- (new COBOL.Numeric'(" 12345"),
- new COBOL.Numeric'(" 12345"),
- new COBOL.Numeric'("1234567890 "),
- new COBOL.Numeric'("1234567890 "),
- new COBOL.Numeric'("1.01"),
- new COBOL.Numeric'(".0000000001"),
- new COBOL.Numeric'("12345 6"),
- new COBOL.Numeric'("MCXVIII"),
- new COBOL.Numeric'("15F"),
- new COBOL.Numeric'("+12345"),
- new COBOL.Numeric'("$12.30"),
- new COBOL.Numeric'("1234-"),
- new COBOL.Numeric'("12--"),
- new COBOL.Numeric'("+12-"),
- new COBOL.Numeric'("++99--"),
- new COBOL.Numeric'("-1.01"),
- new COBOL.Numeric'("(1.01)"),
- new COBOL.Numeric'("123,456"),
- new COBOL.Numeric'("101."),
- new COBOL.Numeric'(""),
- new COBOL.Numeric'("1.0000"));
-
- Valid_Leading_Separate_Items :
- Numeric_Items_Type(1..Number_Of_Valid_Leading_Separate_Items) :=
- (new COBOL.Numeric'("+1000"),
- new COBOL.Numeric'("-1"),
- new COBOL.Numeric'("-0000000001"),
- new COBOL.Numeric'("+1234567890123456"),
- new COBOL.Numeric'("-0000"));
-
- Invalid_Leading_Separate_Items :
- Numeric_Items_Type(1..Number_Of_Invalid_Leading_Separate_Items) :=
- (new COBOL.Numeric'("123456"),
- new COBOL.Numeric'(" +12345"),
- new COBOL.Numeric'(" +12345"),
- new COBOL.Numeric'("- 0000000001"),
- new COBOL.Numeric'("1234567890- "),
- new COBOL.Numeric'("1234567890+ "),
- new COBOL.Numeric'("123-456"),
- new COBOL.Numeric'("+15F"),
- new COBOL.Numeric'("++123"),
- new COBOL.Numeric'("12--"),
- new COBOL.Numeric'("+12-"),
- new COBOL.Numeric'("+/-12"),
- new COBOL.Numeric'("++99--"),
- new COBOL.Numeric'("1.01"),
- new COBOL.Numeric'("(1.01)"),
- new COBOL.Numeric'("+123,456"),
- new COBOL.Numeric'("+15FF"),
- new COBOL.Numeric'("- 123"),
- new COBOL.Numeric'("+$123"),
- new COBOL.Numeric'(""),
- new COBOL.Numeric'("-"),
- new COBOL.Numeric'("-1.01"),
- new COBOL.Numeric'("1.0000+"));
-
- Valid_Trailing_Separate_Items :
- Numeric_Items_Type(1..Number_Of_Valid_Trailing_Separate_Items) :=
- (new COBOL.Numeric'("1001-"),
- new COBOL.Numeric'("1+"),
- new COBOL.Numeric'("0000000001+"),
- new COBOL.Numeric'("1234567890123456-"),
- new COBOL.Numeric'("0000-"));
-
- Invalid_Trailing_Separate_Items :
- Numeric_Items_Type(1..Number_Of_Invalid_Trailing_Separate_Items) :=
- (new COBOL.Numeric'("123456"),
- new COBOL.Numeric'("+12345"),
- new COBOL.Numeric'("12345 "),
- new COBOL.Numeric'("123- "),
- new COBOL.Numeric'("123- "),
- new COBOL.Numeric'("12345 +"),
- new COBOL.Numeric'("12345+ "),
- new COBOL.Numeric'("-0000000001"),
- new COBOL.Numeric'("123-456"),
- new COBOL.Numeric'("12--"),
- new COBOL.Numeric'("+12-"),
- new COBOL.Numeric'("99+-"),
- new COBOL.Numeric'("12+/-"),
- new COBOL.Numeric'("12.01-"),
- new COBOL.Numeric'("$12.01+"),
- new COBOL.Numeric'("(1.01)"),
- new COBOL.Numeric'("DM12-"),
- new COBOL.Numeric'("123,456+"),
- new COBOL.Numeric'(""),
- new COBOL.Numeric'("-"),
- new COBOL.Numeric'("1.01-"),
- new COBOL.Numeric'("+1.0000"));
-
- begin
-
- -- Check that function Valid, with the Display_Format parameter
- -- set to Unsigned, will return True if Numeric parameter Item
- -- comprises one or more decimal digit characters; check that it
- -- returns False if the parameter Item is otherwise comprised.
-
- for i in 1..Number_of_Valid_Unsigned_Items loop
- -- Fail if the Item parameter is _NOT_ considered Valid.
- if not Display_Format.Valid(Item => Valid_Unsigned_Items(i).all,
- Format => COBOL.Unsigned)
- then
- Report.Failed("Incorrect result from function Valid, with " &
- "Format parameter set to Unsigned, for valid " &
- "format item number " & Integer'Image(i));
- end if;
- end loop;
-
-
- for i in 1..Number_of_Invalid_Unsigned_Items loop
- -- Fail if the Item parameter _IS_ considered Valid.
- if Display_Format.Valid(Item => Invalid_Unsigned_Items(i).all,
- Format => COBOL.Unsigned)
- then
- Report.Failed("Incorrect result from function Valid, with " &
- "Format parameter set to Unsigned, for invalid " &
- "format item number " & Integer'Image(i));
- end if;
- end loop;
-
-
-
- -- Check that function Valid, with Display_Format parameter set to
- -- Leading_Separate, will return True if Numeric parameter Item
- -- comprises a single occurrence of a Plus_Sign or Minus_Sign
- -- character, and then by one or more decimal digit characters;
- -- check that it returns False if the parameter Item is otherwise
- -- comprised.
-
- for i in 1..Number_of_Valid_Leading_Separate_Items loop
- -- Fail if the Item parameter is _NOT_ considered Valid.
- if not Display_Format.Valid(Valid_Leading_Separate_Items(i).all,
- Format => COBOL.Leading_Separate)
- then
- Report.Failed("Incorrect result from function Valid, with " &
- "Format parameter set to Leading_Separate, " &
- "for valid format item number " & Integer'Image(i));
- end if;
- end loop;
-
-
- for i in 1..Number_of_Invalid_Leading_Separate_Items loop
- -- Fail if the Item parameter _IS_ considered Valid.
- if Display_Format.Valid(Invalid_Leading_Separate_Items(i).all,
- Format => COBOL.Leading_Separate)
- then
- Report.Failed("Incorrect result from function Valid, with " &
- "Format parameter set to Leading_Separate, " &
- "for invalid format item number " &
- Integer'Image(i));
- end if;
- end loop;
-
-
-
- -- Check that function Valid, with Display_Format parameter set to
- -- Trailing_Separate, will return True if Numeric parameter Item
- -- comprises one or more decimal digit characters, and then by a
- -- single occurrence of the Plus_Sign or Minus_Sign character;
- -- check that it returns False if the parameter Item is otherwise
- -- comprised.
-
- for i in 1..Number_of_Valid_Trailing_Separate_Items loop
- -- Fail if the Item parameter is _NOT_ considered Valid.
- if not Display_Format.Valid(Valid_Trailing_Separate_Items(i).all,
- COBOL.Trailing_Separate)
- then
- Report.Failed("Incorrect result from function Valid, with " &
- "Format parameter set to Trailing_Separate, " &
- "for valid format item number " & Integer'Image(i));
- end if;
- end loop;
-
-
- for i in 1..Number_of_Invalid_Trailing_Separate_Items loop
- -- Fail if the Item parameter _IS_ considered Valid.
- if Display_Format.Valid(Invalid_Trailing_Separate_Items(i).all,
- COBOL.Trailing_Separate)
- then
- Report.Failed("Incorrect result from function Valid, with " &
- "Format parameter set to Trailing_Separate, " &
- "for invalid format item number " &
- Integer'Image(i));
- end if;
- end loop;
-
-
- exception
- when The_Error : others =>
- Report.Failed ("The following exception was raised in the " &
- "Test_Block: " & Exception_Name(The_Error));
- end Test_Block;
-
- Report.Result;
-
-end CXB4003;
diff --git a/gcc/testsuite/ada/acats/tests/cxb/cxb4004.a b/gcc/testsuite/ada/acats/tests/cxb/cxb4004.a
deleted file mode 100644
index 0046c5e7c56..00000000000
--- a/gcc/testsuite/ada/acats/tests/cxb/cxb4004.a
+++ /dev/null
@@ -1,443 +0,0 @@
--- CXB4004.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that function Length, with Display_Format parameter, will
--- return the minimal length of a Numeric value that will be required
--- to hold the largest value of type Num represented as Format.
---
--- Check that function To_Decimal will produce a decimal type Num
--- result that corresponds to parameter Item as represented by
--- parameter Format.
---
--- Check that function To_Decimal propagates Conversion_Error when
--- the value represented by parameter Item is outside the range of
--- the Decimal_Type Num used to instantiate the package
--- Decimal_Conversions
---
--- Check that function To_Display returns a Numeric type result that
--- represents Item under the specific Display_Format.
---
--- Check that function To_Display propagates Conversion_Error when
--- parameter Item is negative and the specified Display_Format
--- parameter is Unsigned.
---
--- TEST DESCRIPTION:
--- This test checks the results from instantiated versions of three
--- functions within generic package Interfaces.COBOL.Decimal_Conversions.
--- This generic package is instantiated twice, with decimal types having
--- four and ten digits representation.
--- The function Length is validated with the Unsigned, Leading_Separate,
--- and Trailing_Separate Display_Format specifiers.
--- The results of function To_Decimal are verified in cases where it
--- is given a variety of Numeric and Display_Format type parameters.
--- Function To_Decimal is also checked to propagate Conversion_Error
--- when the value represented by parameter Item is outside the range
--- of the type used to instantiate the package.
--- The results of function To_Display are verified in cases where it
--- is given a variety of Num and Display_Format parameters. It is also
--- checked to ensure that it propagates Conversion_Error if parameter
--- Num is negative and the Format parameter is Unsigned.
---
--- This test assumes that the following characters are all included
--- in the implementation defined type Interfaces.COBOL.COBOL_Character:
--- ' ', '0'..'9', '+', '-', and '.'.
---
--- APPLICABILITY CRITERIA:
--- This test is applicable to all implementations that provide
--- package Interfaces.COBOL. If an implementation provides
--- package Interfaces.COBOL, this test must compile, execute, and
--- report "PASSED".
---
---
--- CHANGE HISTORY:
--- 06 Feb 96 SAIC Initial release for 2.1.
--- 30 May 96 SAIC Incorporated reviewer comments for ACVC 2.1.
--- 27 Oct 96 SAIC Incorporated reviewer comments.
---
---!
-
-with Report;
-with Interfaces.COBOL; -- N/A => ERROR
-with Ada.Exceptions;
-
-procedure CXB4004 is
-begin
-
- Report.Test ("CXB4004", "Check that the functions Length, To_Decimal, " &
- "and To_Display produce correct results");
-
- Test_Block:
- declare
-
- use Interfaces;
- use Ada.Exceptions;
- use type Interfaces.COBOL.Numeric;
-
- Number_Of_Unsigned_Items : constant := 6;
- Number_Of_Leading_Separate_Items : constant := 6;
- Number_Of_Trailing_Separate_Items : constant := 6;
- Number_Of_Decimal_Items : constant := 9;
-
- type Decimal_Type_1 is delta 0.01 digits 4;
- type Decimal_Type_2 is delta 1.0 digits 10;
- type Numeric_Access is access COBOL.Numeric;
- type Numeric_Items_Type is array(Integer range <>) of Numeric_Access;
-
- Correct_Result : Boolean := False;
- TC_Num_1 : Decimal_Type_1 := 0.0;
- TC_Num_2 : Decimal_Type_2 := 0.0;
-
- package Package_1 is new COBOL.Decimal_Conversions(Decimal_Type_1);
- package Package_2 is new COBOL.Decimal_Conversions(Decimal_Type_2);
-
-
- Package_1_Numeric_Items :
- Numeric_Items_Type(1..Number_Of_Decimal_Items) :=
- (new COBOL.Numeric'("0"),
- new COBOL.Numeric'("591"),
- new COBOL.Numeric'("6342"),
- new COBOL.Numeric'("+0"),
- new COBOL.Numeric'("-1539"),
- new COBOL.Numeric'("+9199"),
- new COBOL.Numeric'("0-"),
- new COBOL.Numeric'("8934+"),
- new COBOL.Numeric'("9949-"));
-
- Package_2_Numeric_Items :
- Numeric_Items_Type(1..Number_Of_Decimal_Items) :=
- (new COBOL.Numeric'("3"),
- new COBOL.Numeric'("105"),
- new COBOL.Numeric'("1234567899"),
- new COBOL.Numeric'("+8"),
- new COBOL.Numeric'("-12345601"),
- new COBOL.Numeric'("+9123459999"),
- new COBOL.Numeric'("1-"),
- new COBOL.Numeric'("123456781+"),
- new COBOL.Numeric'("9499999999-"));
-
-
- Decimal_Type_1_Items : array (1..Number_Of_Decimal_Items)
- of Decimal_Type_1 :=
- (0.0, 5.91, 63.42, 0.0, -15.39, 91.99, 0.0, 89.34, -99.49);
-
- Decimal_Type_2_Items : array (1..Number_Of_Decimal_Items)
- of Decimal_Type_2 :=
- ( 3.0, 105.0, 1234567899.0,
- 8.0, -12345601.0, 9123459999.0,
- -1.0, 123456781.0, -9499999999.0);
-
- begin
-
- -- Check that function Length with Display_Format parameter will
- -- return the minimal length of a Numeric value (number of
- -- COBOL_Characters) that will be required to hold the largest
- -- value of type Num.
-
- if Package_1.Length(COBOL.Unsigned) /= 4 or
- Package_2.Length(COBOL.Unsigned) /= 10
- then
- Report.Failed("Incorrect results from function Length when " &
- "used with Display_Format parameter Unsigned");
- end if;
-
- if Package_1.Length(Format => COBOL.Leading_Separate) /= 5 or
- Package_2.Length(Format => COBOL.Leading_Separate) /= 11
- then
- Report.Failed("Incorrect results from function Length when " &
- "used with Display_Format parameter " &
- "Leading_Separate");
- end if;
-
- if Package_1.Length(COBOL.Trailing_Separate) /= 5 or
- Package_2.Length(COBOL.Trailing_Separate) /= 11
- then
- Report.Failed("Incorrect results from function Length when " &
- "used with Display_Format parameter " &
- "Trailing_Separate");
- end if;
-
-
- -- Check that function To_Decimal with Numeric and Display_Format
- -- parameters will produce a decimal type Num result that corresponds
- -- to parameter Item as represented by parameter Format.
-
- for i in 1..Number_Of_Decimal_Items loop
- case i is
- when 1..3 => -- Unsigned Display_Format parameter.
-
- if Package_1.To_Decimal(Package_1_Numeric_Items(i).all,
- Format => COBOL.Unsigned) /=
- Decimal_Type_1_Items(i)
- then
- Report.Failed
- ("Incorrect result from function To_Decimal " &
- "from an instantiation of Decimal_Conversions " &
- "using a four-digit Decimal type, with Format " &
- "parameter Unsigned, subtest index: " &
- Integer'Image(i));
- end if;
-
- if Package_2.To_Decimal(Package_2_Numeric_Items(i).all,
- Format => COBOL.Unsigned) /=
- Decimal_Type_2_Items(i)
- then
- Report.Failed
- ("Incorrect result from function To_Decimal " &
- "from an instantiation of Decimal_Conversions " &
- "using a ten-digit Decimal type, with Format " &
- "parameter Unsigned, subtest index: " &
- Integer'Image(i));
- end if;
-
- when 4..6 => -- Leading_Separate Display_Format parameter.
-
- if Package_1.To_Decimal(Package_1_Numeric_Items(i).all,
- Format => COBOL.Leading_Separate) /=
- Decimal_Type_1_Items(i)
- then
- Report.Failed
- ("Incorrect result from function To_Decimal " &
- "from an instantiation of Decimal_Conversions " &
- "using a four-digit Decimal type, with Format " &
- "parameter Leading_Separate, subtest index: " &
- Integer'Image(i));
- end if;
-
- if Package_2.To_Decimal(Package_2_Numeric_Items(i).all,
- Format => COBOL.Leading_Separate) /=
- Decimal_Type_2_Items(i)
- then
- Report.Failed
- ("Incorrect result from function To_Decimal " &
- "from an instantiation of Decimal_Conversions " &
- "using a ten-digit Decimal type, with Format " &
- "parameter Leading_Separate, subtest index: " &
- Integer'Image(i));
- end if;
-
- when 7..9 => -- Trailing_Separate Display_Format parameter.
-
- if Package_1.To_Decimal(Package_1_Numeric_Items(i).all,
- COBOL.Trailing_Separate) /=
- Decimal_Type_1_Items(i)
- then
- Report.Failed
- ("Incorrect result from function To_Decimal " &
- "from an instantiation of Decimal_Conversions " &
- "using a four-digit Decimal type, with Format " &
- "parameter Trailing_Separate, subtest index: " &
- Integer'Image(i));
- end if;
-
- if Package_2.To_Decimal(Package_2_Numeric_Items(i).all,
- COBOL.Trailing_Separate) /=
- Decimal_Type_2_Items(i)
- then
- Report.Failed
- ("Incorrect result from function To_Decimal " &
- "from an instantiation of Decimal_Conversions " &
- "using a ten-digit Decimal type, with Format " &
- "parameter Trailing_Separate, subtest index: " &
- Integer'Image(i));
- end if;
-
- end case;
- end loop;
-
-
- -- Check that function To_Decimal propagates Conversion_Error when
- -- the value represented by Numeric type parameter Item is outside
- -- the range of the Decimal_Type Num used to instantiate the package
- -- Decimal_Conversions.
-
- declare
- TC_Numeric_1 : Decimal_Type_1 := Decimal_Type_1_Items(1);
- begin
- -- The COBOL.Numeric type used as parameter Item represents a
- -- Decimal value that is outside the range of the Decimal type
- -- used to instantiate Package_1.
- TC_Numeric_1 :=
- Package_1.To_Decimal(Item => Package_2_Numeric_Items(8).all,
- Format => COBOL.Trailing_Separate);
- Report.Failed("Conversion_Error not raised by To_Decimal " &
- "when the value represented by parameter " &
- "Item is outside the range of the Decimal_Type " &
- "used to instantiate the package " &
- "Decimal_Conversions");
- if TC_Numeric_1 = Decimal_Type_1_Items(1) then
- Report.Comment("To Guard Against Dead Assignment Elimination " &
- "-- Should never be printed");
- end if;
- exception
- when COBOL.Conversion_Error => null; -- OK, expected exception.
- when others =>
- Report.Failed("Incorrect exception raised by To_Decimal " &
- "when the value represented by parameter " &
- "Item is outside the range of the Decimal_Type " &
- "used to instantiate the package " &
- "Decimal_Conversions");
- end;
-
-
- -- Check that function To_Display with decimal type Num and
- -- Display_Format parameters returns a Numeric type result that
- -- represents Item under the specific Display_Format.
-
- -- Unsigned Display_Format parameter.
- TC_Num_1 := 13.04;
- Correct_Result := (Package_1.To_Display(TC_Num_1, COBOL.Unsigned) =
- "1304") AND
- (Package_1.To_Display(TC_Num_1, COBOL.Unsigned) /=
- "13.04");
- if not Correct_Result then
- Report.Failed("Incorrect result from function To_Display with " &
- "Unsigned Display_Format parameter - 1");
- end if;
-
- TC_Num_2 := 1234567890.0;
- Correct_Result := Package_2.To_Display(TC_Num_2,
- COBOL.Unsigned) = "1234567890";
- if not Correct_Result then
- Report.Failed("Incorrect result from function To_Display with " &
- "Unsigned Display_Format parameter - 2");
- end if;
-
- -- Leading_Separate Display_Format parameter.
- TC_Num_1 := -34.29;
- Correct_Result := (Package_1.To_Display(TC_Num_1,
- COBOL.Leading_Separate) =
- "-3429") AND
- (Package_1.To_Display(TC_Num_1,
- COBOL.Leading_Separate) /=
- "-34.29");
- if not Correct_Result then
- Report.Failed("Incorrect result from function To_Display with " &
- "Leading_Separate Display_Format parameter - 1");
- end if;
-
- TC_Num_1 := 19.01;
- Correct_Result := Package_1.To_Display(TC_Num_1,
- COBOL.Leading_Separate) =
- "+1901";
- if not Correct_Result then
- Report.Failed("Incorrect result from function To_Display with " &
- "Leading_Separate Display_Format parameter - 2");
- end if;
-
- TC_Num_2 := 1234567890.0;
- Correct_Result := Package_2.To_Display(TC_Num_2,
- COBOL.Leading_Separate) =
- "+1234567890";
- if not Correct_Result then
- Report.Failed("Incorrect result from function To_Display with " &
- "Leading_Separate Display_Format parameter - 3");
- end if;
-
- TC_Num_2 := -1234567890.0;
- Correct_Result := Package_2.To_Display(TC_Num_2,
- COBOL.Leading_Separate) =
- "-1234567890";
- if not Correct_Result then
- Report.Failed("Incorrect result from function To_Display with " &
- "Leading_Separate Display_Format parameter - 4");
- end if;
-
- -- Trailing_Separate Display_Format parameter.
- TC_Num_1 := -99.91;
- Correct_Result := (Package_1.To_Display(TC_Num_1,
- COBOL.Trailing_Separate) =
- "9991-") AND
- (Package_1.To_Display(TC_Num_1,
- COBOL.Trailing_Separate) /=
- "99.91-");
- if not Correct_Result then
- Report.Failed("Incorrect result from function To_Display with " &
- "Trailing_Separate Display_Format parameter - 1");
- end if;
-
- TC_Num_1 := 51.99;
- Correct_Result := Package_1.To_Display(TC_Num_1,
- COBOL.Trailing_Separate) =
- "5199+";
- if not Correct_Result then
- Report.Failed("Incorrect result from function To_Display with " &
- "Trailing_Separate Display_Format parameter - 2");
- end if;
-
- TC_Num_2 := 1234567890.0;
- Correct_Result := Package_2.To_Display(TC_Num_2,
- COBOL.Trailing_Separate) =
- "1234567890+";
- if not Correct_Result then
- Report.Failed("Incorrect result from function To_Display with " &
- "Trailing_Separate Display_Format parameter - 3");
- end if;
-
- TC_Num_2 := -1234567890.0;
- Correct_Result := Package_2.To_Display(TC_Num_2,
- COBOL.Trailing_Separate) =
- "1234567890-";
- if not Correct_Result then
- Report.Failed("Incorrect result from function To_Display with " &
- "Trailing_Separate Display_Format parameter - 4");
- end if;
-
-
- -- Check that function To_Display propagates Conversion_Error when
- -- parameter Item is negative and the specified Display_Format
- -- parameter is Unsigned.
-
- begin
- if Package_2.To_Display(Item => Decimal_Type_2_Items(9),
- Format => COBOL.Unsigned) =
- Package_2_Numeric_Items(2).all
- then
- Report.Comment("To Guard Against Dead Assignment Elimination " &
- "-- Should never be printed");
- end if;
- Report.Failed("Conversion_Error not raised by To_Display " &
- "when the value represented by parameter " &
- "Item is negative and the Display_Format " &
- "parameter is Unsigned");
- exception
- when COBOL.Conversion_Error => null; -- OK, expected exception.
- when others =>
- Report.Failed("Incorrect exception raised by To_Display " &
- "when the value represented by parameter " &
- "Item is negative and the Display_Format " &
- "parameter is Unsigned");
- end;
-
-
- exception
- when The_Error : others =>
- Report.Failed ("The following exception was raised in the " &
- "Test_Block: " & Exception_Name(The_Error));
- end Test_Block;
-
- Report.Result;
-
-end CXB4004;
diff --git a/gcc/testsuite/ada/acats/tests/cxb/cxb4005.a b/gcc/testsuite/ada/acats/tests/cxb/cxb4005.a
deleted file mode 100644
index 01f1ded1d1d..00000000000
--- a/gcc/testsuite/ada/acats/tests/cxb/cxb4005.a
+++ /dev/null
@@ -1,332 +0,0 @@
--- CXB4005.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that the function To_COBOL will convert a String
--- parameter value into a type Alphanumeric array of
--- COBOL_Characters, with lower bound of one, and length
--- equal to length of the String parameter, based on the
--- mapping Ada_to_COBOL.
---
--- Check that the function To_Ada will convert a type
--- Alphanumeric parameter value into a String type result,
--- with lower bound of one, and length equal to the length
--- of the Alphanumeric parameter, based on the mapping
--- COBOL_to_Ada.
---
--- Check that the Ada_to_COBOL and COBOL_to_Ada mapping
--- arrays provide a mapping capability between Ada's type
--- Character and COBOL run-time character sets.
---
--- TEST DESCRIPTION:
--- This test checks that the functions To_COBOL and To_Ada produce
--- the correct results, based on a variety of parameter input values.
---
--- In the first series of subtests, the results of the function
--- To_COBOL are compared against expected Alphanumeric type results,
--- and the length and lower bound of the alphanumeric result are
--- also verified. In the second series of subtests, the results of
--- the function To_Ada are compared against expected String type
--- results, and the length of the String result is also verified
--- against the Alphanumeric type parameter.
---
--- This test also verifies that two mapping array variables defined
--- in package Interfaces.COBOL, Ada_To_COBOL and COBOL_To_Ada, are
--- available, and that they can be modified by a user at runtime.
--- Finally, the effects of user modifications on these mapping
--- variables is checked in the test.
---
--- This test uses Fixed, Bounded, and Unbounded_Strings in combination
--- with the functions under validation.
---
--- This test assumes that the following characters are all included
--- in the implementation defined type Interfaces.COBOL.COBOL_Character:
--- ' ', 'a'..'z', 'A'..'Z', '0'..'9', '*', ',', '.', and '$'.
---
--- APPLICABILITY CRITERIA:
--- This test is applicable to all implementations that provide
--- package Interfaces.COBOL. If an implementation provides
--- package Interfaces.COBOL, this test must compile, execute, and
--- report "PASSED".
---
---
--- CHANGE HISTORY:
--- 11 Jan 96 SAIC Initial prerelease version for ACVC 2.1
--- 30 May 96 SAIC Incorporated reviewer comments for ACVC 2.1.
--- 27 Oct 96 SAIC Incorporated reviewer comments.
---
---!
-
-with Report;
-with Ada.Exceptions;
-with Ada.Strings.Bounded;
-with Ada.Strings.Unbounded;
-with Interfaces.COBOL; -- N/A => ERROR
-
-procedure CXB4005 is
-begin
-
- Report.Test ("CXB4005", "Check that the functions To_COBOL and " &
- "To_Ada produce correct results");
-
- Test_Block:
- declare
-
- package Bnd is new Ada.Strings.Bounded.Generic_Bounded_Length(5);
- package Unb renames Ada.Strings.Unbounded;
-
- use Ada.Exceptions;
- use Interfaces;
- use Bnd;
- use type Unb.Unbounded_String;
- use type Interfaces.COBOL.Alphanumeric;
-
- TC_Alphanumeric_1 : Interfaces.COBOL.Alphanumeric(1..1);
- TC_Alphanumeric_5 : Interfaces.COBOL.Alphanumeric(1..5);
- TC_Alphanumeric_10 : Interfaces.COBOL.Alphanumeric(1..10);
- TC_Alphanumeric_20 : Interfaces.COBOL.Alphanumeric(1..20);
-
- Bnd_String,
- TC_Bnd_String : Bnd.Bounded_String :=
- Bnd.To_Bounded_String(" ");
- Unb_String,
- TC_Unb_String : Unb.Unbounded_String :=
- Unb.To_Unbounded_String(" ");
-
- The_String,
- TC_String : String(1..20) := (" ");
-
- begin
-
- -- Check that the function To_COBOL will convert a String
- -- parameter value into a type Alphanumeric array of
- -- COBOL_Characters, with lower bound of one, and length
- -- equal to length of the String parameter, based on the
- -- mapping Ada_to_COBOL.
-
- Unb_String := Unb.To_Unbounded_String("A");
- TC_Alphanumeric_1 := COBOL.To_COBOL(Unb.To_String(Unb_String));
-
- if TC_Alphanumeric_1 /= "A" or
- TC_Alphanumeric_1'Length /= Unb.Length(Unb_String) or
- TC_Alphanumeric_1'Length /= 1 or
- COBOL.To_COBOL(Unb.To_String(Unb_String))'First /= 1
- then
- Report.Failed("Incorrect result from function To_COBOL - 1");
- end if;
-
- Bnd_String := Bnd.To_Bounded_String("abcde");
- TC_Alphanumeric_5 := COBOL.To_COBOL(Bnd.To_String(Bnd_String));
-
- if TC_Alphanumeric_5 /= "abcde" or
- TC_Alphanumeric_5'Length /= Bnd.Length(Bnd_String) or
- TC_Alphanumeric_5'Length /= 5 or
- COBOL.To_COBOL(Bnd.To_String(Bnd_String))'First /= 1
- then
- Report.Failed("Incorrect result from function To_COBOL - 2");
- end if;
-
- Unb_String := Unb.To_Unbounded_String("1A2B3c4d5F");
- TC_Alphanumeric_10 := COBOL.To_COBOL(Unb.To_String(Unb_String));
-
- if TC_Alphanumeric_10 /= "1A2B3c4d5F" or
- TC_Alphanumeric_10'Length /= Unb.Length(Unb_String) or
- TC_Alphanumeric_10'Length /= 10 or
- COBOL.To_COBOL(Unb.To_String(Unb_String))'First /= 1
- then
- Report.Failed("Incorrect result from function To_COBOL - 3");
- end if;
-
- The_String := "abcd ghij" & "1234 7890";
- TC_Alphanumeric_20 := COBOL.To_COBOL(The_String);
-
- if TC_Alphanumeric_20 /= "abcd ghij1234 7890" or
- TC_Alphanumeric_20'Length /= The_String'Length or
- TC_Alphanumeric_20'Length /= 20 or
- COBOL.To_COBOL(The_String)'First /= 1
- then
- Report.Failed("Incorrect result from function To_COBOL - 4");
- end if;
-
-
-
- -- Check that the function To_Ada will convert a type
- -- Alphanumeric parameter value into a String type result,
- -- with lower bound of one, and length equal to the length
- -- of the Alphanumeric parameter, based on the mapping
- -- COBOL_to_Ada.
-
- TC_Unb_String := Unb.To_Unbounded_String
- (COBOL.To_Ada(TC_Alphanumeric_1));
-
- if TC_Unb_String /= "A" or
- TC_Alphanumeric_1'Length /= Unb.Length(TC_Unb_String) or
- Unb.Length(TC_Unb_String) /= 1 or
- COBOL.To_Ada(TC_Alphanumeric_1)'First /= 1
- then
- Report.Failed("Incorrect value returned from function To_Ada - 1");
- end if;
-
- TC_Bnd_String := Bnd.To_Bounded_String
- (COBOL.To_Ada(TC_Alphanumeric_5));
-
- if TC_Bnd_String /= "abcde" or
- TC_Alphanumeric_5'Length /= Bnd.Length(TC_Bnd_String) or
- Bnd.Length(TC_Bnd_String) /= 5 or
- COBOL.To_Ada(TC_Alphanumeric_5)'First /= 1
- then
- Report.Failed("Incorrect value returned from function To_Ada - 2");
- end if;
-
- TC_Unb_String := Unb.To_Unbounded_String
- (COBOL.To_Ada(TC_Alphanumeric_10));
-
- if TC_Unb_String /= "1A2B3c4d5F" or
- TC_Alphanumeric_10'Length /= Unb.Length(TC_Unb_String) or
- Unb.Length(TC_Unb_String) /= 10 or
- COBOL.To_Ada(TC_Alphanumeric_10)'First /= 1
- then
- Report.Failed("Incorrect value returned from function To_Ada - 3");
- end if;
-
- TC_String := COBOL.To_Ada(TC_Alphanumeric_20);
-
- if TC_String /= "abcd ghij1234 7890" or
- TC_Alphanumeric_20'Length /= TC_String'Length or
- TC_String'Length /= 20 or
- COBOL.To_Ada(TC_Alphanumeric_20)'First /= 1
- then
- Report.Failed("Incorrect value returned from function To_Ada - 4");
- end if;
-
-
- -- Check the two functions when used in combination.
-
- if COBOL.To_COBOL(Item => COBOL.To_Ada("This is a test")) /=
- "This is a test" or
- COBOL.To_COBOL(COBOL.To_Ada("1234567890abcdeFGHIJ")) /=
- "1234567890abcdeFGHIJ"
- then
- Report.Failed("Incorrect result returned when using the " &
- "functions To_Ada and To_COBOL in combination");
- end if;
-
-
-
- -- Check that the Ada_to_COBOL and COBOL_to_Ada mapping
- -- arrays provide a mapping capability between Ada's type
- -- Character and COBOL run-time character sets.
-
- Interfaces.COBOL.Ada_To_COBOL('a') := 'A';
- Interfaces.COBOL.Ada_To_COBOL('b') := 'B';
- Interfaces.COBOL.Ada_To_COBOL('c') := 'C';
- Interfaces.COBOL.Ada_To_COBOL('d') := '1';
- Interfaces.COBOL.Ada_To_COBOL('e') := '2';
- Interfaces.COBOL.Ada_To_COBOL('f') := '3';
- Interfaces.COBOL.Ada_To_COBOL(' ') := '*';
-
- Unb_String := Unb.To_Unbounded_String("b");
- TC_Alphanumeric_1 := COBOL.To_COBOL(Unb.To_String(Unb_String));
-
- if TC_Alphanumeric_1 /= "B" then
- Report.Failed("Incorrect result from function To_COBOL after " &
- "modification to Ada_To_COBOL mapping array - 1");
- end if;
-
- Bnd_String := Bnd.To_Bounded_String("abcde");
- TC_Alphanumeric_5 := COBOL.To_COBOL(Bnd.To_String(Bnd_String));
-
- if TC_Alphanumeric_5 /= "ABC12" then
- Report.Failed("Incorrect result from function To_COBOL after " &
- "modification to Ada_To_COBOL mapping array - 2");
- end if;
-
- Unb_String := Unb.To_Unbounded_String("1a2B3c4d5e");
- TC_Alphanumeric_10 := COBOL.To_COBOL(Unb.To_String(Unb_String));
-
- if TC_Alphanumeric_10 /= "1A2B3C4152" then
- Report.Failed("Incorrect result from function To_COBOL after " &
- "modification to Ada_To_COBOL mapping array - 3");
- end if;
-
- The_String := "abcd ghij" & "1234 7890";
- TC_Alphanumeric_20 := COBOL.To_COBOL(The_String);
-
- if TC_Alphanumeric_20 /= "ABC1**ghij1234**7890" then
- Report.Failed("Incorrect result from function To_COBOL after " &
- "modification to Ada_To_COBOL mapping array - 4");
- end if;
-
-
- -- Reset the Ada_To_COBOL mapping array to its original state.
-
- Interfaces.COBOL.Ada_To_COBOL('a') := 'a';
- Interfaces.COBOL.Ada_To_COBOL('b') := 'b';
- Interfaces.COBOL.Ada_To_COBOL('c') := 'c';
- Interfaces.COBOL.Ada_To_COBOL('d') := 'd';
- Interfaces.COBOL.Ada_To_COBOL('e') := 'e';
- Interfaces.COBOL.Ada_To_COBOL('f') := 'f';
- Interfaces.COBOL.Ada_To_COBOL(' ') := ' ';
-
- -- Modify the COBOL_To_Ada mapping array to check its effect on
- -- the function To_Ada.
-
- Interfaces.COBOL.COBOL_To_Ada(' ') := '*';
- Interfaces.COBOL.COBOL_To_Ada('$') := 'F';
- Interfaces.COBOL.COBOL_To_Ada('1') := '7';
- Interfaces.COBOL.COBOL_To_Ada('.') := ',';
-
- Unb_String := Unb.To_Unbounded_String(" $$100.00");
- TC_Alphanumeric_10 := COBOL.To_COBOL(Unb.To_String(Unb_String));
- TC_Unb_String := Unb.To_Unbounded_String(
- COBOL.To_Ada(TC_Alphanumeric_10));
-
- if Unb.To_String(TC_Unb_String) /= "**FF700,00" then
- Report.Failed("Incorrect result from function To_Ada after " &
- "modification of COBOL_To_Ada mapping array - 1");
- end if;
-
- Interfaces.COBOL.COBOL_To_Ada('*') := ' ';
- Interfaces.COBOL.COBOL_To_Ada('F') := '$';
- Interfaces.COBOL.COBOL_To_Ada('7') := '1';
- Interfaces.COBOL.COBOL_To_Ada(',') := '.';
-
- if COBOL.To_Ada(COBOL.To_COBOL(Unb.To_String(TC_Unb_String))) /=
- Unb_String
- then
- Report.Failed("Incorrect result from function To_Ada after " &
- "modification of COBOL_To_Ada mapping array - 2");
- end if;
-
-
- exception
- when The_Error : others =>
- Report.Failed ("The following exception was raised in the " &
- "Test_Block: " & Exception_Name(The_Error));
- end Test_Block;
-
- Report.Result;
-
-end CXB4005;
diff --git a/gcc/testsuite/ada/acats/tests/cxb/cxb4006.a b/gcc/testsuite/ada/acats/tests/cxb/cxb4006.a
deleted file mode 100644
index 6e491eebff7..00000000000
--- a/gcc/testsuite/ada/acats/tests/cxb/cxb4006.a
+++ /dev/null
@@ -1,322 +0,0 @@
--- CXB4006.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that the function Valid with Packed_Decimal and Packed_Format
--- parameters returns True if Item (the Packed_Decimal parameter) has
--- a value consistent with the Packed_Format parameter.
---
--- Check that the function Length with Packed_Format parameter returns
--- the minimal length of a Packed_Decimal value sufficient to hold any
--- value of type Num when represented according to parameter Format.
---
--- Check that the function To_Decimal with Packed_Decimal and
--- Packed_Format parameters produces a decimal type value corresponding
--- to the Packed_Decimal parameter value Item, under the conditions of
--- the Packed_Format parameter Format.
---
--- Check that the function To_Packed with Decimal (Num) and
--- Packed_Format parameters produces a Packed_Decimal result that
--- corresponds to the decimal parameter under conditions of the
--- Packed_Format parameter.
---
--- Check that Conversion_Error is propagated by function To_Packed if
--- the value of the decimal parameter Item is negative and the specified
--- Packed_Format parameter is Packed_Unsigned.
---
---
--- TEST DESCRIPTION:
--- This test checks the results from instantiated versions of
--- several functions that deal with parameters or results of type
--- Packed_Decimal. Since the rules for the formation of Packed_Decimal
--- values are implementation defined, several of the subtests cannot
--- directly check the accuracy of the results produced. Instead, they
--- verify that the result is within a range of possible values, or
--- that the result of one function can be converted back to the original
--- actual parameter using a "mirror image" conversion function.
---
--- APPLICABILITY CRITERIA:
--- This test is applicable to all implementations that provide
--- package Interfaces.COBOL. If an implementation provides
--- package Interfaces.COBOL, this test must compile, execute, and
--- report "PASSED".
---
---
--- CHANGE HISTORY:
--- 12 Feb 96 SAIC Initial release for 2.1.
--- 30 May 96 SAIC Incorporated reviewer comments for ACVC 2.1.
--- 27 Oct 96 SAIC Incorporated reviewer comments.
---
---!
-
-with Report;
-with Ada.Exceptions;
-with Interfaces.COBOL; -- N/A => ERROR
-
-procedure CXB4006 is
-begin
-
- Report.Test ("CXB4006", "Check that the functions Valid, Length, " &
- "To_Decimal, and To_Packed specific to " &
- "Packed_Decimal parameters produce correct " &
- "results");
-
- Test_Block:
- declare
-
- use Interfaces.COBOL;
- use Ada.Exceptions;
- use type Interfaces.COBOL.Numeric;
-
- type Decimal_Type_1 is delta 0.1 digits 6;
- type Decimal_Type_2 is delta 0.01 digits 8;
- type Decimal_Type_3 is delta 0.001 digits 10;
- type Decimal_Type_4 is delta 0.0001 digits 12;
-
- package Pack_1 is new Decimal_Conversions(Decimal_Type_1);
- package Pack_2 is new Decimal_Conversions(Decimal_Type_2);
- package Pack_3 is new Decimal_Conversions(Decimal_Type_3);
- package Pack_4 is new Decimal_Conversions(Decimal_Type_4);
-
- TC_Dec_1 : Decimal_Type_1 := 12345.6;
- TC_Dec_2 : Decimal_Type_2 := 123456.78;
- TC_Dec_3 : Decimal_Type_3 := 1234567.890;
- TC_Dec_4 : Decimal_Type_4 := 12345678.9012;
- TC_Min_Length : Natural := 1;
- TC_Max_Length : Natural := 16;
-
- begin
-
- -- Check that the function Valid with Packed_Decimal and Packed_Format
- -- parameters returns True if Item (the Packed_Decimal parameter) has
- -- a value consistent with the Packed_Format parameter.
- -- Note: Since the formation rules for Packed_Decimal values are
- -- implementation defined, the parameter values here are
- -- created by function To_Packed.
-
- TC_Dec_1 := 1434.3;
- if not Pack_1.Valid(Item => Pack_1.To_Packed(TC_Dec_1,
- Packed_Unsigned),
- Format => Packed_Unsigned)
- then
- Report.Failed("Incorrect result from function Valid - 1");
- end if;
-
- TC_Dec_2 := -4321.03;
- if not Pack_2.Valid(Pack_2.To_Packed(TC_Dec_2, Packed_Signed),
- Format => Packed_Signed) or
- Pack_2.Valid(Pack_2.To_Packed(TC_Dec_2, Packed_Signed),
- Format => Packed_Unsigned)
- then
- Report.Failed("Incorrect result from function Valid - 2");
- end if;
-
- TC_Dec_3 := 1234567.890;
- if not Pack_3.Valid(Pack_3.To_Packed(TC_Dec_3, Packed_Unsigned),
- Packed_Unsigned)
- then
- Report.Failed("Incorrect result from function Valid - 3");
- end if;
-
- TC_Dec_4 := -234.6789;
- if not Pack_4.Valid(Item => Pack_4.To_Packed(TC_Dec_4,
- Packed_Signed),
- Format => Packed_Signed) or
- Pack_4.Valid(Item => Pack_4.To_Packed(TC_Dec_4, Packed_Signed),
- Format => Packed_Unsigned)
- then
- Report.Failed("Incorrect result from function Valid - 4");
- end if;
-
-
-
- -- Check that the function Length with Packed_Format parameter returns
- -- the minimal length of a Packed_Decimal value sufficient to hold any
- -- value of type Num when represented according to parameter Format.
-
- if NOT (Pack_1.Length(Packed_Signed) >= TC_Min_Length AND
- Pack_1.Length(Packed_Signed) <= TC_Max_Length AND
- Pack_1.Length(Packed_Unsigned) >= TC_Min_Length AND
- Pack_1.Length(Packed_Unsigned) <= TC_Max_Length)
- then
- Report.Failed("Incorrect result from function Length - 1");
- end if;
-
- if NOT (Pack_2.Length(Packed_Signed) >= TC_Min_Length AND
- Pack_2.Length(Packed_Signed) <= TC_Max_Length AND
- Pack_2.Length(Packed_Unsigned) >= TC_Min_Length AND
- Pack_2.Length(Packed_Unsigned) <= TC_Max_Length)
- then
- Report.Failed("Incorrect result from function Length - 2");
- end if;
-
- if NOT (Pack_3.Length(Packed_Signed) >= TC_Min_Length AND
- Pack_3.Length(Packed_Signed) <= TC_Max_Length AND
- Pack_3.Length(Packed_Unsigned) >= TC_Min_Length AND
- Pack_3.Length(Packed_Unsigned) <= TC_Max_Length)
- then
- Report.Failed("Incorrect result from function Length - 3");
- end if;
-
- if NOT (Pack_4.Length(Packed_Signed) >= TC_Min_Length AND
- Pack_4.Length(Packed_Signed) <= TC_Max_Length AND
- Pack_4.Length(Packed_Unsigned) >= TC_Min_Length AND
- Pack_4.Length(Packed_Unsigned) <= TC_Max_Length)
- then
- Report.Failed("Incorrect result from function Length - 4");
- end if;
-
-
-
- -- Check that the function To_Decimal with Packed_Decimal and
- -- Packed_Format parameters produces a decimal type value corresponding
- -- to the Packed_Decimal parameter value Item, under the conditions of
- -- the Packed_Format parameter Format.
-
- begin
- TC_Dec_1 := 1234.5;
- if Pack_1.To_Decimal(Item => Pack_1.To_Packed(TC_Dec_1,
- Packed_Unsigned),
- Format => Packed_Unsigned) /= TC_Dec_1
- then
- Report.Failed("Incorrect result from function To_Decimal - 1");
- end if;
- exception
- when The_Error : others =>
- Report.Failed("The following exception was raised in " &
- "subtest 1 of function To_Decimal: " &
- Exception_Name(The_Error));
- end;
-
- begin
- TC_Dec_2 := -123456.50;
- if Pack_2.To_Decimal(Pack_2.To_Packed(TC_Dec_2, Packed_Signed),
- Format => Packed_Signed) /= TC_Dec_2
- then
- Report.Failed("Incorrect result from function To_Decimal - 2");
- end if;
- exception
- when The_Error : others =>
- Report.Failed("The following exception was raised in " &
- "subtest 2 of function To_Decimal: " &
- Exception_Name(The_Error));
- end;
-
- begin
- TC_Dec_3 := 1234567.809;
- if Pack_3.To_Decimal(Pack_3.To_Packed(TC_Dec_3, Packed_Unsigned),
- Packed_Unsigned) /= TC_Dec_3
- then
- Report.Failed("Incorrect result from function To_Decimal - 3");
- end if;
- exception
- when The_Error : others =>
- Report.Failed("The following exception was raised in " &
- "subtest 3 of function To_Decimal: " &
- Exception_Name(The_Error));
- end;
-
- begin
- TC_Dec_4 := -789.1234;
- if Pack_4.To_Decimal(Item => Pack_4.To_Packed(TC_Dec_4,
- Packed_Signed),
- Format => Packed_Signed) /= TC_Dec_4
- then
- Report.Failed("Incorrect result from function To_Decimal - 4");
- end if;
- exception
- when The_Error : others =>
- Report.Failed("The following exception was raised in " &
- "subtest 4 of function To_Decimal: " &
- Exception_Name(The_Error));
- end;
-
-
-
- -- Check that the function To_Packed with Decimal (Num) and
- -- Packed_Format parameters produces a Packed_Decimal result that
- -- corresponds to the decimal parameter under conditions of the
- -- Packed_Format parameter.
-
- if Pack_1.To_Packed(Item => 123.4, Format => Packed_Unsigned) =
- Pack_1.To_Packed(Item => -123.4, Format => Packed_Signed)
- then
- Report.Failed("Incorrect result from function To_Packed - 1");
- end if;
-
- if Pack_2.To_Packed( 123.45, Format => Packed_Unsigned) =
- Pack_2.To_Packed(-123.45, Format => Packed_Signed)
- then
- Report.Failed("Incorrect result from function To_Packed - 2");
- end if;
-
- if Pack_3.To_Packed(Item => 123.456, Format => Packed_Unsigned) =
- Pack_3.To_Packed(Item => -123.456, Format => Packed_Signed)
- then
- Report.Failed("Incorrect result from function To_Packed - 3");
- end if;
-
- if (Pack_4.To_Packed( 123.4567, Packed_Unsigned) =
- Pack_4.To_Packed(-123.4567, Packed_Signed)) or
- (Pack_4.To_Packed(12345678.9012, Packed_Unsigned) =
- Pack_4.To_Packed(12345678.9013, Packed_Unsigned)) or
- (Pack_4.To_Packed(12345678.9012, Packed_Unsigned) =
- Pack_4.To_Packed(22345678.9012, Packed_Unsigned))
- then
- Report.Failed("Incorrect result from function To_Packed - 4");
- end if;
-
-
- -- Check that Conversion_Error is propagated by function To_Packed if
- -- the value of the decimal parameter Item is negative and the
- -- specified Packed_Format parameter is Packed_Unsigned.
-
- begin
- if Pack_1.To_Packed(Item => -12.3, Format => Packed_Unsigned) =
- Pack_1.To_Packed(Item => 12.3, Format => Packed_Signed)
- then
- Report.Comment("Should never be printed");
- end if;
- Report.Failed("Conversion_Error not raised following call to " &
- "function To_Packed with a negative parameter " &
- "Item and Packed_Format parameter Packed_Unsigned");
- exception
- when Conversion_Error => null; -- OK, expected exception.
- when The_Error : others =>
- Report.Failed(Exception_Name(The_Error) & " was incorrectly " &
- "raised following call to function To_Packed " &
- "with a negative parameter Item and " &
- "Packed_Format parameter Packed_Unsigned");
- end;
-
- exception
- when The_Error : others =>
- Report.Failed("The following exception was raised in the " &
- "Test_Block: " & Exception_Name(The_Error));
- end Test_Block;
-
- Report.Result;
-
-end CXB4006;
diff --git a/gcc/testsuite/ada/acats/tests/cxb/cxb4007.a b/gcc/testsuite/ada/acats/tests/cxb/cxb4007.a
deleted file mode 100644
index c4e0641766a..00000000000
--- a/gcc/testsuite/ada/acats/tests/cxb/cxb4007.a
+++ /dev/null
@@ -1,271 +0,0 @@
--- CXB4007.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that the function Valid with Byte_Array and Binary_Format
--- parameters returns True if the Byte_Array parameter corresponds
--- to any value inside the range of type Num.
--- Check that function Valid returns False if the Byte_Array parameter
--- corresponds to a value outside the range of Num.
---
--- Check that function Length with Binary_Format parameter will return
--- the minimum length of a Byte_Array value required to hold any value
--- of decimal type Num.
---
--- Check that function To_Decimal with Byte_Array and Binary_Format
--- parameters will return a decimal type value that corresponds to
--- parameter Item (of type Byte_Array) under the specified Format.
---
--- Check that Conversion_Error is propagated by function To_Decimal if
--- the Byte_Array parameter Item represents a decimal value outside the
--- range of decimal type Num.
---
--- Check that function To_Binary will produce a Byte_Array result that
--- corresponds to the decimal type parameter Item, under the specified
--- Binary_Format.
---
--- TEST DESCRIPTION:
--- This test uses several instantiations of generic package
--- Decimal_Conversions to provide appropriate test material.
--- This test uses the function To_Binary to create all Byte_Array
--- parameter values used in calls to functions Valid and To_Decimal.
--- The function Valid is tested with parameters to provide both
--- valid and invalid expected results. This test also checks that
--- Function To_Decimal produces expected results in cases where each
--- of the three predefined Binary_Format constants are used in the
--- function calls. In addition, the prescribed propagation of
--- Conversion_Error by function To_Decimal is verified.
---
--- APPLICABILITY CRITERIA:
--- This test is applicable to all implementations that provide
--- package Interfaces.COBOL. If an implementation provides
--- package Interfaces.COBOL, this test must compile, execute, and
--- report "PASSED".
---
---
--- CHANGE HISTORY:
--- 14 Feb 96 SAIC Initial release for 2.1.
--- 30 May 96 SAIC Incorporated reviewer comments for ACVC 2.1.
--- 27 Oct 96 SAIC Incorporated reviewer comments.
--- 05 JAN 98 EDS Remove incorrect subtest.
---!
-
-with Report;
-with Ada.Exceptions;
-with Interfaces.COBOL; -- N/A => ERROR
-
-procedure CXB4007 is
-begin
-
- Report.Test ("CXB4007", "Check that functions Valid, Length, To_Decimal " &
- "and To_Binary specific to Byte_Array and " &
- "Binary_Format parameters produce correct results");
-
- Test_Block:
- declare
-
- use Interfaces.COBOL;
- use Ada.Exceptions;
- use type Interfaces.COBOL.Numeric;
-
- type Decimal_Type_1 is delta 0.1 digits 6;
- type Decimal_Type_2 is delta 0.01 digits 8;
- type Decimal_Type_3 is delta 0.001 digits 10;
- type Decimal_Type_4 is delta 0.0001 digits 12;
-
- package Pack_1 is new Decimal_Conversions(Decimal_Type_1);
- package Pack_2 is new Decimal_Conversions(Decimal_Type_2);
- package Pack_3 is new Decimal_Conversions(Decimal_Type_3);
- package Pack_4 is new Decimal_Conversions(Decimal_Type_4);
-
- TC_Dec_1 : Decimal_Type_1 := 12345.6;
- TC_Dec_2 : Decimal_Type_2 := 123456.78;
- TC_Dec_3 : Decimal_Type_3 := 1234567.890;
- TC_Dec_4 : Decimal_Type_4 := 12345678.9012;
- TC_Min_Length : Natural := 1;
- TC_Max_Length : Natural := 16;
- TC_Valid : Boolean := False;
-
- begin
-
- -- Check that the function Valid with Byte_Array and Binary_Format
- -- parameters returns True if the Byte_Array parameter corresponds to
- -- any value inside the range of type Num.
-
- if not Pack_1.Valid(Item => Pack_1.To_Binary(TC_Dec_1,
- High_Order_First),
- Format => High_Order_First) or
- not Pack_1.Valid(Pack_1.To_Binary(0.0, Low_Order_First),
- Format => Low_Order_First)
- then
- Report.Failed("Incorrect result from function Valid, using " &
- "parameters that should return a positive result - 1");
- end if;
-
- TC_Valid := (Pack_2.Valid(Pack_2.To_Binary(TC_Dec_2, High_Order_First),
- Format => High_Order_First) and
- Pack_2.Valid(Pack_2.To_Binary(0.01, Low_Order_First),
- Format => Low_Order_First));
- if not TC_Valid then
- Report.Failed("Incorrect result from function Valid, using " &
- "parameters that should return a positive result - 2");
- end if;
-
- if not Pack_3.Valid(Item => Pack_3.To_Binary(TC_Dec_3,
- Low_Order_First),
- Format => Low_Order_First) or
- not Pack_3.Valid(Pack_3.To_Binary(0.001, High_Order_First),
- Format => High_Order_First) or
- not Pack_3.Valid(Pack_3.To_Binary(123.456, Native_Binary),
- Native_Binary)
- then
- Report.Failed("Incorrect result from function Valid, using " &
- "parameters that should return a positive result - 3");
- end if;
-
-
- -- Check that function Valid returns False if the Byte_Array parameter
- -- corresponds to a value outside the range of Num.
- -- Note: use a Byte_Array value Item created by an instantiation of
- -- To_Binary with a larger Num type as the generic formal.
-
- if Pack_1.Valid(Item => Pack_2.To_Binary(TC_Dec_2, Low_Order_First),
- Format => Low_Order_First) or
- Pack_2.Valid(Pack_3.To_Binary(TC_Dec_3, High_Order_First),
- Format => High_Order_First) or
- Pack_3.Valid(Pack_4.To_Binary(TC_Dec_4, Native_Binary),
- Native_Binary)
- then
- Report.Failed("Incorrect result from function Valid, using " &
- "parameters that should return a negative result");
- end if;
-
-
- -- Check that function Length with Binary_Format parameter will return
- -- the minimum length of a Byte_Array value required to hold any value
- -- of decimal type Num.
-
- if not (Pack_1.Length(Native_Binary) >= TC_Min_Length and
- Pack_1.Length(Low_Order_First) <= TC_Max_Length and
- Pack_2.Length(High_Order_First) >= TC_Min_Length and
- Pack_2.Length(Native_Binary) <= TC_Max_Length and
- Pack_3.Length(Low_Order_First) >= TC_Min_Length and
- Pack_3.Length(High_Order_First) <= TC_Max_Length and
- Pack_4.Length(Native_Binary) >= TC_Min_Length and
- Pack_4.Length(Low_Order_First) <= TC_Max_Length)
- then
- Report.Failed("Incorrect result from function Length");
- end if;
-
-
-
- -- Check that function To_Decimal with Byte_Array and Binary_Format
- -- parameters will return a decimal type value that corresponds to
- -- parameter Item (of type Byte_Array) under the specified Format.
-
- if Pack_1.To_Decimal(Item => Pack_1.To_Binary(Item => TC_Dec_1,
- Format => Native_Binary),
- Format => Native_Binary) /=
- TC_Dec_1
- then
- Report.Failed("Incorrect result from function To_Decimal - 1");
- end if;
-
- if Pack_3.To_Decimal(Pack_3.To_Binary(TC_Dec_3, High_Order_First),
- Format => High_Order_First) /=
- TC_Dec_3
- then
- Report.Failed("Incorrect result from function To_Decimal - 2");
- end if;
-
- if Pack_4.To_Decimal(Pack_4.To_Binary(TC_Dec_4, Low_Order_First),
- Low_Order_First) /=
- TC_Dec_4
- then
- Report.Failed("Incorrect result from function To_Decimal - 3");
- end if;
-
-
-
- -- Check that Conversion_Error is propagated by function To_Decimal
- -- if the Byte_Array parameter Item represents a decimal value outside
- -- the range of decimal type Num.
- -- Note: use a Byte_Array value Item created by an instantiation of
- -- To_Binary with a larger Num type as the generic formal.
-
- begin
- TC_Dec_4 := 99999.9001;
- TC_Dec_1 := Pack_1.To_Decimal(Pack_4.To_Binary(TC_Dec_4,
- Native_Binary),
- Format => Native_Binary);
- if TC_Dec_1 = 99999.9 then
- Report.Comment("Minimize dead assignment optimization -- " &
- "Should never be printed");
- end if;
- Report.Failed("Conversion_Error not raised following call to " &
- "function To_Decimal if the Byte_Array parameter " &
- "Item represents a decimal value outside the " &
- "range of decimal type Num");
- exception
- when Conversion_Error => null; -- OK, expected exception.
- when The_Error : others =>
- Report.Failed(Exception_Name(The_Error) & " was incorrectly " &
- "raised following call to function To_Decimal " &
- "if the Byte_Array parameter Item represents " &
- "a decimal value outside the range of decimal " &
- "type Num");
- end;
-
-
-
- -- Check that function To_Binary will produce a Byte_Array result that
- -- corresponds to the decimal type parameter Item, under the specified
- -- Binary_Format.
-
- -- Different ordering.
- TC_Dec_1 := 12345.6;
- if Pack_1.To_Binary(TC_Dec_1, Low_Order_First) =
- Pack_1.To_Binary(TC_Dec_1, High_Order_First)
- then
- Report.Failed("Incorrect result from function To_Binary - 1");
- end if;
-
- -- Variable vs. literal.
- TC_Dec_2 := 12345.00;
- if Pack_2.To_Binary(TC_Dec_2, Native_Binary) /=
- Pack_2.To_Binary(12345.00, Native_Binary)
- then
- Report.Failed("Incorrect result from function To_Binary - 2");
- end if;
-
- exception
- when The_Error : others =>
- Report.Failed("The following exception was raised in the " &
- "Test_Block: " & Exception_Name(The_Error));
- end Test_Block;
-
- Report.Result;
-
-end CXB4007;
diff --git a/gcc/testsuite/ada/acats/tests/cxb/cxb4008.a b/gcc/testsuite/ada/acats/tests/cxb/cxb4008.a
deleted file mode 100644
index 5ab8e6b0339..00000000000
--- a/gcc/testsuite/ada/acats/tests/cxb/cxb4008.a
+++ /dev/null
@@ -1,248 +0,0 @@
--- CXB4008.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that the function To_Decimal with Binary parameter will return
--- the corresponding value of the decimal type Num.
---
--- Check that the function To_Decimal with Long_Binary parameter will
--- return the corresponding value of the decimal type Num.
---
--- Check that both of the To_Decimal functions described above will
--- propagate Conversion_Error if the converted value Item is outside
--- the range of type Num.
---
--- Check that the function To_Binary converts a value of the Ada
--- decimal type Num into a Binary type value.
---
--- Check that the function To_Long_Binary converts a value of the Ada
--- decimal type Num into a Long_Binary type value.
---
--- TEST DESCRIPTION:
--- This test uses several instantiations of generic package
--- Decimal_Conversions to provide appropriate test material.
--- Two of the instantiations use decimal types as generic actuals
--- that include the implementation defined constants Max_Digits_Binary
--- and Max_Digits_Long_Binary in their definition.
---
--- Subtests are included for both versions of function To_Decimal,
--- (Binary and Long_Binary parameters), and include checks that
--- Conversion_Error is propagated under the appropriate circumstances.
--- Functions To_Binary and To_Long_Binary are "sanity" checked, to
--- ensure that the functions are available, and that the results are
--- appropriate based on their parameter input.
---
--- APPLICABILITY CRITERIA:
--- This test is applicable to all implementations that provide
--- package Interfaces.COBOL. If an implementation provides
--- package Interfaces.COBOL, this test must compile, execute, and
--- report "PASSED".
---
---
--- CHANGE HISTORY:
--- 21 Feb 96 SAIC Initial release for 2.1.
--- 10 Jun 96 SAIC Incorporated reviewer comments for ACVC 2.1.
--- 27 Oct 96 SAIC Incorporated reviewer comments.
---
---!
-
-with Report;
-with Ada.Exceptions;
-with Interfaces.COBOL; -- N/A => ERROR
-
-procedure CXB4008 is
-begin
-
- Report.Test ("CXB4008", "Check that functions To_Decimal, To_Binary, and " &
- "To_Long_Binary produce the correct results");
-
- Test_Block:
- declare
-
- use Interfaces.COBOL;
- use Ada.Exceptions;
- use type Interfaces.COBOL.Numeric;
-
- type Decimal_Type_1 is delta 0.1 digits 6;
- type Decimal_Type_2 is delta 0.01 digits Max_Digits_Binary;
- type Decimal_Type_3 is delta 0.001 digits 10;
- type Decimal_Type_4 is delta 0.0001 digits Max_Digits_Long_Binary;
-
- package Pack_1 is new Decimal_Conversions(Decimal_Type_1);
- package Pack_2 is new Decimal_Conversions(Decimal_Type_2);
- package Pack_3 is new Decimal_Conversions(Decimal_Type_3);
- package Pack_4 is new Decimal_Conversions(Decimal_Type_4);
-
- TC_Dec_1 : Decimal_Type_1 := 12345.0;
- TC_Dec_2 : Decimal_Type_2 := 123456.00;
- TC_Dec_3 : Decimal_Type_3 := 1234567.000;
- TC_Dec_4 : Decimal_Type_4 := 12345678.0000;
- TC_Binary : Interfaces.COBOL.Binary;
- TC_Long_Binary : Interfaces.COBOL.Long_Binary;
-
- begin
-
- -- Check that the function To_Decimal with Binary parameter will
- -- return the corresponding value of the decimal type Num.
-
- if Pack_1.To_Decimal(Item => Pack_1.To_Binary(TC_Dec_1)) /= TC_Dec_1 or
- Pack_2.To_Decimal(Pack_2.To_Binary(TC_Dec_2)) /= TC_Dec_2
- then
- Report.Failed("Incorrect result from function To_Decimal with " &
- "Binary parameter - 1");
- end if;
-
- if Pack_1.To_Decimal(Item => Pack_1.To_Binary(1234.0)) /= 1234.0 then
- Report.Failed("Incorrect result from function To_Decimal with " &
- "Binary parameter - 2");
- end if;
-
- TC_Binary := Pack_2.To_Binary(TC_Dec_2);
- if Pack_2.To_Decimal(TC_Binary) /= TC_Dec_2 then
- Report.Failed("Incorrect result from function To_Decimal with " &
- "Binary parameter - 3");
- end if;
-
-
-
- -- Check that the function To_Decimal with Long_Binary parameter
- -- will return the corresponding value of the decimal type Num.
-
- if Pack_3.To_Decimal(Item => Pack_3.To_Long_Binary(TC_Dec_3)) /=
- TC_Dec_3 or
- Pack_4.To_Decimal(Pack_4.To_Long_Binary(TC_Dec_4)) /=
- TC_Dec_4
- then
- Report.Failed("Incorrect result from function To_Decimal with " &
- "Long_Binary parameter - 1");
- end if;
-
- if Pack_3.To_Decimal(Pack_3.To_Long_Binary(1234567.0)) /= 1234567.0 then
- Report.Failed("Incorrect result from function To_Decimal with " &
- "Long_Binary parameter - 2");
- end if;
-
- TC_Long_Binary := Pack_4.To_Long_Binary(TC_Dec_4);
- if Pack_4.To_Decimal(TC_Long_Binary) /= TC_Dec_4 then
- Report.Failed("Incorrect result from function To_Decimal with " &
- "Long_Binary parameter - 3");
- end if;
-
-
-
- -- Check that both of the To_Decimal functions described above
- -- will propagate Conversion_Error if the converted value Item is
- -- outside the range of type Num.
- -- Note: Binary/Long_Binary parameter values are created by an
- -- instantiation of To_Binary/To_Long_Binary with a larger
- -- Num type as the generic formal.
-
- Binary_Parameter:
- begin
- TC_Dec_1 := Pack_1.To_Decimal(Pack_2.To_Binary(123456.78));
- Report.Failed("Conversion_Error was not raised by function " &
- "To_Decimal with Binary parameter, when the " &
- "converted value Item was outside the range " &
- "of type Num");
- if TC_Dec_1 = 12345.6 then -- Avoid dead assignment optimization.
- Report.Comment("Should never be printed");
- end if;
- exception
- when Conversion_Error => null; -- OK, expected exception.
- when The_Error : others =>
- Report.Failed(Ada.Exceptions.Exception_Name(The_Error) & " " &
- "was incorrectly raised by function To_Decimal " &
- "with Binary parameter, when the converted " &
- "value Item was outside the range of type Num");
- end Binary_Parameter;
-
- Long_Binary_Parameter:
- begin
- TC_Dec_3 := Pack_3.To_Decimal(Pack_4.To_Long_Binary(TC_Dec_4));
- Report.Failed("Conversion_Error was not raised by function " &
- "To_Decimal with Long_Binary parameter, when " &
- "the converted value Item was outside the range " &
- "of type Num");
- if TC_Dec_3 = 123456.78 then -- Avoid dead assignment optimization.
- Report.Comment("Should never be printed");
- end if;
- exception
- when Conversion_Error => null; -- OK, expected exception.
- when The_Error : others =>
- Report.Failed(Ada.Exceptions.Exception_Name(The_Error) & " " &
- "was incorrectly raised by function To_Decimal " &
- "with Long_Binary parameter, when the converted " &
- "value Item was outside the range of type Num");
- end Long_Binary_Parameter;
-
-
-
- -- Check that the function To_Binary converts a value of the Ada
- -- decimal type Num into a Binary type value.
-
- TC_Dec_1 := 123.4;
- TC_Dec_2 := 9.99;
- if Pack_1.To_Binary(TC_Dec_1) = Pack_1.To_Binary(-TC_Dec_1) or
- Pack_2.To_Binary(TC_Dec_2) = Pack_2.To_Binary(-TC_Dec_2)
- then
- Report.Failed("Incorrect result from function To_Binary - 1");
- end if;
-
- if Pack_1.To_Binary(1.1) = Pack_1.To_Binary(-1.1) or
- Pack_2.To_Binary(9999.99) = Pack_2.To_Binary(-9999.99)
- then
- Report.Failed("Incorrect result from function To_Binary - 2");
- end if;
-
-
- -- Check that the function To_Long_Binary converts a value of the
- -- Ada decimal type Num into a Long_Binary type value.
-
- TC_Dec_3 := 9.001;
- TC_Dec_4 := 123.4567;
- if Pack_3.To_Long_Binary(TC_Dec_3) = Pack_3.To_Long_Binary(-TC_Dec_3) or
- Pack_4.To_Long_Binary(TC_Dec_4) = Pack_4.To_Long_Binary(-TC_Dec_4)
- then
- Report.Failed("Incorrect result from function To_Long_Binary - 1");
- end if;
-
- if Pack_3.To_Long_Binary(1.011) =
- Pack_3.To_Long_Binary(-1.011) or
- Pack_4.To_Long_Binary(2345678.9012) =
- Pack_4.To_Long_Binary(-2345678.9012)
- then
- Report.Failed("Incorrect result from function To_Long_Binary - 2");
- end if;
-
-
- exception
- when The_Error : others =>
- Report.Failed("The following exception was raised in the " &
- "Test_Block: " & Exception_Name(The_Error));
- end Test_Block;
-
- Report.Result;
-
-end CXB4008;
diff --git a/gcc/testsuite/ada/acats/tests/cxb/cxb5001.a b/gcc/testsuite/ada/acats/tests/cxb/cxb5001.a
deleted file mode 100644
index a681c5f13e2..00000000000
--- a/gcc/testsuite/ada/acats/tests/cxb/cxb5001.a
+++ /dev/null
@@ -1,110 +0,0 @@
--- CXB5001.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that the specification of the package Interfaces.Fortran
--- are available for use.
---
--- TEST DESCRIPTION:
--- This test verifies that the types and subprograms specified for the
--- interface are present
---
--- APPLICABILITY CRITERIA:
--- If an implementation provides package Interfaces.Fortran, this test
--- must compile, execute, and report "PASSED".
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 28 Feb 96 SAIC Added applicability criteria.
--- 27 Oct 96 SAIC Incorporated reviewer comments.
---
---!
-
-with Report;
-with Interfaces.Fortran; -- N/A => ERROR
-
-procedure CXB5001 is
- package Fortran renames Interfaces.FORTRAN;
-
-begin
-
- Report.Test ("CXB5001", "Check the specification of Interfaces.Fortran");
-
-
- declare -- encapsulate the test
-
-
- TC_Int : integer := 1;
- TC_Natural : natural;
- TC_String : String := "ABCD";
- TC_Character : Character := 'a';
-
- TST_Fortran_Integer : FORTRAN.Fortran_Integer;
-
- TST_Real : Fortran.Real;
- TST_Double_Precision : Fortran.Double_Precision;
-
- TST_Logical : Fortran.Logical := FORTRAN.true;
- -- verify it is a Boolean
- TST_Complex : Fortran.Complex;
-
- TST_Imaginary_i : Fortran.Imaginary := FORTRAN.i;
- TST_Imaginary_j : Fortran.Imaginary := FORTRAN.j;
-
-
- -- Initialize it so we can use it below
- TST_Character_Set : Fortran.Character_Set :=
- Fortran.Character_Set'First;
-
- TST_Fortran_Character : FORTRAN.Fortran_Character (1..5) :=
- (others => TST_Character_Set);
-
-
-
- begin -- encapsulation
-
- -- Arrange that the calls to the subprograms are compiled but
- -- not executed
- --
- if not Report.Equal ( TC_Int, TC_Int ) then
-
- TST_Character_Set := Fortran.To_Fortran (TC_Character);
- TC_Character := Fortran.To_Ada (TST_Character_Set);
-
-
- TST_Fortran_Character := FORTRAN.To_Fortran ("TEST STRING");
- Report.Comment ( Fortran.To_Ada (TST_Fortran_Character) );
-
- Fortran.To_Fortran ( TC_String, TST_Fortran_Character, TC_Natural );
- Fortran.To_Ada ( TST_Fortran_Character, TC_String, TC_Natural );
-
- end if;
-
- end; -- encapsulation
-
- Report.Result;
-
-end CXB5001;
diff --git a/gcc/testsuite/ada/acats/tests/cxb/cxb5002.a b/gcc/testsuite/ada/acats/tests/cxb/cxb5002.a
deleted file mode 100644
index 3da7cc9b195..00000000000
--- a/gcc/testsuite/ada/acats/tests/cxb/cxb5002.a
+++ /dev/null
@@ -1,334 +0,0 @@
--- CXB5002.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that the Function To_Fortran with a Character parameter will
--- return the corresponding Fortran Character_Set value.
---
--- Check that the Function To_Ada with a Character_Set parameter will
--- return the corresponding Ada Character value.
---
--- Check that the Function To_Fortran with a String parameter will
--- return the corresponding Fortran_Character value.
---
--- Check that the Function To_Ada with a Fortran_Character parameter
--- will return the corresponding Ada String value.
---
--- TEST DESCRIPTION:
--- This test checks that the functions To_Fortran and To_Ada produce
--- the correct results, based on a variety of parameter input values.
---
--- In the first series of subtests, the results of the function
--- To_Fortran are compared against expected Character_Set type results.
--- In the second series of subtests, the results of the function To_Ada
--- are compared against expected String type results, and the length of
--- the String result is also verified against the Fortran_Character type
--- parameter.
---
--- This test uses Fixed, Bounded, and Unbounded_Strings in combination
--- with the functions under validation.
---
--- This test assumes that the following characters are all included
--- in the implementation defined type Interfaces.Fortran.Character_Set:
--- ' ', 'a'..'z', 'A'..'Z', '1'..'9', '-', '_', '$', '#', and '*'.
---
--- APPLICABILITY CRITERIA:
--- This test is applicable to all implementations that provide
--- package Interfaces.Fortran. If an implementation provides
--- package Interfaces.Fortran, this test must compile, execute, and
--- report "PASSED".
---
--- This test does not apply to an implementation in which the Fortran
--- character set ranges are not contiguous (e.g., EBCDIC).
---
---
---
--- CHANGE HISTORY:
--- 11 Mar 96 SAIC Initial release for 2.1.
--- 10 Jun 96 SAIC Incorporated reviewer comments for ACVC 2.1.
--- 27 Oct 96 SAIC Incorporated reviewer comments.
---
---!
-
-with Ada.Characters.Latin_1;
-with Ada.Exceptions;
-with Ada.Strings.Bounded;
-with Ada.Strings.Unbounded;
-with Ada.Unchecked_Conversion;
-with Interfaces.Fortran; -- N/A => ERROR
-with Report;
-
-procedure CXB5002 is
-begin
-
- Report.Test ("CXB5002", "Check that functions To_Fortran and To_Ada " &
- "produce correct results");
-
- Test_Block:
- declare
-
- package ACL renames Ada.Characters.Latin_1;
- package Bnd is new Ada.Strings.Bounded.Generic_Bounded_Length(10);
- package Unb renames Ada.Strings.Unbounded;
-
- use Bnd, Unb;
- use Interfaces.Fortran;
- use Ada.Exceptions;
-
- Null_Fortran_Character : constant Fortran_Character := "";
- Fortran_Character_1 : Fortran_Character(1..1) := " ";
- Fortran_Character_5 : Fortran_Character(1..5) := " ";
- Fortran_Character_10 : Fortran_Character(1..10) := " ";
- Fortran_Character_20 : Fortran_Character(1..20) :=
- " ";
- TC_Fortran_Character_1 : Fortran_Character(1..1) := "A";
- TC_Fortran_Character_5 : Fortran_Character(1..5) := "ab*de";
- TC_Fortran_Character_10 : Fortran_Character(1..10) := "$1a2b3C4D5";
- TC_Fortran_Character_20 : Fortran_Character(1..20) :=
- "1234-ABCD_6789#fghij";
-
- Bnd_String : Bnd.Bounded_String :=
- Bnd.To_Bounded_String(" ");
- TC_Bnd_String : Bounded_String :=
- To_Bounded_String("$1a2b3C4D5");
-
- Unb_String : Unb.Unbounded_String :=
- Unb.To_Unbounded_String(" ");
- TC_Unb_String : Unbounded_String :=
- To_Unbounded_String("ab*de");
-
- String_1 : String(1..1) := " ";
- String_5 : String(1..5) := " ";
- String_10 : String(1..10) := " ";
- String_20 : String(1..20) := " ";
- TC_String_1 : String(1..1) := "A";
- TC_String_20 : String(1..20) := "1234-ABCD_6789#fghij";
- Null_String : constant String := "";
-
- Null_Character : constant Character := ACL.Nul;
- Character_A : constant Character := Character'Val(65);
- Character_Z : constant Character := Character'Val(90);
- TC_Character : Character := Character'First;
-
- Null_Character_Set : Character_Set := To_Fortran(ACL.Nul);
- TC_Character_Set,
- TC_Low_Character_Set,
- TC_High_Character_Set : Character_Set := Character_Set'First;
-
-
- -- The following procedure checks the results of function To_Ada.
-
- procedure Check_Length (Str : in String;
- Ftn : in Fortran_Character;
- Num : in Natural) is
- begin
- if Str'Length /= Ftn'Length or
- Str'Length /= Num
- then
- Report.Failed("Incorrect result from Function To_Ada " &
- "with string length " & Integer'Image(Num));
- end if;
- end Check_Length;
-
- -- To facilitate the conversion of Character-Character_Set data, the
- -- following functions have been instantiated.
-
- function Character_to_Character_Set is
- new Ada.Unchecked_Conversion(Character, Character_Set);
-
- function Character_Set_to_Character is
- new Ada.Unchecked_Conversion(Character_Set, Character);
-
- begin
-
- -- Check that the Function To_Fortran with a Character parameter
- -- will return the corresponding Fortran Character_Set value.
-
- for TC_Character in ACL.LC_A..ACL.LC_Z loop
- if To_Fortran(Item => TC_Character) /=
- Character_to_Character_Set(TC_Character)
- then
- Report.Failed("Incorrect result from To_Fortran with lower " &
- "case alphabetic character input");
- end if;
- end loop;
-
- for TC_Character in Character_A..Character_Z loop
- if To_Fortran(TC_Character) /=
- Character_to_Character_Set(TC_Character)
- then
- Report.Failed("Incorrect result from To_Fortran with upper " &
- "case alphabetic character input");
- end if;
- end loop;
-
- if To_Fortran(Null_Character) /=
- Character_to_Character_Set(Null_Character)
- then
- Report.Failed
- ("Incorrect result from To_Fortran with null character input");
- end if;
-
-
- -- Check that the Function To_Ada with a Character_Set parameter
- -- will return the corresponding Ada Character value.
-
- TC_Low_Character_Set := Character_to_Character_Set('a');
- TC_High_Character_Set := Character_to_Character_Set('z');
- for TC_Character_Set in TC_Low_Character_Set..TC_High_Character_Set loop
- if To_Ada(Item => TC_Character_Set) /=
- Character_Set_to_Character(TC_Character_Set)
- then
- Report.Failed("Incorrect result from To_Ada with lower case " &
- "alphabetic Character_Set input");
- end if;
- end loop;
-
- TC_Low_Character_Set := Character_to_Character_Set('A');
- TC_High_Character_Set := Character_to_Character_Set('Z');
- for TC_Character_Set in TC_Low_Character_Set..TC_High_Character_Set loop
- if To_Ada(TC_Character_Set) /=
- Character_Set_to_Character(TC_Character_Set)
- then
- Report.Failed("Incorrect result from To_Ada with upper case " &
- "alphabetic Character_Set input");
- end if;
- end loop;
-
- if To_Ada(Character_to_Character_Set(Null_Character)) /=
- Null_Character
- then
- Report.Failed("Incorrect result from To_Ada with a null " &
- "Character_Set input");
- end if;
-
-
- -- Check that the Function To_Fortran with a String parameter
- -- will return the corresponding Fortran_Character value.
- -- Note: The type Fortran_Character is a character array type that
- -- corresponds to Ada type String.
-
- Fortran_Character_1 := To_Fortran(Item => TC_String_1);
-
- if Fortran_Character_1 /= TC_Fortran_Character_1 then
- Report.Failed("Incorrect result from procedure To_Fortran - 1");
- end if;
-
- Fortran_Character_5 := To_Fortran(To_String(TC_Unb_String));
-
- if Fortran_Character_5 /= TC_Fortran_Character_5 then
- Report.Failed("Incorrect result from procedure To_Fortran - 2");
- end if;
-
- Fortran_Character_10 := To_Fortran(To_String(TC_Bnd_String));
-
- if Fortran_Character_10 /= TC_Fortran_Character_10 then
- Report.Failed("Incorrect result from procedure To_Fortran - 3");
- end if;
-
- Fortran_Character_20 := To_Fortran(Item => TC_String_20);
-
- if Fortran_Character_20 /= TC_Fortran_Character_20 then
- Report.Failed("Incorrect result from procedure To_Fortran - 4");
- end if;
-
- if To_Fortran(Null_String) /= Null_Fortran_Character then
- Report.Failed("Incorrect result from procedure To_Fortran - 5");
- end if;
-
-
- -- Check that the Function To_Ada with a Fortran_Character parameter
- -- will return the corresponding Ada String value.
-
- String_1 := To_Ada(TC_Fortran_Character_1);
-
- if String_1 /= TC_String_1 then
- Report.Failed("Incorrect value returned from function To_Ada - 1");
- end if;
-
- Check_Length(To_Ada(TC_Fortran_Character_1),
- TC_Fortran_Character_1,
- Num => 1);
-
-
- Unb_String := Unb.To_Unbounded_String(To_Ada(TC_Fortran_Character_5));
-
- if Unb_String /= TC_Unb_String then
- Report.Failed("Incorrect value returned from function To_Ada - 2");
- end if;
-
- Check_Length(To_Ada(TC_Fortran_Character_5),
- TC_Fortran_Character_5,
- Num => 5);
-
-
- Bnd_String := Bnd.To_Bounded_String
- (To_Ada(TC_Fortran_Character_10));
-
- if Bnd_String /= TC_Bnd_String then
- Report.Failed("Incorrect value returned from function To_Ada - 3");
- end if;
-
- Check_Length(To_Ada(TC_Fortran_Character_10),
- TC_Fortran_Character_10,
- Num => 10);
-
-
- String_20 := To_Ada(TC_Fortran_Character_20);
-
- if String_20 /= TC_String_20 then
- Report.Failed("Incorrect value returned from function To_Ada - 4");
- end if;
-
- Check_Length(To_Ada(TC_Fortran_Character_20),
- TC_Fortran_Character_20,
- Num => 20);
-
- if To_Ada(Null_Character_Set) /= Null_Character then
- Report.Failed("Incorrect value returned from function To_Ada - 5");
- end if;
-
-
- -- Check the two functions when used in combination.
-
- if To_Ada(Item => To_Fortran("This is a test")) /=
- "This is a test" or
- To_Ada(To_Fortran("1234567890abcdeFGHIJ")) /=
- Report.Ident_Str("1234567890abcdeFGHIJ")
- then
- Report.Failed("Incorrect result returned when using the " &
- "functions To_Ada and To_Fortran in combination");
- end if;
-
-
- exception
- when The_Error : others =>
- Report.Failed("The following exception was raised in the " &
- "Test_Block: " & Exception_Name(The_Error));
- end Test_Block;
-
- Report.Result;
-
-end CXB5002;
diff --git a/gcc/testsuite/ada/acats/tests/cxb/cxb5003.a b/gcc/testsuite/ada/acats/tests/cxb/cxb5003.a
deleted file mode 100644
index 1c2b1c537ae..00000000000
--- a/gcc/testsuite/ada/acats/tests/cxb/cxb5003.a
+++ /dev/null
@@ -1,295 +0,0 @@
--- CXB5003.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that the procedure To_Fortran converts the character elements
--- of the String parameter Item into Character_Set elements of the
--- Fortran_Character type parameter Target. Check that the parameter
--- Last contains the index of the last element of parameter Target
--- that was assigned by To_Fortran.
---
--- Check that Constraint_Error is propagated by procedure To_Fortran
--- when the length of String parameter Item exceeds the length of
--- Fortran_Character parameter Target.
---
--- Check that the procedure To_Ada converts the Character_Set
--- elements of the Fortran_Character parameter Item into Character
--- elements of the String parameter Target. Check that the parameter
--- Last contains the index of the last element of parameter Target
--- that was assigned by To_Ada.
---
--- Check that Constraint_Error is propagated by procedure To_Ada when
--- the length of Fortran_Character parameter Item exceeds the length of
--- String parameter Target.
---
--- TEST DESCRIPTION:
--- This test checks that the procedures To_Fortran and To_Ada produce
--- the correct results, based on a variety of parameter input values.
---
--- In the first series of subtests, the Out parameter results of
--- procedure To_Fortran are compared against expected results,
--- which includes (in the parameter Last) the index in Target of the
--- last element assigned. The situation where procedure To_Fortran
--- raises Constraint_Error (when Item'Length exceeds Target'Length)
--- is also verified.
---
--- In the second series of subtests, the Out parameter results of
--- procedure To_Ada are verified, in a similar manner as is done for
--- procedure To_Fortran. The case of procedure To_Ada raising
--- Constraint_Error is also verified.
---
--- This test assumes that the following characters are all included
--- in the implementation defined type Interfaces.Fortran.Character_Set:
--- ' ', 'a'..'j', 'A'..'D', '1'..'9', '-', '_', '$', '#', and '*'.
---
--- APPLICABILITY CRITERIA:
--- This test is applicable to all implementations that provide
--- package Interfaces.Fortran. If an implementation provides
--- package Interfaces.Fortran, this test must compile, execute, and
--- report "PASSED".
---
---
--- CHANGE HISTORY:
--- 14 Mar 96 SAIC Initial release for 2.1.
--- 10 Jun 96 SAIC Incorporated reviewer comments for ACVC 2.1.
--- 27 Oct 96 SAIC Incorporated reviewer comments.
---
---!
-
-with Ada.Exceptions;
-with Ada.Strings.Bounded;
-with Ada.Strings.Unbounded;
-with Interfaces.Fortran; -- N/A => ERROR
-with Report;
-
-procedure CXB5003 is
-begin
-
- Report.Test ("CXB5003", "Check that procedures To_Fortran and To_Ada " &
- "produce correct results");
-
- Test_Block:
- declare
-
- package Bnd is new Ada.Strings.Bounded.Generic_Bounded_Length(10);
- package Unb renames Ada.Strings.Unbounded;
-
- use Bnd, Unb;
- use Interfaces.Fortran;
- use Ada.Exceptions;
-
- Fortran_Character_1 : Fortran_Character(1..1) := " ";
- Fortran_Character_5 : Fortran_Character(1..5) := " ";
- Fortran_Character_10 : Fortran_Character(1..10) := " ";
- Fortran_Character_20 : Fortran_Character(1..20) :=
- " ";
- TC_Fortran_Character_1 : Fortran_Character(1..1) := "A";
- TC_Fortran_Character_5 : Fortran_Character(1..5) := "ab*de";
- TC_Fortran_Character_10 : Fortran_Character(1..10) := "$1a2b3C4D5";
- TC_Fortran_Character_20 : Fortran_Character(1..20) :=
- "1234-ABCD_6789#fghij";
-
- Bnd_String : Bnd.Bounded_String :=
- Bnd.To_Bounded_String(" ");
- TC_Bnd_String : Bounded_String :=
- To_Bounded_String("$1a2b3C4D5");
-
- Unb_String : Unb.Unbounded_String :=
- Unb.To_Unbounded_String(" ");
- TC_Unb_String : Unbounded_String :=
- To_Unbounded_String("ab*de");
-
- String_1 : String(1..1) := " ";
- String_5 : String(1..5) := " ";
- String_10 : String(1..10) := " ";
- String_20 : String(1..20) := " ";
- TC_String_1 : String(1..1) := "A";
- TC_String_20 : String(1..20) := "1234-ABCD_6789#fghij";
-
- TC_Fortran_Character : constant Fortran_Character := "";
- TC_String : constant String := "";
- TC_Natural : Natural := 0;
-
-
- begin
-
- -- Check that the procedure To_Fortran converts the character elements
- -- of the String parameter Item into Character_Set elements of the
- -- Fortran_Character type parameter Target.
- -- Check that the parameter Last contains the index of the last element
- -- of parameter Target that was assigned by To_Fortran.
-
- To_Fortran(Item => TC_String_1,
- Target => Fortran_Character_1,
- Last => TC_Natural);
-
- if Fortran_Character_1 /= TC_Fortran_Character_1 or
- TC_Natural /= TC_Fortran_Character_1'Length
- then
- Report.Failed("Incorrect result from procedure To_Fortran - 1");
- end if;
-
- To_Fortran(To_String(TC_Unb_String),
- Target => Fortran_Character_5,
- Last => TC_Natural);
-
- if Fortran_Character_5 /= TC_Fortran_Character_5 or
- TC_Natural /= TC_Fortran_Character_5'Length
- then
- Report.Failed("Incorrect result from procedure To_Fortran - 2");
- end if;
-
- To_Fortran(To_String(TC_Bnd_String),
- Fortran_Character_10,
- Last => TC_Natural);
-
- if Fortran_Character_10 /= TC_Fortran_Character_10 or
- TC_Natural /= TC_Fortran_Character_10'Length
- then
- Report.Failed("Incorrect result from procedure To_Fortran - 3");
- end if;
-
- To_Fortran(TC_String_20, Fortran_Character_20, TC_Natural);
-
- if Fortran_Character_20 /= TC_Fortran_Character_20 or
- TC_Natural /= TC_Fortran_Character_20'Length
- then
- Report.Failed("Incorrect result from procedure To_Fortran - 4");
- end if;
-
- To_Fortran(Item => TC_String, -- null string
- Target => Fortran_Character_1,
- Last => TC_Natural);
-
- if TC_Natural /= 0 then
- Report.Failed("Incorrect result from procedure To_Fortran, value " &
- "returned in parameter Last should be zero, since " &
- "parameter Item is null array");
- end if;
-
-
- -- Check that Constraint_Error is propagated by procedure To_Fortran
- -- when the length of String parameter Item exceeds the length of
- -- Fortran_Character parameter Target.
-
- begin
-
- To_Fortran(Item => TC_String_20,
- Target => Fortran_Character_10,
- Last => TC_Natural);
- Report.Failed("Constraint_Error not raised by procedure " &
- "To_Fortran when Item'Length exceeds Target'Length");
- exception
- when Constraint_Error => null; -- OK, expected exception.
- when The_Error : others =>
- Report.Failed("The following exception was raised by procedure " &
- "To_Fortran when Item'Length exceeds " &
- "Target'Length: " & Exception_Name(The_Error));
- end;
-
-
- -- Check that the procedure To_Ada converts the Character_Set
- -- elements of the Fortran_Character parameter Item into Character
- -- elements of the String parameter Target.
- -- Check that the parameter Last contains the index of the last
- -- element of parameter Target that was assigned by To_Ada.
-
- To_Ada(Item => TC_Fortran_Character_1,
- Target => String_1,
- Last => TC_Natural);
-
- if String_1 /= TC_String_1 or
- TC_Natural /= TC_String_1'Length
- then
- Report.Failed("Incorrect result from procedure To_Ada - 1");
- end if;
-
- To_Ada(TC_Fortran_Character_5,
- Target => String_5,
- Last => TC_Natural);
-
- if String_5 /= To_String(TC_Unb_String) or
- TC_Natural /= Length(TC_Unb_String)
- then
- Report.Failed("Incorrect result from procedure To_Ada - 2");
- end if;
-
- To_Ada(TC_Fortran_Character_10,
- String_10,
- Last => TC_Natural);
-
- if String_10 /= To_String(TC_Bnd_String) or
- TC_Natural /= Length(TC_Bnd_String)
- then
- Report.Failed("Incorrect result from procedure To_Ada - 3");
- end if;
-
- To_Ada(TC_Fortran_Character_20, String_20, TC_Natural);
-
- if String_20 /= TC_String_20 or
- TC_Natural /= TC_String_20'Length
- then
- Report.Failed("Incorrect result from procedure To_Ada - 4");
- end if;
-
- To_Ada(Item => TC_Fortran_Character, -- null array.
- Target => String_20,
- Last => TC_Natural);
-
- if TC_Natural /= 0 then
- Report.Failed("Incorrect result from procedure To_Ada, value " &
- "returned in parameter Last should be zero, since " &
- "parameter Item is null array");
- end if;
-
-
- -- Check that Constraint_Error is propagated by procedure To_Ada
- -- when the length of Fortran_Character parameter Item exceeds the
- -- length of String parameter Target.
-
- begin
-
- To_Ada(Item => TC_Fortran_Character_10,
- Target => String_5,
- Last => TC_Natural);
- Report.Failed("Constraint_Error not raised by procedure To_Ada " &
- "when Item'Length exceeds Target'Length");
- exception
- when Constraint_Error => null; -- OK, expected exception.
- when The_Error : others =>
- Report.Failed("Incorrect exception raised by procedure To_Ada " &
- "when Item'Length exceeds Target'Length");
- end;
-
-
- exception
- when The_Error : others =>
- Report.Failed("The following exception was raised in the " &
- "Test_Block: " & Exception_Name(The_Error));
- end Test_Block;
-
- Report.Result;
-
-end CXB5003;
diff --git a/gcc/testsuite/ada/acats/tests/cxf/cxf1001.a b/gcc/testsuite/ada/acats/tests/cxf/cxf1001.a
deleted file mode 100644
index be7e5069252..00000000000
--- a/gcc/testsuite/ada/acats/tests/cxf/cxf1001.a
+++ /dev/null
@@ -1,261 +0,0 @@
--- CXF1001.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that values of 2 and 10 are allowable values for Machine_Radix
--- of a decimal first subtype.
--- Check that the value of Decimal.Max_Decimal_Digits is at least 18;
--- the value of Decimal.Max_Scale is at least 18; the value of
--- Decimal.Min_Scale is at most 0.
---
--- TEST DESCRIPTION:
--- This test examines the Machine_Radix attribute definition clause
--- and its effect on Decimal fixed point types, as well as several
--- constants from the package Ada.Decimal.
--- The first subtest checks that the Machine_Radix attribute will
--- return the value set for Machine_Radix by an attribute definition
--- clause. The second and third subtests examine differences between
--- the binary and decimal scaling of a type, based on the radix
--- representation. The final subtest examines the values
--- assigned to constants Min_Scale, Max_Scale, and Max_Decimal_Digits,
--- found in the package Ada.Decimal.
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 29 Dec 94 SAIC Restructured Radix 10 and Radix 2 test blocks.
---
---!
-
-with Report;
-with Ada.Decimal;
-
-procedure CXF1001 is
-begin
-
- Report.Test ("CXF1001", "Check that values of 2 and 10 are allowable " &
- "values for Machine_Radix of a decimal first " &
- "subtype. Check that the value of " &
- "Decimal.Max_Decimal_Digits is at least 18; " &
- "the value of Decimal.Max_Scale is at least " &
- "18; the value of Decimal.Min_Scale is at " &
- "most 0");
-
- Attribute_Check_Block:
- declare
-
- Del : constant := 1.0/10**2;
- Const_Digits : constant := 3;
- Two : constant := 2;
- Ten : constant := 10;
-
- type Radix_2_Type_1 is delta 0.01 digits 7;
- type Radix_2_Type_2 is delta Ada.Decimal.Min_Delta digits 10;
- type Radix_2_Type_3 is
- delta 0.000_1 digits Ada.Decimal.Max_Decimal_Digits;
-
- type Radix_10_Type_1 is delta 10.0**(-Ada.Decimal.Max_Scale) digits 8;
- type Radix_10_Type_2 is delta 10.0**(-Ada.Decimal.Min_Scale) digits 6;
- type Radix_10_Type_3 is delta Ada.Decimal.Max_Delta digits 15;
-
-
- -- Use an attribute definition clause to set the Machine_Radix for a
- -- decimal first subtype to either 2 or 10.
- for Radix_2_Type_1'Machine_Radix use 2;
- for Radix_2_Type_2'Machine_Radix use Two;
- for Radix_2_Type_3'Machine_Radix use 10-8;
-
- for Radix_10_Type_1'Machine_Radix use 2*15/Const_Digits;
- for Radix_10_Type_2'Machine_Radix use Ten;
- for Radix_10_Type_3'Machine_Radix use Radix_10_Type_2'Machine_Radix;
-
-
- begin
-
- -- Check that the attribute 'Machine_Radix returns the value assigned
- -- by the attribute definition clause.
-
- if Radix_2_Type_1'Machine_Radix /= 2 or else
- Radix_2_Type_2'Machine_Radix /= 2 or else
- Radix_2_Type_3'Machine_Radix /= 2
- then
- Report.Failed("Incorrect radix value returned, 2 expected");
- end if;
-
- if Radix_10_Type_1'Machine_Radix /= 10 or else
- Radix_10_Type_2'Machine_Radix /= 10 or else
- Radix_10_Type_3'Machine_Radix /= 10
- then
- Report.Failed("Incorrect radix value returned, 10 expected");
- end if;
-
- exception
- when others => Report.Failed ("Exception raised in Attr_Check_Block");
- end Attribute_Check_Block;
-
-
-
- Radix_Block:
- -- Premises:
- -- 1) Choose several numbers, from types using either decimal scaling or
- -- binary scaling.
- -- 1) Repetitively add these numbers to themselves.
- -- 3) Validate that the result is the expected result, regardless of the
- -- scaling used in the definition of the type.
- declare
-
- Number_Of_Values : constant := 3;
- Loop_Count : constant := 1000;
-
- type Radix_2_Type is delta 0.0001 digits 10;
- type Radix_10_Type is delta 0.0001 digits 10;
-
- for Radix_2_Type'Machine_Radix use 2;
- for Radix_10_Type'Machine_Radix use 10;
-
- type Result_Record_Type is record
- Rad_2 : Radix_2_Type;
- Rad_10 : Radix_10_Type;
- end record;
-
- type Result_Array_Type is array (1..Number_Of_Values)
- of Result_Record_Type;
-
- Result_Array : Result_Array_Type := ((50.00, 50.00),
- (613.00, 613.00),
- (72.70, 72.70));
-
- function Repetitive_Radix_2_Add (Value : in Radix_2_Type)
- return Radix_2_Type is
- Result : Radix_2_Type := 0.0;
- begin
- for i in 1..Loop_Count loop
- Result := Result + Value;
- end loop;
- return Result;
- end Repetitive_Radix_2_Add;
-
- function Repetitive_Radix_10_Add (Value : in Radix_10_Type)
- return Radix_10_Type is
- Result : Radix_10_Type := 0.0;
- begin
- for i in 1..Loop_Count loop
- Result := Result + Value;
- end loop;
- return Result;
- end Repetitive_Radix_10_Add;
-
- begin
-
- -- Radix 2 Cases, three different values.
- -- Compare the result of the repetitive addition with the expected
- -- Radix 2 result, as well as with the Radix 10 value after type
- -- conversion.
-
- if Repetitive_Radix_2_Add(0.05) /= Result_Array(1).Rad_2 or
- Repetitive_Radix_2_Add(0.05) /= Radix_2_Type(Result_Array(1).Rad_10)
- then
- Report.Failed("Incorrect Radix 2 Result, Case 1");
- end if;
-
- if Repetitive_Radix_2_Add(0.613) /=
- Result_Array(2).Rad_2 or
- Repetitive_Radix_2_Add(0.613) /=
- Radix_2_Type(Result_Array(2).Rad_10)
- then
- Report.Failed("Incorrect Radix 2 Result, Case 2");
- end if;
-
- if Repetitive_Radix_2_Add(0.0727) /=
- Result_Array(3).Rad_2 or
- Repetitive_Radix_2_Add(0.0727) /=
- Radix_2_Type(Result_Array(3).Rad_10)
- then
- Report.Failed("Incorrect Radix 2 Result, Case 3");
- end if;
-
- -- Radix 10 Cases, three different values.
- -- Compare the result of the repetitive addition with the expected
- -- Radix 10 result, as well as with the Radix 2 value after type
- -- conversion.
-
- if Repetitive_Radix_10_Add(0.05) /= Result_Array(1).Rad_10 or
- Repetitive_Radix_10_Add(0.05) /= Radix_10_Type(Result_Array(1).Rad_2)
- then
- Report.Failed("Incorrect Radix 10 Result, Case 1");
- end if;
-
- if Repetitive_Radix_10_Add(0.613) /=
- Result_Array(2).Rad_10 or
- Repetitive_Radix_10_Add(0.613) /=
- Radix_10_Type(Result_Array(2).Rad_2)
- then
- Report.Failed("Incorrect Radix 10 Result, Case 2");
- end if;
-
- if Repetitive_Radix_10_Add(0.0727) /=
- Result_Array(3).Rad_10 or
- Repetitive_Radix_10_Add(0.0727) /=
- Radix_10_Type(Result_Array(3).Rad_2)
- then
- Report.Failed("Incorrect Radix 10 Result, Case 3");
- end if;
-
- exception
- when others => Report.Failed ("Exception raised in Radix_Block");
- end Radix_Block;
-
-
-
- Size_Block:
- -- Check the implementation max/min values of constants declared in
- -- package Ada.Decimal.
- declare
- Minimum_Required_Size : constant := 18;
- Maximum_Allowed_Size : constant := 0;
- begin
-
- -- Check that the Max_Decimal_Digits value is at least 18.
- if not (Ada.Decimal.Max_Decimal_Digits >= Minimum_Required_Size) then
- Report.Failed("Insufficient size provided for Max_Decimal_Digits");
- end if;
-
- -- Check that the Max_Scale value is at least 18.
- if not (Ada.Decimal.Max_Scale >= Minimum_Required_Size) then
- Report.Failed("Insufficient size provided for Max_Scale");
- end if;
-
- -- Check that the Min_Scale value is at most 0.
- if not (Ada.Decimal.Min_Scale <= Maximum_Allowed_Size) then
- Report.Failed("Too large a value provided for Min_Scale");
- end if;
-
- exception
- when others => Report.Failed ("Exception raised in Size_Block");
- end Size_Block;
-
- Report.Result;
-
-end CXF1001;
diff --git a/gcc/testsuite/ada/acats/tests/cxf/cxf2001.a b/gcc/testsuite/ada/acats/tests/cxf/cxf2001.a
deleted file mode 100644
index 96d0a0a17d3..00000000000
--- a/gcc/testsuite/ada/acats/tests/cxf/cxf2001.a
+++ /dev/null
@@ -1,755 +0,0 @@
--- CXF2001.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that the Divide procedure provides the following results:
--- Quotient = Dividend divided by Divisor and
--- Remainder = Dividend - (Divisor * Quotient)
--- Check that the Remainder is calculated exactly.
---
--- TEST DESCRIPTION:
--- This test is designed to test the generic procedure Divide found in
--- package Ada.Decimal.
---
--- The table below attempts to portray the design approach used in this
--- test. There are three "dimensions" of concern:
--- 1) the delta value of the Quotient and Remainder types, shown as
--- column headers,
--- 2) specific choices for the Dividend and Divisor numerical values
--- (i.e., whether they yielded a repeating/non-terminating result,
--- or a terminating result ["exact"]), displayed on the left side
--- of the tables, and
--- 3) the delta for the Dividend and Divisor.
---
--- Each row in the tables indicates a specific test case, showing the
--- specific quotient and remainder (under the appropriate Delta column)
--- for each combination of dividend and divisor values. Test cases
--- follow the top-to-bottom sequence shown in the tables.
---
--- Most of the test case sets (same dividend/divisor combinations -
--- indicated by dashed horizontal lines in the tables) vary the
--- delta of the quotient and remainder types between test cases. This
--- allows for an examination of how different deltas for a quotient
--- and/or remainder type can influence the results of a division with
--- identical dividend and divisor.
---
--- Note: Test cases are performed for both Radix 10 and Radix 2 types.
---
---
--- Divid Divis Delta Delta Delta Delta Delta
--- (Delta)(Delta)| .1 | .01 | .001 | .0001 | .00001 |Test
--- |---|---|-----|-----|-----|-----|-----|-----|-----|-----|Case
--- quotient | Q | R | Q | R | Q | R | Q | R | Q | R | No.
--- ---------------------------------------------------------------------------
--- .05 .3 |.1 .02 1,21
--- (.01) (.1) |.1 0 2,22
--- | .16 .002 3,23
--- 0.166666.. | .16 .00 4,24
--- | .166 .0002 5,25
--- ---------------------------------------------------------------------------
--- .15 20 | .00 .1500 6,26
--- (.01) (1) | .00 .150 7,27
--- | .00 .15 8,28
--- 0.0075 | .01 .007 9,29
--- | .007 .010 10,30
--- | .0075 .0000 11,31
--- ---------------------------------------------------------------------------
--- .03125 .5 | .0625 .0000 12,32
--- (.00001) (.1) | .062 .00025 13,33
--- | .062 .0002 14,34
--- 0.0625 | .062 .000 15,35
--- | .00 .062 16,36
--- | .06 .00125 17,37
--- | .06 .0012 18,38
--- | .06 .001 19,39
--- | .06 .00 20,40
--- ---------------------------------------------------------------------------
--- Divide by Zero| Raise Constraint_Error 41
--- ---------------------------------------------------------------------------
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 29 Dec 94 SAIC Modified Radix 2 cases to match Radix 10 cases.
--- 03 Oct 95 RBKD Modified to fix incorrect remainder results
--- 15 Nov 95 SAIC Incorporated reviewer fixes for ACVC 2.0.1.
---
---!
-
-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
deleted file mode 100644
index 984daa97bca..00000000000
--- a/gcc/testsuite/ada/acats/tests/cxf/cxf2002.a
+++ /dev/null
@@ -1,352 +0,0 @@
--- CXF2002.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that the multiplying operators for a decimal fixed point type
--- return values that are integral multiples of the small of the type.
--- Check the case where the operand and result types are the same.
---
--- Check that if the mathematical result is between multiples of the
--- small of the result type, the result is truncated toward zero.
--- Check that if the attribute 'Round is applied to the mathematical
--- result, however, the result is rounded to the nearest multiple of
--- the small (away from zero if the result is midway between two
--- multiples of the small).
---
--- TEST DESCRIPTION:
--- Two decimal fixed point types are declared, one with a Machine_Radix
--- value of 2, and one with a value of 10. For each type, checks are
--- performed on the following operations, where the operand and result
--- types are the same:
---
--- - Multiplication.
--- - Multiplication, where the attribute 'Round is applied to the
--- result.
--- - Division.
--- - Division, where the attribute 'Round is applied to the result.
---
--- Each operation is performed within a loop, where one operand is
--- always the same variable. After the loop completes, the cumulative
--- total contained in this variable is compared with the expected
--- result.
---
--- APPLICABILITY CRITERIA:
--- This test is only applicable for a compiler attempting validation
--- for the Information Systems Annex.
---
---
--- CHANGE HISTORY:
--- 27 Mar 96 SAIC Prerelease version for ACVC 2.1.
---
---!
-
-generic
- type Decimal_Fixed is delta <> digits <>;
-package CXF2002_0 is
-
- procedure Multiply_And_Truncate (Balance : in out Decimal_Fixed;
- Factor : in Decimal_Fixed);
-
- procedure Divide_And_Truncate (Balance : in out Decimal_Fixed;
- Divisor : in Decimal_Fixed);
-
- procedure Multiply_And_Round (Balance : in out Decimal_Fixed;
- Factor : in Decimal_Fixed);
-
- procedure Divide_And_Round (Balance : in out Decimal_Fixed;
- Divisor : in Decimal_Fixed);
-
-end CXF2002_0;
-
-
- --==================================================================--
-
-
-package body CXF2002_0 is
-
- procedure Multiply_And_Truncate (Balance : in out Decimal_Fixed;
- Factor : in Decimal_Fixed) is
- Interest : Decimal_Fixed;
- begin
- Interest := Factor * Balance; -- Fixed-fixed multiplication.
- Balance := Balance + Interest;
- end Multiply_And_Truncate;
-
-
- procedure Divide_And_Truncate (Balance : in out Decimal_Fixed;
- Divisor : in Decimal_Fixed) is
- Interest : Decimal_Fixed;
- begin
- Interest := Balance / Divisor; -- Fixed-fixed division.
- Balance := Balance + Interest;
- end Divide_And_Truncate;
-
-
- procedure Multiply_And_Round (Balance : in out Decimal_Fixed;
- Factor : in Decimal_Fixed) is
- Interest : Decimal_Fixed;
- begin
- -- Fixed-fixed multiplication.
- Interest := Decimal_Fixed'Round ( Factor * Balance );
- Balance := Balance + Interest;
- end Multiply_And_Round;
-
-
- procedure Divide_And_Round (Balance : in out Decimal_Fixed;
- Divisor : in Decimal_Fixed) is
- Interest : Decimal_Fixed;
- begin
- -- Fixed-fixed division.
- Interest := Decimal_Fixed'Round ( Balance / Divisor );
- Balance := Balance + Interest;
- end Divide_And_Round;
-
-end CXF2002_0;
-
-
- --==================================================================--
-
-
-package CXF2002_1 is
-
- type Money_Radix2 is delta 0.01 digits 11; -- range -999,999,999.99 ..
- for Money_Radix2'Machine_Radix use 2; -- +999,999,999.99
-
-
- type Money_Radix10 is delta 0.01 digits 11; -- range -999,999,999.99 ..
- for Money_Radix10'Machine_Radix use 10; -- +999,999,999.99
-
-end CXF2002_1;
-
-
- --==================================================================--
-
-
-with CXF2002_0;
-with CXF2002_1;
-
-with Report;
-procedure CXF2002 is
-
- Loop_Count : constant := 300;
- type Loop_Range is range 1 .. Loop_Count;
-
-begin
-
- Report.Test ("CXF2002", "Check decimal multiplication and division, and " &
- "'Round, where the operand and result types are " &
- "the same");
-
-
- ---=---=---=---=---=---=---=---=---=---=---
-
-
- RADIX_2_SUBTESTS:
- declare
- package Radix_2 is new CXF2002_0 (CXF2002_1.Money_Radix2);
- use type CXF2002_1.Money_Radix2;
- begin
-
- RADIX_2_MULTIPLICATION:
- declare
- Rate : constant CXF2002_1.Money_Radix2 := 0.12;
- Period : constant Integer := 12;
- Factor : CXF2002_1.Money_Radix2 := Rate / Period;
-
- Initial : constant CXF2002_1.Money_Radix2 := 100_000.00;
- Trunc_Expected : constant CXF2002_1.Money_Radix2 := 1_978_837.50;
- Round_Expected : constant CXF2002_1.Money_Radix2 := 1_978_846.75;
-
- Balance : CXF2002_1.Money_Radix2;
- begin
- ---=---=---=---=---=---=---
-
- Balance := Initial;
-
- for I in Loop_Range loop
- Radix_2.Multiply_And_Truncate (Balance, Factor);
- end loop;
-
- if Balance /= Trunc_Expected then
- Report.Failed ("Wrong result: Radix 2 multiply and truncate");
- end if;
-
- ---=---=---=---=---=---=---
-
- Balance := Initial;
-
- for I in Loop_Range loop
- Radix_2.Multiply_And_Round (Balance, Factor);
- end loop;
-
- if Balance /= Round_Expected then
- Report.Failed ("Wrong result: Radix 2 multiply and round");
- end if;
-
- ---=---=---=---=---=---=---
- end RADIX_2_MULTIPLICATION;
-
-
- RADIX_2_DIVISION:
- declare
- Rate : constant CXF2002_1.Money_Radix2 := 0.25;
- Period : constant Integer := 12;
- Factor : CXF2002_1.Money_Radix2 := Rate / Period;
- Divisor : constant CXF2002_1.Money_Radix2 := 1.0 / Factor;
-
- Initial : constant CXF2002_1.Money_Radix2 := 5_500.36;
- Trunc_Expected : constant CXF2002_1.Money_Radix2 := 2_091_332.87;
- Round_Expected : constant CXF2002_1.Money_Radix2 := 2_091_436.88;
-
- Balance : CXF2002_1.Money_Radix2;
- begin
- ---=---=---=---=---=---=---
-
- Balance := Initial;
-
- for I in Loop_Range loop
- Radix_2.Divide_And_Truncate (Balance, Divisor);
- end loop;
-
- if Balance /= Trunc_Expected then
- Report.Failed ("Wrong result: Radix 2 divide and truncate");
- end if;
-
- ---=---=---=---=---=---=---
-
- Balance := Initial;
-
- for I in Loop_Range loop
- Radix_2.Divide_And_Round (Balance, Divisor);
- end loop;
-
- if Balance /= Round_Expected then
- Report.Failed ("Wrong result: Radix 2 divide and round");
- end if;
-
- ---=---=---=---=---=---=---
- end RADIX_2_DIVISION;
-
- end RADIX_2_SUBTESTS;
-
-
- ---=---=---=---=---=---=---=---=---=---=---
-
-
- RADIX_10_SUBTESTS:
- declare
- package Radix_10 is new CXF2002_0 (CXF2002_1.Money_Radix10);
- use type CXF2002_1.Money_Radix10;
- begin
-
- RADIX_10_MULTIPLICATION:
- declare
- Rate : constant CXF2002_1.Money_Radix10 := 0.37;
- Period : constant Integer := 12;
- Factor : CXF2002_1.Money_Radix10 := Rate / Period;
-
- Initial : constant CXF2002_1.Money_Radix10 := 459.33;
- Trunc_Expected : constant CXF2002_1.Money_Radix10 := 3_259_305.54;
- Round_Expected : constant CXF2002_1.Money_Radix10 := 3_260_544.11;
-
- Balance : CXF2002_1.Money_Radix10;
- begin
- ---=---=---=---=---=---=---
-
- Balance := Initial;
-
- for I in Loop_Range loop
- Radix_10.Multiply_And_Truncate (Balance, Factor);
- end loop;
-
- if Balance /= Trunc_Expected then
- Report.Failed ("Wrong result: Radix 10 multiply and truncate");
- end if;
-
- ---=---=---=---=---=---=---
-
- Balance := Initial;
-
- for I in Loop_Range loop
- Radix_10.Multiply_And_Round (Balance, Factor);
- end loop;
-
- if Balance /= Round_Expected then
- Report.Failed ("Wrong result: Radix 10 multiply and round");
- end if;
-
- ---=---=---=---=---=---=---
- end RADIX_10_MULTIPLICATION;
-
-
- RADIX_10_DIVISION:
- declare
- Rate : constant CXF2002_1.Money_Radix10 := 0.15;
- Period : constant Integer := 12;
- Factor : CXF2002_1.Money_Radix10 := Rate / Period;
- Divisor : constant CXF2002_1.Money_Radix10 := 1.0 / Factor;
-
- Initial : constant CXF2002_1.Money_Radix10 := 29_842.08;
- Trunc_Expected : constant CXF2002_1.Money_Radix10 := 590_519.47;
- Round_Expected : constant CXF2002_1.Money_Radix10 := 590_528.98;
-
- Balance : CXF2002_1.Money_Radix10;
- begin
- ---=---=---=---=---=---=---
-
- Balance := Initial;
-
- for I in Loop_Range loop
- Radix_10.Divide_And_Truncate (Balance, Divisor);
- end loop;
-
- if Balance /= Trunc_Expected then
- Report.Failed ("Wrong result: Radix 10 divide and truncate");
- end if;
-
- ---=---=---=---=---=---=---
-
- Balance := Initial;
-
- for I in Loop_Range loop
- Radix_10.Divide_And_Round (Balance, Divisor);
- end loop;
-
- if Balance /= Round_Expected then
- Report.Failed ("Wrong result: Radix 10 divide and round");
- end if;
-
- ---=---=---=---=---=---=---
- end RADIX_10_DIVISION;
-
- end RADIX_10_SUBTESTS;
-
-
- ---=---=---=---=---=---=---=---=---=---=---
-
-
- Report.Result;
-
-end CXF2002;
diff --git a/gcc/testsuite/ada/acats/tests/cxf/cxf2003.a b/gcc/testsuite/ada/acats/tests/cxf/cxf2003.a
deleted file mode 100644
index 133dc48e6c2..00000000000
--- a/gcc/testsuite/ada/acats/tests/cxf/cxf2003.a
+++ /dev/null
@@ -1,363 +0,0 @@
--- CXF2003.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that the multiplying operators for a decimal fixed point type
--- return values that are integral multiples of the small of the type.
--- Check the case where the two operands are of different decimal
--- fixed point types.
---
--- Check that if the mathematical result is between multiples of the
--- small of the result type, the result is truncated toward zero.
--- Check that if the attribute 'Round is applied to the mathematical
--- result, however, the result is rounded to the nearest multiple of
--- the small (away from zero if the result is midway between two
--- multiples of the small).
---
--- TEST DESCRIPTION:
--- Two decimal fixed point types A and B are declared, one with a
--- Machine_Radix value of 2, and one with a value of 10. A third decimal
--- fixed point type C is declared with digits and delta values different
--- from those of A and B. For type A (and B), checks are performed
--- on the following operations, where one operand type is C, and the
--- other operand type and the result type is A (or B):
---
--- - Multiplication.
--- - Multiplication, where the attribute 'Round is applied to the
--- result.
--- - Division.
--- - Division, where the attribute 'Round is applied to the result.
---
--- Each operation is performed within a loop, where one operand is
--- always the same variable. After the loop completes, the cumulative
--- total contained in this variable is compared with the expected
--- result.
---
--- APPLICABILITY CRITERIA:
--- This test is only applicable for a compiler attempting validation
--- for the Information Systems Annex.
---
---
--- CHANGE HISTORY:
--- 22 Mar 96 SAIC Prerelease version for ACVC 2.1.
---
---!
-
-generic
- type Decimal_Fixed_1 is delta <> digits <>;
- type Decimal_Fixed_2 is delta <> digits <>;
-package CXF2003_0 is
-
- procedure Multiply_And_Truncate (Balance : in out Decimal_Fixed_1;
- Factor : in Decimal_Fixed_2);
-
- procedure Divide_And_Truncate (Balance : in out Decimal_Fixed_1;
- Divisor : in Decimal_Fixed_2);
-
- procedure Multiply_And_Round (Balance : in out Decimal_Fixed_1;
- Factor : in Decimal_Fixed_2);
-
- procedure Divide_And_Round (Balance : in out Decimal_Fixed_1;
- Divisor : in Decimal_Fixed_2);
-
-end CXF2003_0;
-
-
- --==================================================================--
-
-
-package body CXF2003_0 is
-
- procedure Multiply_And_Truncate (Balance : in out Decimal_Fixed_1;
- Factor : in Decimal_Fixed_2) is
- Interest : Decimal_Fixed_1;
- begin
- Interest := Factor * Balance; -- Fixed-fixed multiplication.
- Balance := Balance + Interest;
- end Multiply_And_Truncate;
-
-
- procedure Divide_And_Truncate (Balance : in out Decimal_Fixed_1;
- Divisor : in Decimal_Fixed_2) is
- Interest : Decimal_Fixed_1;
- begin
- Interest := Balance / Divisor; -- Fixed-fixed division.
- Balance := Balance + Interest;
- end Divide_And_Truncate;
-
-
- procedure Multiply_And_Round (Balance : in out Decimal_Fixed_1;
- Factor : in Decimal_Fixed_2) is
- Interest : Decimal_Fixed_1;
- begin
- -- Fixed-fixed multiplication.
- Interest := Decimal_Fixed_1'Round ( Factor * Balance );
- Balance := Balance + Interest;
- end Multiply_And_Round;
-
-
- procedure Divide_And_Round (Balance : in out Decimal_Fixed_1;
- Divisor : in Decimal_Fixed_2) is
- Interest : Decimal_Fixed_1;
- begin
- -- Fixed-fixed division.
- Interest := Decimal_Fixed_1'Round ( Balance / Divisor );
- Balance := Balance + Interest;
- end Divide_And_Round;
-
-end CXF2003_0;
-
-
- --==================================================================--
-
-
-package CXF2003_1 is
-
- type Money_Radix2 is delta 0.01 digits 11; -- range -999,999,999.99 ..
- for Money_Radix2'Machine_Radix use 2; -- +999,999,999.99
-
-
- type Money_Radix10 is delta 0.01 digits 11; -- range -999,999,999.99 ..
- for Money_Radix10'Machine_Radix use 10; -- +999,999,999.99
-
-
- type Interest_Rate is delta 0.00001 digits 9; -- range -9999.99999 ..
- -- +9999.99999
-
-end CXF2003_1;
-
-
- --==================================================================--
-
-
-with CXF2003_0;
-with CXF2003_1;
-
-with Report;
-procedure CXF2003 is
-
- Loop_Count : constant := 1825;
- type Loop_Range is range 1 .. Loop_Count;
-
-begin
-
- Report.Test ("CXF2003", "Check decimal multiplication and division, and " &
- "'Round, where the operand types are different");
-
-
- ---=---=---=---=---=---=---=---=---=---=---
-
-
- RADIX_2_SUBTESTS:
- declare
- package Radix_2 is new CXF2003_0 (CXF2003_1.Money_Radix2,
- CXF2003_1.Interest_Rate);
- use type CXF2003_1.Money_Radix2;
- use type CXF2003_1.Interest_Rate;
- begin
-
- RADIX_2_MULTIPLICATION:
- declare
- Rate : CXF2003_1.Interest_Rate := 0.198;
- Period : Integer := 365;
- Factor : CXF2003_1.Interest_Rate := Rate / Period;
-
- Initial : constant CXF2003_1.Money_Radix2 := 1_000.00;
- Trunc_Expected : constant CXF2003_1.Money_Radix2 := 2_662.94;
- Round_Expected : constant CXF2003_1.Money_Radix2 := 2_678.34;
-
- Balance : CXF2003_1.Money_Radix2;
- begin
- ---=---=---=---=---=---=---
-
- Balance := Initial;
-
- for I in Loop_Range loop
- Radix_2.Multiply_And_Truncate (Balance, Factor);
- end loop;
-
- if Balance /= Trunc_Expected then
- Report.Failed ("Wrong result: Radix 2 multiply and truncate");
- end if;
-
- ---=---=---=---=---=---=---
-
- Balance := Initial;
-
- for I in Loop_Range loop
- Radix_2.Multiply_And_Round (Balance, Factor);
- end loop;
-
- if Balance /= Round_Expected then
- Report.Failed ("Wrong result: Radix 2 multiply and round");
- end if;
-
- ---=---=---=---=---=---=---
- end RADIX_2_MULTIPLICATION;
-
-
- RADIX_2_DIVISION:
- declare
- Rate : CXF2003_1.Interest_Rate := 0.129;
- Period : Integer := 365;
- Factor : CXF2003_1.Interest_Rate := Rate / Period;
- Divisor : CXF2003_1.Interest_Rate := 1.0 / Factor;
-
- Initial : constant CXF2003_1.Money_Radix2 := 14_626.52;
- Trunc_Expected : constant CXF2003_1.Money_Radix2 := 27_688.26;
- Round_Expected : constant CXF2003_1.Money_Radix2 := 27_701.12;
-
- Balance : CXF2003_1.Money_Radix2;
- begin
- ---=---=---=---=---=---=---
-
- Balance := Initial;
-
- for I in Loop_Range loop
- Radix_2.Divide_And_Truncate (Balance, Divisor);
- end loop;
-
- if Balance /= Trunc_Expected then
- Report.Failed ("Wrong result: Radix 2 divide and truncate");
- end if;
-
- ---=---=---=---=---=---=---
-
- Balance := Initial;
-
- for I in Loop_Range loop
- Radix_2.Divide_And_Round (Balance, Divisor);
- end loop;
-
- if Balance /= Round_Expected then
- Report.Failed ("Wrong result: Radix 2 divide and round");
- end if;
-
- ---=---=---=---=---=---=---
- end RADIX_2_DIVISION;
-
- end RADIX_2_SUBTESTS;
-
-
- ---=---=---=---=---=---=---=---=---=---=---
-
-
- RADIX_10_SUBTESTS:
- declare
- package Radix_10 is new CXF2003_0 (CXF2003_1.Money_Radix10,
- CXF2003_1.Interest_Rate);
- use type CXF2003_1.Money_Radix10;
- use type CXF2003_1.Interest_Rate;
- begin
-
- RADIX_10_MULTIPLICATION:
- declare
- Rate : CXF2003_1.Interest_Rate := 0.063;
- Period : Integer := 365;
- Factor : CXF2003_1.Interest_Rate := Rate / Period;
-
- Initial : constant CXF2003_1.Money_Radix10 := 314_036.10;
- Trunc_Expected : constant CXF2003_1.Money_Radix10 := 428_249.48;
- Round_Expected : constant CXF2003_1.Money_Radix10 := 428_260.52;
-
- Balance : CXF2003_1.Money_Radix10;
- begin
- ---=---=---=---=---=---=---
-
- Balance := Initial;
-
- for I in Loop_Range loop
- Radix_10.Multiply_And_Truncate (Balance, Factor);
- end loop;
-
- if Balance /= Trunc_Expected then
- Report.Failed ("Wrong result: Radix 10 multiply and truncate");
- end if;
-
- ---=---=---=---=---=---=---
-
- Balance := Initial;
-
- for I in Loop_Range loop
- Radix_10.Multiply_And_Round (Balance, Factor);
- end loop;
-
- if Balance /= Round_Expected then
- Report.Failed ("Wrong result: Radix 10 multiply and round");
- end if;
-
- ---=---=---=---=---=---=---
- end RADIX_10_MULTIPLICATION;
-
-
- RADIX_10_DIVISION:
- declare
- Rate : CXF2003_1.Interest_Rate := 0.273;
- Period : Integer := 365;
- Factor : CXF2003_1.Interest_Rate := Rate / Period;
- Divisor : CXF2003_1.Interest_Rate := 1.0 / Factor;
-
- Initial : constant CXF2003_1.Money_Radix10 := 25.72;
- Trunc_Expected : constant CXF2003_1.Money_Radix10 := 79.05;
- Round_Expected : constant CXF2003_1.Money_Radix10 := 97.46;
-
- Balance : CXF2003_1.Money_Radix10;
- begin
- ---=---=---=---=---=---=---
-
- Balance := Initial;
-
- for I in Loop_Range loop
- Radix_10.Divide_And_Truncate (Balance, Divisor);
- end loop;
-
- if Balance /= Trunc_Expected then
- Report.Failed ("Wrong result: Radix 10 divide and truncate");
- end if;
-
- ---=---=---=---=---=---=---
-
- Balance := Initial;
-
- for I in Loop_Range loop
- Radix_10.Divide_And_Round (Balance, Divisor);
- end loop;
-
- if Balance /= Round_Expected then
- Report.Failed ("Wrong result: Radix 10 divide and round");
- end if;
-
- ---=---=---=---=---=---=---
- end RADIX_10_DIVISION;
-
- end RADIX_10_SUBTESTS;
-
-
- ---=---=---=---=---=---=---=---=---=---=---
-
-
- Report.Result;
-
-end CXF2003;
diff --git a/gcc/testsuite/ada/acats/tests/cxf/cxf2004.a b/gcc/testsuite/ada/acats/tests/cxf/cxf2004.a
deleted file mode 100644
index 9651384ce7e..00000000000
--- a/gcc/testsuite/ada/acats/tests/cxf/cxf2004.a
+++ /dev/null
@@ -1,513 +0,0 @@
--- CXF2004.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that the multiplying operators for a decimal fixed point type
--- return values that are integral multiples of the small of the type.
--- Check the case where one operand is of an ordinary fixed point type.
---
--- Check that if the mathematical result is between multiples of the
--- small of the result type, the result is truncated toward zero.
--- Check that if the attribute 'Round is applied to the mathematical
--- result, however, the result is rounded to the nearest multiple of
--- the small (away from zero if the result is midway between two
--- multiples of the small).
---
--- TEST DESCRIPTION:
--- Two decimal fixed point types A and B are declared, one with a
--- Machine_Radix value of 2, and one with a value of 10. An ordinary
--- fixed point type C is declared with a delta value different from
--- those of A and B (although still a power of 10). For type A (and B),
--- checks are performed on the following operations, where one operand
--- type is C, and the other operand type and the result type is A (or B):
---
--- - Multiplication.
--- - Multiplication, where the attribute 'Round is applied to the
--- result.
--- - Division.
--- - Division, where the attribute 'Round is applied to the result.
---
--- Each operation is performed within a loop, where one operand is
--- always the same variable. After the loop completes, the cumulative
--- total contained in this variable is compared with the expected
--- result.
---
--- APPLICABILITY CRITERIA:
--- This test is only applicable for a compiler attempting validation
--- for the Information Systems Annex.
---
---
--- CHANGE HISTORY:
--- 22 Mar 96 SAIC Prerelease version for ACVC 2.1.
--- 11 Aug 96 SAIC ACVC 2.1: In RADIX_2_MULTIPLICATION, corrected
--- value of Rate. Corrected associated commentary.
---
---!
-
-generic
- type Decimal_Fixed is delta <> digits <>;
- type Ordinary_Fixed is delta <>;
-package CXF2004_0 is
-
- procedure Multiply_And_Truncate (Balance : in out Decimal_Fixed;
- Factor : in Ordinary_Fixed);
-
- procedure Divide_And_Truncate (Balance : in out Decimal_Fixed;
- Divisor : in Ordinary_Fixed);
-
- procedure Multiply_And_Round (Balance : in out Decimal_Fixed;
- Factor : in Ordinary_Fixed);
-
- procedure Divide_And_Round (Balance : in out Decimal_Fixed;
- Divisor : in Ordinary_Fixed);
-
-end CXF2004_0;
-
-
- --==================================================================--
-
-
-package body CXF2004_0 is
-
- procedure Multiply_And_Truncate (Balance : in out Decimal_Fixed;
- Factor : in Ordinary_Fixed) is
- Interest : Decimal_Fixed;
- begin
- Interest := Factor * Balance; -- Fixed-fixed multiplication.
- Balance := Balance + Interest;
- end Multiply_And_Truncate;
-
-
- procedure Divide_And_Truncate (Balance : in out Decimal_Fixed;
- Divisor : in Ordinary_Fixed) is
- Interest : Decimal_Fixed;
- begin
- Interest := Balance / Divisor; -- Fixed-fixed division.
- Balance := Balance + Interest;
- end Divide_And_Truncate;
-
-
- procedure Multiply_And_Round (Balance : in out Decimal_Fixed;
- Factor : in Ordinary_Fixed) is
- Interest : Decimal_Fixed;
- begin
- -- Fixed-fixed multiplication.
- Interest := Decimal_Fixed'Round ( Factor * Balance );
- Balance := Balance + Interest;
- end Multiply_And_Round;
-
-
- procedure Divide_And_Round (Balance : in out Decimal_Fixed;
- Divisor : in Ordinary_Fixed) is
- Interest : Decimal_Fixed;
- begin
- -- Fixed-fixed division.
- Interest := Decimal_Fixed'Round ( Balance / Divisor );
- Balance := Balance + Interest;
- end Divide_And_Round;
-
-end CXF2004_0;
-
-
- --==================================================================--
-
-
-package CXF2004_1 is
-
- type Money_Radix2 is delta 0.01 digits 11; -- range -999,999,999.99 ..
- for Money_Radix2'Machine_Radix use 2; -- +999,999,999.99
-
-
- type Money_Radix10 is delta 0.01 digits 11; -- range -999,999,999.99 ..
- for Money_Radix10'Machine_Radix use 10; -- +999,999,999.99
-
-
- type Interest_Rate is delta 0.001 range 0.0 .. 1_000.0;
- for Interest_Rate'Small use 0.001; -- Power of 10.
-
-end CXF2004_1;
-
-
- --==================================================================--
-
-
-with CXF2004_0;
-with CXF2004_1;
-
-with Report;
-procedure CXF2004 is
-
- Loop_Count : constant := 180;
- type Loop_Range is range 1 .. Loop_Count;
-
- type Rounding_Scheme is ( Rounds, Truncates );
- Machine : Rounding_Scheme;
-
-begin
-
- Report.Test ("CXF2004", "Check decimal multiplication and division, and " &
- "'Round, where one operand type is ordinary fixed");
-
-
- ---=---=---=---=---=---=---=---=---=---=---
-
- if CXF2004_1.Interest_Rate'Machine_Rounds then -- Determine machine's
- Machine := Rounds; -- rounding scheme.
- else
- Machine := Truncates;
- end if;
-
- ---=---=---=---=---=---=---=---=---=---=---
-
-
- RADIX_2_SUBTESTS:
- declare
- package Radix_2 is new CXF2004_0 (CXF2004_1.Money_Radix2,
- CXF2004_1.Interest_Rate);
- use type CXF2004_1.Money_Radix2;
- use type CXF2004_1.Interest_Rate;
- begin
-
- RADIX_2_MULTIPLICATION:
- declare
- Rate : constant CXF2004_1.Interest_Rate := 0.154;
- Period : constant Integer := 12;
- Factor : CXF2004_1.Interest_Rate := Rate / Period;
-
- -- The exact value of Factor is:
- --
- -- 0.154/12 = 0.01283333...
- --
- -- The adjacent multiples of small are 0.012 and 0.013. Since
- -- Factor is of an ordinary fixed point type, it may contain either
- -- of these values. However, since "Rate / Period" is a static
- -- expression, the value Factor contains is determined by the
- -- value of CXF2004_1.Interest_Rate'Machine_Rounds:
- --
- -- If Machine_Rounds = FALSE : Factor = 0.012
- -- If Machine_Rounds = TRUE : Factor = 0.013
-
- Initial : constant CXF2004_1.Money_Radix2 := 1_000.00;
-
- Trunc_Expected_MachTrnc: constant CXF2004_1.Money_Radix2 := 8_557.07;
- Round_Expected_MachTrnc: constant CXF2004_1.Money_Radix2 := 8_560.47;
-
- Trunc_Expected_MachRnds: constant CXF2004_1.Money_Radix2 := 10_222.65;
- Round_Expected_MachRnds: constant CXF2004_1.Money_Radix2 := 10_225.81;
-
- Balance : CXF2004_1.Money_Radix2;
- begin
- ---=---=---=---=---=---=---
-
- Balance := Initial;
-
- for I in Loop_Range loop
- Radix_2.Multiply_And_Truncate (Balance, Factor);
- end loop;
-
- case (Machine) is
- when Rounds =>
- if Balance /= Trunc_Expected_MachRnds then
- Report.Failed ("Error (R): Radix 2 multiply and truncate");
- end if;
- when Truncates =>
- if Balance /= Trunc_Expected_MachTrnc then
- Report.Failed ("Error (T): Radix 2 multiply and truncate");
- end if;
- end case;
-
- ---=---=---=---=---=---=---
-
- Balance := Initial;
-
- for I in Loop_Range loop
- Radix_2.Multiply_And_Round (Balance, Factor);
- end loop;
-
- case (Machine) is
- when Rounds =>
- if Balance /= Round_Expected_MachRnds then
- Report.Failed ("Error (R): Radix 2 multiply and round");
- end if;
- when Truncates =>
- if Balance /= Round_Expected_MachTrnc then
- Report.Failed ("Error (T): Radix 2 multiply and round");
- end if;
- end case;
-
- ---=---=---=---=---=---=---
- end RADIX_2_MULTIPLICATION;
-
-
- RADIX_2_DIVISION:
- declare
- Rate : constant CXF2004_1.Interest_Rate := 0.210;
- Period : constant Integer := 12;
- Factor : constant CXF2004_1.Interest_Rate := Rate / Period;
- Divisor : CXF2004_1.Interest_Rate := 1.0 / Factor;
-
- -- The exact value of Factor is:
- --
- -- 0.210/12 = 0.0175
- --
- -- The adjacent multiples of small are 0.017 and 0.018. Since
- -- Factor is of an ordinary fixed point type, it may contain either
- -- of these values. However, since "Rate / Period" is a static
- -- expression, the value Factor contains is determined by the
- -- value of CXF2004_1.Interest_Rate'Machine_Rounds:
- --
- -- If Machine_Rounds = FALSE : Factor = 0.017
- -- If Machine_Rounds = TRUE : Factor = 0.018
- --
- -- The exact value of Divisor is one of the following values:
- --
- -- 1.0/0.017 = 58.82352... (Adjacent smalls 58.823 and 58.824)
- -- 1.0/0.018 = 55.55555... (Adjacent smalls 55.555 and 55.556)
- --
- -- Again, since "1.0 / Factor" is static, the value Divisor contains
- -- is determined by the value of CXF2004_1.Interest_Rate'Rounds:
- --
- -- If Machine_Rounds = FALSE : Divisor = 58.823
- -- If Machine_Rounds = TRUE : Divisor = 55.556
-
- Initial : constant CXF2004_1.Money_Radix2 := 260.13;
-
- Trunc_Expected_MachTrnc: constant CXF2004_1.Money_Radix2 := 5_401.46;
- Round_Expected_MachTrnc: constant CXF2004_1.Money_Radix2 := 5_406.95;
-
- Trunc_Expected_MachRnds: constant CXF2004_1.Money_Radix2 := 6_446.56;
- Round_Expected_MachRnds: constant CXF2004_1.Money_Radix2 := 6_453.78;
-
- Balance : CXF2004_1.Money_Radix2;
- begin
- ---=---=---=---=---=---=---
-
- Balance := Initial;
-
- for I in Loop_Range loop
- Radix_2.Divide_And_Truncate (Balance, Divisor);
- end loop;
-
- case (Machine) is
- when Rounds =>
- if Balance /= Trunc_Expected_MachRnds then
- Report.Failed ("Error (R): Radix 2 divide and truncate");
- end if;
- when Truncates =>
- if Balance /= Trunc_Expected_MachTrnc then
- Report.Failed ("Error (T): Radix 2 divide and truncate");
- end if;
- end case;
-
- ---=---=---=---=---=---=---
-
- Balance := Initial;
-
- for I in Loop_Range loop
- Radix_2.Divide_And_Round (Balance, Divisor);
- end loop;
-
- case (Machine) is
- when Rounds =>
- if Balance /= Round_Expected_MachRnds then
- Report.Failed ("Error (R): Radix 2 divide and round");
- end if;
- when Truncates =>
- if Balance /= Round_Expected_MachTrnc then
- Report.Failed ("Error (T): Radix 2 divide and round");
- end if;
- end case;
-
- ---=---=---=---=---=---=---
- end RADIX_2_DIVISION;
-
- end RADIX_2_SUBTESTS;
-
-
- ---=---=---=---=---=---=---=---=---=---=---
-
-
- RADIX_10_SUBTESTS:
- declare
- package Radix_10 is new CXF2004_0 (CXF2004_1.Money_Radix10,
- CXF2004_1.Interest_Rate);
- use type CXF2004_1.Money_Radix10;
- use type CXF2004_1.Interest_Rate;
- begin
-
- RADIX_10_MULTIPLICATION:
- declare
- Rate : constant CXF2004_1.Interest_Rate := 0.095;
- Period : constant Integer := 12;
- Factor : CXF2004_1.Interest_Rate := Rate / Period;
-
- -- The exact value of Factor is:
- --
- -- 0.095/12 = 0.00791666...
- --
- -- The adjacent multiples of small are 0.007 and 0.008. Since
- -- Factor is of an ordinary fixed point type, it may contain either
- -- of these values. However, since "Rate / Period" is a static
- -- expression, the value Factor contains can be determined based
- -- on the value of CXF2004_1.Interest_Rate'Machine_Rounds:
- --
- -- If Machine_Rounds = FALSE : Factor = 0.007
- -- If Machine_Rounds = TRUE : Factor = 0.008
-
- Initial : constant CXF2004_1.Money_Radix10 := 2_125.00;
-
- Trunc_Expected_MachTrnc: constant CXF2004_1.Money_Radix10 := 7_456.90;
- Round_Expected_MachTrnc: constant CXF2004_1.Money_Radix10 := 7_458.77;
-
- Trunc_Expected_MachRnds: constant CXF2004_1.Money_Radix10 := 8_915.74;
- Round_Expected_MachRnds: constant CXF2004_1.Money_Radix10 := 8_917.84;
-
- Balance : CXF2004_1.Money_Radix10;
- begin
- ---=---=---=---=---=---=---
-
- Balance := Initial;
-
- for I in Loop_Range loop
- Radix_10.Multiply_And_Truncate (Balance, Factor);
- end loop;
-
- case (Machine) is
- when Rounds =>
- if Balance /= Trunc_Expected_MachRnds then
- Report.Failed ("Error (R): Radix 10 multiply and truncate");
- end if;
- when Truncates =>
- if Balance /= Trunc_Expected_MachTrnc then
- Report.Failed ("Error (T): Radix 10 multiply and truncate");
- end if;
- end case;
-
- ---=---=---=---=---=---=---
-
- Balance := Initial;
-
- for I in Loop_Range loop
- Radix_10.Multiply_And_Round (Balance, Factor);
- end loop;
-
- case (Machine) is
- when Rounds =>
- if Balance /= Round_Expected_MachRnds then
- Report.Failed ("Error (R): Radix 10 multiply and round");
- end if;
- when Truncates =>
- if Balance /= Round_Expected_MachTrnc then
- Report.Failed ("Error (T): Radix 10 multiply and round");
- end if;
- end case;
-
- ---=---=---=---=---=---=---
- end RADIX_10_MULTIPLICATION;
-
-
- RADIX_10_DIVISION:
- declare
- Rate : constant CXF2004_1.Interest_Rate := 0.295;
- Period : constant Integer := 12;
- Factor : constant CXF2004_1.Interest_Rate := Rate / Period;
- Divisor : CXF2004_1.Interest_Rate := 1.0 / Factor;
-
- -- The exact value of Factor is:
- --
- -- 0.295/12 = 0.02458333...
- --
- -- The adjacent multiples of small are 0.024 and 0.025. Thus, the
- -- exact value of Divisor is one of the following:
- --
- -- 1.0/0.024 = 41.66666... (Adjacent smalls 41.666 and 41.667)
- -- 1.0/0.025 = 40.0
- --
- -- The value of CXF2004_1.Interest_Rate'Machine_Rounds determines
- -- what Divisor contains:
- --
- -- If Machine_Rounds = FALSE : Divisor = 41.666
- -- If Machine_Rounds = TRUE : Divisor = 40.000
-
- Initial : constant CXF2004_1.Money_Radix10 := 72.19;
-
- Trunc_Expected_MachTrnc: constant CXF2004_1.Money_Radix10 := 5_144.60;
- Round_Expected_MachTrnc: constant CXF2004_1.Money_Radix10 := 5_157.80;
-
- Trunc_Expected_MachRnds: constant CXF2004_1.Money_Radix10 := 6_133.28;
- Round_Expected_MachRnds: constant CXF2004_1.Money_Radix10 := 6_149.06;
-
- Balance : CXF2004_1.Money_Radix10;
- begin
- ---=---=---=---=---=---=---
-
- Balance := Initial;
-
- for I in Loop_Range loop
- Radix_10.Divide_And_Truncate (Balance, Divisor);
- end loop;
-
- case (Machine) is
- when Rounds =>
- if Balance /= Trunc_Expected_MachRnds then
- Report.Failed ("Error (R): Radix 10 divide and truncate");
- end if;
- when Truncates =>
- if Balance /= Trunc_Expected_MachTrnc then
- Report.Failed ("Error (T): Radix 10 divide and truncate");
- end if;
- end case;
-
- ---=---=---=---=---=---=---
-
- Balance := Initial;
-
- for I in Loop_Range loop
- Radix_10.Divide_And_Round (Balance, Divisor);
- end loop;
-
- case (Machine) is
- when Rounds =>
- if Balance /= Round_Expected_MachRnds then
- Report.Failed ("Error (R): Radix 10 divide and round");
- end if;
- when Truncates =>
- if Balance /= Round_Expected_MachTrnc then
- Report.Failed ("Error (T): Radix 10 divide and round");
- end if;
- end case;
-
- ---=---=---=---=---=---=---
- end RADIX_10_DIVISION;
-
- end RADIX_10_SUBTESTS;
-
-
- ---=---=---=---=---=---=---=---=---=---=---
-
-
- Report.Result;
-
-end CXF2004;
diff --git a/gcc/testsuite/ada/acats/tests/cxf/cxf2005.a b/gcc/testsuite/ada/acats/tests/cxf/cxf2005.a
deleted file mode 100644
index 71cd5bb31b5..00000000000
--- a/gcc/testsuite/ada/acats/tests/cxf/cxf2005.a
+++ /dev/null
@@ -1,293 +0,0 @@
--- CXF2005.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that the multiplying operators for a decimal fixed point type
--- return values that are integral multiples of the small of the type.
--- Check the case where one operand is of the predefined type Integer.
---
--- TEST DESCRIPTION:
--- Two decimal fixed point types A and B are declared, one with a
--- Machine_Radix value of 2, and one with a value of 10. A variable of
--- each type is multiplied repeatedly by a series of different Integer
--- values. A cumulative result is kept and compared to an expected
--- final result. Similar checks are performed for division.
---
--- APPLICABILITY CRITERIA:
--- This test is only applicable for a compiler attempting validation
--- for the Information Systems Annex.
---
---
--- CHANGE HISTORY:
--- 28 Mar 96 SAIC Prerelease version for ACVC 2.1.
---
---!
-
-generic
- type Decimal_Fixed is delta <> digits <>;
-package CXF2005_0 is
-
- function Multiply (Operand : Decimal_Fixed;
- Interval : Integer) return Decimal_Fixed;
-
- function Divide (Operand : Decimal_Fixed;
- Interval : Integer) return Decimal_Fixed;
-
-end CXF2005_0;
-
-
- --==================================================================--
-
-
-package body CXF2005_0 is
-
- function Multiply (Operand : Decimal_Fixed;
- Interval : Integer) return Decimal_Fixed is
- begin
- return Operand * Interval; -- Fixed-Integer multiplication.
- end Multiply;
-
-
- function Divide (Operand : Decimal_Fixed;
- Interval : Integer) return Decimal_Fixed is
- begin
- return Operand / Interval; -- Fixed-Integer division.
- end Divide;
-
-end CXF2005_0;
-
-
- --==================================================================--
-
-
-package CXF2005_1 is
-
- ---=---=---=---=---=---=---=---=---=---=---
-
- type Interest_Rate is delta 0.001 range 0.0 .. 1_000.0;
- for Interest_Rate'Small use 0.001; -- Power of 10.
-
- ---=---=---=---=---=---=---=---=---=---=---
-
- type Money_Radix2 is delta 0.01 digits 11; -- range -999,999,999.99 ..
- for Money_Radix2'Machine_Radix use 2; -- +999,999,999.99
-
- function Factor (Rate : Interest_Rate;
- Interval : Integer) return Money_Radix2;
-
- ---=---=---=---=---=---=---=---=---=---=---
-
- type Money_Radix10 is delta 0.01 digits 11; -- range -999,999,999.99 ..
- for Money_Radix10'Machine_Radix use 10; -- +999,999,999.99
-
- function Factor (Rate : Interest_Rate;
- Interval : Integer) return Money_Radix10;
-
- ---=---=---=---=---=---=---=---=---=---=---
-
-end CXF2005_1;
-
-
- --==================================================================--
-
-
-package body CXF2005_1 is
-
- ---=---=---=---=---=---=---=---=---=---=---
-
- function Factor (Rate : Interest_Rate;
- Interval : Integer) return Money_Radix2 is
- begin
- return Money_Radix2( Rate / Interval );
- end Factor;
-
- ---=---=---=---=---=---=---=---=---=---=---
-
- function Factor (Rate : Interest_Rate;
- Interval : Integer) return Money_Radix10 is
- begin
- return Money_Radix10( Rate / Interval );
- end Factor;
-
- ---=---=---=---=---=---=---=---=---=---=---
-
-end CXF2005_1;
-
-
- --==================================================================--
-
-
-with CXF2005_0;
-with CXF2005_1;
-
-with Report;
-procedure CXF2005 is
-
- Loop_Count : constant := 25_000;
- type Loop_Range is range 1 .. Loop_Count;
-
-begin
-
- Report.Test ("CXF2005", "Check decimal multiplication and division, " &
- "where one operand type is Integer");
-
-
- ---=---=---=---=---=---=---=---=---=---=---
-
-
- RADIX_2_SUBTESTS:
- declare
- package Radix_2 is new CXF2005_0 (CXF2005_1.Money_Radix2);
- use type CXF2005_1.Money_Radix2;
- begin
-
- RADIX_2_MULTIPLICATION:
- declare
- Rate : constant CXF2005_1.Interest_Rate := 0.127;
- Period : constant Integer := 12;
-
- Expected : constant CXF2005_1.Money_Radix2 := 2_624.88;
- Balance : CXF2005_1.Money_Radix2 := 1_000.00;
-
- Operand : CXF2005_1.Money_Radix2;
- Increment : CXF2005_1.Money_Radix2;
- Interval : Integer;
- begin
-
- for I in Loop_Range loop
- Interval := (Integer(I) mod Period) + 1; -- Range from 1 to 12.
- Operand := CXF2005_1.Factor (Rate, Period);
- Increment := Radix_2.Multiply (Operand, Interval);
- Balance := Balance + Increment;
- end loop;
-
- if Balance /= Expected then
- Report.Failed ("Error: Radix 2 multiply");
- end if;
-
- end RADIX_2_MULTIPLICATION;
-
-
-
- RADIX_2_DIVISION:
- declare
- Rate : constant CXF2005_1.Interest_Rate := 0.377;
- Period : constant Integer := 12;
-
- Expected : constant CXF2005_1.Money_Radix2 := 36_215.58;
- Balance : CXF2005_1.Money_Radix2 := 456_985.01;
-
- Operand : CXF2005_1.Money_Radix2;
- Increment : CXF2005_1.Money_Radix2;
- Interval : Integer;
- begin
-
- for I in Loop_Range loop
- Interval := (Integer(I+1000) mod (200*Period)) + 1; -- 1 .. 2400.
- Operand := CXF2005_1.Factor (Rate, Period);
- Increment := Radix_2.Divide (Balance, Interval);
- Balance := Balance - (Operand * Increment);
- end loop;
-
- if Balance /= Expected then
- Report.Failed ("Error: Radix 2 divide");
- end if;
-
- end RADIX_2_DIVISION;
-
- end RADIX_2_SUBTESTS;
-
-
- ---=---=---=---=---=---=---=---=---=---=---
-
-
- RADIX_10_SUBTESTS:
- declare
- package Radix_10 is new CXF2005_0 (CXF2005_1.Money_Radix10);
- use type CXF2005_1.Money_Radix10;
- begin
-
- RADIX_10_MULTIPLICATION:
- declare
- Rate : constant CXF2005_1.Interest_Rate := 0.721;
- Period : constant Integer := 12;
-
- Expected : constant CXF2005_1.Money_Radix10 := 9_875.62;
- Balance : CXF2005_1.Money_Radix10 := 126.34;
-
- Operand : CXF2005_1.Money_Radix10;
- Increment : CXF2005_1.Money_Radix10;
- Interval : Integer;
- begin
-
- for I in Loop_Range loop
- Interval := (Integer(I) mod Period) + 1; -- Range from 1 to 12.
- Operand := CXF2005_1.Factor (Rate, Period);
- Increment := Radix_10.Multiply (Operand, Interval);
- Balance := Balance + Increment;
- end loop;
-
- if Balance /= Expected then
- Report.Failed ("Error: Radix 10 multiply");
- end if;
-
- end RADIX_10_MULTIPLICATION;
-
-
- RADIX_10_DIVISION:
- declare
- Rate : constant CXF2005_1.Interest_Rate := 0.547;
- Period : constant Integer := 12;
-
- Expected : constant CXF2005_1.Money_Radix10 := 26_116.37;
- Balance : CXF2005_1.Money_Radix10 := 770_082.46;
-
- Operand : CXF2005_1.Money_Radix10;
- Increment : CXF2005_1.Money_Radix10;
- Interval : Integer;
- begin
-
- for I in Loop_Range loop
- Interval := (Integer(I+1000) mod (200*Period)) + 1; -- 1 .. 2400.
- Operand := CXF2005_1.Factor (Rate, Period);
- Increment := Radix_10.Divide (Balance, Interval);
- Balance := Balance - (Operand * Increment);
- end loop;
-
- if Balance /= Expected then
- Report.Failed ("Error: Radix 10 divide");
- end if;
-
- end RADIX_10_DIVISION;
-
- end RADIX_10_SUBTESTS;
-
-
- ---=---=---=---=---=---=---=---=---=---=---
-
-
- Report.Result;
-
-end CXF2005;
diff --git a/gcc/testsuite/ada/acats/tests/cxf/cxf2a01.a b/gcc/testsuite/ada/acats/tests/cxf/cxf2a01.a
deleted file mode 100644
index 002c59d6c8e..00000000000
--- a/gcc/testsuite/ada/acats/tests/cxf/cxf2a01.a
+++ /dev/null
@@ -1,448 +0,0 @@
--- CXF2A01.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that the binary adding operators for a decimal fixed point type
--- return values that are integral multiples of the small of the type.
---
--- TEST DESCRIPTION:
--- The test verifies that decimal addition and subtraction behave as
--- expected for types with various digits, delta, and Machine_Radix
--- values. Types with the minimum values for Decimal.Max_Digits and
--- Decimal.Max_Scale (18) are included.
---
--- Two kinds of checks are performed for each type. In the first check,
--- the iteration, operation, and operand counts in the foundation and
--- the operation tables in this test are given values such that, when the
--- operations loop is complete, each operand will have been added to and
--- subtracted from the loop's cumulator variable the same number of times,
--- albeit in varying order. Thus, the result returned by the operations
--- loop should have the same value as that used to initialize the
--- cumulator (in this test, zero).
---
--- In the second check, the same operation (addition for some types and
--- subtraction for others) is performed during each loop iteration,
--- resulting in a cumulative total which is checked against an expected
--- value.
---
--- TEST FILES:
--- The following files comprise this test:
---
--- FXF2A00.A
--- -> CXF2A01.A
---
--- APPLICABILITY CRITERIA:
--- This test is only applicable for a compiler attempting validation
--- for the Information Systems Annex.
---
---
--- CHANGE HISTORY:
--- 08 Apr 96 SAIC Prerelease version for ACVC 2.1.
---
---!
-
-package CXF2A01_0 is
-
- ---=---=---=---=---=---=---=---=---=---=---
-
- type Micro is delta 10.0**(-18) digits 18; -- range -0.999999999999999999 ..
- for Micro'Machine_Radix use 10; -- +0.999999999999999999
-
- function Add (Left, Right : Micro) return Micro;
- function Subtract (Left, Right : Micro) return Micro;
-
-
- type Micro_Optr_Ptr is access function (Left, Right : Micro) return Micro;
-
- Micro_Add : Micro_Optr_Ptr := Add'Access;
- Micro_Sub : Micro_Optr_Ptr := Subtract'Access;
-
- ---=---=---=---=---=---=---=---=---=---=---
-
- type Money is delta 0.01 digits 11; -- range -999,999,999.99 ..
- for Money'Machine_Radix use 2; -- +999,999,999.99
-
- function Add (Left, Right : Money) return Money;
- function Subtract (Left, Right : Money) return Money;
-
-
- type Money_Optr_Ptr is access function (Left, Right : Money) return Money;
-
- Money_Add : Money_Optr_Ptr := Add'Access;
- Money_Sub : Money_Optr_Ptr := Subtract'Access;
-
- ---=---=---=---=---=---=---=---=---=---=---
-
- -- Same as Money, but with Radix 10:
-
- type Cash is delta 0.01 digits 11; -- range -999,999,999.99 ..
- for Cash'Machine_Radix use 10; -- +999,999,999.99
-
- function Add (Left, Right : Cash) return Cash;
- function Subtract (Left, Right : Cash) return Cash;
-
-
- type Cash_Optr_Ptr is access function (Left, Right : Cash) return Cash;
-
- Cash_Add : Cash_Optr_Ptr := Add'Access;
- Cash_Sub : Cash_Optr_Ptr := Subtract'Access;
-
- ---=---=---=---=---=---=---=---=---=---=---
-
- type Broad is delta 10.0**(-9) digits 18; -- range -999,999,999.999999999 ..
- for Broad'Machine_Radix use 10; -- +999,999,999.999999999
-
- function Add (Left, Right : Broad) return Broad;
- function Subtract (Left, Right : Broad) return Broad;
-
-
- type Broad_Optr_Ptr is access function (Left, Right : Broad) return Broad;
-
- Broad_Add : Broad_Optr_Ptr := Add'Access;
- Broad_Sub : Broad_Optr_Ptr := Subtract'Access;
-
- ---=---=---=---=---=---=---=---=---=---=---
-
-end CXF2A01_0;
-
-
- --==================================================================--
-
-
-package body CXF2A01_0 is
-
- ---=---=---=---=---=---=---=---=---=---=---
-
- function Add (Left, Right : Micro) return Micro is
- begin
- return (Left + Right); -- Decimal fixed addition.
- end Add;
-
- function Subtract (Left, Right : Micro) return Micro is
- begin
- return (Left - Right); -- Decimal fixed subtraction.
- end Subtract;
-
- ---=---=---=---=---=---=---=---=---=---=---
-
- function Add (Left, Right : Money) return Money is
- begin
- return (Left + Right); -- Decimal fixed addition.
- end Add;
-
- function Subtract (Left, Right : Money) return Money is
- begin
- return (Left - Right); -- Decimal fixed subtraction.
- end Subtract;
-
- ---=---=---=---=---=---=---=---=---=---=---
-
- function Add (Left, Right : Cash) return Cash is
- begin
- return (Left + Right); -- Decimal fixed addition.
- end Add;
-
- function Subtract (Left, Right : Cash) return Cash is
- begin
- return (Left - Right); -- Decimal fixed subtraction.
- end Subtract;
-
- ---=---=---=---=---=---=---=---=---=---=---
-
- function Add (Left, Right : Broad) return Broad is
- begin
- return (Left + Right); -- Decimal fixed addition.
- end Add;
-
- function Subtract (Left, Right : Broad) return Broad is
- begin
- return (Left - Right); -- Decimal fixed subtraction.
- end Subtract;
-
- ---=---=---=---=---=---=---=---=---=---=---
-
-end CXF2A01_0;
-
-
- --==================================================================--
-
-
-with FXF2A00;
-package CXF2A01_0.CXF2A01_1 is
-
- ---=---=---=---=---=---=---=---=---=---=---
-
- type Micro_Ops is array (FXF2A00.Optr_Range) of Micro_Optr_Ptr;
- type Micro_Opnds is array (FXF2A00.Opnd_Range) of Micro;
-
- Micro_Optr_Table_Cancel : Micro_Ops := ( Micro_Add, Micro_Sub,
- Micro_Add, Micro_Sub,
- Micro_Add, Micro_Sub );
-
- Micro_Optr_Table_Cumul : Micro_Ops := ( others => Micro_Add );
-
- Micro_Opnd_Table_Cancel : Micro_Opnds := ( 0.001025000235111997,
- 0.000000000000000003,
- 0.724902903219925400,
- 0.000459228020000011,
- 0.049832104921096533 );
-
- Micro_Opnd_Table_Cumul : Micro_Opnds := ( 0.000002309540000000,
- 0.000000278060000000,
- 0.000000000000070000,
- 0.000010003000000000,
- 0.000000023090000000 );
-
- function Test_Micro_Ops is new FXF2A00.Operations_Loop
- (Decimal_Fixed => Micro,
- Operator_Ptr => Micro_Optr_Ptr,
- Operator_Table => Micro_Ops,
- Operand_Table => Micro_Opnds);
-
- ---=---=---=---=---=---=---=---=---=---=---
-
- type Money_Ops is array (FXF2A00.Optr_Range) of Money_Optr_Ptr;
- type Money_Opnds is array (FXF2A00.Opnd_Range) of Money;
-
- Money_Optr_Table_Cancel : Money_Ops := ( Money_Add, Money_Add,
- Money_Sub, Money_Add,
- Money_Sub, Money_Sub );
-
- Money_Optr_Table_Cumul : Money_Ops := ( others => Money_Sub );
-
- Money_Opnd_Table_Cancel : Money_Opnds := ( 127.10,
- 5600.44,
- 0.05,
- 189662.78,
- 226900402.99 );
-
- Money_Opnd_Table_Cumul : Money_Opnds := ( 17.99,
- 500.41,
- 92.78,
- 0.38,
- 2942.99 );
-
- function Test_Money_Ops is new FXF2A00.Operations_Loop
- (Decimal_Fixed => Money,
- Operator_Ptr => Money_Optr_Ptr,
- Operator_Table => Money_Ops,
- Operand_Table => Money_Opnds);
-
- ---=---=---=---=---=---=---=---=---=---=---
-
- type Cash_Ops is array (FXF2A00.Optr_Range) of Cash_Optr_Ptr;
- type Cash_Opnds is array (FXF2A00.Opnd_Range) of Cash;
-
- Cash_Optr_Table_Cancel : Cash_Ops := ( Cash_Add, Cash_Add,
- Cash_Sub, Cash_Add,
- Cash_Sub, Cash_Sub );
-
- Cash_Optr_Table_Cumul : Cash_Ops := ( others => Cash_Add );
-
- Cash_Opnd_Table_Cancel : Cash_Opnds := ( 127.10,
- 5600.44,
- 0.05,
- 189662.78,
- 226900402.99 );
-
- Cash_Opnd_Table_Cumul : Cash_Opnds := ( 3.33,
- 100056.14,
- 22.87,
- 3901.55,
- 111.21 );
-
- function Test_Cash_Ops is new FXF2A00.Operations_Loop
- (Decimal_Fixed => Cash,
- Operator_Ptr => Cash_Optr_Ptr,
- Operator_Table => Cash_Ops,
- Operand_Table => Cash_Opnds);
-
- ---=---=---=---=---=---=---=---=---=---=---
-
- type Broad_Ops is array (FXF2A00.Optr_Range) of Broad_Optr_Ptr;
- type Broad_Opnds is array (FXF2A00.Opnd_Range) of Broad;
-
- Broad_Optr_Table_Cancel : Broad_Ops := ( Broad_Sub, Broad_Add,
- Broad_Add, Broad_Sub,
- Broad_Sub, Broad_Add );
-
- Broad_Optr_Table_Cumul : Broad_Ops := ( others => Broad_Sub );
-
- Broad_Opnd_Table_Cancel : Broad_Opnds := ( 1.000009092,
- 732919479.445022293,
- 89662.787000006,
- 660.101010133,
- 1121127.999905594 );
-
- Broad_Opnd_Table_Cumul : Broad_Opnds := ( 12.000450223,
- 479.430320780,
- 0.003492096,
- 8.112888400,
- 1002.994937800 );
-
- function Test_Broad_Ops is new FXF2A00.Operations_Loop
- (Decimal_Fixed => Broad,
- Operator_Ptr => Broad_Optr_Ptr,
- Operator_Table => Broad_Ops,
- Operand_Table => Broad_Opnds);
-
- ---=---=---=---=---=---=---=---=---=---=---
-
-end CXF2A01_0.CXF2A01_1;
-
-
- --==================================================================--
-
-
-with CXF2A01_0.CXF2A01_1;
-
-with Report;
-procedure CXF2A01 is
- package Data renames CXF2A01_0.CXF2A01_1;
-
- use type CXF2A01_0.Micro;
- use type CXF2A01_0.Money;
- use type CXF2A01_0.Cash;
- use type CXF2A01_0.Broad;
-
- Micro_Cancel_Expected : constant CXF2A01_0.Micro := 0.0;
- Money_Cancel_Expected : constant CXF2A01_0.Money := 0.0;
- Cash_Cancel_Expected : constant CXF2A01_0.Cash := 0.0;
- Broad_Cancel_Expected : constant CXF2A01_0.Broad := 0.0;
-
- Micro_Cumul_Expected : constant CXF2A01_0.Micro := 0.075682140420000000;
- Money_Cumul_Expected : constant CXF2A01_0.Money := -21327300.00;
- Cash_Cumul_Expected : constant CXF2A01_0.Cash := 624570600.00;
- Broad_Cumul_Expected : constant CXF2A01_0.Broad := -9015252.535794000;
-
- Micro_Actual : CXF2A01_0.Micro;
- Money_Actual : CXF2A01_0.Money;
- Cash_Actual : CXF2A01_0.Cash;
- Broad_Actual : CXF2A01_0.Broad;
-begin
-
- Report.Test ("CXF2A01", "Check decimal addition and subtraction");
-
-
- ---=---=---=---=---=---=---=---=---=---=---
-
-
- Micro_Actual := Data.Test_Micro_Ops (0.0,
- Data.Micro_Optr_Table_Cancel,
- Data.Micro_Opnd_Table_Cancel);
-
- if Micro_Actual /= Micro_Cancel_Expected then
- Report.Failed ("Wrong cancellation result for type Micro");
- end if;
-
- ---=---=---=---=---=---=---
-
-
- Micro_Actual := Data.Test_Micro_Ops (0.0,
- Data.Micro_Optr_Table_Cumul,
- Data.Micro_Opnd_Table_Cumul);
-
- if Micro_Actual /= Micro_Cumul_Expected then
- Report.Failed ("Wrong cumulation result for type Micro");
- end if;
-
-
- ---=---=---=---=---=---=---=---=---=---=---
-
-
- Money_Actual := Data.Test_Money_Ops (0.0,
- Data.Money_Optr_Table_Cancel,
- Data.Money_Opnd_Table_Cancel);
-
- if Money_Actual /= Money_Cancel_Expected then
- Report.Failed ("Wrong cancellation result for type Money");
- end if;
-
- ---=---=---=---=---=---=---
-
-
- Money_Actual := Data.Test_Money_Ops (0.0,
- Data.Money_Optr_Table_Cumul,
- Data.Money_Opnd_Table_Cumul);
-
- if Money_Actual /= Money_Cumul_Expected then
- Report.Failed ("Wrong cumulation result for type Money");
- end if;
-
-
- ---=---=---=---=---=---=---=---=---=---=---
-
-
- Cash_Actual := Data.Test_Cash_Ops (0.0,
- Data.Cash_Optr_Table_Cancel,
- Data.Cash_Opnd_Table_Cancel);
-
- if Cash_Actual /= Cash_Cancel_Expected then
- Report.Failed ("Wrong cancellation result for type Cash");
- end if;
-
-
- ---=---=---=---=---=---=---
-
-
- Cash_Actual := Data.Test_Cash_Ops (0.0,
- Data.Cash_Optr_Table_Cumul,
- Data.Cash_Opnd_Table_Cumul);
-
- if Cash_Actual /= Cash_Cumul_Expected then
- Report.Failed ("Wrong cumulation result for type Cash");
- end if;
-
-
- ---=---=---=---=---=---=---=---=---=---=---
-
-
- Broad_Actual := Data.Test_Broad_Ops (0.0,
- Data.Broad_Optr_Table_Cancel,
- Data.Broad_Opnd_Table_Cancel);
-
- if Broad_Actual /= Broad_Cancel_Expected then
- Report.Failed ("Wrong cancellation result for type Broad");
- end if;
-
-
- ---=---=---=---=---=---=---
-
-
- Broad_Actual := Data.Test_Broad_Ops (0.0,
- Data.Broad_Optr_Table_Cumul,
- Data.Broad_Opnd_Table_Cumul);
-
- if Broad_Actual /= Broad_Cumul_Expected then
- Report.Failed ("Wrong cumulation result for type Broad");
- end if;
-
-
- ---=---=---=---=---=---=---=---=---=---=---
-
-
- Report.Result;
-
-end CXF2A01;
diff --git a/gcc/testsuite/ada/acats/tests/cxf/cxf2a02.a b/gcc/testsuite/ada/acats/tests/cxf/cxf2a02.a
deleted file mode 100644
index e9977b0f502..00000000000
--- a/gcc/testsuite/ada/acats/tests/cxf/cxf2a02.a
+++ /dev/null
@@ -1,354 +0,0 @@
--- CXF2A02.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that the multiplying operators for a decimal fixed point type
--- return values that are integral multiples of the small of the type.
--- Check the case where the operand and result types are the same.
---
--- Check that if the mathematical result is between multiples of the
--- small of the result type, the result is truncated toward zero.
---
--- TEST DESCRIPTION:
--- The test verifies that decimal multiplication and division behave as
--- expected for types with various digits, delta, and Machine_Radix
--- values.
---
--- The iteration, operation, and operand counts in the foundation, and
--- the operations and operand tables in the test, are given values such
--- that, when the operations loop is complete, truncation of inexact
--- results should cause the result returned by the operations loop to be
--- the same as that used to initialize the loop's cumulator variable (in
--- this test, one).
---
--- TEST FILES:
--- This test consists of the following files:
---
--- FXF2A00.A
--- -> CXF2A02.A
---
--- APPLICABILITY CRITERIA:
--- This test is only applicable for a compiler attempting validation
--- for the Information Systems Annex.
---
---
--- CHANGE HISTORY:
--- 13 Mar 96 SAIC Prerelease version for ACVC 2.1.
--- 04 Aug 96 SAIC Updated prologue.
---
---!
-
-package CXF2A02_0 is
-
- ---=---=---=---=---=---=---=---=---=---=---
-
- type Micro is delta 10.0**(-5) digits 6; -- range -9.99999 ..
- for Micro'Machine_Radix use 2; -- +9.99999
-
- function Multiply (Left, Right : Micro) return Micro;
- function Divide (Left, Right : Micro) return Micro;
-
-
- type Micro_Optr_Ptr is access function (Left, Right : Micro) return Micro;
-
- Micro_Mult : Micro_Optr_Ptr := Multiply'Access;
- Micro_Div : Micro_Optr_Ptr := Divide'Access;
-
- ---=---=---=---=---=---=---=---=---=---=---
-
- type Basic is delta 0.01 digits 11; -- range -999,999,999.99 ..
- for Basic'Machine_Radix use 10; -- +999,999,999.99
-
- function Multiply (Left, Right : Basic) return Basic;
- function Divide (Left, Right : Basic) return Basic;
-
-
- type Basic_Optr_Ptr is access function (Left, Right : Basic) return Basic;
-
- Basic_Mult : Basic_Optr_Ptr := Multiply'Access;
- Basic_Div : Basic_Optr_Ptr := Divide'Access;
-
- ---=---=---=---=---=---=---=---=---=---=---
-
- type Broad is delta 10.0**(-3) digits 10; -- range -9,999,999.999 ..
- for Broad'Machine_Radix use 2; -- +9,999,999.999
-
- function Multiply (Left, Right : Broad) return Broad;
- function Divide (Left, Right : Broad) return Broad;
-
-
- type Broad_Optr_Ptr is access function (Left, Right : Broad) return Broad;
-
- Broad_Mult : Broad_Optr_Ptr := Multiply'Access;
- Broad_Div : Broad_Optr_Ptr := Divide'Access;
-
- ---=---=---=---=---=---=---=---=---=---=---
-
-end CXF2A02_0;
-
-
- --==================================================================--
-
-
-package body CXF2A02_0 is
-
- ---=---=---=---=---=---=---=---=---=---=---
-
- function Multiply (Left, Right : Micro) return Micro is
- begin
- return (Left * Right); -- Decimal fixed multiplication.
- end Multiply;
-
- function Divide (Left, Right : Micro) return Micro is
- begin
- return (Left / Right); -- Decimal fixed division.
- end Divide;
-
- ---=---=---=---=---=---=---=---=---=---=---
-
- function Multiply (Left, Right : Basic) return Basic is
- begin
- return (Left * Right); -- Decimal fixed multiplication.
- end Multiply;
-
- function Divide (Left, Right : Basic) return Basic is
- begin
- return (Left / Right); -- Decimal fixed division.
- end Divide;
-
- ---=---=---=---=---=---=---=---=---=---=---
-
- function Multiply (Left, Right : Broad) return Broad is
- begin
- return (Left * Right); -- Decimal fixed multiplication.
- end Multiply;
-
- function Divide (Left, Right : Broad) return Broad is
- begin
- return (Left / Right); -- Decimal fixed division.
- end Divide;
-
- ---=---=---=---=---=---=---=---=---=---=---
-
-end CXF2A02_0;
-
-
- --==================================================================--
-
-
-with FXF2A00;
-package CXF2A02_0.CXF2A02_1 is
-
- ---=---=---=---=---=---=---=---=---=---=---
-
- type Micro_Ops is array (FXF2A00.Optr_Range) of Micro_Optr_Ptr;
- type Micro_Opnds is array (FXF2A00.Opnd_Range) of Micro;
-
- Micro_Mult_Operator_Table : Micro_Ops := ( Micro_Mult, Micro_Mult,
- Micro_Mult, Micro_Mult,
- Micro_Mult, Micro_Mult );
-
- Micro_Div_Operator_Table : Micro_Ops := ( Micro_Div, Micro_Div,
- Micro_Div, Micro_Div,
- Micro_Div, Micro_Div );
-
- Micro_Mult_Operand_Table : Micro_Opnds := ( 2.35119,
- 0.05892,
- 9.58122,
- 0.80613,
- 0.93462 );
-
- Micro_Div_Operand_Table : Micro_Opnds := ( 0.58739,
- 4.90012,
- 0.08765,
- 0.71577,
- 5.53768 );
-
- function Test_Micro_Ops is new FXF2A00.Operations_Loop
- (Decimal_Fixed => Micro,
- Operator_Ptr => Micro_Optr_Ptr,
- Operator_Table => Micro_Ops,
- Operand_Table => Micro_Opnds);
-
- ---=---=---=---=---=---=---=---=---=---=---
-
- type Basic_Ops is array (FXF2A00.Optr_Range) of Basic_Optr_Ptr;
- type Basic_Opnds is array (FXF2A00.Opnd_Range) of Basic;
-
- Basic_Mult_Operator_Table : Basic_Ops := ( Basic_Mult, Basic_Mult,
- Basic_Mult, Basic_Mult,
- Basic_Mult, Basic_Mult );
-
- Basic_Div_Operator_Table : Basic_Ops := ( Basic_Div, Basic_Div,
- Basic_Div, Basic_Div,
- Basic_Div, Basic_Div );
-
- Basic_Mult_Operand_Table : Basic_Opnds := ( 127.10,
- 0.02,
- 0.87,
- 45.67,
- 0.01 );
-
- Basic_Div_Operand_Table : Basic_Opnds := ( 0.03,
- 0.08,
- 23.57,
- 0.11,
- 159.11 );
-
- function Test_Basic_Ops is new FXF2A00.Operations_Loop
- (Decimal_Fixed => Basic,
- Operator_Ptr => Basic_Optr_Ptr,
- Operator_Table => Basic_Ops,
- Operand_Table => Basic_Opnds);
-
- ---=---=---=---=---=---=---=---=---=---=---
-
- type Broad_Ops is array (FXF2A00.Optr_Range) of Broad_Optr_Ptr;
- type Broad_Opnds is array (FXF2A00.Opnd_Range) of Broad;
-
- Broad_Mult_Operator_Table : Broad_Ops := ( Broad_Mult, Broad_Mult,
- Broad_Mult, Broad_Mult,
- Broad_Mult, Broad_Mult );
-
- Broad_Div_Operator_Table : Broad_Ops := ( Broad_Div, Broad_Div,
- Broad_Div, Broad_Div,
- Broad_Div, Broad_Div );
-
- Broad_Mult_Operand_Table : Broad_Opnds := ( 589.720,
- 0.106,
- 21.018,
- 0.002,
- 0.381 );
-
- Broad_Div_Operand_Table : Broad_Opnds := ( 0.008,
- 0.793,
- 9.092,
- 214.300,
- 0.080 );
-
- function Test_Broad_Ops is new FXF2A00.Operations_Loop
- (Decimal_Fixed => Broad,
- Operator_Ptr => Broad_Optr_Ptr,
- Operator_Table => Broad_Ops,
- Operand_Table => Broad_Opnds);
-
- ---=---=---=---=---=---=---=---=---=---=---
-
-end CXF2A02_0.CXF2A02_1;
-
-
- --==================================================================--
-
-
-with CXF2A02_0.CXF2A02_1;
-
-with Report;
-procedure CXF2A02 is
- package Data renames CXF2A02_0.CXF2A02_1;
-
- use type CXF2A02_0.Micro;
- use type CXF2A02_0.Basic;
- use type CXF2A02_0.Broad;
-
- Micro_Expected : constant CXF2A02_0.Micro := 1.0;
- Basic_Expected : constant CXF2A02_0.Basic := 1.0;
- Broad_Expected : constant CXF2A02_0.Broad := 1.0;
-
- Micro_Actual : CXF2A02_0.Micro;
- Basic_Actual : CXF2A02_0.Basic;
- Broad_Actual : CXF2A02_0.Broad;
-begin
-
- Report.Test ("CXF2A02", "Check decimal multiplication and division, " &
- "where the operand and result types are the same");
-
- ---=---=---=---=---=---=---=---=---=---=---
-
- Micro_Actual := 0.0;
- Micro_Actual := Data.Test_Micro_Ops (1.0,
- Data.Micro_Mult_Operator_Table,
- Data.Micro_Mult_Operand_Table);
-
- if Micro_Actual /= Micro_Expected then
- Report.Failed ("Wrong result for type Micro multiplication");
- end if;
-
-
- Micro_Actual := 0.0;
- Micro_Actual := Data.Test_Micro_Ops (1.0,
- Data.Micro_Div_Operator_Table,
- Data.Micro_Div_Operand_Table);
-
- if Micro_Actual /= Micro_Expected then
- Report.Failed ("Wrong result for type Micro division");
- end if;
-
- ---=---=---=---=---=---=---=---=---=---=---
-
- Basic_Actual := 0.0;
- Basic_Actual := Data.Test_Basic_Ops (1.0,
- Data.Basic_Mult_Operator_Table,
- Data.Basic_Mult_Operand_Table);
-
- if Basic_Actual /= Basic_Expected then
- Report.Failed ("Wrong result for type Basic multiplication");
- end if;
-
-
- Basic_Actual := 0.0;
- Basic_Actual := Data.Test_Basic_Ops (1.0,
- Data.Basic_Div_Operator_Table,
- Data.Basic_Div_Operand_Table);
-
- if Basic_Actual /= Basic_Expected then
- Report.Failed ("Wrong result for type Basic division");
- end if;
-
- ---=---=---=---=---=---=---=---=---=---=---
-
- Broad_Actual := 0.0;
- Broad_Actual := Data.Test_Broad_Ops (1.0,
- Data.Broad_Mult_Operator_Table,
- Data.Broad_Mult_Operand_Table);
-
- if Broad_Actual /= Broad_Expected then
- Report.Failed ("Wrong result for type Broad multiplication");
- end if;
-
-
- Broad_Actual := 0.0;
- Broad_Actual := Data.Test_Broad_Ops (1.0,
- Data.Broad_Div_Operator_Table,
- Data.Broad_Div_Operand_Table);
-
- if Broad_Actual /= Broad_Expected then
- Report.Failed ("Wrong result for type Broad division");
- end if;
-
- ---=---=---=---=---=---=---=---=---=---=---
-
- Report.Result;
-
-end CXF2A02;
diff --git a/gcc/testsuite/ada/acats/tests/cxf/cxf3001.a b/gcc/testsuite/ada/acats/tests/cxf/cxf3001.a
deleted file mode 100644
index 1b9abca153f..00000000000
--- a/gcc/testsuite/ada/acats/tests/cxf/cxf3001.a
+++ /dev/null
@@ -1,192 +0,0 @@
--- CXF3001.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that the edited output string value returned by Function Image
--- is correct.
---
--- TEST DESCRIPTION:
--- This test is structured using tables of data, consisting of
--- numerical values, picture strings, and expected image
--- result strings.
---
--- Each picture string is checked for validity, and an invalid picture
--- string will cause immediate test failure on its first pass through
--- the evaluation loop. Inside the evaluation loop, each decimal data
--- item is combined with each of the picture strings as parameters to a
--- call to Image, and the result of each call is compared to an
--- expected edited output result string.
---
---
--- CHANGE HISTORY:
--- 24 Feb 95 SAIC Initial prerelease version.
--- 23 Jun 95 SAIC Corrected call to functions Valid and To_Picture.
--- 22 Aug 95 SAIC Test name changed to CXF3001 (from CXF3301) to
--- conform to naming conventions.
--- 24 Feb 97 CTA.PWB Corrected picture strings and expected results.
---!
-
-with Ada.Text_IO.Editing;
-with Report;
-
-procedure CXF3001 is
-begin
-
- Report.Test ("CXF3001", "Check that the string value returned by " &
- "Function Image is correct");
-
- Test_Block:
- declare
-
- use Ada.Text_IO;
-
- Number_Of_Decimal_Items : constant := 5;
- Number_Of_Picture_Strings : constant := 4;
- Number_Of_Expected_Results : constant := Number_Of_Decimal_Items *
- Number_Of_Picture_Strings;
-
- type String_Pointer_Type is access String;
-
- -- Define a decimal data type, and instantiate the Decimal_Output
- -- generic package for the data type.
-
- type Decimal_Data_Type is delta 0.01 digits 16;
- package Ed_Out is new Editing.Decimal_Output (Decimal_Data_Type);
-
- -- Define types for the arrays of data that will hold the decimal data
- -- values, picture strings, and expected edited output results.
-
- type Decimal_Data_Array_Type is
- array (Integer range <>) of Decimal_Data_Type;
-
- type Picture_String_Array_Type is
- array (Integer range <>) of String_Pointer_Type;
-
- type Edited_Output_Results_Array_Type is
- array (Integer range <>) of String_Pointer_Type;
-
- -- Define the data arrays for this test.
-
- Decimal_Data :
- Decimal_Data_Array_Type(1..Number_Of_Decimal_Items) :=
- ( 1 => 5678.90,
- 2 => -6789.01,
- 3 => 0.00,
- 4 => 0.20,
- 5 => 3.45
- );
-
- Picture_Strings :
- Picture_String_Array_Type(1..Number_Of_Picture_Strings) :=
- ( 1 => new String'("-$$_$$9.99"),
- 2 => new String'("-$$_$$$.$$"),
- 3 => new String'("-ZZZZ.ZZ"),
- 4 => new String'("-$$$_999.99")
- );
-
- Edited_Output :
- Edited_Output_Results_Array_Type(1..Number_Of_Expected_Results) :=
- ( 1 => new String'(" $5,678.90"),
- 2 => new String'(" $5,678.90"),
- 3 => new String'(" 5678.90"),
- 4 => new String'(" $5,678.90"),
-
- 5 => new String'("-$6,789.01"),
- 6 => new String'("-$6,789.01"),
- 7 => new String'("-6789.01"),
- 8 => new String'("- $6,789.01"),
-
- 9 => new String'(" $0.00"),
- 10 => new String'(" "),
- 11 => new String'(" "),
- 12 => new String'(" $ 000.00"),
-
- 13 => new String'(" $0.20"),
- 14 => new String'(" $.20"),
- 15 => new String'(" .20"),
- 16 => new String'(" $ 000.20"),
-
- 17 => new String'(" $3.45"),
- 18 => new String'(" $3.45"),
- 19 => new String'(" 3.45"),
- 20 => new String'(" $ 003.45")
- );
-
- TC_Picture : Editing.Picture;
- TC_Loop_Count : Natural := 0;
-
- begin
-
- -- Compare string result of Image with expected edited output string.
-
- Evaluate_Edited_Output:
- for i in 1..Number_Of_Decimal_Items loop
- for j in 1..Number_Of_Picture_Strings loop
-
- TC_Loop_Count := TC_Loop_Count + 1;
-
- -- Check on the validity of the picture strings prior to
- -- processing.
-
- if Editing.Valid(Picture_Strings(j).all) then
-
- -- Create the picture object from the picture string.
- TC_Picture := Editing.To_Picture(Picture_Strings(j).all);
-
- -- Compare actual edited output result of Function Image with
- -- the expected result.
-
- if Ed_Out.Image(Decimal_Data(i), TC_Picture) /=
- Edited_Output(TC_Loop_Count).all
- then
- Report.Failed("Incorrect result from Function Image, " &
- "when used with decimal data item # " &
- Integer'Image(i) &
- " and picture string # " &
- Integer'Image(j));
- end if;
-
- else
- Report.Failed("Picture String # " & Integer'Image(j) &
- "reported as being invalid");
- -- Immediate test failure if a string is invalid.
- exit Evaluate_Edited_Output;
- end if;
-
- end loop;
- end loop Evaluate_Edited_Output;
-
- exception
- when Editing.Picture_Error =>
- Report.Failed ("Picture_Error raised in Test_Block");
- when Layout_Error =>
- Report.Failed ("Layout_Error raised in Test_Block");
- when others =>
- Report.Failed ("Exception raised in Test_Block");
- end Test_Block;
-
- Report.Result;
-
-end CXF3001;
diff --git a/gcc/testsuite/ada/acats/tests/cxf/cxf3002.a b/gcc/testsuite/ada/acats/tests/cxf/cxf3002.a
deleted file mode 100644
index 8444244ef5c..00000000000
--- a/gcc/testsuite/ada/acats/tests/cxf/cxf3002.a
+++ /dev/null
@@ -1,231 +0,0 @@
--- CXF3002.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that the functionality contained in package
--- Ada.Wide_Text_IO.Editing is available and produces correct results.
---
--- TEST DESCRIPTION:
--- This test is designed to validate the procedures and functions that
--- are found in package Ada.Wide_Text_IO.Editing, the "wide"
--- complementary package to Ada.Text_IO.Editing. The test is similar
--- to CXF3301, which tested a large portion of the Ada.Text_IO.Editing
--- package. Additional testing has been added here to cover the balance
--- of the Wide_Text_IO.Editing child package.
-
--- This test is structured using tables of data, consisting of
--- numerical values, picture strings, and expected image
--- result strings.
---
--- Each picture string is checked for validity, and an invalid picture
--- string will cause immediate test failure on its first pass through
--- the evaluation loop. Inside the evaluation loop, each decimal data
--- item is combined with each of the picture strings as parameters to a
--- call to Image, and the result of each call is compared to an
--- expected edited output result string.
---
--- Note: Each of the functions Valid, To_Picture, and Pic_String has
--- String (rather than Wide_String) as its parameter or result
--- subtype, since a picture String is not localizable.
---
---
--- CHANGE HISTORY:
--- 22 Jun 95 SAIC Initial prerelease version.
--- 22 Aug 95 SAIC Test name changed to CXF3002 (from CXF3401) to
--- conform with naming conventions.
--- 24 Feb 97 PWB.CTA Corrected picture strings and expected values.
---!
-
-with Ada.Wide_Text_IO.Editing;
-with Report;
-
-procedure CXF3002 is
-begin
-
- Report.Test ("CXF3002", "Check that the functionality contained " &
- "in package Ada.Wide_Text_IO.Editing is " &
- "available and produces correct results");
-
- Test_Block:
- declare
-
- use Ada.Wide_Text_IO;
-
- Number_Of_Decimal_Items : constant := 5;
- Number_Of_Picture_Strings : constant := 4;
- Number_Of_Expected_Results : constant := Number_Of_Decimal_Items *
- Number_Of_Picture_Strings;
-
- Def_Cur : constant Wide_String := "$";
- Def_Fill : constant Wide_Character := '*';
- Def_Sep : constant Wide_Character := Editing.Default_Separator;
- Def_Radix : constant Wide_Character := Editing.Default_Radix_Mark;
-
- type String_Pointer_Type is access String;
- type Wide_String_Pointer_Type is access Wide_String;
-
- -- Define a decimal data type, and instantiate the Decimal_Output
- -- generic package for the data type.
-
- type Decimal_Data_Type is delta 0.01 digits 16;
-
- package Wide_Ed_Out is
- new Editing.Decimal_Output(Num => Decimal_Data_Type,
- Default_Currency => Def_Cur,
- Default_Fill => Def_Fill,
- Default_Separator => Def_Sep,
- Default_Radix_Mark => Def_Radix);
-
- -- Define types for the arrays of data that will hold the decimal data
- -- values, picture strings, and expected edited output results.
-
- type Decimal_Data_Array_Type is
- array (Integer range <>) of Decimal_Data_Type;
-
- type Picture_String_Array_Type is
- array (Integer range <>) of String_Pointer_Type;
-
- type Edited_Output_Results_Array_Type is
- array (Integer range <>) of Wide_String_Pointer_Type;
-
- -- Define the data arrays for this test.
-
- Decimal_Data :
- Decimal_Data_Array_Type(1..Number_Of_Decimal_Items) :=
- ( 1 => 5678.90,
- 2 => -6789.01,
- 3 => 0.00,
- 4 => 0.20,
- 5 => 3.45
- );
-
- Picture_Strings :
- Picture_String_Array_Type(1..Number_Of_Picture_Strings) :=
- ( 1 => new String'("-$$_$$9.99"),
- 2 => new String'("-$$_$$$.$$"),
- 3 => new String'("-ZZZZ.ZZ"),
- 4 => new String'("-$$$_999.99")
- );
-
-
- Edited_Output :
- Edited_Output_Results_Array_Type(1..Number_Of_Expected_Results) :=
- ( 1 => new Wide_String'(" $5,678.90"),
- 2 => new Wide_String'(" $5,678.90"),
- 3 => new Wide_String'(" 5678.90"),
- 4 => new Wide_String'(" $5,678.90"),
-
- 5 => new Wide_String'("-$6,789.01"),
- 6 => new Wide_String'("-$6,789.01"),
- 7 => new Wide_String'("-6789.01"),
- 8 => new Wide_String'("- $6,789.01"),
-
- 9 => new Wide_String'(" $0.00"),
- 10 => new Wide_String'(" "),
- 11 => new Wide_String'(" "),
- 12 => new Wide_String'(" $ 000.00"),
-
- 13 => new Wide_String'(" $0.20"),
- 14 => new Wide_String'(" $.20"),
- 15 => new Wide_String'(" .20"),
- 16 => new Wide_String'(" $ 000.20"),
-
- 17 => new Wide_String'(" $3.45"),
- 18 => new Wide_String'(" $3.45"),
- 19 => new Wide_String'(" 3.45"),
- 20 => new Wide_String'(" $ 003.45")
- );
-
- TC_Picture : Editing.Picture;
- TC_Loop_Count : Natural := 0;
-
- begin
-
- -- Compare string result of Image with expected edited output wide
- -- string.
-
- Evaluate_Edited_Output:
- for i in 1..Number_Of_Decimal_Items loop
- for j in 1..Number_Of_Picture_Strings loop
-
- TC_Loop_Count := TC_Loop_Count + 1;
-
- -- Check on the validity of the picture strings prior to
- -- processing.
-
- if Editing.Valid(Picture_Strings(j).all) then
-
- -- Create the picture object from the picture string.
- TC_Picture := Editing.To_Picture(Picture_Strings(j).all);
-
- -- Check results of function Decimal_Output.Valid.
- if not Wide_Ed_Out.Valid(Decimal_Data(i), TC_Picture) then
- Report.Failed("Incorrect result from function Valid " &
- "when examining the picture string that " &
- "was produced from string " &
- Integer'Image(j) & " in conjunction with " &
- "decimal data item # " & Integer'Image(i));
- end if;
-
- -- Check results of function Editing.Pic_String.
- if Editing.Pic_String(TC_Picture) /= Picture_Strings(j).all then
- Report.Failed("Incorrect result from To_Picture/" &
- "Pic_String conversion for picture " &
- "string # " & Integer'Image(j));
- end if;
-
- -- Compare actual edited output result of Function Image with
- -- the expected result.
-
- if Wide_Ed_Out.Image(Decimal_Data(i), TC_Picture) /=
- Edited_Output(TC_Loop_Count).all
- then
- Report.Failed("Incorrect result from Function Image, " &
- "when used with decimal data item # " &
- Integer'Image(i) &
- " and picture string # " &
- Integer'Image(j));
- end if;
-
- else
- Report.Failed("Picture String # " & Integer'Image(j) &
- "reported as being invalid");
- end if;
-
- end loop;
- end loop Evaluate_Edited_Output;
-
- exception
- when Editing.Picture_Error =>
- Report.Failed ("Picture_Error raised in Test_Block");
- when Layout_Error =>
- Report.Failed ("Layout_Error raised in Test_Block");
- when others =>
- Report.Failed ("Exception raised in Test_Block");
- end Test_Block;
-
- Report.Result;
-
-end CXF3002;
diff --git a/gcc/testsuite/ada/acats/tests/cxf/cxf3003.a b/gcc/testsuite/ada/acats/tests/cxf/cxf3003.a
deleted file mode 100644
index 7cfce618e7c..00000000000
--- a/gcc/testsuite/ada/acats/tests/cxf/cxf3003.a
+++ /dev/null
@@ -1,292 +0,0 @@
--- CXF3003.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that statically identifiable picture strings can be used to
--- produce correctly formatted edited output.
---
--- TEST DESCRIPTION:
--- This test defines several picture strings that are statically
--- identifiable, (i.e., Pic : Picture := To_Picture("..."); ).
--- These picture strings are used in conjunction with decimal data
--- as parameters in calls to functions Valid and Image. These
--- functions are created by an instantiation of the generic package
--- Ada.Text_IO.Editing.Decimal_Output.
---
---
--- CHANGE HISTORY:
--- 04 Apr 96 SAIC Initial release for 2.1.
--- 13 Feb 97 PWB.CTA corrected incorrect picture strings.
---!
-
-with Report;
-with Ada.Text_IO.Editing;
-with Ada.Exceptions;
-
-procedure CXF3003 is
-begin
-
- Report.Test ("CXF3003", "Check that statically identifiable " &
- "picture strings can be used to produce " &
- "correctly formatted edited output");
-
- Test_Block:
- declare
-
- use Ada.Exceptions;
- use Ada.Text_IO.Editing;
-
- Def_Cur : constant String := "$";
- Def_Fill : constant Character := '*';
- Def_Sep : constant Character := Default_Separator;
- Def_Radix : constant Character :=
- Ada.Text_IO.Editing.Default_Radix_Mark;
-
- type Str_Ptr is access String;
- type Edited_Output_Array_Type is array (Integer range <>) of Str_Ptr;
-
- -- Define a decimal data type, and instantiate the Decimal_Output
- -- generic package for the data type.
-
- type Decimal_Data_Type is delta 0.01 digits 16;
-
- package Image_IO is
- new Decimal_Output(Num => Decimal_Data_Type,
- Default_Currency => Def_Cur,
- Default_Fill => '*',
- Default_Separator => Default_Separator,
- Default_Radix_Mark => Def_Radix);
-
-
- type Decimal_Data_Array_Type is
- array (Integer range <>) of Decimal_Data_Type;
-
- Decimal_Data : Decimal_Data_Array_Type(1..5) :=
- (1 => 1357.99,
- 2 => -9029.01,
- 3 => 0.00,
- 4 => 0.20,
- 5 => 3.45);
-
- -- Statically identifiable picture strings.
-
- Picture_1 : Picture := To_Picture("-$$_$$9.99");
- Picture_2 : Picture := To_Picture("-$$_$$$.$$");
- Picture_3 : Picture := To_Picture("-ZZZZ.ZZ");
- Picture_5 : Picture := To_Picture("-$$$_999.99");
- Picture_6 : Picture := To_Picture("-###**_***_**9.99");
- Picture_7 : Picture := To_Picture("-$**_***_**9.99");
- Picture_8 : Picture := To_Picture("-$$$$$$.$$");
- Picture_9 : Picture := To_Picture("-$$$$$$.$$");
- Picture_10 : Picture := To_Picture("+BBBZZ_ZZZ_ZZZ.ZZ");
- Picture_11 : Picture := To_Picture("--_---_---_--9");
- Picture_12 : Picture := To_Picture("-$_$$$_$$$_$$9.99");
- Picture_14 : Picture := To_Picture("$_$$9.99");
- Picture_15 : Picture := To_Picture("$$9.99");
-
-
- Picture_1_Output : Edited_Output_Array_Type(1..5) :=
- ( 1 => new String'(" $1,357.99"),
- 2 => new String'("-$9,029.01"),
- 3 => new String'(" $0.00"),
- 4 => new String'(" $0.20"),
- 5 => new String'(" $3.45"));
-
- Picture_2_Output : Edited_Output_Array_Type(1..5) :=
- (1 => new String'(" $1,357.99"),
- 2 => new String'("-$9,029.01"),
- 3 => new String'(" "),
- 4 => new String'(" $.20"),
- 5 => new String'(" $3.45"));
-
- Picture_3_Output : Edited_Output_Array_Type(1..5) :=
- (1 => new String'(" 1357.99"),
- 2 => new String'("-9029.01"),
- 3 => new String'(" "),
- 4 => new String'(" .20"),
- 5 => new String'(" 3.45"));
-
- Picture_5_Output : Edited_Output_Array_Type(1..5) :=
- (1 => new String'(" $1,357.99"),
- 2 => new String'("- $9,029.01"),
- 3 => new String'(" $ 000.00"),
- 4 => new String'(" $ 000.20"),
- 5 => new String'(" $ 003.45"));
-
- begin
-
- -- Check the results of function Valid, using the first five decimal
- -- data items and picture strings.
-
- if not Image_IO.Valid(Decimal_Data(1), Picture_1) then
- Report.Failed("Picture string 1 not valid");
- elsif not Image_IO.Valid(Decimal_Data(2), Picture_2) then
- Report.Failed("Picture string 2 not valid");
- elsif not Image_IO.Valid(Decimal_Data(3), Picture_3) then
- Report.Failed("Picture string 3 not valid");
- elsif not Image_IO.Valid(Decimal_Data(5), Picture_5) then
- Report.Failed("Picture string 5 not valid");
- end if;
-
-
- -- Check the results of function Image, using the picture strings
- -- constructed above, with a variety of named vs. positional
- -- parameter notation and defaulted parameters.
-
- for i in 1..5 loop
- if Image_IO.Image(Item => Decimal_Data(i), Pic => Picture_1) /=
- Picture_1_Output(i).all
- then
- Report.Failed("Incorrect result from function Image with " &
- "decimal data item #" & Integer'Image(i) & ", " &
- "combined with Picture_1 picture string." &
- "Expected: " & Picture_1_Output(i).all & ", " &
- "Found: " &
- Image_IO.Image(Decimal_Data(i),Picture_1));
- end if;
-
- if Image_IO.Image(Decimal_Data(i), Pic => Picture_2) /=
- Picture_2_Output(i).all
- then
- Report.Failed("Incorrect result from function Image with " &
- "decimal data item #" & Integer'Image(i) & ", " &
- "combined with Picture_2 picture string." &
- "Expected: " & Picture_2_Output(i).all & ", " &
- "Found: " &
- Image_IO.Image(Decimal_Data(i),Picture_2));
- end if;
-
- if Image_IO.Image(Decimal_Data(i), Picture_3) /=
- Picture_3_Output(i).all
- then
- Report.Failed("Incorrect result from function Image with " &
- "decimal data item #" & Integer'Image(i) & ", " &
- "combined with Picture_3 picture string." &
- "Expected: " & Picture_3_Output(i).all & ", " &
- "Found: " &
- Image_IO.Image(Decimal_Data(i),Picture_3));
- end if;
-
- if Image_IO.Image(Decimal_Data(i), Picture_5) /=
- Picture_5_Output(i).all
- then
- Report.Failed("Incorrect result from function Image with " &
- "decimal data item #" & Integer'Image(i) & ", " &
- "combined with Picture_5 picture string." &
- "Expected: " & Picture_5_Output(i).all & ", " &
- "Found: " &
- Image_IO.Image(Decimal_Data(i),Picture_5));
- end if;
- end loop;
-
-
- if Image_IO.Image(Item => 123456.78,
- Pic => Picture_6,
- Currency => "$",
- Fill => Def_Fill,
- Separator => Def_Sep,
- Radix_Mark => Def_Radix) /= " $***123,456.78"
- then
- Report.Failed("Incorrect result from Fn. Image using Picture_6");
- end if;
-
- if Image_IO.Image(123456.78,
- Pic => Picture_7,
- Currency => Def_Cur,
- Fill => '*',
- Separator => Def_Sep,
- Radix_Mark => Def_Radix) /= " $***123,456.78"
- then
- Report.Failed("Incorrect result from Fn. Image using Picture_7");
- end if;
-
- if Image_IO.Image(0.0,
- Picture_8,
- Currency => "$",
- Fill => '*',
- Separator => Def_Sep,
- Radix_Mark => Def_Radix) /= " "
- then
- Report.Failed("Incorrect result from Fn. Image using Picture_8");
- end if;
-
- if Image_IO.Image(0.20,
- Picture_9,
- Def_Cur,
- Fill => Def_Fill,
- Separator => Default_Separator,
- Radix_Mark => Default_Radix_Mark) /= " $.20"
- then
- Report.Failed("Incorrect result from Fn. Image using Picture_9");
- end if;
-
- if Image_IO.Image(123456.00,
- Picture_10,
- "$",
- '*',
- Separator => Def_Sep,
- Radix_Mark => Def_Radix) /= "+ 123,456.00"
- then
- Report.Failed("Incorrect result from Fn. Image using Picture_10");
- end if;
-
- if Image_IO.Image(-123456.78,
- Picture_11,
- Default_Currency,
- Default_Fill,
- Default_Separator,
- Radix_Mark => Def_Radix) /= " -123,457"
- then
- Report.Failed("Incorrect result from Fn. Image using Picture_11");
- end if;
-
- if Image_IO.Image(123456.78, Picture_12, "$", '*', ',', '.') /=
- " $123,456.78"
- then
- Report.Failed("Incorrect result from Fn. Image using Picture_12");
- end if;
-
- if Image_IO.Image(1.23,
- Picture_14,
- Currency => Def_Cur,
- Fill => Def_Fill) /= " $1.23"
- then
- Report.Failed("Incorrect result from Fn. Image using Picture_14");
- end if;
-
- if Image_IO.Image(12.34, Pic => Picture_15) /= "$12.34"
- then
- Report.Failed("Incorrect result from Fn. Image using Picture_15");
- end if;
-
- exception
- when The_Error : others =>
- Report.Failed("The following exception was raised in the " &
- "Test_Block: " & Exception_Name(The_Error));
- end Test_Block;
-
- Report.Result;
-
-end CXF3003;
diff --git a/gcc/testsuite/ada/acats/tests/cxf/cxf3004.a b/gcc/testsuite/ada/acats/tests/cxf/cxf3004.a
deleted file mode 100644
index 146047bc824..00000000000
--- a/gcc/testsuite/ada/acats/tests/cxf/cxf3004.a
+++ /dev/null
@@ -1,257 +0,0 @@
--- CXF3004.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that statically identifiable picture strings can be used
--- in conjunction with function Image to produce output strings
--- appropriate to foreign currency representations.
---
--- Check that statically identifiable picture strings will cause
--- function Image to raise Layout_Error under the appropriate
--- conditions.
---
--- TEST DESCRIPTION:
--- This test defines several picture strings that are statically
--- identifiable, (i.e., Pic : Picture := To_Picture("..."); ).
--- These picture strings are used in conjunction with decimal data
--- as parameters in calls to function Image.
---
---
--- CHANGE HISTORY:
--- 11 Apr 96 SAIC Initial release for 2.1.
---
---!
-
-with Report;
-with Ada.Text_IO.Editing;
-with Ada.Exceptions;
-
-procedure CXF3004 is
-begin
-
- Report.Test ("CXF3004", "Check that statically identifiable " &
- "picture strings will cause function Image " &
- "to raise Layout_Error under appropriate " &
- "conditions");
-
- Test_Block:
- declare
-
- use Ada.Exceptions;
- use Ada.Text_IO.Editing;
-
- FF_Currency : constant String := "FF";
- DM_Currency : constant String := "DM";
- FF_Separator : constant Character := '.';
- DM_Separator : constant Character := ',';
- FF_Radix : constant Character := ',';
- DM_Radix : constant Character := '.';
- Blank_Fill : constant Character := ' ';
- Star_Fill : constant Character := '*';
-
-
- -- Define a decimal data type, and instantiate the Decimal_Output
- -- generic package for the data type.
-
- type Decimal_Data_Type is delta 0.01 digits 16;
-
- package Image_IO is
- new Decimal_Output(Num => Decimal_Data_Type,
- Default_Currency => "$",
- Default_Fill => Star_Fill,
- Default_Separator => Default_Separator,
- Default_Radix_Mark => DM_Radix);
-
-
-
- -- The following decimal data items are used with picture strings
- -- in evaluating use of foreign currency symbols.
-
- Dec_Data_1 : Decimal_Data_Type := 123456.78;
- Dec_Data_2 : Decimal_Data_Type := 32.10;
- Dec_Data_3 : Decimal_Data_Type := -1234.57;
- Dec_Data_4 : Decimal_Data_Type := 123456.78;
- Dec_Data_5 : Decimal_Data_Type := 12.34;
- Dec_Data_6 : Decimal_Data_Type := 12.34;
- Dec_Data_7 : Decimal_Data_Type := 12345.67;
-
-
- -- Statically identifiable picture strings.
- -- These strings are used in conjunction with non-default values
- -- for Currency string, Radix mark, and Separator in calls to
- -- function Image.
-
- Picture_1 : Picture := To_Picture("-###**_***_**9.99"); -- FF
- Picture_2 : Picture := To_Picture("###z_ZZ9.99"); -- FF
- Picture_3 : Picture := To_Picture("<<<<_<<<.<<###>"); -- DM
- Picture_4 : Picture := To_Picture("-$_$$$_$$$_$$9.99"); -- DM
- Picture_5 : Picture := To_Picture("$Zz9.99"); -- DM
- Picture_6 : Picture := To_Picture("$$$9.99"); -- DM
- Picture_7 : Picture := To_Picture("###_###_##9.99"); -- CHF
-
-
- -- The following ten edited output strings correspond to the ten
- -- foreign currency picture strings.
-
- Output_1 : constant String := " FF***123.456,78";
- Output_2 : constant String := " FF 32,10";
- Output_3 : constant String := " (1,234.57DM )";
- Output_4 : constant String := " DM123,456.78";
- Output_5 : constant String := "DM 12.34";
- Output_6 : constant String := " DM12.34";
- Output_7 : constant String := " CHF12,345.67";
-
-
- begin
-
- -- Check the results of function Image, using the picture strings
- -- constructed above, in creating foreign currency edited output
- -- strings.
-
- if Image_IO.Image(Item => Dec_Data_1,
- Pic => Picture_1,
- Currency => FF_Currency,
- Fill => Star_Fill,
- Separator => FF_Separator,
- Radix_Mark => FF_Radix) /= Output_1
- then
- Report.Failed("Incorrect result from Fn. Image using Picture_1");
- end if;
-
- if Image_IO.Image(Item => Dec_Data_2,
- Pic => Picture_2,
- Currency => FF_Currency,
- Fill => Blank_Fill,
- Separator => FF_Separator,
- Radix_Mark => FF_Radix) /= Output_2
- then
- Report.Failed("Incorrect result from Fn. Image using Picture_2");
- end if;
-
- if Image_IO.Image(Item => Dec_Data_3,
- Pic => Picture_3,
- Currency => DM_Currency,
- Fill => Blank_Fill,
- Separator => DM_Separator,
- Radix_Mark => DM_Radix) /= Output_3
- then
- Report.Failed("Incorrect result from Fn. Image using Picture_3");
- end if;
-
- if Image_IO.Image(Item => Dec_Data_4,
- Pic => Picture_4,
- Currency => DM_Currency,
- Fill => Blank_Fill,
- Separator => DM_Separator,
- Radix_Mark => DM_Radix) /= Output_4
- then
- Report.Failed("Incorrect result from Fn. Image using Picture_4");
- end if;
-
- if Image_IO.Image(Item => Dec_Data_5,
- Pic => Picture_5,
- Currency => DM_Currency,
- Fill => Blank_Fill,
- Separator => DM_Separator,
- Radix_Mark => DM_Radix) /= Output_5
- then
- Report.Failed("Incorrect result from Fn. Image using Picture_5");
- end if;
-
- if Image_IO.Image(Item => Dec_Data_6,
- Pic => Picture_6,
- Currency => DM_Currency,
- Fill => Blank_Fill,
- Separator => DM_Separator,
- Radix_Mark => DM_Radix) /= Output_6
- then
- Report.Failed("Incorrect result from Fn. Image using Picture_6");
- end if;
-
- if Image_IO.Image(Item => Dec_Data_7,
- Pic => Picture_7,
- Currency => "CHF",
- Fill => Blank_Fill,
- Separator => ',',
- Radix_Mark => '.') /= Output_7
- then
- Report.Failed("Incorrect result from Fn. Image using Picture_7");
- end if;
-
-
- -- The following calls of Function Image, using the specific
- -- decimal values and picture strings provided, will cause
- -- a Layout_Error to be raised.
- -- Note: The data and the picture strings used in the following
- -- evaluations are not themselves erroneous, but when used in
- -- combination will cause Layout_Error to be raised.
-
- Exception_Block_1 :
- declare
- Erroneous_Data_1 : Decimal_Data_Type := 12.34;
- Erroneous_Picture_1 : Picture := To_Picture("9.99");
- N : constant Natural := Image_IO.Length(Erroneous_Picture_1);
- TC_String : String(1..N);
- begin
- TC_String := Image_IO.Image(Erroneous_Data_1, Erroneous_Picture_1);
- Report.Failed("Layout_Error not raised by combination of " &
- "Erroneous_Picture_1 and Erroneous_Data_1");
- Report.Comment("Should never be printed: " & TC_String);
- exception
- when Ada.Text_IO.Layout_Error => null; -- OK, expected exception.
- when The_Error : others =>
- Report.Failed
- ("The following exception was incorrectly raised in " &
- "Exception_Block_1: " & Exception_Name(The_Error));
- end Exception_Block_1;
-
- Exception_Block_2 :
- declare
- Erroneous_Data_2 : Decimal_Data_Type := -12.34;
- Erroneous_Picture_2 : Picture := To_Picture("99.99");
- N : constant Natural := Image_IO.Length(Erroneous_Picture_2);
- TC_String : String(1..N);
- begin
- TC_String := Image_IO.Image(Erroneous_Data_2, Erroneous_Picture_2);
- Report.Failed("Layout_Error not raised by combination of " &
- "Erroneous_Picture_2 and Erroneous_Data_2");
- Report.Comment("Should never be printed: " & TC_String);
- exception
- when Ada.Text_IO.Layout_Error => null; -- OK, expected exception.
- when The_Error : others =>
- Report.Failed
- ("The following exception was incorrectly raised in " &
- "Exception_Block_2: " & Exception_Name(The_Error));
- end Exception_Block_2;
-
- exception
- when The_Error : others =>
- Report.Failed("The following exception was raised in the " &
- "Test_Block: " & Exception_Name(The_Error));
- end Test_Block;
-
- Report.Result;
-
-end CXF3004;
diff --git a/gcc/testsuite/ada/acats/tests/cxf/cxf3a01.a b/gcc/testsuite/ada/acats/tests/cxf/cxf3a01.a
deleted file mode 100644
index 202a6996e32..00000000000
--- a/gcc/testsuite/ada/acats/tests/cxf/cxf3a01.a
+++ /dev/null
@@ -1,167 +0,0 @@
--- CXF3A01.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that the function Ada.Text_IO.Editing.Valid returns False if
--- a) Pic_String is not a well-formed Picture string, or
--- b) the length of Pic_String exceeds Max_Picture_Length, or
--- c) Blank_When_Zero is True and Pic_String contains '*';
--- Check that Valid otherwise returns True.
---
--- TEST DESCRIPTION:
--- This test validates the results of function Editing.Valid under a
--- variety of conditions. Both valid and invalid picture strings are
--- provided as input parameters to the function. The use of the
--- Blank_When_Zero parameter is evaluated with strings that contain the
--- zero suppression character '*'.
---
--- TEST FILES:
--- The following files comprise this test:
---
--- FXF3A00.A (foundation code)
--- => CXF3A01.A
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
---
---!
-
-with FXF3A00;
-with Ada.Text_IO.Editing;
-with Report;
-
-procedure CXF3A01 is
-begin
-
- Report.Test ("CXF3A01", "Check that the Valid function from package " &
- "Ada.Text_IO.Editing returns False for strings " &
- "that fail to comply with the composition " &
- "constraints defined for picture strings. " &
- "Check that the Valid function returns True " &
- "for strings that conform to the composition " &
- "constraints defined for picture strings");
-
- Test_Block:
- declare
- use FXF3A00;
- use Ada.Text_IO;
- begin
-
- -- Use a series of picture strings that conform to the composition
- -- constraints to validate the Ada.Text_IO.Editing.Valid function.
- -- The result for each of these calls should be True.
- -- In all the following cases, the default value of the Blank_When_Zero
- -- parameter is used.
-
- for i in 1..FXF3A00.Number_Of_Valid_Strings loop
-
- if not Editing.Valid(Pic_String => FXF3A00.Valid_Strings(i).all)
- then
- Report.Failed("Incorrect result from Function Valid using " &
- "Valid_String = " & FXF3A00.Valid_Strings(i).all);
- end if;
-
- end loop;
-
-
- for i in 1..FXF3A00.Number_Of_Foreign_Strings loop
-
- if not Editing.Valid(Pic_String => FXF3A00.Foreign_Strings(i).all)
- then
- Report.Failed("Incorrect result from Function Valid using " &
- "Foreign_String = " &
- FXF3A00.Foreign_Strings(i).all);
- end if;
-
- end loop;
-
-
- -- Use a series of picture strings that violate one or more of the
- -- composition constraints to validate the Ada.Text_IO.Editing.Valid
- -- function. The result for each of these calls should be False.
- -- In all the following cases, the default value of the Blank_When_Zero
- -- parameter is used.
-
- for i in 1..FXF3A00.Number_Of_Invalid_Strings loop
-
- if Editing.Valid(Pic_String => FXF3A00.Invalid_Strings(i).all)
- then
- Report.Failed("Incorrect result from Function Valid using " &
- "Invalid_String = " &
- FXF3A00.Invalid_Strings(i).all);
- end if;
-
- end loop;
-
-
- -- In all the following cases, the default value of the Blank_When_Zero
- -- parameter is overridden with a True actual parameter value. Using
- -- valid picture strings that contain the '*' zero suppression character
- -- when this parameter value is True must result in a False result
- -- from function Valid. Valid picture strings that do not contain the
- -- '*' character should return a function result of True with True
- -- provided as the actual parameter to Blank_When_Zero.
-
- -- Check entries 1, 2, 25, 36 from the Valid_Strings array, all of
- -- which contain the '*' zero suppression character.
-
- if Editing.Valid(Valid_Strings(1).all, Blank_When_Zero => True) or
- Editing.Valid(Valid_Strings(2).all, Blank_When_Zero => True) or
- Editing.Valid(Valid_Strings(25).all, Blank_When_Zero => True) or
- Editing.Valid(Valid_Strings(36).all, Blank_When_Zero => True)
- then
- Report.Failed
- ("Incorrect result from Function Valid when setting " &
- "the value of the Blank_When_Zero parameter to True, " &
- "and using picture strings with the '*' character");
- end if;
-
-
- -- Check entries from the Valid_Strings array, none of
- -- which contain the '*' zero suppression character.
-
- for i in 3..24 loop
-
- if not Editing.Valid(Pic_String => Valid_Strings(i).all,
- Blank_When_Zero => True)
- then
- Report.Failed("Incorrect result from Function Valid when " &
- "setting the value of the Blank_When_Zero " &
- "parameter to True, and using picture strings " &
- "without the '*' character, Valid_String = " &
- FXF3A00.Valid_Strings(i).all);
- end if;
-
- end loop;
-
-
- exception
- when others => Report.Failed ("Exception raised in Test_Block");
- end Test_Block;
-
- Report.Result;
-
-end CXF3A01;
diff --git a/gcc/testsuite/ada/acats/tests/cxf/cxf3a02.a b/gcc/testsuite/ada/acats/tests/cxf/cxf3a02.a
deleted file mode 100644
index 4231b56aa46..00000000000
--- a/gcc/testsuite/ada/acats/tests/cxf/cxf3a02.a
+++ /dev/null
@@ -1,267 +0,0 @@
--- CXF3A02.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that the function Ada.Text_IO.Editing.To_Picture raises
--- Picture_Error if the picture string provided as input parameter does
--- not conform to the composition constraints defined for picture
--- strings.
--- Check that when Pic_String is applied to To_Picture, the result
--- is equivalent to the actual string parameter of To_Picture;
--- Check that when Blank_When_Zero is applied to To_Picture, the result
--- is the same value as the Blank_When_Zero parameter of To_Picture.
---
--- TEST DESCRIPTION:
--- This test validates that function Editing.To_Picture returns a
--- Picture result when provided a valid picture string, and raises a
--- Picture_Error exception when provided an invalid picture string
--- input parameter. In addition, the Picture result of To_Picture is
--- converted back to a picture string value using function Pic_String,
--- and the result of function Blank_When_Zero is validated based on the
--- value of parameter Blank_When_Zero used in the formation of the Picture
--- by function To_Picture.
---
--- TEST FILES:
--- The following files comprise this test:
---
--- FXF3A00.A (foundation code)
--- => CXF3A02.A
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 11 Mar 97 PWB.CTA Corrected invalid picture string and uppercase
--- problem.
---!
-
-with FXF3A00;
-with Ada.Text_IO.Editing;
-with Ada.Strings.Maps;
-with Ada.Strings.Fixed;
-with Report;
-
-procedure CXF3A02 is
-
- Lower_Alpha : constant String := "abcdefghijklmnopqrstuvwxyz";
- Upper_Alpha : constant String := "ABCDEFGHIJKLMNOPQRSTUVWXYZ";
- function UpperCase ( Source : String ) return String is
- begin
- return
- Ada.Strings.Fixed.Translate
- ( Source => Source,
- Mapping => Ada.Strings.Maps.To_Mapping
- ( From => Lower_Alpha,
- To => Upper_Alpha ) );
- end UpperCase;
-
-begin
-
- Report.Test ("CXF3A02", "Check that the function " &
- "Ada.Text_IO.Editing.To_Picture raises " &
- "Picture_Error if the picture string provided " &
- "as input parameter does not conform to the " &
- "composition constraints defined for picture " &
- "strings");
-
- Test_Block:
- declare
-
- use Ada.Text_IO;
- use FXF3A00;
-
- TC_Picture : Editing.Picture;
- TC_Blank_When_Zero : Boolean;
-
- begin
-
-
- -- Validate that function To_Picture does not raise Picture_Error when
- -- provided a valid picture string as an input parameter.
-
- for i in 1..FXF3A00.Number_Of_Valid_Strings loop
- begin
- TC_Picture :=
- Editing.To_Picture(Pic_String => Valid_Strings(i).all,
- Blank_When_Zero => False );
- exception
- when Editing.Picture_Error =>
- Report.Failed
- ("Picture_Error raised by function To_Picture " &
- "with a valid picture string as input parameter, " &
- "Valid_String = " & FXF3A00.Valid_Strings(i).all);
- when others =>
- Report.Failed("Unexpected exception raised - 1, " &
- "Valid_String = " & FXF3A00.Valid_Strings(i).all);
- end;
- end loop;
-
-
-
- -- Validate that function To_Picture raises Picture_Error when an
- -- invalid picture string is provided as an input parameter.
- -- Default value used for parameter Blank_When_Zero.
-
- for i in 1..FXF3A00.Number_Of_Invalid_Strings loop
- begin
- TC_Picture :=
- Editing.To_Picture(Pic_String => FXF3A00.Invalid_Strings(i).all);
- Report.Failed
- ("Picture_Error not raised by function To_Picture " &
- "with an invalid picture string as input parameter, " &
- "Invalid_String = " & FXF3A00.Invalid_Strings(i).all);
- exception
- when Editing.Picture_Error => null; -- OK, expected exception.
- when others =>
- Report.Failed("Unexpected exception raised, " &
- "Invalid_String = " &
- FXF3A00.Invalid_Strings(i).all);
- end;
- end loop;
-
-
-
- -- Validate that To_Picture and Pic_String/Blank_When_Zero provide
- -- "inverse" results.
-
- -- Use the default value of the Blank_When_Zero parameter (False) for
- -- these evaluations (some valid strings have the '*' zero suppression
- -- character, which would result in an invalid string if used with a
- -- True value for the Blank_When_Zero parameter).
-
- for i in 1..FXF3A00.Number_Of_Valid_Strings loop
- begin
-
- -- Format a picture string using function To_Picture.
-
- TC_Picture := Editing.To_Picture(FXF3A00.Valid_Strings(i).all);
-
- -- Reconvert the Picture result from To_Picture to a string value
- -- using function Pic_String, and compare to the original string.
-
- if Editing.Pic_String(Pic => TC_Picture) /=
- Uppercase (FXF3A00.Valid_Strings(i).all)
- then
- Report.Failed
- ("Inverse result incorrect from Editing.Pic_String, " &
- "Valid_String = " & FXF3A00.Valid_Strings(i).all);
- end if;
-
- -- Ensure that function Blank_When_Zero returns the correct value
- -- of the Blank_When_Zero parameter used in forming the Picture
- -- (default parameter value False used in call to To_Picture
- -- above).
-
- if Editing.Blank_When_Zero(Pic => TC_Picture) then
- Report.Failed
- ("Inverse result incorrect from Editing.Blank_When_Zero, " &
- "Valid_String = " & FXF3A00.Valid_Strings(i).all);
- end if;
-
- exception
- when others =>
- Report.Failed("Unexpected exception raised - 2, " &
- "Valid_String = " & FXF3A00.Valid_Strings(i).all);
- end;
- end loop;
-
-
- -- Specifically check that any lower case letters in the original
- -- picture string have been converted to upper case form following
- -- the To_Picture/Pic_String conversion (as shown in previous loop).
-
- declare
- The_Picture : Editing.Picture;
- The_Picture_String : constant String := "+bBbZz_zZz_Zz9.99";
- The_Expected_Result : constant String := "+BBBZZ_ZZZ_ZZ9.99";
- begin
- -- Convert Picture String to Picture.
- The_Picture := Editing.To_Picture(Pic_String => The_Picture_String);
-
- declare
- -- Reconvert the Picture to a Picture String.
- The_Result : constant String := Editing.Pic_String(The_Picture);
- begin
- if The_Result /= The_Expected_Result then
- Report.Failed("Conversion to Picture/Reconversion to String " &
- "did not produce expected result when Picture " &
- "String had lower case letters");
- end if;
- end;
- end;
-
-
- -- Use a value of True for the Blank_When_Zero parameter for the
- -- following evaluations (picture strings that do not have the '*' zero
- -- suppression character, which would result in an invalid string when
- -- used here with a True value for the Blank_When_Zero parameter).
-
- for i in 3..24 loop
- begin
-
- -- Format a picture string using function To_Picture.
-
- TC_Picture :=
- Editing.To_Picture(Pic_String => Valid_Strings(i).all,
- Blank_When_Zero => True);
-
- -- Reconvert the Picture result from To_Picture to a string value
- -- using function Pic_String, and compare to the original string.
-
- if Editing.Pic_String(Pic => TC_Picture) /=
- UpperCase (FXF3A00.Valid_Strings(i).all)
- then
- Report.Failed
- ("Inverse result incorrect from Editing.Pic_String, used " &
- "on Picture formed with parameter Blank_When_Zero = True, " &
- "Valid_String = " & FXF3A00.Valid_Strings(i).all);
- end if;
-
- -- Ensure that function Blank_When_Zero returns the correct value
- -- of the Blank_When_Zero parameter used in forming the Picture
- -- (default parameter value False overridden in call to
- -- To_Picture above).
-
- if not Editing.Blank_When_Zero(Pic => TC_Picture) then
- Report.Failed
- ("Inverse result incorrect from Editing.Blank_When_Zero, " &
- "used on a Picture formed with parameter Blank_When_Zero " &
- "= True, Valid_String = " & FXF3A00.Valid_Strings(i).all);
- end if;
-
- exception
- when others =>
- Report.Failed("Unexpected exception raised - 3, " &
- "Valid_String = " & FXF3A00.Valid_Strings(i).all);
- end;
- end loop;
-
-
- exception
- when others => Report.Failed ("Exception raised in Test_Block");
- end Test_Block;
-
- Report.Result;
-
-end CXF3A02;
diff --git a/gcc/testsuite/ada/acats/tests/cxf/cxf3a03.a b/gcc/testsuite/ada/acats/tests/cxf/cxf3a03.a
deleted file mode 100644
index 86709601464..00000000000
--- a/gcc/testsuite/ada/acats/tests/cxf/cxf3a03.a
+++ /dev/null
@@ -1,429 +0,0 @@
--- CXF3A03.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that function Length in the generic package Decimal_Output
--- returns the number of characters in the edited output string
--- produced by function Image, for a particular decimal type,
--- currency string, and radix mark.
--- Check that function Valid in the generic package Decimal_Output
--- returns correct results based on the particular decimal value,
--- and the Picture and Currency string parameters.
---
--- TEST DESCRIPTION:
--- This test uses two instantiations of package Decimal_Output, one
--- for decimal data with delta 0.01, the other for decimal data with
--- delta 1.0. The functions Length and Valid found in this generic
--- package are evaluated for each instantiation.
--- Function Length is examined with picture and currency string input
--- parameters of different sizes.
--- Function Valid is examined with a decimal type data item, picture
--- object, and currency string, for cases that are both valid and
--- invalid (Layout_Error would result from the particular items as
--- input parameters to function Image).
---
--- TEST FILES:
--- The following files comprise this test:
---
--- FXF3A00.A (foundation code)
--- => CXF3A03.A
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
---
---!
-
-with FXF3A00;
-with Ada.Text_IO.Editing;
-with Report;
-
-procedure CXF3A03 is
-begin
-
- Report.Test ("CXF3A03", "Check that function Length returns the " &
- "number of characters in the edited output " &
- "string produced by function Image, for a " &
- "particular decimal type, currency string, " &
- "and radix mark. Check that function Valid " &
- "returns correct results based on the " &
- "particular decimal value, and the Picture " &
- "and Currency string parameters");
-
- Test_Block:
- declare
-
- use Ada.Text_IO;
- use FXF3A00;
-
- type Instantiation_Type is (NDP, TwoDP);
-
- -- Defaults used for all other generic parameters in these
- -- instantiations.
- package Pack_NDP is new Editing.Decimal_Output (Decimal_Type_NDP);
- package Pack_2DP is new Editing.Decimal_Output (Decimal_Type_2DP);
-
- TC_Lower_Bound,
- TC_Higher_Bound : Integer := 0;
-
- TC_Picture : Editing.Picture;
- TC_US_String : constant String := "$";
- TC_FF_String : constant String := "FF";
- TC_DM_String : constant String := "DM";
- TC_CHF_String : constant String := "CHF";
-
-
- function Dollar_Sign_Present (Str : String) return Boolean is
- begin
- for i in 1..Str'Length loop
- if Str(i) = '$' then
- return True;
- end if;
- end loop;
- return False;
- end Dollar_Sign_Present;
-
- function V_Present (Str : String) return Boolean is
- begin
- for i in 1..Str'Length loop
- if Str(i) = 'V' or Str(i) = 'v' then
- return True;
- end if;
- end loop;
- return False;
- end V_Present;
-
-
- function Accurate_Length (Pict_Str : String;
- Inst : Instantiation_Type;
- Currency_String : String)
- return Boolean is
-
- TC_Length : Natural := 0;
- TC_Currency_Length_Adjustment : Natural := 0;
- TC_Radix_Adjustment : Natural := 0;
- begin
-
- -- Create the picture object from the picture string.
- TC_Picture := Editing.To_Picture(Pict_Str);
-
- -- Calculate the currency length adjustment.
- if Dollar_Sign_Present (Editing.Pic_String(TC_Picture)) then
- TC_Currency_Length_Adjustment := Currency_String'Length - 1;
- end if;
-
- -- Calculate the Radix adjustment.
- if V_Present (Editing.Pic_String(TC_Picture)) then
- TC_Radix_Adjustment := 1;
- end if;
-
- -- Calculate the length, using the version of Length that comes
- -- from the appropriate instantiation of Decimal_Output, based
- -- on the decimal type used in the instantiation.
- if Inst = NDP then
- TC_Length := Pack_NDP.Length(TC_Picture,
- Currency_String);
- else
- TC_Length := Pack_2DP.Length(TC_Picture,
- Currency_String);
- end if;
-
- return TC_Length = Editing.Pic_String(TC_Picture)'Length +
- TC_Currency_Length_Adjustment -
- TC_Radix_Adjustment;
- end Accurate_Length;
-
-
- begin
-
- Length_Block:
- begin
-
- -- The first 10 picture strings in the Valid_Strings array correspond
- -- to data values of a decimal type with delta 0.01.
- -- Note: The appropriate instantiation of the Decimal_Output package
- -- (and therefore function Length) is used by function
- -- Accurate_Length to calculate length.
-
- for i in 1..10 loop
- if not Accurate_Length (FXF3A00.Valid_Strings(i).all,
- TwoDP,
- TC_US_String)
- then
- Report.Failed("Incorrect result from function Length, " &
- "when used with a decimal type with delta .01 " &
- "and with the currency string " & TC_US_String &
- " in evaluating picture string " &
- FXF3A00.Valid_Strings(i).all );
- end if;
- end loop;
-
-
- -- Picture strings 17-20 in the Valid_Strings array correspond
- -- to data values of a decimal type with delta 1.0. Again, the
- -- instantiation of Decimal_Output used is based on this particular
- -- decimal type.
-
- for i in 17..20 loop
- if not Accurate_Length (FXF3A00.Valid_Strings(i).all,
- NDP,
- TC_US_String)
- then
- Report.Failed("Incorrect result from function Length, " &
- "when used with a decimal type with delta 1.0 " &
- "and with the currency string " & TC_US_String &
- " in evaluating picture string " &
- FXF3A00.Valid_Strings(i).all );
- end if;
- end loop;
-
-
- -- The first 4 picture strings in the Foreign_Strings array
- -- correspond to data values of a decimal type with delta 0.01,
- -- and to the currency string "FF" (two characters).
-
- for i in 1..FXF3A00.Number_of_FF_Strings loop
- if not Accurate_Length (FXF3A00.Foreign_Strings(i).all,
- TwoDP,
- TC_FF_String)
- then
- Report.Failed("Incorrect result from function Length, " &
- "when used with a decimal type with delta .01 " &
- "and with the currency string " & TC_FF_String &
- " in evaluating picture string " &
- FXF3A00.Foreign_Strings(i).all );
- end if;
- end loop;
-
-
- -- Picture strings 5-9 in the Foreign_Strings array correspond
- -- to data values of a decimal type with delta 0.01, and to the
- -- currency string "DM" (two characters).
-
- TC_Lower_Bound := FXF3A00.Number_of_FF_Strings + 1;
- TC_Higher_Bound := FXF3A00.Number_of_FF_Strings +
- FXF3A00.Number_of_DM_Strings;
-
- for i in TC_Lower_Bound..TC_Higher_Bound loop
- if not Accurate_Length (FXF3A00.Foreign_Strings(i).all,
- TwoDP,
- TC_DM_String)
- then
- Report.Failed("Incorrect result from function Length, " &
- "when used with a decimal type with delta .01 " &
- "and with the currency string " & TC_DM_String &
- " in evaluating picture string " &
- FXF3A00.Foreign_Strings(i).all );
- end if;
- end loop;
-
-
- -- Picture string #10 in the Foreign_Strings array corresponds
- -- to a data value of a decimal type with delta 0.01, and to the
- -- currency string "CHF" (three characters).
-
- if not Accurate_Length (FXF3A00.Foreign_Strings(10).all,
- TwoDP,
- TC_CHF_String)
- then
- Report.Failed("Incorrect result from function Length, " &
- "when used with a decimal type with delta .01 " &
- "and with the currency string " &
- TC_CHF_String);
- end if;
-
- exception
- when others =>
- Report.Failed("Unexpected exception raised in Length_Block");
- end Length_Block;
-
-
- Valid_Block:
- declare
-
- -- This offset value is used to align picture string and decimal
- -- data values from package FXF3A00 for proper correspondence for
- -- the evaluations below.
-
- TC_Offset : constant Natural := 10;
-
- begin
-
- -- The following four For Loops examine cases where the
- -- decimal data/picture string/currency combinations used will
- -- generate valid Edited Output strings. These combinations, when
- -- provided to the Function Valid (from instantiations of
- -- Decimal_Output), should result in a return result of True.
- -- The particular instantiated version of Valid used in these loops
- -- is that for decimal data with delta 0.01.
-
- -- The first 4 picture strings in the Foreign_Strings array
- -- correspond to data values of a decimal type with delta 0.01,
- -- and to the currency string "FF" (two characters).
-
- for i in 1..FXF3A00.Number_of_FF_Strings loop
- -- Create the picture object from the picture string.
- TC_Picture := Editing.To_Picture(FXF3A00.Foreign_Strings(i).all);
-
- if not Pack_2DP.Valid (FXF3A00.Data_With_2DP(TC_Offset + i),
- TC_Picture,
- TC_FF_String)
- then
- Report.Failed("Incorrect result from function Valid, " &
- "when used with a decimal type with delta .01 " &
- "and with the currency string " & TC_FF_String &
- " in evaluating picture string " &
- FXF3A00.Foreign_Strings(i).all );
- end if;
- end loop;
-
-
- -- Picture strings 5-9 in the Foreign_Strings array correspond
- -- to data values of a decimal type with delta 0.01, and to the
- -- currency string "DM" (two characters).
-
- TC_Lower_Bound := FXF3A00.Number_of_FF_Strings + 1;
- TC_Higher_Bound := FXF3A00.Number_of_FF_Strings +
- FXF3A00.Number_of_DM_Strings;
-
- for i in TC_Lower_Bound..TC_Higher_Bound loop
- -- Create the picture object from the picture string.
- TC_Picture := Editing.To_Picture(FXF3A00.Foreign_Strings(i).all);
-
- if not Pack_2DP.Valid (FXF3A00.Data_With_2DP(TC_Offset + i),
- TC_Picture,
- TC_DM_String)
- then
- Report.Failed("Incorrect result from function Valid, " &
- "when used with a decimal type with delta .01 " &
- "and with the currency string " & TC_DM_String &
- " in evaluating picture string " &
- FXF3A00.Foreign_Strings(i).all );
- end if;
- end loop;
-
-
- -- Picture string #10 in the Foreign_Strings array corresponds
- -- to a data value of a decimal type with delta 0.01, and to the
- -- currency string "CHF" (three characters).
-
- -- Create the picture object from the picture string.
- TC_Picture := Editing.To_Picture(FXF3A00.Foreign_Strings(10).all);
-
- if not Pack_2DP.Valid (FXF3A00.Data_With_2DP(TC_Offset + 10),
- TC_Picture,
- TC_CHF_String)
- then
- Report.Failed("Incorrect result from function Valid, " &
- "when used with a decimal type with delta .01 " &
- "and with the currency string " &
- TC_CHF_String);
- end if;
-
-
- -- The following For Loop examines cases where the
- -- decimal data/picture string/currency combinations used will
- -- generate valid Edited Output strings.
- -- The particular instantiated version of Valid used in this loop
- -- is that for decimal data with delta 1.0; the others above have
- -- been for decimal data with delta 0.01.
- -- Note: TC_Offset is used here to align picture strings from the
- -- FXF3A00.Valid_Strings table with the appropriate decimal
- -- data in the FXF3A00.Data_With_NDP table.
-
- for i in 1..FXF3A00.Number_Of_NDP_Items loop
- -- Create the picture object from the picture string.
- TC_Picture :=
- Editing.To_Picture(FXF3A00.Valid_Strings(TC_Offset + i).all);
-
- if not Pack_NDP.Valid (FXF3A00.Data_With_NDP(i),
- TC_Picture,
- TC_US_String)
- then
- Report.Failed("Incorrect result from function Valid, " &
- "when used with a decimal type with delta .01 " &
- "and with the currency string " & TC_US_String &
- " in evaluating picture string " &
- FXF3A00.Valid_Strings(i).all );
- end if;
- end loop;
-
-
- -- The following three evaluations of picture strings, used in
- -- conjunction with the specific decimal values provided, will cause
- -- Editing.Image to raise Layout_Error (to be examined in other
- -- tests). Function Valid should return a False result for these
- -- combinations.
- -- The first two evaluations use the instantiation of Decimal_Output
- -- with a decimal type with delta 0.01, while the last evaluation
- -- uses the instantiation with decimal type with delta 1.0.
-
- for i in 1..FXF3A00.Number_of_Erroneous_Conditions loop
-
- -- Create the picture object from the picture string.
- TC_Picture :=
- Editing.To_Picture(FXF3A00.Erroneous_Strings(i).all);
-
- if i < 3 then -- Choose the appropriate instantiation.
- if Pack_2DP.Valid(Item => FXF3A00.Erroneous_Data(i),
- Pic => TC_Picture,
- Currency => TC_US_String)
- then
- Report.Failed("Incorrect result from function Valid, " &
- "when used with a decimal type with delta " &
- "0.01 and with the currency string " &
- TC_US_String &
- " in evaluating picture string " &
- FXF3A00.Valid_Strings(i).all );
- end if;
- else
- if Pack_NDP.Valid(Item => FXF3A00.Decimal_Type_NDP(
- FXF3A00.Erroneous_Data(i)),
- Pic => TC_Picture,
- Currency => TC_US_String)
- then
- Report.Failed("Incorrect result from function Valid, " &
- "when used with a decimal type with delta " &
- "1.0 and with the currency string " &
- TC_US_String &
- " in evaluating picture string " &
- FXF3A00.Valid_Strings(i).all );
- end if;
- end if;
- end loop;
-
- exception
- when others =>
- Report.Failed("Unexpected exception raised in Valid_Block");
- end Valid_Block;
-
-
- exception
- when others => Report.Failed ("Exception raised in Test_Block");
- end Test_Block;
-
- Report.Result;
-
-end CXF3A03;
diff --git a/gcc/testsuite/ada/acats/tests/cxf/cxf3a04.a b/gcc/testsuite/ada/acats/tests/cxf/cxf3a04.a
deleted file mode 100644
index 9eee39bb694..00000000000
--- a/gcc/testsuite/ada/acats/tests/cxf/cxf3a04.a
+++ /dev/null
@@ -1,293 +0,0 @@
--- CXF3A04.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that the edited output string value returned by Function Image
--- is correct.
---
--- TEST DESCRIPTION:
--- This test is structured using tables of data, consisting of
--- numerical values, picture strings, and expected image
--- result strings. These data tables are found in package FXF3A00.
---
--- The results of the Image function are examined under a number of
--- circumstances. The generic package Decimal_Output is instantiated
--- twice, for decimal data with delta 0.01 and delta 1.0. Each version
--- of Image is called with both default parameters and user-provided
--- parameters. The results of each call to Image are compared to an
--- expected edited output result string.
---
--- In addition, three calls to Image are designed to raise Layout_Error,
--- due to the combination of decimal value and picture string provided
--- as input parameters. If Layout_Error is not raised, or an alternate
--- exception is raised instead, test failure results.
---
--- TEST FILES:
--- The following files comprise this test:
---
--- FXF3A00.A (foundation code)
--- => CXF3A04.A
---
---
--- CHANGE HISTORY:
--- 22 JAN 95 SAIC Initial prerelease version.
--- 11 MAR 97 PWB.CTA Corrected incorrect index expression
---!
-
-with FXF3A00;
-with Ada.Text_IO.Editing;
-with Report;
-
-procedure CXF3A04 is
-begin
-
- Report.Test ("CXF3A04", "Check that the string value returned by " &
- "Function Image is correct, based on the " &
- "numerical data and picture formatting " &
- "parameters provided to the function");
-
- Test_Block:
- declare
-
- use Ada.Text_IO;
-
- -- Instantiate the Decimal_Output generic package for the two data
- -- types, using the default values for the Default_Currency,
- -- Default_Fill, Default_Separator, and Default_Radix_Mark
- -- parameters.
-
- package Pack_NDP is
- new Editing.Decimal_Output (FXF3A00.Decimal_Type_NDP);
-
- package Pack_2DP is
- new Editing.Decimal_Output (FXF3A00.Decimal_Type_2DP);
-
- TC_Currency : constant String := "$";
- TC_Fill : constant Character := '*';
- TC_Separator : constant Character := ',';
- TC_Radix_Mark : constant Character := '.';
-
- TC_Picture : Editing.Picture;
-
-
- begin
-
- Two_Decimal_Place_Data:
- -- Use a decimal fixed point type with delta 0.01 (two decimal places)
- -- and valid picture strings. Evaluate the result of function Image
- -- with the expected edited output result string.
- declare
-
- TC_Loop_End : constant := -- 10
- FXF3A00.Number_Of_2DP_Items - FXF3A00.Number_Of_Foreign_Strings;
-
- begin
- -- The first 10 picture strings in the Valid_Strings array
- -- correspond to data values of a decimal type with delta 0.01.
-
- -- Compare string result of Image with expected edited output
- -- string. Evaluate data using both default parameters of Image
- -- and user-provided parameter values.
- for i in 1..TC_Loop_End loop
-
- -- Create the picture object from the picture string.
- TC_Picture := Editing.To_Picture(FXF3A00.Valid_Strings(i).all);
-
- -- Use the default parameters for this loop evaluation of Image.
- if Pack_2DP.Image(FXF3A00.Data_With_2DP(i), TC_Picture) /=
- FXF3A00.Edited_Output(i).all
- then
- Report.Failed("Incorrect result from Function Image, " &
- "when used with a decimal type with delta " &
- "0.01, picture string " &
- FXF3A00.Valid_Strings(i).all &
- ", and the default parameters of Image");
- end if;
-
- -- Use user-provided parameters for this loop evaluation of Image.
-
- if Pack_2DP.Image(Item => FXF3A00.Data_With_2DP(i),
- Pic => TC_Picture,
- Currency => TC_Currency,
- Fill => TC_Fill,
- Separator => TC_Separator,
- Radix_Mark => TC_Radix_Mark) /=
- FXF3A00.Edited_Output(i).all
- then
- Report.Failed("Incorrect result from Function Image, " &
- "when used with a decimal type with delta " &
- "0.01, picture string " &
- FXF3A00.Valid_Strings(i).all &
- ", and user-provided parameters");
- end if;
-
- end loop;
-
- exception
- when others =>
- Report.Failed("Exception raised in Two_Decimal_Place_Data block");
- end Two_Decimal_Place_Data;
-
-
-
- No_Decimal_Place_Data:
- -- Use a decimal fixed point type with delta 1.00 (no decimal places)
- -- and valid picture strings. Evaluate the result of function Image
- -- with the expected result string.
- declare
-
- use Editing, FXF3A00;
-
- TC_Offset : constant := 10;
- TC_Loop_Start : constant := TC_Offset + 1; -- 11
- TC_Loop_End : constant := TC_Loop_Start +
- Number_Of_NDP_Items - 1; -- 22
-
- begin
- -- The following evaluations correspond to data values of a
- -- decimal type with delta 1.0.
-
- -- Compare string result of Image with expected edited output
- -- string. Evaluate data using both default parameters of Image
- -- and user-provided parameter values.
- -- Note: TC_Offset is used to align corresponding data the various
- -- data tables in foundation package FXF3A00.
-
- for i in TC_Loop_Start..TC_Loop_End loop
-
- -- Create the picture object from the picture string.
- TC_Picture := To_Picture(Valid_Strings(i).all);
-
- -- Use the default parameters for this loop evaluation of Image.
- if not (Pack_NDP.Image(Data_With_NDP(i-TC_Offset), TC_Picture) =
- Edited_Output(TC_Offset+i).all)
- then
- Report.Failed("Incorrect result from Function Image, " &
- "when used with a decimal type with delta " &
- "1.0, picture string " &
- Valid_Strings(i).all &
- ", and the default parameters of Image");
- end if;
-
- -- Use user-provided parameters for this loop evaluation of Image.
- if Pack_NDP.Image(Item => Data_With_NDP(i - TC_Offset),
- Pic => TC_Picture,
- Currency => TC_Currency,
- Fill => TC_Fill,
- Separator => TC_Separator,
- Radix_Mark => TC_Radix_Mark) /=
- Edited_Output(TC_Offset+i).all
- then
- Report.Failed("Incorrect result from Function Image, " &
- "when used with a decimal type with delta " &
- "1.0, picture string " &
- Valid_Strings(i).all &
- ", and user-provided parameters");
- end if;
-
- end loop;
-
- exception
- when others =>
- Report.Failed("Exception raised in No_Decimal_Place_Data block");
- end No_Decimal_Place_Data;
-
-
-
- Exception_Block:
- -- The following three calls of Function Image, using the specific
- -- decimal values and picture strings provided, will cause
- -- a Layout_Error to be raised.
- -- The first two evaluations use the instantiation of Decimal_Output
- -- with a decimal type with delta 0.01, while the last evaluation
- -- uses the instantiation with decimal type with delta 1.0.
-
- -- Note: The data and the picture strings used in the following
- -- evaluations are not themselves erroneous, but when used in
- -- combination will cause Layout_Error to be raised.
-
- begin
-
- for i in 1..FXF3A00.Number_Of_Erroneous_Conditions loop -- 1..3
- begin
- -- Create the picture object from the picture string.
- TC_Picture :=
- Editing.To_Picture(FXF3A00.Erroneous_Strings(i).all);
-
- -- Layout_Error must be raised by the following calls to
- -- Function Image.
-
- if i < 3 then -- Choose the appropriate instantiation.
- declare
- N : constant Natural := Pack_2DP.Length(TC_Picture);
- TC_String : String(1..N);
- begin
- TC_String := Pack_2DP.Image(FXF3A00.Erroneous_Data(i),
- TC_Picture);
- end;
- else
- declare
- use FXF3A00;
- N : constant Natural := Pack_NDP.Length(TC_Picture,
- TC_Currency);
- TC_String : String(1..N);
- begin
- TC_String :=
- Pack_NDP.Image(Item => Decimal_Type_NDP(
- Erroneous_Data(i)),
- Pic => TC_Picture,
- Currency => TC_Currency,
- Fill => TC_Fill,
- Separator => TC_Separator,
- Radix_Mark => TC_Radix_Mark);
- end;
- end if;
-
- Report.Failed("Layout_Error not raised by combination " &
- "# " & Integer'Image(i) & " " &
- "of decimal data and picture string");
-
- exception
- when Layout_Error => null; -- Expected exception.
- when others =>
- Report.Failed("Incorrect exception raised by combination " &
- "# " & Integer'Image(i) & " " &
- "of decimal data and picture string");
- end;
- end loop;
-
- exception
- when others =>
- Report.Failed("Unexpected exception raised in Exception_Block");
- end Exception_Block;
-
-
- exception
- when others => Report.Failed ("Exception raised in Test_Block");
- end Test_Block;
-
- Report.Result;
-
-end CXF3A04;
diff --git a/gcc/testsuite/ada/acats/tests/cxf/cxf3a05.a b/gcc/testsuite/ada/acats/tests/cxf/cxf3a05.a
deleted file mode 100644
index 3fb39332a50..00000000000
--- a/gcc/testsuite/ada/acats/tests/cxf/cxf3a05.a
+++ /dev/null
@@ -1,266 +0,0 @@
--- CXF3A05.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that Function Image produces correct results when provided
--- non-default parameters for Currency, Fill, Separator, and
--- Radix_Mark at either the time of package Decimal_Output instantiation,
--- or in a call to Image. Check non-default parameters that are
--- appropriate for foreign currency representations.
---
--- TEST DESCRIPTION:
--- This test is structured using tables of data, consisting of
--- numerical values, picture strings, and expected image
--- result strings. These data tables are found in package FXF3A00.
---
--- The results of the Image function, resulting from several different
--- instantiations of Decimal_Output, are compared with expected
--- edited output string results. The primary focus of this test is to
--- examine the effect of non-default parameters, provided during the
--- instantiation of package Decimal_Output, or provided as part of a
--- call to Function Image (that resulted from an instantiation of
--- Decimal_Output that used default parameters). The non-default
--- parameters provided correspond to foreign currency representations.
---
--- For each picture string/decimal data combination examined, two
--- evaluations of Image are performed. These correspond to the two
--- methods of providing the appropriate non-default parameters described
--- above. Both forms of Function Image should produce the same expected
--- edited output string.
---
--- TEST FILES:
--- The following files comprise this test:
---
--- FXF3A00.A (foundation code)
--- => CXF3A05.A
---
---
--- CHANGE HISTORY:
--- 26 JAN 95 SAIC Initial prerelease version.
--- 17 FEB 97 PWB.CTA Correct array indices for Foreign_Strings array
--- references.
---!
-
-with FXF3A00;
-with Ada.Text_IO.Editing;
-with Report;
-
-procedure CXF3A05 is
-begin
-
- Report.Test ("CXF3A05", "Check that Function Image produces " &
- "correct results when provided non-default " &
- "parameters for Currency, Fill, Separator, " &
- "and Radix_Mark, appropriate to foreign " &
- "currency representations");
-
- Test_Block:
- declare
-
- use Ada.Text_IO;
-
- -- Instantiate the Decimal_Output generic package for the several
- -- combinations of Default_Currency, Default_Fill, Default_Separator,
- -- and Default_Radix_Mark.
-
- package Pack_Def is -- Uses default parameter values.
- new Editing.Decimal_Output(FXF3A00.Decimal_Type_2DP);
-
- package Pack_FF is
- new Editing.Decimal_Output(FXF3A00.Decimal_Type_2DP,
- Default_Currency => "FF",
- Default_Fill => '*',
- Default_Separator => '.',
- Default_Radix_Mark => ',');
-
- package Pack_DM is
- new Editing.Decimal_Output(FXF3A00.Decimal_Type_2DP,
- Default_Currency => "DM",
- Default_Fill => '*',
- Default_Separator => ',',
- Default_Radix_Mark => '.');
-
- package Pack_CHF is
- new Editing.Decimal_Output(FXF3A00.Decimal_Type_2DP,
- Default_Currency => "CHF",
- Default_Fill => '*',
- Default_Separator => ',',
- Default_Radix_Mark => '.');
-
-
- TC_Picture : Editing.Picture;
- TC_Start_Loop : constant := 11;
- TC_End_Loop : constant := TC_Start_Loop + -- 20
- FXF3A00.Number_Of_Foreign_Strings - 1;
-
- begin
-
- -- In the case of each particular type of foreign string examined,
- -- two versions of Function Image are examined. First, a version of
- -- the function that originated from an instantiation of Decimal_Output
- -- with non-default parameters is checked. This version of Image is
- -- called making use of default parameters in the actual function call.
- -- In addition, a version of Function Image is checked that resulted
- -- from an instantiation of Decimal_Output using default parameters,
- -- but which uses non-default parameters in the function call.
-
- for i in TC_Start_Loop..TC_End_Loop loop
-
- -- Create the picture object from the picture string.
-
- TC_Picture := Editing.To_Picture
- (FXF3A00.Foreign_Strings(i - TC_Start_Loop + 1).all);
-
- -- Based on the ordering of the specific foreign picture strings
- -- in the FXF3A00.Foreign_Strings table, the following conditional
- -- is used to determine which type of currency is being examined
- -- as the loop executes.
-
- if i < TC_Start_Loop + FXF3A00.Number_Of_FF_Strings then -- (11-14)
- -- Process the FF picture strings.
-
- -- Check the result of Function Image from an instantiation
- -- of Decimal_Output that provided non-default actual
- -- parameters at the time of package instantiation, and uses
- -- default parameters in the call of Image.
-
- if Pack_FF.Image(Item => FXF3A00.Data_With_2DP(i),
- Pic => TC_Picture) /=
- FXF3A00.Edited_Output(i).all
- then
- Report.Failed("Incorrect output from Function Image " &
- "from package instantiated with FF " &
- "related parameters, using picture string " &
- FXF3A00.Foreign_Strings
- (i - TC_Start_Loop + 1).all);
- end if;
-
- -- Check the result of Function Image that originated from
- -- an instantiation of Decimal_Output where default parameters
- -- were used at the time of package Instantiation, but where
- -- non-default parameters are provided in the call of Image.
-
- if Pack_Def.Image(Item => FXF3A00.Data_With_2DP(i),
- Pic => TC_Picture,
- Currency => "FF",
- Fill => '*',
- Separator => '.',
- Radix_Mark => ',') /=
- FXF3A00.Edited_Output(i).all
- then
- Report.Failed("Incorrect output from Function Image " &
- "from package instantiated with default " &
- "parameters, using picture string " &
- FXF3A00.Foreign_Strings
- (i - TC_Start_Loop + 1).all &
- ", and FF related parameters in call to Image");
- end if;
-
-
- elsif i < TC_Start_Loop + -- (15-19)
- FXF3A00.Number_Of_FF_Strings +
- FXF3A00.Number_Of_DM_Strings then
- -- Process the DM picture strings.
-
- -- Non-default instantiation parameters, default function call
- -- parameters.
-
- if Pack_DM.Image(Item => FXF3A00.Data_With_2DP(i),
- Pic => TC_Picture) /=
- FXF3A00.Edited_Output(i).all
- then
- Report.Failed("Incorrect output from Function Image " &
- "from package instantiated with DM " &
- "related parameters, using picture string " &
- FXF3A00.Foreign_Strings
- (i - TC_Start_Loop + 1).all);
- end if;
-
- -- Default instantiation parameters, non-default function call
- -- parameters.
-
- if Pack_Def.Image(Item => FXF3A00.Data_With_2DP(i),
- Pic => TC_Picture,
- Currency => "DM",
- Fill => '*',
- Separator => ',',
- Radix_Mark => '.') /=
- FXF3A00.Edited_Output(i).all
- then
- Report.Failed("Incorrect output from Function Image " &
- "from package instantiated with default " &
- "parameters, using picture string " &
- FXF3A00.Foreign_Strings
- (i - TC_Start_Loop + 1).all &
- ", and DM related parameters in call to Image");
- end if;
-
-
- else -- (i=20)
- -- Process the CHF string.
-
- -- Non-default instantiation parameters, default function call
- -- parameters.
-
- if Pack_CHF.Image(FXF3A00.Data_With_2DP(i), TC_Picture) /=
- FXF3A00.Edited_Output(i).all
- then
- Report.Failed("Incorrect output from Function Image " &
- "from package instantiated with CHF " &
- "related parameters, using picture string " &
- FXF3A00.Foreign_Strings
- (i - TC_Start_Loop + 1).all);
- end if;
-
- -- Default instantiation parameters, non-default function call
- -- parameters.
-
- if Pack_Def.Image(FXF3A00.Data_With_2DP(i),
- TC_Picture,
- "CHF",
- '*',
- ',',
- '.') /=
- FXF3A00.Edited_Output(i).all
- then
- Report.Failed("Incorrect output from Function Image " &
- "from package instantiated with default " &
- "parameters, using picture string " &
- FXF3A00.Foreign_Strings
- (i - TC_Start_Loop + 1).all &
- ", and CHF related parameters in call to Image");
- end if;
-
- end if;
-
- end loop;
-
- exception
- when others => Report.Failed ("Exception raised in Test_Block");
- end Test_Block;
-
- Report.Result;
-
-end CXF3A05;
diff --git a/gcc/testsuite/ada/acats/tests/cxf/cxf3a06.a b/gcc/testsuite/ada/acats/tests/cxf/cxf3a06.a
deleted file mode 100644
index 7b769ba96bf..00000000000
--- a/gcc/testsuite/ada/acats/tests/cxf/cxf3a06.a
+++ /dev/null
@@ -1,302 +0,0 @@
--- CXF3A06.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that Ada.Text_IO.Editing.Put and Ada.Text_IO.Put have the same
--- effect.
---
--- TEST DESCRIPTION:
--- This test is structured using tables of data, consisting of
--- numerical values, picture strings, and expected image
--- result strings. These data tables are found in package FXF3A00.
---
--- The testing approach used in this test is that of writing edited
--- output data to a text file, using two different approaches. First,
--- Ada.Text_IO.Put is used, with a call to an instantiated version of
--- Function Image supplied as the actual for parameter Item. The
--- second approach is to use a version of Function Put from an
--- instantiation of Ada.Text_IO.Editing.Decimal_Output, with the
--- appropriate parameters for decimal data, picture, and format
--- specific parameters. A call to New_Line follows each Put, so that
--- each entry is placed on a separate line in the text file.
---
--- Edited output for decimal data with two decimal places is in the
--- first loop, and once the data has been written to the file, the
--- text file is closed, then opened in In_File mode. The edited
--- output data is read from the file, and data on successive lines
--- is compared with the expected edited output result. The edited
--- output data produced by both of the Put procedures should be
--- identical.
---
--- This process is repeated for decimal data with no decimal places.
--- The file is reopened in Append_File mode, and the edited output
--- data is added to the file in the same manner as described above.
--- The file is closed, and reopened to verify the data written.
--- The data written above (with two decimal places) is skipped, then
--- the data to be verified is extracted as above and verified against
--- the expected edited output string values.
---
--- APPLICABILITY CRITERIA:
--- This test is applicable only to implementations that support
--- external text files.
---
--- TEST FILES:
--- The following files comprise this test:
---
--- FXF3A00.A (foundation code)
--- => CXF3A06.A
---
---
--- CHANGE HISTORY:
--- 26 JAN 95 SAIC Initial prerelease version.
--- 26 FEB 97 PWB.CTA Made input buffers sufficiently long
--- and removed code depending on shorter buffers
---!
-
-with FXF3A00;
-with Ada.Text_IO.Editing;
-with Report;
-
-procedure CXF3A06 is
- use Ada;
-begin
-
- Report.Test ("CXF3A06", "Check that Ada.Text_IO.Editing.Put and " &
- "Ada.Text_IO.Put have the same effect");
-
- Test_for_Text_IO_Support:
- declare
- Text_File : Ada.Text_IO.File_Type;
- Text_Filename : constant String := Report.Legal_File_Name(1);
- begin
-
- -- Use_Error will be raised if Text_IO operations or external files
- -- are not supported.
-
- Text_IO.Create (Text_File, Text_IO.Out_File, Text_Filename);
-
- Test_Block:
- declare
- use Ada.Text_IO;
-
- -- Instantiate the Decimal_Output generic package for two
- -- different decimal data types.
-
- package Pack_2DP is -- Uses decimal type with delta 0.01.
- new Editing.Decimal_Output(FXF3A00.Decimal_Type_2DP);
-
- package Pack_NDP is -- Uses decimal type with delta 1.0.
- new Editing.Decimal_Output(Num => FXF3A00.Decimal_Type_NDP,
- Default_Currency => "$",
- Default_Fill => '*',
- Default_Separator => ',',
- Default_Radix_Mark => '.');
-
- TC_Picture : Editing.Picture;
- TC_Start_Loop : constant := 1;
- TC_End_Loop_1 : constant := FXF3A00.Number_Of_2DP_Items - -- 20-10
- FXF3A00.Number_Of_Foreign_Strings;
- TC_End_Loop_2 : constant := FXF3A00.Number_Of_NDP_Items; -- 12
- TC_Offset : constant := FXF3A00.Number_Of_2DP_Items; -- 20
-
- TC_String_1, TC_String_2 : String(1..255) := (others => ' ');
- TC_Last_1, TC_Last_2 : Natural := 0;
-
- begin
-
- -- Use the two versions of Put, for data with two decimal points,
- -- to write edited output strings to the text file. Use a separate
- -- line for each string entry.
-
- for i in TC_Start_Loop..TC_End_Loop_1 loop -- 1..10
-
- -- Create the picture object from the picture string.
-
- TC_Picture := Editing.To_Picture(FXF3A00.Valid_Strings(i).all);
-
- -- Use the Text_IO version of Put to place an edited output
- -- string into a text file. Use default parameters in the call
- -- to Image for Currency, Fill, Separator, and Radix_Mark.
-
- Text_IO.Put(Text_File,
- Pack_2DP.Image(Item => FXF3A00.Data_With_2DP(i),
- Pic => TC_Picture));
- Text_IO.New_Line(Text_File);
-
- -- Use the version of Put from the instantiation of
- -- Decimal_Output to place an edited output string on a separate
- -- line of the Text_File. Use default parameters for Currency,
- -- Fill, Separator, and Radix_Mark.
-
- Pack_2DP.Put(File => Text_File,
- Item => FXF3A00.Data_With_2DP(i),
- Pic => TC_Picture);
- Text_IO.New_Line(Text_File);
-
- end loop;
-
- Text_IO.Close(Text_File);
-
- -- Reopen the text file in In_File mode, and verify the edited
- -- output found on consecutive lines of the file.
-
- Text_IO.Open(Text_File, Text_IO.In_File, Text_Filename);
-
- for i in TC_Start_Loop..TC_End_Loop_1 loop
- -- Read successive lines in the text file.
- Text_IO.Get_Line(Text_File, TC_String_1, TC_Last_1);
- Text_IO.Get_Line(Text_File, TC_String_2, TC_Last_2);
-
- -- Compare the two strings for equality with the expected edited
- -- output result. Failure results if strings don't match, or if
- -- a reading error occurred from the attempted Get_Line resulting
- -- from an improperly formed edited output string.
-
- if TC_String_1(1..TC_Last_1) /= FXF3A00.Edited_Output(i).all or
- TC_String_2(1..TC_Last_2) /= FXF3A00.Edited_Output(i).all
- then
- Report.Failed("Failed comparison of two edited output " &
- "strings from data with two decimal points " &
- ", loop number = " & Integer'Image(i));
- end if;
- end loop;
-
- Text_IO.Close(Text_File);
-
- -- Reopen the text file in Append_File mode.
- -- Use the two versions of Put, for data with no decimal points,
- -- to write edited output strings to the text file. Use a separate
- -- line for each string entry.
-
- Text_IO.Open(Text_File, Text_IO.Append_File, Text_Filename);
-
- for i in TC_Start_Loop..TC_End_Loop_2 loop -- 1..12
-
- -- Create the picture object from the picture string specific to
- -- data with no decimal points. Use appropriate offset into the
- -- Valid_Strings array to account for the string data used above.
-
- TC_Picture :=
- Editing.To_Picture(FXF3A00.Valid_Strings(i+TC_End_Loop_1).all);
-
- -- Use the Text_IO version of Put to place an edited output
- -- string into a text file. Use non-default parameters in the
- -- call to Image for Currency, Fill, Separator, and Radix_Mark.
-
- Text_IO.Put(Text_File,
- Pack_NDP.Image(Item => FXF3A00.Data_With_NDP(i),
- Pic => TC_Picture,
- Currency => "$",
- Fill => '*',
- Separator => ',',
- Radix_Mark => '.'));
- Text_IO.New_Line(Text_File);
-
- -- Use the version of Put from the instantiation of
- -- Decimal_Output to place an edited output string on a separate
- -- line of the Text_File. Use non-default parameters for
- -- Currency, Fill, Separator, and Radix_Mark.
-
- Pack_NDP.Put(File => Text_File,
- Item => FXF3A00.Data_With_NDP(i),
- Pic => TC_Picture,
- Currency => "$",
- Fill => '*',
- Separator => ',',
- Radix_Mark => '.');
- Text_IO.New_Line(Text_File);
-
- end loop;
-
- Text_IO.Close(Text_File);
-
- -- Reopen the text file in In_File mode, and verify the edited
- -- output found on consecutive lines of the file.
-
- Text_IO.Open(Text_File, Text_IO.In_File, Text_Filename);
-
- -- Read past data that has been verified above, skipping two lines
- -- of the data file for each loop.
-
- for i in TC_Start_Loop..TC_End_Loop_1 loop -- 1..10
- Text_IO.Skip_Line(Text_File, 2);
- end loop;
-
- -- Verify the last data set that was written to the file.
-
- for i in TC_Start_Loop..TC_End_Loop_2 loop -- 1..12
- Text_IO.Get_Line(Text_File, TC_String_1, TC_Last_1);
- Text_IO.Get_Line(Text_File, TC_String_2, TC_Last_2);
-
- -- Compare the two strings for equality with the expected edited
- -- output result. Failure results if strings don't match, or if
- -- a reading error occurred from the attempted Get_Line resulting
- -- from an improperly formed edited output string.
-
- if TC_String_1(1..TC_Last_1) /=
- FXF3A00.Edited_Output(i+TC_Offset).all or
- TC_String_2(1..TC_Last_2) /=
- FXF3A00.Edited_Output(i+TC_Offset).all
- then
- Report.Failed("Failed comparison of two edited output " &
- "strings from data with no decimal points " &
- ", loop number = " &
- Integer'Image(i));
- end if;
-
- end loop;
-
- exception
- when others => Report.Failed("Exception raised in Test_Block");
- end Test_Block;
-
- -- Delete the external file.
- if Text_IO.Is_Open (Text_File) then
- Text_IO.Delete (Text_File);
- else
- Text_IO.Open (Text_File, Text_IO.In_File, Text_Filename);
- Text_IO.Delete (Text_File);
- end if;
-
- exception
-
- -- Since Use_Error can be raised if, for the specified mode,
- -- the environment does not support Text_IO operations, the
- -- following handlers are included:
-
- when Text_IO.Use_Error =>
- Report.Not_Applicable ("Use_Error raised on Text_IO Create");
-
- when Text_IO.Name_Error =>
- Report.Not_Applicable ("Name_Error raised on Text_IO Create");
-
- when others =>
- Report.Failed ("Unexpected exception raised in Create block");
-
- end Test_for_Text_IO_Support;
-
- Report.Result;
-
-end CXF3A06;
diff --git a/gcc/testsuite/ada/acats/tests/cxf/cxf3a07.a b/gcc/testsuite/ada/acats/tests/cxf/cxf3a07.a
deleted file mode 100644
index 7cb2c360c97..00000000000
--- a/gcc/testsuite/ada/acats/tests/cxf/cxf3a07.a
+++ /dev/null
@@ -1,337 +0,0 @@
--- CXF3A07.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that Ada.Text_IO.Editing.Put and Ada.Strings.Fixed.Move
--- have the same effect in putting edited output results into string
--- variables.
---
--- TEST DESCRIPTION:
--- This test is structured using tables of data, consisting of
--- numerical values, picture strings, and expected image
--- result strings. These data tables are found in package FXF3A00.
---
--- The operation of the two above subprograms are examined twice, first
--- with the output of an edited output string to a receiving string
--- object of equal size, the other to a receiving string object of
--- larger size, where justification and padding are considered.
--- The procedure Editing.Put will place an edited output string into
--- a larger receiving string with right justification and blank fill.
--- Procedure Move has parameter control of justification and fill, and
--- in this test will mirror Put by specifying right justification and
--- blank fill.
---
--- In the cases where the edited output string is of shorter length
--- than the receiving string object, a blank-filled constant string
--- will be catenated to the front of the expected edited output string
--- for comparison with the receiving string object, enabling direct
--- string comparison for result verification.
---
--- TEST FILES:
--- The following files comprise this test:
---
--- FXF3A00.A (foundation code)
--- => CXF3A07.A
---
---
--- CHANGE HISTORY:
--- 30 JAN 95 SAIC Initial prerelease version.
--- 11 MAR 97 PWB.CTA Fixed string lengths
---!
-
-with FXF3A00;
-with Ada.Text_IO.Editing;
-with Ada.Strings.Fixed;
-with Report;
-
-procedure CXF3A07 is
-begin
-
- Report.Test ("CXF3A07", "Check that Ada.Text_IO.Editing.Put and " &
- "Ada.Strings.Fixed.Move have the same " &
- "effect in putting edited output results " &
- "into string variables");
- Test_Block:
- declare
-
- use Ada.Text_IO;
-
- -- Instantiate the Decimal_Output generic package for two
- -- different decimal data types.
-
- package Pack_2DP is -- Uses decimal type with delta 0.01.
- new Editing.Decimal_Output(FXF3A00.Decimal_Type_2DP);
-
- package Pack_NDP is -- Uses decimal type with delta 1.0.
- new Editing.Decimal_Output(Num => FXF3A00.Decimal_Type_NDP,
- Default_Currency => "$",
- Default_Fill => '*',
- Default_Separator => ',',
- Default_Radix_Mark => '.');
-
- TC_Picture : Editing.Picture;
- TC_Start_Loop : Integer := 0;
- TC_End_Loop : Integer := 0;
- TC_Offset : Integer := 0;
- TC_Length : Natural := 0;
-
- TC_Put_String_20, -- Longer than the longest edited
- TC_Move_String_20 : String(1..20); -- output string.
-
- TC_Put_String_17, -- Exact length of longest edited
- TC_Move_String_17 : String(1..17); -- output string in 2DP-US data set.
-
- TC_Put_String_8, -- Exact length of longest edited
- TC_Move_String_8 : String(1..8); -- output string in NDP-US data set.
-
-
- begin
-
- -- Examine cases where the output string is longer than the length
- -- of the edited output result. Use the instantiation of
- -- Decimal_Output specific to data with two decimal places.
-
- TC_Start_Loop := 1;
- TC_End_Loop := FXF3A00.Number_of_2DP_Items - -- 10
- FXF3A00.Number_Of_Foreign_Strings;
-
- for i in TC_Start_Loop..TC_End_Loop loop -- 1..10
-
- -- Create the picture object from the picture string.
-
- TC_Picture := Editing.To_Picture(FXF3A00.Valid_Strings(i).all,
- Blank_When_Zero => False);
-
- -- Determine the actual length of the edited output string
- -- that is expected from Put and Image.
-
- TC_Length := Pack_2DP.Length(Pic => TC_Picture,
- Currency => "$");
-
- -- Determine the difference in length between the receiving string
- -- object and the expected length of the edited output string.
- -- Define a blank filled string constant with length equal to this
- -- length difference.
-
- declare
- TC_Length_Diff : Integer := TC_Put_String_20'Length -
- TC_Length;
- TC_Buffer_String : constant String(1..TC_Length_Diff) :=
- (others => ' ');
- begin
-
- -- Fill the two receiving string objects with edited output,
- -- using the two different methods (Put and Move).
-
- Pack_2DP.Put(To => TC_Put_String_20,
- Item => FXF3A00.Data_With_2DP(i),
- Pic => TC_Picture,
- Currency => "$",
- Fill => '*',
- Separator => ',',
- Radix_Mark => '.');
-
-
- Ada.Strings.Fixed.Move
- (Source => Pack_2DP.Image(Item => FXF3A00.Data_With_2DP(i),
- Pic => TC_Picture,
- Currency => "$",
- Fill => '*',
- Separator => ',',
- Radix_Mark => '.'),
- Target => TC_Move_String_20,
- Drop => Ada.Strings.Error,
- Justify => Ada.Strings.Right,
- Pad => Ada.Strings.Space);
-
- -- Each receiving string object is now filled with the edited
- -- output result, right justified.
- -- Compare these two string objects with the expected edited
- -- output value, which is appended to the blank filled string
- -- whose length is the difference between the expected edited
- -- output length and the length of the receiving strings.
-
- if TC_Buffer_String & FXF3A00.Edited_Output(i).all /=
- TC_Put_String_20 or
- TC_Buffer_String & FXF3A00.Edited_Output(i).all /=
- TC_Move_String_20
- then
- Report.Failed("Failed case where the output string is " &
- "longer than the length of the edited " &
- "output result, loop #" & Integer'Image(i));
- end if;
-
- exception
- when Layout_Error =>
- Report.Failed("Layout_Error raised when the output string " &
- "is longer than the length of the edited " &
- "output result, loop #" & Integer'Image(i));
- when others =>
- Report.Failed("Exception raised when the output string is " &
- "longer than the length of the edited " &
- "output result, loop #" & Integer'Image(i));
- end;
- end loop;
-
-
- -- Repeat the above loop, but only evaluate three cases - those where
- -- the length of the expected edited output string is the exact length
- -- of the receiving strings (no justification will be required within
- -- the string. This series of evaluations again uses decimal data
- -- with two decimal places.
-
- for i in TC_Start_Loop..TC_End_Loop loop -- 1..10
-
- case i is
- when 1 | 5 | 7 =>
-
- -- Create the picture object from the picture string.
- TC_Picture :=
- Editing.To_Picture(FXF3A00.Valid_Strings(i).all);
-
- -- Fill the two receiving string objects with edited output,
- -- using the two different methods (Put and Move).
- -- Use default parameters in the various calls where possible.
-
- Pack_2DP.Put(To => TC_Put_String_17,
- Item => FXF3A00.Data_With_2DP(i),
- Pic => TC_Picture);
-
-
- Ada.Strings.Fixed.Move
- (Source => Pack_2DP.Image(Item => FXF3A00.Data_With_2DP(i),
- Pic => TC_Picture),
- Target => TC_Move_String_17);
-
- -- Each receiving string object is now filled with the edited
- -- output result. Compare these two string objects with the
- -- expected edited output value.
-
- if FXF3A00.Edited_Output(i).all /= TC_Put_String_17 or
- FXF3A00.Edited_Output(i).all /= TC_Move_String_17
- then
- Report.Failed("Failed case where the output string is " &
- "the exact length of the edited output " &
- "result, loop #" & Integer'Image(i));
- end if;
-
- when others => null;
- end case;
- end loop;
-
-
- -- Evaluate a mix of cases, where the expected edited output string
- -- length is either exactly as long or shorter than the receiving
- -- output string parameter. This series of evaluations uses decimal
- -- data with no decimal places.
-
- TC_Start_Loop := TC_End_Loop + 1; -- 11
- TC_End_Loop := TC_Start_Loop + -- 22
- FXF3A00.Number_of_NDP_Items - 1;
- TC_Offset := FXF3A00.Number_of_Foreign_Strings; -- 10
- -- This offset is required due to the arrangement of data within the
- -- tables found in FXF3A00.
-
- for i in TC_Start_Loop..TC_End_Loop loop -- 11..22
-
- -- Create the picture object from the picture string.
-
- TC_Picture := Editing.To_Picture(FXF3A00.Valid_Strings(i).all);
-
- -- Determine the actual length of the edited output string
- -- that is expected from Put and Image.
-
- TC_Length := Pack_NDP.Length(TC_Picture);
-
- -- Fill the two receiving string objects with edited output,
- -- using the two different methods (Put and Move).
-
- Pack_NDP.Put(TC_Put_String_8,
- FXF3A00.Data_With_NDP(i-TC_Offset),
- TC_Picture);
-
- Ada.Strings.Fixed.Move
- (Pack_NDP.Image(FXF3A00.Data_With_NDP(i-TC_Offset), TC_Picture),
- TC_Move_String_8,
- Ada.Strings.Error,
- Ada.Strings.Right,
- Ada.Strings.Space);
-
- -- Determine if there is a difference in length between the
- -- receiving string object and the expected length of the edited
- -- output string. If so, then define a blank filled string constant
- -- with length equal to this length difference.
-
- if TC_Length < TC_Put_String_8'Length then
- declare
- TC_Length_Diff : Integer := TC_Put_String_8'Length -
- TC_Length;
- TC_Buffer_String : constant String(1..TC_Length_Diff) :=
- (others => ' ');
- begin
-
- -- Each receiving string object is now filled with the edited
- -- output result, right justified.
- -- Compare these two string objects with the expected edited
- -- output value, which is appended to the blank filled string
- -- whose length is the difference between the expected edited
- -- output length and the length of the receiving strings.
-
- if TC_Buffer_String & FXF3A00.Edited_Output(i+TC_Offset).all /=
- TC_Put_String_8 or
- TC_Buffer_String & FXF3A00.Edited_Output(i+TC_Offset).all /=
- TC_Move_String_8
- then
- Report.Failed("Failed case where the output string is " &
- "longer than the length of the edited " &
- "output result, loop #" & Integer'Image(i) &
- ", using data with no decimal places");
- end if;
- end;
- else
-
- -- Compare these two string objects with the expected edited
- -- output value, which is appended to the blank filled string
- -- whose length is the difference between the expected edited
- -- output length and the length of the receiving strings.
-
- if FXF3A00.Edited_Output(i+TC_Offset).all /= TC_Put_String_8 or
- FXF3A00.Edited_Output(i+TC_Offset).all /= TC_Move_String_8
- then
- Report.Failed("Failed case where the output string is " &
- "the same length as the edited output " &
- "result, loop #" & Integer'Image(i) &
- ", using data with no decimal places");
- end if;
- end if;
- end loop;
-
- exception
- when others => Report.Failed("Exception raised in Test_Block");
- end Test_Block;
-
- Report.Result;
-
-end CXF3A07;
diff --git a/gcc/testsuite/ada/acats/tests/cxf/cxf3a08.a b/gcc/testsuite/ada/acats/tests/cxf/cxf3a08.a
deleted file mode 100644
index 871ab5600a9..00000000000
--- a/gcc/testsuite/ada/acats/tests/cxf/cxf3a08.a
+++ /dev/null
@@ -1,289 +0,0 @@
--- CXF3A08.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that the version of Ada.Text_IO.Editing.Put with an out
--- String parameter propagates Layout_Error if the edited output string
--- result of Put exceeds the length of the out String parameter.
---
--- TEST DESCRIPTION:
--- This test is structured using tables of data, consisting of
--- numerical values, picture strings, and expected image
--- result strings. These data tables are found in package FXF3A00.
---
--- This test examines the case of the out string parameter to Procedure
--- Put being insufficiently long to hold the entire edited output
--- string result of the procedure. In this case, Layout_Error is to be
--- raised. Test failure results if Layout_Error is not raised, or if an
--- exception other than Layout_Error is raised.
---
--- A number of data combinations are examined, using instantiations
--- of Package Decimal_Output with different decimal data types and
--- both default and non-default parameters as generic actual parameters.
--- In addition, calls to Procedure Put are performed using default
--- parameters, non-default parameters, and non-default parameters that
--- override the generic actual parameters provided at the time of
--- instantiation of Decimal_Output.
---
--- TEST FILES:
--- The following files comprise this test:
---
--- FXF3A00.A (foundation code)
--- => CXF3A08.A
---
---
--- CHANGE HISTORY:
--- 31 JAN 95 SAIC Initial prerelease version.
---
---!
-
-with FXF3A00;
-with Ada.Text_IO.Editing;
-with Report;
-
-procedure CXF3A08 is
-begin
-
- Report.Test ("CXF3A08", "Check that the version of " &
- "Ada.Text_IO.Editing.Put with an out " &
- "String parameter propagates Layout_Error " &
- "if the output string exceeds the length " &
- "of the out String parameter");
-
- Test_Block:
- declare
-
- use Ada.Text_IO;
-
- -- Instantiate the Decimal_Output generic package for two
- -- different decimal data types.
- -- Uses decimal type with delta 0.01 and
- package Pack_2DP is -- non-default generic actual parameters.
- new Editing.Decimal_Output(Num => FXF3A00.Decimal_Type_2DP,
- Default_Currency => "$",
- Default_Fill => '*',
- Default_Separator => ',',
- Default_Radix_Mark => '.');
-
- package Pack_NDP is -- Uses decimal type with delta 1.0.
- new Editing.Decimal_Output(FXF3A00.Decimal_Type_NDP);
-
- TC_Picture : Editing.Picture;
- TC_Start_Loop : Integer := 0;
- TC_End_Loop : Integer := 0;
- TC_Offset : Integer := 0;
-
- TC_Short_String : String(1..4); -- Shorter than the shortest edited
- -- output string result.
-
- begin
-
- -- Examine cases where the out string parameter is shorter than
- -- the length of the edited output result. Use the instantiation of
- -- Decimal_Output specific to data with two decimal places.
-
- TC_Start_Loop := 1;
- TC_End_Loop := FXF3A00.Number_of_2DP_Items - -- 10
- FXF3A00.Number_Of_Foreign_Strings;
-
- for i in TC_Start_Loop..TC_End_Loop loop -- 1..10
-
- -- Create the picture object from the picture string.
-
- TC_Picture :=
- Editing.To_Picture(Pic_String => FXF3A00.Valid_Strings(i).all,
- Blank_When_Zero => False);
-
- -- The out parameter string provided in the call to Put is
- -- shorter than the edited output result of the procedure.
- -- This will result in a Layout_Error being raised and handled.
- -- Test failure results from no exception being raised, or from
- -- the wrong exception being raised.
-
- begin
-
- -- Use the instantiation of Decimal_Output specific to decimal
- -- data with two decimal places, as well as non-default
- -- parameters and named parameter association.
-
- Pack_2DP.Put(To => TC_Short_String,
- Item => FXF3A00.Data_With_2DP(i),
- Pic => TC_Picture,
- Currency => "$",
- Fill => '*',
- Separator => ',',
- Radix_Mark => '.');
-
- -- Test failure if exception not raised.
-
- Report.Failed
- ("Layout_Error not raised, decimal data with two decimal " &
- "places, loop #" & Integer'Image(i));
-
- exception
- when Layout_Error => null; -- OK, expected exception.
- when others =>
- Report.Failed
- ("Incorrect exception raised, Layout_Error expected, " &
- "decimal data with two decimal places, loop #" &
- Integer'Image(i));
- end;
- end loop;
-
-
- -- Perform similar evaluations as above, but use the instantiation
- -- of Decimal_Output specific to decimal data with no decimal places.
-
- TC_Start_Loop := TC_End_Loop + 1; -- 11
- TC_End_Loop := TC_Start_Loop + -- 22
- FXF3A00.Number_of_NDP_Items - 1;
- TC_Offset := FXF3A00.Number_of_Foreign_Strings; -- 10
- -- This offset is required due to the arrangement of data within the
- -- tables found in FXF3A00.
-
- for i in TC_Start_Loop..TC_End_Loop loop -- 11..22
-
- -- Create the picture object from the picture string.
-
- TC_Picture := Editing.To_Picture(FXF3A00.Valid_Strings(i).all);
-
- begin
-
- -- Use the instantiation of Decimal_Output specific to decimal
- -- data with no decimal places, as well as default parameters
- -- and positional parameter association.
-
- Pack_NDP.Put(TC_Short_String,
- FXF3A00.Data_With_NDP(i-TC_Offset),
- TC_Picture);
-
- -- Test failure if exception not raised.
-
- Report.Failed
- ("Layout_Error not raised, decimal data with no decimal " &
- "places, loop #" & Integer'Image(i));
-
- exception
- when Layout_Error => null; -- OK, expected exception.
- when others =>
- Report.Failed
- ("Incorrect exception raised, Layout_Error expected, " &
- "decimal data with no decimal places, loop #" &
- Integer'Image(i));
- end;
-
- end loop;
-
-
- -- Check that Layout_Error is raised by Put resulting from an
- -- instantiation of Decimal_Output specific to foreign currency
- -- representations.
- -- Note: Both of the following evaluation sets use decimal data with
- -- two decimal places.
-
- declare
-
- package Pack_FF is
- new Editing.Decimal_Output(Num => FXF3A00.Decimal_Type_2DP,
- Default_Currency => "FF",
- Default_Fill => '*',
- Default_Separator => '.',
- Default_Radix_Mark => ',');
-
- begin
-
- TC_Offset := FXF3A00.Number_Of_2DP_Items - -- 10
- FXF3A00.Number_Of_Foreign_Strings;
-
- for i in 1..FXF3A00.Number_Of_FF_Strings loop -- 1..4
- begin
-
- -- Create the picture object from the picture string.
- TC_Picture :=
- Editing.To_Picture(FXF3A00.Foreign_Strings(i).all);
-
- Pack_FF.Put(To => TC_Short_String,
- Item => FXF3A00.Data_With_2DP(i+TC_Offset),
- Pic => TC_Picture);
-
- Report.Failed("Layout_Error was not raised by Put from " &
- "an instantiation of Decimal_Output using " &
- "non-default parameters specific to FF " &
- "currency, loop #" & Integer'Image(i));
-
- exception
- when Layout_Error => null; -- OK, expected exception.
- when others =>
- Report.Failed("Incorrect exception raised by Put from " &
- "an instantiation of Decimal_Output using " &
- "non-default parameters specific to FF " &
- "currency, loop #" & Integer'Image(i));
- end;
- end loop;
-
-
- -- These evaluations use a version of Put resulting from a
- -- non-default instantiation of Decimal_Output, but which has
- -- specific foreign currency parameters provided in the call that
- -- override the generic actual parameters provided at instantiation.
-
- TC_Offset := TC_Offset + FXF3A00.Number_Of_FF_Strings; -- 14
-
- for i in 1..FXF3A00.Number_Of_DM_Strings loop -- 1..5
- begin
- TC_Picture :=
- Editing.To_Picture(FXF3A00.Foreign_Strings
- (i+FXF3A00.Number_Of_FF_Strings).all);
-
- Pack_2DP.Put(To => TC_Short_String,
- Item => FXF3A00.Data_With_2DP(i+TC_Offset),
- Pic => TC_Picture,
- Currency => "DM",
- Fill => '*',
- Separator => ',',
- Radix_Mark => '.');
-
- Report.Failed("Layout_Error was not raised by Put using " &
- "non-default parameters specific to DM " &
- "currency, loop #" & Integer'Image(i));
-
- exception
- when Layout_Error => null; -- OK, expected exception.
- when others =>
- Report.Failed("Incorrect exception raised by Put using " &
- "non-default parameters specific to DM " &
- "currency, loop #" & Integer'Image(i));
- end;
- end loop;
-
- end;
-
- exception
- when others => Report.Failed("Exception raised in Test_Block");
- end Test_Block;
-
- Report.Result;
-
-end CXF3A08;
diff --git a/gcc/testsuite/ada/acats/tests/cxg/cxg1001.a b/gcc/testsuite/ada/acats/tests/cxg/cxg1001.a
deleted file mode 100644
index 01a0f061e51..00000000000
--- a/gcc/testsuite/ada/acats/tests/cxg/cxg1001.a
+++ /dev/null
@@ -1,276 +0,0 @@
--- CXG1001.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that the subprograms defined in the package
--- Ada.Numerics.Generic_Complex_Types provide correct results.
--- Specifically, check the functions Re, Im (both versions), procedures
--- Set_Re, Set_Im (both versions), functions Compose_From_Cartesian (all
--- versions), Compose_From_Polar, Modulus, Argument, and "abs".
---
--- TEST DESCRIPTION:
--- The generic package Generic_Complex_Types
--- is instantiated with a real type (new Float), and the results
--- produced by the specified subprograms are verified.
---
--- APPLICABILITY CRITERIA:
--- This test applies only to implementations supporting the
--- Numerics Annex.
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 15 Nov 95 SAIC Corrected visibility problems for ACVC 2.0.1.
--- Modified subtest for Compose_From_Polar.
--- 29 Sep 96 SAIC Incorporated reviewer comments.
---
---!
-
-with Ada.Numerics.Generic_Complex_Types;
-with Report;
-
-procedure CXG1001 is
-
-begin
-
- Report.Test ("CXG1001", "Check that the subprograms defined in " &
- "the package Ada.Numerics.Generic_Complex_Types " &
- "provide correct results");
-
- Test_Block:
- declare
-
- type Real_Type is new Float;
-
- package Complex_Pack is new
- Ada.Numerics.Generic_Complex_Types(Real_Type);
-
- use type Complex_Pack.Complex;
-
- -- Declare a zero valued complex number.
- Complex_Zero : constant Complex_Pack.Complex := (0.0, 0.0);
-
- TC_Complex : Complex_Pack.Complex := Complex_Zero;
- TC_Imaginary : Complex_Pack.Imaginary;
-
- begin
-
- -- Check that the procedures Set_Re and Set_Im (both versions) provide
- -- correct results.
-
- declare
- TC_Complex_Real_Field : Complex_Pack.Complex := (5.0, 0.0);
- TC_Complex_Both_Fields : Complex_Pack.Complex := (5.0, 7.0);
- begin
-
- Complex_Pack.Set_Re(X => TC_Complex, Re => 5.0);
-
- if TC_Complex /= TC_Complex_Real_Field then
- Report.Failed("Incorrect results from Procedure Set_Re");
- end if;
-
- Complex_Pack.Set_Im(X => TC_Complex, Im => 7.0);
-
- if TC_Complex.Re /= 5.0 or
- TC_Complex.Im /= 7.0 or
- TC_Complex /= TC_Complex_Both_Fields
- then
- Report.Failed("Incorrect results from Procedure Set_Im " &
- "with Complex argument");
- end if;
-
- Complex_Pack.Set_Im(X => TC_Imaginary, Im => 3.0);
-
-
- if Complex_Pack.Im(TC_Imaginary) /= 3.0 then
- Report.Failed("Incorrect results returned following the use " &
- "of Procedure Set_Im with Imaginary argument");
- end if;
-
- end;
-
-
- -- Check that the functions Re and Im (both versions) provide
- -- correct results.
-
- declare
- TC_Complex_1 : Complex_Pack.Complex := (1.0, 0.0);
- TC_Complex_2 : Complex_Pack.Complex := (0.0, 2.0);
- TC_Complex_3 : Complex_Pack.Complex := (4.0, 3.0);
- begin
-
- -- Function Re.
-
- if Complex_Pack.Re(X => TC_Complex_1) /= 1.0 or
- Complex_Pack.Re(X => TC_Complex_2) /= 0.0 or
- Complex_Pack.Re(X => TC_Complex_3) /= 4.0
- then
- Report.Failed("Incorrect results from Function Re");
- end if;
-
- -- Function Im; version with Complex argument.
-
- if Complex_Pack.Im(X => TC_Complex_1) /= 0.0 or
- Complex_Pack.Im(X => TC_Complex_2) /= 2.0 or
- Complex_Pack.Im(X => TC_Complex_3) /= 3.0
- then
- Report.Failed("Incorrect results from Function Im " &
- "with Complex argument");
- end if;
-
-
- -- Function Im; version with Imaginary argument.
-
- if Complex_Pack.Im(Complex_Pack.i) /= 1.0 or
- Complex_Pack.Im(Complex_Pack.j) /= 1.0
- then
- Report.Failed("Incorrect results from use of Function Im " &
- "when used with an Imaginary argument");
- end if;
-
- end;
-
-
- -- Verify the results of the three versions of Function
- -- Compose_From_Cartesian
-
- declare
-
- Zero : constant Real_Type := 0.0;
- Six : constant Real_Type := 6.0;
-
- TC_Complex_1 : Complex_Pack.Complex := (3.0, 8.0);
- TC_Complex_2 : Complex_Pack.Complex := (Six, Zero);
- TC_Complex_3 : Complex_Pack.Complex := (Zero, 1.0);
-
- begin
-
- TC_Complex := Complex_Pack.Compose_From_Cartesian(3.0, 8.0);
-
- if TC_Complex /= TC_Complex_1 then
- Report.Failed("Incorrect results from Function " &
- "Compose_From_Cartesian - 1");
- end if;
-
- -- If only one component is given, the other component is
- -- implicitly zero (Both components are set by the following two
- -- function calls).
-
- TC_Complex := Complex_Pack.Compose_From_Cartesian(Re => 6.0);
-
- if TC_Complex /= TC_Complex_2 then
- Report.Failed("Incorrect results from Function " &
- "Compose_From_Cartesian - 2");
- end if;
-
- TC_Complex :=
- Complex_Pack.Compose_From_Cartesian(Im => Complex_Pack.i);
-
- if TC_Complex /= TC_Complex_3 then
- Report.Failed("Incorrect results from Function " &
- "Compose_From_Cartesian - 3");
- end if;
-
- end;
-
-
- -- Verify the results of Function Compose_From_Polar, Modulus, "abs",
- -- and Argument.
-
- declare
-
- use Complex_Pack;
-
- TC_Modulus,
- TC_Argument : Real_Type := 0.0;
-
-
- Angle_0 : constant Real_Type := 0.0;
- Angle_90 : constant Real_Type := 90.0;
- Angle_180 : constant Real_Type := 180.0;
- Angle_270 : constant Real_Type := 270.0;
- Angle_360 : constant Real_Type := 360.0;
-
- begin
-
- -- Verify the result of Function Compose_From_Polar.
- -- When the value of the parameter Modulus is zero, the
- -- Compose_From_Polar function yields a result of zero.
-
- if Compose_From_Polar(0.0, 30.0, 360.0) /= Complex_Zero
- then
- Report.Failed("Incorrect result from Function " &
- "Compose_From_Polar - 1");
- end if;
-
- -- When the value of the parameter Argument is equal to a multiple
- -- of the quarter cycle, the result of the Compose_From_Polar
- -- function with specified cycle lies on one of the axes.
-
- if Compose_From_Polar( 5.0, Angle_0, Angle_360) /= (5.0, 0.0) or
- Compose_From_Polar( 5.0, Angle_90, Angle_360) /= (0.0, 5.0) or
- Compose_From_Polar(-5.0, Angle_180, Angle_360) /= (5.0, 0.0) or
- Compose_From_Polar(-5.0, Angle_270, Angle_360) /= (0.0, 5.0) or
- Compose_From_Polar(-5.0, Angle_90, Angle_360) /= (0.0, -5.0) or
- Compose_From_Polar( 5.0, Angle_270, Angle_360) /= (0.0, -5.0)
- then
- Report.Failed("Incorrect result from Function " &
- "Compose_From_Polar - 2");
- end if;
-
- -- When the parameter to Function Argument represents a point on
- -- the non-negative real axis, the function yields a zero result.
-
- if Argument(Complex_Zero, Angle_360) /= 0.0 then
- Report.Failed("Incorrect result from Function Argument");
- end if;
-
- -- Function Modulus
-
- if Modulus(Complex_Zero) /= 0.0 or
- Modulus(Compose_From_Polar( 5.0, Angle_90, Angle_360)) /= 5.0 or
- Modulus(Compose_From_Polar(-5.0, Angle_180, Angle_360)) /= 5.0
- then
- Report.Failed("Incorrect results from Function Modulus");
- end if;
-
- -- Function "abs", a rename of Function Modulus.
-
- if "abs"(Complex_Zero) /= 0.0 or
- "abs"(Compose_From_Polar( 5.0, Angle_90, Angle_360)) /= 5.0 or
- "abs"(Compose_From_Polar(-5.0, Angle_180, Angle_360)) /= 5.0
- then
- Report.Failed("Incorrect results from Function abs");
- end if;
-
- end;
-
- exception
- when others => Report.Failed ("Exception raised in Test_Block");
- end Test_Block;
-
- Report.Result;
-
-end CXG1001;
diff --git a/gcc/testsuite/ada/acats/tests/cxg/cxg1002.a b/gcc/testsuite/ada/acats/tests/cxg/cxg1002.a
deleted file mode 100644
index 39f5f00dbc3..00000000000
--- a/gcc/testsuite/ada/acats/tests/cxg/cxg1002.a
+++ /dev/null
@@ -1,198 +0,0 @@
--- CXG1002.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that the subprograms defined in the package
--- Ada.Numerics.Generic_Complex_Types provide the prescribed results.
--- Specifically, check the various versions of functions "+" and "-".
---
--- TEST DESCRIPTION:
--- This test checks that the subprograms "+" and "-" defined in the
--- Generic_Complex_Types package provide the results prescribed for the
--- evaluation of these complex arithmetic operations. The functions
--- Re and Im are used to extract the appropriate component of the
--- complex result, in order that the prescribed result component can be
--- verified.
--- The generic package is instantiated with a real type (new Float),
--- and the results produced by the specified subprograms are verified.
---
--- SPECIAL REQUIREMENTS:
--- This test can be run in either "relaxed" or "strict" mode.
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
---
---!
-
-with Ada.Numerics.Generic_Complex_Types;
-with Report;
-
-procedure CXG1002 is
-
-begin
-
- Report.Test ("CXG1002", "Check that the subprograms defined in " &
- "the package Ada.Numerics.Generic_Complex_Types " &
- "provide the prescribed results");
-
- Test_Block:
- declare
-
- type Real_Type is new Float;
-
- package Complex_Pack is new
- Ada.Numerics.Generic_Complex_Types(Real_Type);
- use Complex_Pack;
-
- -- Declare a zero valued complex number using the record
- -- aggregate approach.
-
- Complex_Zero : constant Complex_Pack.Complex := (0.0, 0.0);
-
- TC_Complex,
- TC_Complex_Right,
- TC_Complex_Left : Complex_Pack.Complex := Complex_Zero;
-
- TC_Real : Real_Type := 0.0;
-
- TC_Imaginary : Complex_Pack.Imaginary;
-
- begin
-
-
- -- Check that the imaginary component of the result of a binary addition
- -- operator that yields a result of complex type is exact when either
- -- of its operands is of pure-real type.
-
- TC_Complex := Compose_From_Cartesian(2.0, 3.0);
- TC_Real := 3.0;
-
- if Im("+"(Left => TC_Complex, Right => TC_Real)) /= 3.0 or
- Im("+"(TC_Complex, 6.0)) /= 3.0 or
- Im(TC_Complex + TC_Real) /= 3.0 or
- Im(TC_Complex + 5.0) /= 3.0 or
- Im((7.0, 2.0) + 1.0) /= 2.0 or
- Im((7.0, 5.0) + (-2.0)) /= 5.0 or
- Im((-7.0, -2.0) + 1.0) /= -2.0 or
- Im((-7.0, -3.0) + (-3.0)) /= -3.0
- then
- Report.Failed("Incorrect results from Function ""+"" with " &
- "one Complex and one Real argument - 1");
- end if;
-
- if Im("+"(Left => TC_Real, Right => TC_Complex)) /= 3.0 or
- Im("+"(4.0, TC_Complex)) /= 3.0 or
- Im(TC_Real + TC_Complex) /= 3.0 or
- Im(9.0 + TC_Complex) /= 3.0 or
- Im(1.0 + (7.0, -9.0)) /= -9.0 or
- Im((-2.0) + (7.0, 2.0)) /= 2.0 or
- Im(1.0 + (-7.0, -5.0)) /= -5.0 or
- Im((-3.0) + (-7.0, 16.0)) /= 16.0
- then
- Report.Failed("Incorrect results from Function ""+"" with " &
- "one Complex and one Real argument - 2");
- end if;
-
-
- -- Check that the imaginary component of the result of a binary
- -- subtraction operator that yields a result of complex type is exact
- -- when its right operand is of pure-real type.
-
- TC_Complex := (8.0, -4.0);
- TC_Real := 2.0;
-
- if Im("-"(Left => TC_Complex, Right => TC_Real)) /= -4.0 or
- Im("-"(TC_Complex, 5.0)) /= -4.0 or
- Im(TC_Complex - TC_Real) /= -4.0 or
- Im(TC_Complex - 4.0) /= -4.0 or
- Im((6.0, 5.0) - 1.0) /= 5.0 or
- Im((6.0, 13.0) - 7.0) /= 13.0 or
- Im((-5.0, 3.0) - (2.0)) /= 3.0 or
- Im((-5.0, -6.0) - (-3.0)) /= -6.0
- then
- Report.Failed("Incorrect results from Function ""-"" with " &
- "one Complex and one Real argument");
- end if;
-
-
- -- Check that the real component of the result of a binary addition
- -- operator that yields a result of complex type is exact when either
- -- of its operands is of pure-imaginary type.
-
- TC_Complex := (5.0, 0.0);
-
- if Re("+"(Left => TC_Complex, Right => i)) /= 5.0 or
- Re("+"(Complex_Pack.j, TC_Complex)) /= 5.0 or
- Re((-8.0, 5.0) + ( 2.0*i)) /= -8.0 or
- Re((2.0, 5.0) + (-2.0*i)) /= 2.0 or
- Re((-20.0, -5.0) + ( 3.0*i)) /= -20.0 or
- Re((6.0, -5.0) + (-3.0*i)) /= 6.0
- then
- Report.Failed("Incorrect results from Function ""+"" with " &
- "one Complex and one Imaginary argument");
- end if;
-
-
- -- Check that the real component of the result of a binary
- -- subtraction operator that yields a result of complex type is exact
- -- when its right operand is of pure-imaginary type.
-
- TC_Complex := TC_Complex + i; -- Should produce (5.0, 1.0)
-
- if Re("-"(TC_Complex, i)) /= 5.0 or
- Re((-4.0, 4.0) - ( 2.0*i)) /= -4.0 or
- Re((9.0, 4.0) - ( 5.0*i)) /= 9.0 or
- Re((16.0, -5.0) - ( 3.0*i)) /= 16.0 or
- Re((-3.0, -5.0) - (-4.0*i)) /= -3.0
- then
- Report.Failed("Incorrect results from Function ""-"" with " &
- "one Complex and one Imaginary argument");
- end if;
-
-
- -- Check that the result of a binary addition operation is exact when
- -- one of its operands is of real type and the other is of
- -- pure-imaginary type; the operator is analogous to the
- -- Compose_From_Cartesian function; it performs no arithmetic.
-
- TC_Complex := Complex_Pack."+"(5.0, Complex_Pack.i);
-
- if TC_Complex /= (5.0, 1.0) or
- (4.0 + i) /= (4.0, 1.0) or
- "+"(Left => j, Right => 3.0) /= (3.0, 1.0)
- then
- Report.Failed("Incorrect results from Function ""+"" with " &
- "one Real and one Imaginary argument");
- end if;
-
-
- exception
- when others => Report.Failed ("Exception raised in Test_Block");
- end Test_Block;
-
- Report.Result;
-
-end CXG1002;
diff --git a/gcc/testsuite/ada/acats/tests/cxg/cxg1003.a b/gcc/testsuite/ada/acats/tests/cxg/cxg1003.a
deleted file mode 100644
index c3885136b86..00000000000
--- a/gcc/testsuite/ada/acats/tests/cxg/cxg1003.a
+++ /dev/null
@@ -1,478 +0,0 @@
--- CXG1003.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that the subprograms defined in the package Text_IO.Complex_IO
--- provide correct results.
---
--- TEST DESCRIPTION:
--- The generic package Ada.Numerics.Generic_Complex_Types is instantiated
--- with a real type (new Float). The resulting new package is used as
--- the generic actual to package Complex_IO.
--- Two different versions of Put and Get are examined in this test,
--- those that input/output complex data values from/to Text_IO files,
--- and those that input/output complex data values from/to strings.
--- Two procedures are defined to perform the file data manipulations;
--- one to place complex data into the file, and one to retrieve the data
--- from the file and verify its correctness.
--- Complex data is also put into string variables using the Procedure
--- Put for strings, and this data is then retrieved and reconverted into
--- complex values using the Get procedure.
---
---
--- APPLICABILITY CRITERIA:
--- This test is only applicable to implementations that:
--- support Annex G,
--- support Text_IO and external files
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 29 Dec 94 SAIC Modified Width parameter in Get function calls.
--- 16 Nov 95 SAIC Corrected visibility problems for ACVC 2.0.1.
--- 29 Sep 96 SAIC Incorporated reviewer comments.
---
---!
-
-with Ada.Text_IO.Complex_IO;
-with Ada.Numerics.Generic_Complex_Types;
-with Report;
-
-procedure CXG1003 is
-begin
-
- Report.Test ("CXG1003", "Check that the subprograms defined in " &
- "the package Text_IO.Complex_IO " &
- "provide correct results");
-
- Test_for_Text_IO_Support:
- declare
- use Ada;
-
- Data_File : Ada.Text_IO.File_Type;
- Data_Filename : constant String := Report.Legal_File_Name;
-
- begin
-
- -- An application creates a text file in mode Out_File, with the
- -- intention of entering complex data into the file as appropriate.
- -- In the event that the particular environment where the application
- -- is running does not support Text_IO, Use_Error or Name_Error will be
- -- raised on calls to Text_IO operations. Either of these exceptions
- -- will be handled to produce a Not_Applicable result.
-
- Text_IO.Create (File => Data_File,
- Mode => Ada.Text_IO.Out_File,
- Name => Data_Filename);
-
- Test_Block:
- declare
-
- TC_Verbose : Boolean := False;
-
- type Real_Type is new Float;
-
- package Complex_Pack is new
- Ada.Numerics.Generic_Complex_Types(Real_Type);
-
- package C_IO is new Ada.Text_IO.Complex_IO(Complex_Pack);
-
- use Ada.Text_IO, C_IO;
- use type Complex_Pack.Complex;
-
- Number_Of_Complex_Items : constant := 6;
- Number_Of_Error_Items : constant := 2;
-
- TC_Complex : Complex_Pack.Complex;
- TC_Last_Character_Read : Positive;
-
- Complex_Array : array (1..Number_Of_Complex_Items)
- of Complex_Pack.Complex := ( (3.0, 9.0),
- (4.0, 7.0),
- (5.0, 6.0),
- (6.0, 3.0),
- (2.0, 5.0),
- (3.0, 7.0) );
-
-
- procedure Load_Data_File (The_File : in out Text_IO.File_Type) is
- use Ada.Text_IO;
- begin
- -- This procedure does not create, open, or close the data file;
- -- The_File file object must be Open at this point.
- -- This procedure is designed to load complex data into a data
- -- file twice, first using Text_IO, then Complex_IO. In this
- -- first case, the complex data values are entered as strings,
- -- assuming a variety of legal formats, as provided in the
- -- reference manual.
-
- Put_Line(The_File, "(3.0, 9.0)");
- Put_Line(The_File, "+4. +7."); -- Relaxed real literal format.
- Put_Line(The_File, "(5.0 6.)");
- Put_Line(The_File, "6., 3.0");
- Put_Line(The_File, " ( 2.0 , 5.0 ) ");
- Put_Line(The_File, "("); -- Complex data separated over
- Put_Line(The_File, "3.0"); -- several (5) lines.
- Put_Line(The_File, " , ");
- Put_Line(The_File, "7.0 ");
- Put_Line(The_File, ")");
-
- if TC_Verbose then
- Report.Comment("Complex values entered into data file using " &
- "Text_IO, Procedure Load_Data_File");
- end if;
-
- -- Use the Complex_IO procedure Put to enter Complex data items
- -- into the data file.
- -- Note: Data is being entered into the file for the *second* time
- -- at this point. (Using Complex_IO here, Text_IO above)
-
- for i in 1..Number_Of_Complex_Items loop
- C_IO.Put(File => The_File,
- Item => Complex_Array(i),
- Fore => 1,
- Aft => 1,
- Exp => 0);
- end loop;
-
- if TC_Verbose then
- Report.Comment("Complex values entered into data file using " &
- "Complex_IO, Procedure Load_Data_File");
- end if;
-
- Put_Line(The_File, "(5A,3)"); -- data to raise Data_Error.
- Put_Line(The_File, "(3.0,,8.0)"); -- data to raise Data_Error.
-
- end Load_Data_File;
-
-
-
- procedure Process_Data_File (The_File : in out Text_IO.File_Type) is
- TC_Complex : Complex_Pack.Complex := (0.0, 0.0);
- TC_Width : Integer := 0;
- begin
- -- This procedure does not create, open, or close the data file;
- -- The_File file object must be Open at this point.
- -- Use procedure Get (for Files) to extract the complex data from
- -- the Text_IO file. This data was placed into the file using
- -- Text_IO.
-
-
- for i in 1..Number_Of_Complex_Items loop
-
- C_IO.Get(The_File, TC_Complex, TC_Width);
-
- if TC_Complex /= Complex_Array(i) then
- Report.Failed("Incorrect complex data read from file " &
- "when using Text_IO procedure Get, " &
- "data item #" & Integer'Image(i));
- end if;
- end loop;
-
- if TC_Verbose then
- Report.Comment("First set of complex values extracted " &
- "from data file using Complex_IO, " &
- "Procedure Process_Data_File");
- end if;
-
- -- Use procedure Get (for Files) to extract the complex data from
- -- the Text_IO file. This data was placed into the file using
- -- procedure Complex_IO.Put.
- -- Note: Data is being extracted from the file for the *second*
- -- time at this point (Using Complex_IO here, Text_IO above)
-
- for i in 1..Number_Of_Complex_Items loop
-
- C_IO.Get(The_File, TC_Complex, TC_Width);
-
- if TC_Complex /= Complex_Array(i) then
- Report.Failed("Incorrect complex data read from file " &
- "when using Complex_IO procedure Get, " &
- "data item #" & Integer'Image(i));
- end if;
- end loop;
-
- if TC_Verbose then
- Report.Comment("Second set of complex values extracted " &
- "from data file using Complex_IO, " &
- "Procedure Process_Data_File");
- end if;
-
- -- The final items in the Data_File are complex values with
- -- incorrect syntax, which should raise Data_Error on an attempt
- -- to read them from the file.
- TC_Width := 10;
- for i in 1..Number_Of_Error_Items loop
- begin
- C_IO.Get(The_File, TC_Complex, TC_Width);
- Report.Failed
- ("Exception Data_Error not raised when Complex_IO.Get " &
- "was used to read complex data with incorrect " &
- "syntax from the Data_File, data item #" &
- Integer'Image(i));
- exception
- when Ada.Text_IO.Data_Error => -- OK, expected exception.
- Text_IO.Skip_Line(The_File);
- when others =>
- Report.Failed
- ("Unexpected exception raised when Complex_IO.Get " &
- "was used to read complex data with incorrect " &
- "syntax from the Data_File, data item #" &
- Integer'Image(i));
- end;
- end loop;
-
- if TC_Verbose then
- Report.Comment("Erroneous set of complex values extracted " &
- "from data file using Complex_IO, " &
- "Procedure Process_Data_File");
- end if;
-
-
- exception
- when others =>
- Report.Failed
- ("Unexpected exception raised in Process_Data_File");
- end Process_Data_File;
-
-
-
- begin -- Test_Block.
-
- -- Place complex values into data file.
-
- Load_Data_File(Data_File);
- Text_IO.Close(Data_File);
-
- if TC_Verbose then
- Report.Comment("Data file loaded with Complex values");
- end if;
-
- -- Read complex values from data file.
-
- Text_IO.Open(Data_File, Text_IO.In_File, Data_Filename);
- Process_Data_File(Data_File);
-
- if TC_Verbose then
- Report.Comment("Complex values extracted from data file");
- end if;
-
-
-
- -- Verify versions of Procedures Put and Get for Strings.
-
- declare
- TC_String_Array : array (1..Number_Of_Complex_Items)
- of String(1..15) := (others =>(others => ' '));
- begin
-
- -- Place complex values into strings using the Procedure Put.
-
- for i in 1..Number_Of_Complex_Items loop
- C_IO.Put(To => TC_String_Array(i),
- Item => Complex_Array(i),
- Aft => 1,
- Exp => 0);
- end loop;
-
- if TC_Verbose then
- Report.Comment("Complex values placed into string array");
- end if;
-
- -- Check the format of the strings containing a complex number.
- -- The resulting strings are of 15 character length, with the
- -- real component left justified within the string, followed by
- -- a comma, and with the imaginary component and closing
- -- parenthesis right justified in the string, with blank fill
- -- for the balance of the string.
-
- if TC_String_Array(1) /= "(3.0, 9.0)" or
- TC_String_Array(2) /= "(4.0, 7.0)" or
- TC_String_Array(3) /= "(5.0, 6.0)" or
- TC_String_Array(4) /= "(6.0, 3.0)" or
- TC_String_Array(5) /= "(2.0, 5.0)" or
- TC_String_Array(6) /= "(3.0, 7.0)"
- then
- Report.Failed("Incorrect format for complex values that " &
- "have been placed into string variables " &
- "using the Complex_IO.Put procedure for " &
- "strings");
- end if;
-
- if TC_Verbose then
- Report.Comment("String format of Complex values verified");
- end if;
-
- -- Get complex values from strings using the Procedure Get.
- -- Compare with expected complex values.
-
- for i in 1..Number_Of_Complex_Items loop
-
- C_IO.Get(From => TC_String_Array(i),
- Item => TC_Complex,
- Last => TC_Last_Character_Read);
-
- if TC_Complex /= Complex_Array(i) then
- Report.Failed("Incorrect complex data value obtained " &
- "from String following use of Procedures " &
- "Put and Get from Strings, Complex_Array " &
- "item #" & Integer'Image(i));
- end if;
- end loop;
-
- if TC_Verbose then
- Report.Comment("Complex values removed from String array");
- end if;
-
- -- Verify that Layout_Error is raised if the given string is
- -- too short to hold the formatted output.
- Layout_Error_On_Put:
- declare
- Much_Too_Short : String(1..2);
- Complex_Value : Complex_Pack.Complex := (5.0, 0.0);
- begin
- C_IO.Put(Much_Too_Short, Complex_Value);
- Report.Failed("Layout_Error not raised by Procedure Put " &
- "when the given string was too short to " &
- "hold the formatted output");
- exception
- when Layout_Error => null; -- OK, expected exception.
- when others =>
- Report.Failed
- ("Unexpected exception raised by Procedure Put when " &
- "the given string was too short to hold the " &
- "formatted output");
- end Layout_Error_On_Put;
-
- if TC_Verbose then
- Report.Comment("Layout Errors verified");
- end if;
-
- exception
- when others =>
- Report.Failed("Unexpected exception raised during the " &
- "evaluation of Put and Get for Strings");
- end;
-
-
- -- Place complex values into strings using a variety of legal
- -- complex data formats.
- declare
-
- type String_Ptr is access String;
-
- TC_Complex_String_Array :
- array (1..Number_Of_Complex_Items) of String_Ptr :=
- (new String'( "(3.0, 9.0 )" ),
- new String'( "+4.0 +7.0" ),
- new String'( "(5.0 6.0)" ),
- new String'( "6.0, 3.0" ),
- new String'( " ( 2.0 , 5.0 ) " ),
- new String'( "(3.0 7.0)" ));
-
- -- The following array contains Positive values that correspond
- -- to the last character that will be read by Procedure Get when
- -- given each of the above strings as input.
-
- TC_Last_Char_Array : array (1..Number_Of_Complex_Items)
- of Positive := (12,10,9,8,20,22);
-
- begin
-
- -- Get complex values from strings using the Procedure Get.
- -- Compare with expected complex values.
-
- for i in 1..Number_Of_Complex_Items loop
-
- C_IO.Get(TC_Complex_String_Array(i).all,
- TC_Complex,
- TC_Last_Character_Read);
-
- if TC_Complex /= Complex_Array(i) then
- Report.Failed
- ("Incorrect complex data value obtained from " &
- "Procedure Get with complex data input of: " &
- TC_Complex_String_Array(i).all);
- end if;
-
- if TC_Last_Character_Read /= TC_Last_Char_Array(i) then
- Report.Failed
- ("Incorrect value returned as the last character of " &
- "the input string processed by Procedure Get, " &
- "string value : " & TC_Complex_String_Array(i).all &
- " expected last character value read : " &
- Positive'Image(TC_Last_Char_Array(i)) &
- " last character value read : " &
- Positive'Image(TC_Last_Character_Read));
- end if;
-
- end loop;
-
- if TC_Verbose then
- Report.Comment("Complex values removed from strings and " &
- "verified against expected values");
- end if;
-
- exception
- when others =>
- Report.Failed("Unexpected exception raised during the " &
- "evaluation of Get for Strings");
- end;
-
- exception
- when others => Report.Failed ("Exception raised in Test_Block");
- end Test_Block;
-
-
- -- Delete the external file.
- if Ada.Text_IO.Is_Open(Data_File) then
- Ada.Text_IO.Delete(Data_File);
- else
- Ada.Text_IO.Open(Data_File,
- Ada.Text_IO.In_File,
- Data_Filename);
- Ada.Text_IO.Delete(Data_File);
- end if;
-
- exception
-
- -- Since Use_Error can be raised if, for the specified mode,
- -- the environment does not support Text_IO operations, the
- -- following handlers are included:
-
- when Ada.Text_IO.Use_Error =>
- Report.Not_Applicable ("Use_Error raised on Text_IO Create");
-
- when Ada.Text_IO.Name_Error =>
- Report.Not_Applicable ("Name_Error raised on Text_IO Create");
-
- when others =>
- Report.Failed ("Unexpected exception raised on text file Create");
-
- end Test_for_Text_IO_Support;
-
- Report.Result;
-
-end CXG1003;
diff --git a/gcc/testsuite/ada/acats/tests/cxg/cxg1004.a b/gcc/testsuite/ada/acats/tests/cxg/cxg1004.a
deleted file mode 100644
index f026eae70db..00000000000
--- a/gcc/testsuite/ada/acats/tests/cxg/cxg1004.a
+++ /dev/null
@@ -1,360 +0,0 @@
--- CXG1004.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that the specified exceptions are raised by the subprograms
--- defined in package Ada.Numerics.Generic_Complex_Elementary_Functions
--- given the prescribed input parameter values.
---
--- TEST DESCRIPTION:
--- This test checks that specific subprograms defined in the
--- package Ada.Numerics.Generic_Complex_Elementary_Functions raise the
--- exceptions Argument_Error and Constraint_Error when their input
--- parameter value are those specified as causing each exception.
--- In the case of Constraint_Error, the exception will be raised in
--- each test case, provided that the value of the attribute
--- 'Machine_Overflows (for the actual type of package
--- Generic_Complex_Type) is True.
---
--- APPLICABILITY CRITERIA:
--- This test only applies to implementations supporting the
--- numerics annex.
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 16 Nov 95 SAIC Corrected visibility problems for ACVC 2.0.1.
--- 29 Sep 96 SAIC Incorporated reviewer comments.
--- 02 Jun 98 EDS Replace "_i" with "_One".
---!
-
-with Ada.Numerics.Generic_Complex_Types;
-with Ada.Numerics.Generic_Complex_Elementary_Functions;
-with Report;
-
-procedure CXG1004 is
-begin
-
- Report.Test ("CXG1004", "Check that the specified exceptions are " &
- "raised by the subprograms defined in package " &
- "Ada.Numerics.Generic_Complex_Elementary_" &
- "Functions given the prescribed input " &
- "parameter values");
-
- Test_Block:
- declare
-
- type Real_Type is new Float;
-
- TC_Overflows : Boolean := Real_Type'Machine_Overflows;
-
- package Complex_Pack is
- new Ada.Numerics.Generic_Complex_Types(Real_Type);
-
- package CEF is
- new Ada.Numerics.Generic_Complex_Elementary_Functions(Complex_Pack);
-
- use Ada.Numerics, Complex_Pack, CEF;
-
- Complex_Zero : constant Complex := Compose_From_Cartesian(0.0, 0.0);
- Plus_One : constant Complex := Compose_From_Cartesian(1.0, 0.0);
- Minus_One : constant Complex := Compose_From_Cartesian(-1.0, 0.0);
- Plus_i : constant Complex := Compose_From_Cartesian(i);
- Minus_i : constant Complex := Compose_From_Cartesian(-i);
-
- Complex_Negative_Real : constant Complex :=
- Compose_From_Cartesian(-4.0, 2.0);
- Complex_Negative_Imaginary : constant Complex :=
- Compose_From_Cartesian(3.0, -5.0);
-
- TC_Complex : Complex;
-
-
- -- This procedure is used in "Exception Raising" calls below in an
- -- attempt to avoid elimination of the subtest through optimization.
-
- procedure No_Optimize (The_Complex_Number : Complex) is
- begin
- Report.Comment("No Optimize: Should never be printed " &
- Integer'Image(Integer(The_Complex_Number.Im)));
- end No_Optimize;
-
-
- begin
-
- -- Check that the exception Numerics.Argument_Error is raised by the
- -- exponentiation operator when the value of the left operand is zero,
- -- and the real component of the exponent (or the exponent itself) is
- -- zero.
-
- begin
- TC_Complex := "**"(Left => Complex_Zero, Right => Complex_Zero);
- Report.Failed("Argument_Error not raised by exponentiation " &
- "operator, left operand = complex zero, right " &
- "operand = complex zero");
- No_Optimize(TC_Complex);
- exception
- when Argument_Error => null; -- OK, expected exception.
- when others =>
- Report.Failed("Incorrect exception raised by exponentiation " &
- "operator, left operand = complex zero, right " &
- "operand = complex zero");
- end;
-
- begin
- TC_Complex := Complex_Zero**0.0;
- Report.Failed("Argument_Error not raised by exponentiation " &
- "operator, left operand = complex zero, right " &
- "operand = real zero");
- No_Optimize(TC_Complex);
- exception
- when Argument_Error => null; -- OK, expected exception.
- when others =>
- Report.Failed("Incorrect exception raised by exponentiation " &
- "operator, left operand = complex zero, right " &
- "operand = real zero");
- end;
-
-
- begin
- TC_Complex := "**"(Left => 0.0, Right => Complex_Zero);
- Report.Failed("Argument_Error not raised by exponentiation " &
- "operator, left operand = real zero, right " &
- "operand = complex zero");
- No_Optimize(TC_Complex);
- exception
- when Argument_Error => null; -- OK, expected exception.
- when others =>
- Report.Failed("Incorrect exception raised by exponentiation " &
- "operator, left operand = real zero, right " &
- "operand = complex zero");
- end;
-
-
- -- Check that the exception Constraint_Error is raised under the
- -- specified circumstances, provided that
- -- Complex_Types.Real'Machine_Overflows is True.
-
- if TC_Overflows then
-
- -- Raised by Log, when the value of the parameter X is zero.
- begin
- TC_Complex := Log (X => Complex_Zero);
- Report.Failed("Constraint_Error not raised when Function " &
- "Log given parameter value of complex zero");
- No_Optimize(TC_Complex);
- exception
- when Constraint_Error => null; -- OK, expected exception.
- when others =>
- Report.Failed("Incorrect exception raised when Function " &
- "Log given parameter value of complex zero");
- end;
-
- -- Raised by Cot, when the value of the parameter X is zero.
- begin
- TC_Complex := Cot (X => Complex_Zero);
- Report.Failed("Constraint_Error not raised when Function " &
- "Cot given parameter value of complex zero");
- No_Optimize(TC_Complex);
- exception
- when Constraint_Error => null; -- OK, expected exception.
- when others =>
- Report.Failed("Incorrect exception raised when Function " &
- "Cot given parameter value of complex zero");
- end;
-
- -- Raised by Coth, when the value of the parameter X is zero.
- begin
- TC_Complex := Coth (Complex_Zero);
- Report.Failed("Constraint_Error not raised when Function " &
- "Coth given parameter value of complex zero");
- No_Optimize(TC_Complex);
- exception
- when Constraint_Error => null; -- OK, expected exception.
- when others =>
- Report.Failed("Incorrect exception raised when Function " &
- "Coth given parameter value of complex zero");
- end;
-
- -- Raised by the exponentiation operator, when the value of the
- -- left operand is zero and the real component of the exponent
- -- is negative.
- begin
- TC_Complex := Complex_Zero**Complex_Negative_Real;
- Report.Failed("Constraint_Error not raised when the " &
- "exponentiation operator left operand is " &
- "complex zero, and the real component of " &
- "the exponent is negative");
- No_Optimize(TC_Complex);
- exception
- when Constraint_Error => null; -- OK, expected exception.
- when others =>
- Report.Failed("Incorrect exception raised when the " &
- "exponentiation operator left operand is " &
- "complex zero, and the real component of " &
- "the exponent is negative");
- end;
-
- -- Raised by the exponentiation operator, when the value of the
- -- left operand is zero and the exponent itself (when it is of
- -- type real) is negative.
- declare
- Negative_Exponent : constant Real_Type := -4.0;
- begin
- TC_Complex := Complex_Zero**Negative_Exponent;
- Report.Failed("Constraint_Error not raised when the " &
- "exponentiation operator left operand is " &
- "complex zero, and the real exponent is " &
- "negative");
- No_Optimize(TC_Complex);
- exception
- when Constraint_Error => null; -- OK, expected exception.
- when others =>
- Report.Failed("Incorrect exception raised when the " &
- "exponentiation operator left operand is " &
- "complex zero, and the real exponent is " &
- "negative");
- end;
-
- -- Raised by Arctan, when the value of the parameter is +i.
- begin
- TC_Complex := Arctan (Plus_i);
- Report.Failed("Constraint_Error not raised when Function " &
- "Arctan is given parameter value +i");
- No_Optimize(TC_Complex);
- exception
- when Constraint_Error => null; -- OK, expected exception.
- when others =>
- Report.Failed("Incorrect exception raised when Function " &
- "Arctan is given parameter value +i");
- end;
-
- -- Raised by Arctan, when the value of the parameter is -i.
- begin
- TC_Complex := Arctan (Minus_i);
- Report.Failed("Constraint_Error not raised when Function " &
- "Arctan is given parameter value -i");
- No_Optimize(TC_Complex);
- exception
- when Constraint_Error => null; -- OK, expected exception.
- when others =>
- Report.Failed("Incorrect exception raised when Function " &
- "Arctan is given parameter value -i");
- end;
-
- -- Raised by Arccot, when the value of the parameter is +i.
- begin
- TC_Complex := Arccot (Plus_i);
- Report.Failed("Constraint_Error not raised when Function " &
- "Arccot is given parameter value +i");
- No_Optimize(TC_Complex);
- exception
- when Constraint_Error => null; -- OK, expected exception.
- when others =>
- Report.Failed("Incorrect exception raised when Function " &
- "Arccot is given parameter value +i");
- end;
-
- -- Raised by Arccot, when the value of the parameter is -i.
- begin
- TC_Complex := Arccot (Minus_i);
- Report.Failed("Constraint_Error not raised when Function " &
- "Arccot is given parameter value -i");
- No_Optimize(TC_Complex);
- exception
- when Constraint_Error => null; -- OK, expected exception.
- when others =>
- Report.Failed("Incorrect exception raised when Function " &
- "Arccot is given parameter value -i");
- end;
-
- -- Raised by Arctanh, when the value of the parameter is +1.
- begin
- TC_Complex := Arctanh (Plus_One);
- Report.Failed("Constraint_Error not raised when Function " &
- "Arctanh is given parameter value +1");
- No_Optimize(TC_Complex);
- exception
- when Constraint_Error => null; -- OK, expected exception.
- when others =>
- Report.Failed("Incorrect exception raised when Function " &
- "Arctanh is given parameter value +1");
- end;
-
- -- Raised by Arctanh, when the value of the parameter is -1.
- begin
- TC_Complex := Arctanh (Minus_One);
- Report.Failed("Constraint_Error not raised when Function " &
- "Arctanh is given parameter value -1");
- No_Optimize(TC_Complex);
- exception
- when Constraint_Error => null; -- OK, expected exception.
- when others =>
- Report.Failed("Incorrect exception raised when Function " &
- "Arctanh is given parameter value -1");
- end;
-
- -- Raised by Arccoth, when the value of the parameter is +1.
- begin
- TC_Complex := Arccoth (Plus_One);
- Report.Failed("Constraint_Error not raised when Function " &
- "Arccoth is given parameter value +1");
- No_Optimize(TC_Complex);
- exception
- when Constraint_Error => null; -- OK, expected exception.
- when others =>
- Report.Failed("Incorrect exception raised when Function " &
- "Arccoth is given parameter value +1");
- end;
-
- -- Raised by Arccoth, when the value of the parameter is -1.
- begin
- TC_Complex := Arccoth (Minus_One);
- Report.Failed("Constraint_Error not raised when Function " &
- "Arccoth is given parameter value -1");
- No_Optimize(TC_Complex);
- exception
- when Constraint_Error => null; -- OK, expected exception.
- when others =>
- Report.Failed("Incorrect exception raised when Function " &
- "Arccoth is given parameter value -1");
- end;
-
- else
- Report.Comment
- ("Attribute Complex_Pack.Real'Machine_Overflows is False; " &
- "evaluation of the complex elementary functions under " &
- "specified circumstances was not performed");
- end if;
-
-
- exception
- when others =>
- Report.Failed ("Unexpected exception raised in Test_Block");
- end Test_Block;
-
- Report.Result;
-
-end CXG1004;
diff --git a/gcc/testsuite/ada/acats/tests/cxg/cxg1005.a b/gcc/testsuite/ada/acats/tests/cxg/cxg1005.a
deleted file mode 100644
index 6faad4e1357..00000000000
--- a/gcc/testsuite/ada/acats/tests/cxg/cxg1005.a
+++ /dev/null
@@ -1,393 +0,0 @@
--- CXG1005.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that the subprograms defined in the package
--- Ada.Numerics.Generic_Complex_Elementary_Functions provide correct
--- results.
---
--- TEST DESCRIPTION:
--- This test checks that specific subprograms defined in the generic
--- package Generic_Complex_Elementary_Functions are available, and that
--- they provide prescribed results given specific input values.
--- The generic package Ada.Numerics.Generic_Complex_Types is instantiated
--- with a real type (new Float). The resulting new package is used as
--- the generic actual to package Complex_IO.
---
--- SPECIAL REQUIREMENTS:
--- Implementations for which Float'Signed_Zeros is True must provide
--- a body for ImpDef.Annex_G.Negative_Zero which returns a negative
--- zero.
---
--- APPLICABILITY CRITERIA
--- This test only applies to implementations that support the
--- numerics annex.
---
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 16 Nov 95 SAIC Corrected visibility problems for ACVC 2.0.1.
--- 21 Feb 96 SAIC Incorporated new structure for package Impdef.
--- 29 Sep 96 SAIC Incorporated reviewer comments.
---
---!
-
-with Ada.Numerics.Generic_Complex_Types;
-with Ada.Numerics.Generic_Complex_Elementary_Functions;
-with ImpDef.Annex_G;
-with Report;
-
-procedure CXG1005 is
-begin
-
- Report.Test ("CXG1005", "Check that the subprograms defined in " &
- "the package Generic_Complex_Elementary_" &
- "Functions provide correct results");
-
- Test_Block:
- declare
-
- type Real_Type is new Float;
-
- TC_Signed_Zeros : Boolean := Real_Type'Signed_Zeros;
-
- package Complex_Pack is new
- Ada.Numerics.Generic_Complex_Types(Real_Type);
-
- package CEF is
- new Ada.Numerics.Generic_Complex_Elementary_Functions(Complex_Pack);
-
- use Ada.Numerics, Complex_Pack, CEF;
-
- Complex_Zero : constant Complex := Compose_From_Cartesian( 0.0, 0.0);
- Plus_One : constant Complex := Compose_From_Cartesian( 1.0, 0.0);
- Minus_One : constant Complex := Compose_From_Cartesian(-1.0, 0.0);
- Plus_i : constant Complex := Compose_From_Cartesian(i);
- Minus_i : constant Complex := Compose_From_Cartesian(-i);
-
- Complex_Positive_Real : constant Complex :=
- Compose_From_Cartesian(4.0, 2.0);
- Complex_Positive_Imaginary : constant Complex :=
- Compose_From_Cartesian(3.0, 5.0);
- Complex_Negative_Real : constant Complex :=
- Compose_From_Cartesian(-4.0, 2.0);
- Complex_Negative_Imaginary : constant Complex :=
- Compose_From_Cartesian(3.0, -5.0);
-
-
- function A_Zero_Result (Z : Complex) return Boolean is
- begin
- return (Re(Z) = 0.0 and Im(Z) = 0.0);
- end A_Zero_Result;
-
-
- -- In order to evaluate complex elementary functions that are
- -- prescribed to return a "real" result (meaning that the imaginary
- -- component is zero), the Function A_Real_Result is defined.
-
- function A_Real_Result (Z : Complex) return Boolean is
- begin
- return Im(Z) = 0.0;
- end A_Real_Result;
-
-
- -- In order to evaluate complex elementary functions that are
- -- prescribed to return an "imaginary" result (meaning that the real
- -- component of the complex number is zero, and the imaginary
- -- component is non-zero), the Function An_Imaginary_Result is defined.
-
- function An_Imaginary_Result (Z : Complex) return Boolean is
- begin
- return (Re(Z) = 0.0 and Im(Z) /= 0.0);
- end An_Imaginary_Result;
-
-
- begin
-
- -- Check that when the input parameter value is zero, the following
- -- functions yield a zero result.
-
- if not A_Zero_Result( Sqrt(Complex_Zero) ) then
- Report.Failed("Non-zero result from Function Sqrt with zero input");
- end if;
-
- if not A_Zero_Result( Sin(Complex_Zero) ) then
- Report.Failed("Non-zero result from Function Sin with zero input");
- end if;
-
- if not A_Zero_Result( Arcsin(Complex_Zero) ) then
- Report.Failed("Non-zero result from Function Arcsin with zero " &
- "input");
- end if;
-
- if not A_Zero_Result( Tan(Complex_Zero) ) then
- Report.Failed("Non-zero result from Function Tan with zero input");
- end if;
-
- if not A_Zero_Result( Arctan(Complex_Zero) ) then
- Report.Failed("Non-zero result from Function Arctan with zero " &
- "input");
- end if;
-
- if not A_Zero_Result( Sinh(Complex_Zero) ) then
- Report.Failed("Non-zero result from Function Sinh with zero input");
- end if;
-
- if not A_Zero_Result( Arcsinh(Complex_Zero) ) then
- Report.Failed("Non-zero result from Function Arcsinh with zero " &
- "input");
- end if;
-
- if not A_Zero_Result( Tanh(Complex_Zero) ) then
- Report.Failed("Non-zero result from Function Tanh with zero input");
- end if;
-
- if not A_Zero_Result( Arctanh(Complex_Zero) ) then
- Report.Failed("Non-zero result from Function Arctanh with zero " &
- "input");
- end if;
-
-
- -- Check that when the input parameter value is zero, the following
- -- functions yield a result of one.
-
- if Exp(Complex_Zero) /= Plus_One
- then
- Report.Failed("Non-zero result from Function Exp with zero input");
- end if;
-
- if Cos(Complex_Zero) /= Plus_One
- then
- Report.Failed("Non-zero result from Function Cos with zero input");
- end if;
-
- if Cosh(Complex_Zero) /= Plus_One
- then
- Report.Failed("Non-zero result from Function Cosh with zero input");
- end if;
-
-
- -- Check that when the input parameter value is zero, the following
- -- functions yield a real result.
-
- if not A_Real_Result( Arccos(Complex_Zero) ) then
- Report.Failed("Non-real result from Function Arccos with zero input");
- end if;
-
- if not A_Real_Result( Arccot(Complex_Zero) ) then
- Report.Failed("Non-real result from Function Arccot with zero input");
- end if;
-
-
- -- Check that when the input parameter value is zero, the following
- -- functions yield an imaginary result.
-
- if not An_Imaginary_Result( Arccoth(Complex_Zero) ) then
- Report.Failed("Non-imaginary result from Function Arccoth with " &
- "zero input");
- end if;
-
-
- -- Check that when the input parameter value is one, the Sqrt function
- -- yields a result of one.
-
- if Sqrt(Plus_One) /= Plus_One then
- Report.Failed("Incorrect result from Function Sqrt with input " &
- "value of one");
- end if;
-
-
- -- Check that when the input parameter value is one, the following
- -- functions yield a result of zero.
-
- if not A_Zero_Result( Log(Plus_One) ) then
- Report.Failed("Non-zero result from Function Log with input " &
- "value of one");
- end if;
-
- if not A_Zero_Result( Arccos(Plus_One) ) then
- Report.Failed("Non-zero result from Function Arccos with input " &
- "value of one");
- end if;
-
- if not A_Zero_Result( Arccosh(Plus_One) ) then
- Report.Failed("Non-zero result from Function Arccosh with input " &
- "value of one");
- end if;
-
-
- -- Check that when the input parameter value is one, the Arcsin
- -- function yields a real result.
-
- if not A_Real_Result( Arcsin(Plus_One) ) then
- Report.Failed("Non-real result from Function Arcsin with input " &
- "value of one");
- end if;
-
-
- -- Check that when the input parameter value is minus one, the Sqrt
- -- function yields a result of "i", when the sign of the imaginary
- -- component of the input parameter is positive (and yields "-i", if
- -- the sign on the imaginary component is negative), and the
- -- Complex_Types.Real'Signed_Zeros attribute is True.
-
- if TC_Signed_Zeros then
-
- declare
- Minus_One_With_Pos_Zero_Im_Component : Complex :=
- Compose_From_Cartesian(-1.0, +0.0);
- Minus_One_With_Neg_Zero_Im_Component : Complex :=
- Compose_From_Cartesian
- (-1.0, Real_Type(ImpDef.Annex_G.Negative_Zero));
- begin
-
- if Sqrt(Minus_One_With_Pos_Zero_Im_Component) /= Plus_i then
- Report.Failed("Incorrect result from Function Sqrt, when " &
- "input value is minus one with a positive " &
- "imaginary component, Signed_Zeros being True");
- end if;
-
- if Sqrt(Minus_One_With_Neg_Zero_Im_Component) /= Minus_i then
- Report.Failed("Incorrect result from Function Sqrt, when " &
- "input value is minus one with a negative " &
- "imaginary component, Signed_Zeros being True");
- end if;
- end;
-
- else -- Signed_Zeros is False.
-
- -- Check that when the input parameter value is minus one, the Sqrt
- -- function yields a result of "i", when the
- -- Complex_Types.Real'Signed_Zeros attribute is False.
-
- if Sqrt(Minus_One) /= Plus_i then
- Report.Failed("Incorrect result from Function Sqrt, when " &
- "input value is minus one, Signed_Zeros being " &
- "False");
- end if;
-
- end if;
-
-
- -- Check that when the input parameter value is minus one, the Log
- -- function yields an imaginary result.
-
- if not An_Imaginary_Result( Log(Minus_One) ) then
- Report.Failed("Non-imaginary result from Function Log with a " &
- "minus one input value");
- end if;
-
- -- Check that when the input parameter is minus one, the following
- -- functions yield a real result.
-
- if not A_Real_Result( Arcsin(Minus_One) ) then
- Report.Failed("Non-real result from Function Arcsin with a " &
- "minus one input value");
- end if;
-
- if not A_Real_Result( Arccos(Minus_One) ) then
- Report.Failed("Non-real result from Function Arccos with a " &
- "minus one input value");
- end if;
-
-
- -- Check that when the input parameter has a value of +i or -i, the
- -- Log function yields an imaginary result.
-
- if not An_Imaginary_Result( Log(Plus_i) ) then
- Report.Failed("Non-imaginary result from Function Log with an " &
- "input value of ""+i""");
- end if;
-
- if not An_Imaginary_Result( Log(Minus_i) ) then
- Report.Failed("Non-imaginary result from Function Log with an " &
- "input value of ""-i""");
- end if;
-
-
- -- Check that exponentiation by a zero exponent yields the value one.
-
- if "**"(Left => Compose_From_Cartesian(5.0, 3.0),
- Right => Complex_Zero) /= Plus_One or
- Complex_Negative_Real**0.0 /= Plus_One or
- 15.0**Complex_Zero /= Plus_One
- then
- Report.Failed("Incorrect result from exponentiation with a zero " &
- "exponent");
- end if;
-
-
- -- Check that exponentiation by a unit exponent yields the value of
- -- the left operand (as a complex value).
- -- Note: a "unit exponent" is considered the complex number (1.0, 0.0)
-
- if "**"(Complex_Negative_Real, Plus_One) /=
- Complex_Negative_Real or
- Complex_Negative_Imaginary**Plus_One /=
- Complex_Negative_Imaginary or
- 4.0**Plus_One /=
- Compose_From_Cartesian(4.0, 0.0)
- then
- Report.Failed("Incorrect result from exponentiation with a unit " &
- "exponent");
- end if;
-
-
- -- Check that exponentiation of the value one yields the value one.
-
- if "**"(Plus_One, Complex_Negative_Imaginary) /= Plus_One or
- Plus_One**9.0 /= Plus_One or
- 1.0**Complex_Negative_Real /= Plus_One
- then
- Report.Failed("Incorrect result from exponentiation of the value " &
- "One");
- end if;
-
-
- -- Check that exponentiation of the value zero yields the value zero.
- begin
- if not A_Zero_Result("**"(Complex_Zero,
- Complex_Positive_Imaginary)) or
- not A_Zero_Result(Complex_Zero**4.0) or
- not A_Zero_Result(0.0**Complex_Positive_Real)
- then
- Report.Failed("Incorrect result from exponentiation of the " &
- "value zero");
- end if;
- exception
- when others =>
- Report.Failed("Exception raised during the exponentiation of " &
- "the complex value zero");
- end;
-
-
- exception
- when others => Report.Failed ("Exception raised in Test_Block");
- end Test_Block;
-
- Report.Result;
-
-end CXG1005;
diff --git a/gcc/testsuite/ada/acats/tests/cxg/cxg2001.a b/gcc/testsuite/ada/acats/tests/cxg/cxg2001.a
deleted file mode 100644
index 0d7afa46091..00000000000
--- a/gcc/testsuite/ada/acats/tests/cxg/cxg2001.a
+++ /dev/null
@@ -1,322 +0,0 @@
--- CXG2001.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that the floating point attributes Model_Mantissa,
--- Machine_Mantissa, Machine_Radix, and Machine_Rounds
--- are properly reported.
---
--- TEST DESCRIPTION:
--- This test uses a generic package to compute and check the
--- values of the Machine_ attributes listed above. The
--- generic package is instantiated with the standard FLOAT
--- type and a floating point type for the maximum number
--- of digits of precision.
---
--- APPLICABILITY CRITERIA:
--- This test applies only to implementations supporting the
--- Numerics Annex.
---
---
--- CHANGE HISTORY:
--- 26 JAN 96 SAIC Initial Release for 2.1
---
---!
-
--- References:
---
--- "Algorithms To Reveal Properties of Floating-Point Arithmetic"
--- Michael A. Malcolm; CACM November 1972; pgs 949-951.
---
--- Software Manual for Elementary Functions; W. J. Cody and W. Waite;
--- Prentice-Hall; 1980
------------------------------------------------------------------------
---
--- This test relies upon the fact that
--- (A+2.0)-A is not necessarily 2.0. If A is large enough then adding
--- a small value to A does not change the value of A. Consider the case
--- where we have a decimal based floating point representation with 4
--- digits of precision. A floating point number would logically be
--- represented as "DDDD * 10 ** exp" where D is a value in the range 0..9.
--- The first loop of the test starts A at 2.0 and doubles it until
--- ((A+1.0)-A)-1.0 is no longer zero. For our decimal floating point
--- number this will be 1638 * 10**1 (the value 16384 rounded or truncated
--- to fit in 4 digits).
--- The second loop starts B at 2.0 and keeps doubling B until (A+B)-A is
--- no longer 0. This will keep looping until B is 8.0 because that is
--- the first value where rounding (assuming our machine rounds and addition
--- employs a guard digit) will change the upper 4 digits of the result:
--- 1638_
--- + 8
--- -------
--- 1639_
--- Without rounding the second loop will continue until
--- B is 16:
--- 1638_
--- + 16
--- -------
--- 1639_
---
--- The radix is then determined by (A+B)-A which will give 10.
---
--- The use of Tmp and ITmp in the test is to force values to be
--- stored into memory in the event that register precision is greater
--- than the stored precision of the floating point values.
---
---
--- The test for rounding is (ignoring the temporary variables used to
--- get the stored precision) is
--- Rounds := A + Radix/2.0 - A /= 0.0 ;
--- where A is the value determined in the first step that is the smallest
--- power of 2 such that A + 1.0 = A. This means that the true value of
--- A has one more digit in its value than 'Machine_Mantissa.
--- This check will detect the case where a value is always rounded.
--- There is an additional case where values are rounded to the nearest
--- even value. That is referred to as IEEE style rounding in the test.
---
------------------------------------------------------------------------
-
-with System;
-with Report;
-with Ada.Numerics.Generic_Elementary_Functions;
-procedure CXG2001 is
- Verbose : constant Boolean := False;
-
- -- if one of the attribute computation loops exceeds Max_Iterations
- -- it is most likely due to the compiler reordering an expression
- -- that should not be reordered.
- Illegal_Optimization : exception;
- Max_Iterations : constant := 10_000;
-
- generic
- type Real is digits <>;
- package Chk_Attrs is
- procedure Do_Test;
- end Chk_Attrs;
-
- package body Chk_Attrs is
- package EF is new Ada.Numerics.Generic_Elementary_Functions (Real);
- function Log (X : Real) return Real renames EF.Log;
-
-
- -- names used in paper
- Radix : Integer; -- Beta
- Mantissa_Digits : Integer; -- t
- Rounds : Boolean; -- RND
-
- -- made global to Determine_Attributes to help thwart optimization
- A, B : Real := 2.0;
- Tmp, Tmpa, Tmp1 : Real;
- ITmp : Integer;
- Half_Radix : Real;
-
- -- special constants - not declared as constants so that
- -- the "stored" precision will be used instead of a "register"
- -- precision.
- Zero : Real := 0.0;
- One : Real := 1.0;
- Two : Real := 2.0;
-
-
- procedure Thwart_Optimization is
- -- the purpose of this procedure is to reference the
- -- global variables used by Determine_Attributes so
- -- that the compiler is not likely to keep them in
- -- a higher precision register for their entire lifetime.
- begin
- if Report.Ident_Bool (False) then
- -- never executed
- A := A + 5.0;
- B := B + 6.0;
- Tmp := Tmp + 1.0;
- Tmp1 := Tmp1 + 2.0;
- Tmpa := Tmpa + 2.0;
- One := 12.34; Two := 56.78; Zero := 90.12;
- end if;
- end Thwart_Optimization;
-
-
- -- determines values for Radix, Mantissa_Digits, and Rounds
- -- This is mostly a straight translation of the C code.
- -- The only significant addition is the iteration count
- -- to prevent endless looping if things are really screwed up.
- procedure Determine_Attributes is
- Iterations : Integer;
- begin
- Rounds := True;
-
- Iterations := 0;
- Tmp := Real'Machine (((A + One) - A) - One);
- while Tmp = Zero loop
- A := Real'Machine(A + A);
- Tmp := Real'Machine(A + One);
- Tmp1 := Real'Machine(Tmp - A);
- Tmp := Real'Machine(Tmp1 - One);
-
- Iterations := Iterations + 1;
- if Iterations > Max_Iterations then
- raise Illegal_Optimization;
- end if;
- end loop;
-
- Iterations := 0;
- Tmp := Real'Machine(A + B);
- ITmp := Integer (Tmp - A);
- while ITmp = 0 loop
- B := Real'Machine(B + B);
- Tmp := Real'Machine(A + B);
- ITmp := Integer (Tmp - A);
-
- Iterations := Iterations + 1;
- if Iterations > Max_Iterations then
- raise Illegal_Optimization;
- end if;
- end loop;
-
- Radix := ITmp;
-
- Mantissa_Digits := 0;
- B := 1.0;
- Tmp := Real'Machine(((B + One) - B) - One);
- Iterations := 0;
- while (Tmp = Zero) loop
- Mantissa_Digits := Mantissa_Digits + 1;
- B := B * Real (Radix);
- Tmp := Real'Machine(B + One);
- Tmp1 := Real'Machine(Tmp - B);
- Tmp := Real'Machine(Tmp1 - One);
-
- Iterations := Iterations + 1;
- if Iterations > Max_Iterations then
- raise Illegal_Optimization;
- end if;
- end loop;
-
- Rounds := False;
- Half_Radix := Real (Radix) / Two;
- Tmp := Real'Machine(A + Half_Radix);
- Tmp1 := Real'Machine(Tmp - A);
- if (Tmp1 /= Zero) then
- Rounds := True;
- end if;
- Tmpa := Real'Machine(A + Real (Radix));
- Tmp := Real'Machine(Tmpa + Half_Radix);
- if not Rounds and (Tmp - TmpA /= Zero) then
- Rounds := True;
- if Verbose then
- Report.Comment ("IEEE style rounding");
- end if;
- end if;
-
- exception
- when others =>
- Thwart_Optimization;
- raise;
- end Determine_Attributes;
-
-
- procedure Do_Test is
- Show_Results : Boolean := Verbose;
- Min_Mantissa_Digits : Integer;
- begin
- -- compute the actual Machine_* attribute values
- Determine_Attributes;
-
- if Real'Machine_Radix /= Radix then
- Report.Failed ("'Machine_Radix incorrectly reports" &
- Integer'Image (Real'Machine_Radix));
- Show_Results := True;
- end if;
-
- if Real'Machine_Mantissa /= Mantissa_Digits then
- Report.Failed ("'Machine_Mantissa incorrectly reports" &
- Integer'Image (Real'Machine_Mantissa));
- Show_Results := True;
- end if;
-
- if Real'Machine_Rounds /= Rounds then
- Report.Failed ("'Machine_Rounds incorrectly reports " &
- Boolean'Image (Real'Machine_Rounds));
- Show_Results := True;
- end if;
-
- if Show_Results then
- Report.Comment ("computed Machine_Mantissa is" &
- Integer'Image (Mantissa_Digits));
- Report.Comment ("computed Radix is" &
- Integer'Image (Radix));
- Report.Comment ("computed Rounds is " &
- Boolean'Image (Rounds));
- end if;
-
- -- check the model attributes against the machine attributes
- -- G.2.2(3)/3;6.0
- if Real'Model_Mantissa > Real'Machine_Mantissa then
- Report.Failed ("model mantissa > machine mantissa");
- end if;
-
- -- G.2.2(3)/2;6.0
- -- 'Model_Mantissa >= ceiling(d*log(10)/log(radix))+1
- Min_Mantissa_Digits :=
- Integer (
- Real'Ceiling (
- Real(Real'Digits) * Log(10.0) / Log(Real(Real'Machine_Radix))
- ) ) + 1;
- if Real'Model_Mantissa < Min_Mantissa_Digits then
- Report.Failed ("Model_Mantissa [" &
- Integer'Image (Real'Model_Mantissa) &
- "] < minimum mantissa digits [" &
- Integer'Image (Min_Mantissa_Digits) &
- "]");
- end if;
-
- exception
- when Illegal_Optimization =>
- Report.Failed ("illegal optimization of" &
- " floating point expression");
- end Do_Test;
- end Chk_Attrs;
-
- package Chk_Float is new Chk_Attrs (Float);
-
- -- check the floating point type with the most digits
- type A_Long_Float is digits System.Max_Digits;
- package Chk_A_Long_Float is new Chk_Attrs (A_Long_Float);
-begin
- Report.Test ("CXG2001",
- "Check the attributes Model_Mantissa," &
- " Machine_Mantissa, Machine_Radix," &
- " and Machine_Rounds");
-
- Report.Comment ("checking Standard.Float");
- Chk_Float.Do_Test;
-
- Report.Comment ("checking a digits" &
- Integer'Image (System.Max_Digits) &
- " floating point type");
- Chk_A_Long_Float.Do_Test;
-
- Report.Result;
-end CXG2001;
diff --git a/gcc/testsuite/ada/acats/tests/cxg/cxg2002.a b/gcc/testsuite/ada/acats/tests/cxg/cxg2002.a
deleted file mode 100644
index 6a1f322e8bf..00000000000
--- a/gcc/testsuite/ada/acats/tests/cxg/cxg2002.a
+++ /dev/null
@@ -1,468 +0,0 @@
--- CXG2002.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that the complex "abs" or modulus function returns
--- results that are within the error bound allowed.
---
--- TEST DESCRIPTION:
--- This test uses a generic package to compute and check the
--- values of the modulus function. In addition, a non-generic
--- copy of this package is used to check the non-generic package
--- Ada.Numerics.Complex_Types.
--- Of special interest is the case where either the real or
--- the imaginary part of the argument is very large while the
--- other part is very small or 0.
--- We want to check that the value is computed such that
--- an overflow does not occur. If computed directly from the
--- definition
--- abs (x+yi) = sqrt(x**2 + y**2)
--- then overflow or underflow is much more likely than if the
--- argument is normalized first.
---
--- SPECIAL REQUIREMENTS
--- The Strict Mode for the numerical accuracy must be
--- selected. The method by which this mode is selected
--- is implementation dependent.
---
--- APPLICABILITY CRITERIA:
--- This test applies only to implementations supporting the
--- Numerics Annex.
--- This test only applies to the Strict Mode for numerical
--- accuracy.
---
---
--- CHANGE HISTORY:
--- 31 JAN 96 SAIC Initial release for 2.1
--- 02 JUN 98 EDS Add parens to intermediate calculations.
---!
-
---
--- Reference:
--- Problems and Methodologies in Mathematical Software Production;
--- editors: P. C. Messina and A Murli;
--- Lecture Notes in Computer Science
--- Volume 142
--- Springer Verlag 1982
---
-
-with System;
-with Report;
-with Ada.Numerics.Generic_Complex_Types;
-with Ada.Numerics.Complex_Types;
-procedure CXG2002 is
- Verbose : constant Boolean := False;
- Maximum_Relative_Error : constant := 3.0;
-
- generic
- type Real is digits <>;
- package Generic_Check is
- procedure Do_Test;
- end Generic_Check;
-
- package body Generic_Check is
- package Complex_Types is new
- Ada.Numerics.Generic_Complex_Types (Real);
- use Complex_Types;
-
- procedure Check (Actual, Expected : Real;
- Test_Name : String;
- MRE : Real := Maximum_Relative_Error) is
- Rel_Error,
- Abs_Error,
- Max_Error : Real;
- begin
- -- In the case where the expected result is very small or 0
- -- we compute the maximum error as a multiple of Model_Epsilon instead
- -- of Model_Epsilon and Expected.
- Rel_Error := MRE * (abs Expected * Real'Model_Epsilon);
- Abs_Error := MRE * Real'Model_Epsilon;
- if Rel_Error > Abs_Error then
- Max_Error := Rel_Error;
- else
- Max_Error := Abs_Error;
- end if;
-
- if abs (Actual - Expected) > Max_Error then
- Report.Failed (Test_Name &
- " actual: " & Real'Image (Actual) &
- " expected: " & Real'Image (Expected) &
- " difference: " &
- Real'Image (Expected - Actual) &
- " max_err:" & Real'Image (Max_Error) );
- elsif Verbose then
- if Actual = Expected then
- Report.Comment (Test_Name & " exact result");
- else
- Report.Comment (Test_Name & " passed");
- end if;
- end if;
- end Check;
-
-
- procedure Do_Test is
- Z : Complex;
- X : Real;
- T : Real;
- begin
-
- --- test 1 ---
- begin
- T := Real'Safe_Last;
- Z := T + 0.0*i;
- X := abs Z;
- Check (X, T, "test 1 -- abs(bigreal + 0i)");
- exception
- when Constraint_Error =>
- Report.Failed ("Constraint_Error raised in test 1");
- when others =>
- Report.Failed ("exception in test 1");
- end;
-
- --- test 2 ---
- begin
- T := Real'Safe_Last;
- Z := 0.0 + T*i;
- X := Modulus (Z);
- Check (X, T, "test 2 -- abs(0 + bigreal*i)");
- exception
- when Constraint_Error =>
- Report.Failed ("Constraint_Error raised in test 2");
- when others =>
- Report.Failed ("exception in test 2");
- end;
-
- --- test 3 ---
- begin
- Z := 3.0 + 4.0*i;
- X := abs Z;
- Check (X, 5.0 , "test 3 -- abs(3 + 4*i)");
- exception
- when Constraint_Error =>
- Report.Failed ("Constraint_Error raised in test 3");
- when others =>
- Report.Failed ("exception in test 3");
- end;
-
- --- test 4 ---
- declare
- S : Real;
- begin
- S := Real(Real'Machine_Radix) ** (Real'Machine_EMax - 3);
- Z := 3.0 * S + 4.0*S*i;
- X := abs Z;
- Check (X, 5.0*S, "test 4 -- abs(3S + 4S*i) for large S",
- 5.0*Real'Model_Epsilon);
- exception
- when Constraint_Error =>
- Report.Failed ("Constraint_Error raised in test 4");
- when others =>
- Report.Failed ("exception in test 4");
- end;
-
- --- test 5 ---
- begin
- T := Real'Model_Small;
- Z := T + 0.0*i;
- X := abs Z;
- Check (X, T , "test 5 -- abs(small + 0*i)");
- exception
- when Constraint_Error =>
- Report.Failed ("Constraint_Error raised in test 5");
- when others =>
- Report.Failed ("exception in test 5");
- end;
-
- --- test 6 ---
- begin
- T := Real'Model_Small;
- Z := 0.0 + T*i;
- X := abs Z;
- Check (X, T , "test 6 -- abs(0 + small*i)");
- exception
- when Constraint_Error =>
- Report.Failed ("Constraint_Error raised in test 6");
- when others =>
- Report.Failed ("exception in test 6");
- end;
-
- --- test 7 ---
- declare
- S : Real;
- begin
- S := Real(Real'Machine_Radix) ** (Real'Model_EMin + 3);
- Z := 3.0 * S + 4.0*S*i;
- X := abs Z;
- Check (X, 5.0*S, "test 7 -- abs(3S + 4S*i) for small S",
- 5.0*Real'Model_Epsilon);
- exception
- when Constraint_Error =>
- Report.Failed ("Constraint_Error raised in test 7");
- when others =>
- Report.Failed ("exception in test 7");
- end;
-
- --- test 8 ---
- declare
- -- CRC Standard Mathematical Tables; 23rd Edition; pg 738
- Sqrt2 : constant :=
- 1.41421_35623_73095_04880_16887_24209_69807_85696_71875_37695;
- begin
- Z := 1.0 + 1.0*i;
- X := abs Z;
- Check (X, Sqrt2 , "test 8 -- abs(1 + 1*i)");
- exception
- when Constraint_Error =>
- Report.Failed ("Constraint_Error raised in test 8");
- when others =>
- Report.Failed ("exception in test 8");
- end;
-
- --- test 9 ---
- begin
- T := 0.0;
- Z := T + 0.0*i;
- X := abs Z;
- Check (X, T , "test 5 -- abs(0 + 0*i)");
- exception
- when Constraint_Error =>
- Report.Failed ("Constraint_Error raised in test 9");
- when others =>
- Report.Failed ("exception in test 9");
- end;
- end Do_Test;
- end Generic_Check;
-
- -----------------------------------------------------------------------
- --- non generic copy of the above generic package
- -----------------------------------------------------------------------
-
- package Non_Generic_Check is
- subtype Real is Float;
- procedure Do_Test;
- end Non_Generic_Check;
-
- package body Non_Generic_Check is
- use Ada.Numerics.Complex_Types;
-
- procedure Check (Actual, Expected : Real;
- Test_Name : String;
- MRE : Real := Maximum_Relative_Error) is
- Rel_Error,
- Abs_Error,
- Max_Error : Real;
- begin
- -- In the case where the expected result is very small or 0
- -- we compute the maximum error as a multiple of Model_Epsilon instead
- -- of Model_Epsilon and Expected.
- Rel_Error := MRE * (abs Expected * Real'Model_Epsilon);
- Abs_Error := MRE * Real'Model_Epsilon;
- if Rel_Error > Abs_Error then
- Max_Error := Rel_Error;
- else
- Max_Error := Abs_Error;
- end if;
-
- if abs (Actual - Expected) > Max_Error then
- Report.Failed (Test_Name &
- " actual: " & Real'Image (Actual) &
- " expected: " & Real'Image (Expected) &
- " difference: " &
- Real'Image (Expected - Actual) &
- " max_err:" & Real'Image (Max_Error) );
- elsif Verbose then
- if Actual = Expected then
- Report.Comment (Test_Name & " exact result");
- else
- Report.Comment (Test_Name & " passed");
- end if;
- end if;
- end Check;
-
-
- procedure Do_Test is
- Z : Complex;
- X : Real;
- T : Real;
- begin
-
- --- test 1 ---
- begin
- T := Real'Safe_Last;
- Z := T + 0.0*i;
- X := abs Z;
- Check (X, T, "test 1 -- abs(bigreal + 0i)");
- exception
- when Constraint_Error =>
- Report.Failed ("Constraint_Error raised in test 1");
- when others =>
- Report.Failed ("exception in test 1");
- end;
-
- --- test 2 ---
- begin
- T := Real'Safe_Last;
- Z := 0.0 + T*i;
- X := Modulus (Z);
- Check (X, T, "test 2 -- abs(0 + bigreal*i)");
- exception
- when Constraint_Error =>
- Report.Failed ("Constraint_Error raised in test 2");
- when others =>
- Report.Failed ("exception in test 2");
- end;
-
- --- test 3 ---
- begin
- Z := 3.0 + 4.0*i;
- X := abs Z;
- Check (X, 5.0 , "test 3 -- abs(3 + 4*i)");
- exception
- when Constraint_Error =>
- Report.Failed ("Constraint_Error raised in test 3");
- when others =>
- Report.Failed ("exception in test 3");
- end;
-
- --- test 4 ---
- declare
- S : Real;
- begin
- S := Real(Real'Machine_Radix) ** (Real'Machine_EMax - 3);
- Z := 3.0 * S + 4.0*S*i;
- X := abs Z;
- Check (X, 5.0*S, "test 4 -- abs(3S + 4S*i) for large S",
- 5.0*Real'Model_Epsilon);
- exception
- when Constraint_Error =>
- Report.Failed ("Constraint_Error raised in test 4");
- when others =>
- Report.Failed ("exception in test 4");
- end;
-
- --- test 5 ---
- begin
- T := Real'Model_Small;
- Z := T + 0.0*i;
- X := abs Z;
- Check (X, T , "test 5 -- abs(small + 0*i)");
- exception
- when Constraint_Error =>
- Report.Failed ("Constraint_Error raised in test 5");
- when others =>
- Report.Failed ("exception in test 5");
- end;
-
- --- test 6 ---
- begin
- T := Real'Model_Small;
- Z := 0.0 + T*i;
- X := abs Z;
- Check (X, T , "test 6 -- abs(0 + small*i)");
- exception
- when Constraint_Error =>
- Report.Failed ("Constraint_Error raised in test 6");
- when others =>
- Report.Failed ("exception in test 6");
- end;
-
- --- test 7 ---
- declare
- S : Real;
- begin
- S := Real(Real'Machine_Radix) ** (Real'Model_EMin + 3);
- Z := 3.0 * S + 4.0*S*i;
- X := abs Z;
- Check (X, 5.0*S, "test 7 -- abs(3S + 4S*i) for small S",
- 5.0*Real'Model_Epsilon);
- exception
- when Constraint_Error =>
- Report.Failed ("Constraint_Error raised in test 7");
- when others =>
- Report.Failed ("exception in test 7");
- end;
-
- --- test 8 ---
- declare
- -- CRC Standard Mathematical Tables; 23rd Edition; pg 738
- Sqrt2 : constant :=
- 1.41421_35623_73095_04880_16887_24209_69807_85696_71875_37695;
- begin
- Z := 1.0 + 1.0*i;
- X := abs Z;
- Check (X, Sqrt2 , "test 8 -- abs(1 + 1*i)");
- exception
- when Constraint_Error =>
- Report.Failed ("Constraint_Error raised in test 8");
- when others =>
- Report.Failed ("exception in test 8");
- end;
-
- --- test 9 ---
- begin
- T := 0.0;
- Z := T + 0.0*i;
- X := abs Z;
- Check (X, T , "test 5 -- abs(0 + 0*i)");
- exception
- when Constraint_Error =>
- Report.Failed ("Constraint_Error raised in test 9");
- when others =>
- Report.Failed ("exception in test 9");
- end;
- end Do_Test;
- end Non_Generic_Check;
-
- -----------------------------------------------------------------------
- --- end of "manual instantiation"
- -----------------------------------------------------------------------
- package Chk_Float is new Generic_Check (Float);
-
- -- check the floating point type with the most digits
- type A_Long_Float is digits System.Max_Digits;
- package Chk_A_Long_Float is new Generic_Check (A_Long_Float);
-begin
- Report.Test ("CXG2002",
- "Check the accuracy of the complex modulus" &
- " function");
-
- if Verbose then
- Report.Comment ("checking Standard.Float");
- end if;
- Chk_Float.Do_Test;
-
- if Verbose then
- Report.Comment ("checking a digits" &
- Integer'Image (System.Max_Digits) &
- " floating point type");
- end if;
- Chk_A_Long_Float.Do_Test;
-
- if Verbose then
- Report.Comment ("checking non-generic package");
- end if;
- Non_Generic_Check.Do_Test;
- Report.Result;
-end CXG2002;
diff --git a/gcc/testsuite/ada/acats/tests/cxg/cxg2003.a b/gcc/testsuite/ada/acats/tests/cxg/cxg2003.a
deleted file mode 100644
index d1a225a50a1..00000000000
--- a/gcc/testsuite/ada/acats/tests/cxg/cxg2003.a
+++ /dev/null
@@ -1,701 +0,0 @@
--- CXG2003.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that the sqrt function returns
--- results that are within the error bound allowed.
---
--- TEST DESCRIPTION:
--- This test contains three test packages that are almost
--- identical. The first two packages differ only in the
--- floating point type that is being tested. The first
--- and third package differ only in whether the generic
--- elementary functions package or the pre-instantiated
--- package is used.
--- The test package is not generic so that the arguments
--- and expected results for some of the test values
--- can be expressed as universal real instead of being
--- computed at runtime.
---
--- SPECIAL REQUIREMENTS
--- The Strict Mode for the numerical accuracy must be
--- selected. The method by which this mode is selected
--- is implementation dependent.
---
--- APPLICABILITY CRITERIA:
--- This test applies only to implementations supporting the
--- Numerics Annex.
--- This test only applies to the Strict Mode for numerical
--- accuracy.
---
---
--- CHANGE HISTORY:
--- 2 FEB 96 SAIC Initial release for 2.1
--- 18 AUG 96 SAIC Made Check consistent with other tests.
---
---!
-
-with System;
-with Report;
-with Ada.Numerics.Generic_Elementary_Functions;
-with Ada.Numerics.Elementary_Functions;
-procedure CXG2003 is
- Verbose : constant Boolean := False;
-
- package Float_Check is
- subtype Real is Float;
- procedure Do_Test;
- end Float_Check;
-
- package body Float_Check is
- package Elementary_Functions is new
- Ada.Numerics.Generic_Elementary_Functions (Real);
- function Sqrt (X : Real) return Real renames
- Elementary_Functions.Sqrt;
- function Log (X : Real) return Real renames
- Elementary_Functions.Log;
- function Exp (X : Real) return Real renames
- Elementary_Functions.Exp;
-
- -- The default Maximum Relative Error is the value specified
- -- in the LRM.
- Default_MRE : constant Real := 2.0;
-
- procedure Check (Actual, Expected : Real;
- Test_Name : String;
- MRE : Real := Default_MRE) is
- Rel_Error : Real;
- Abs_Error : Real;
- Max_Error : Real;
- begin
- -- In the case where the expected result is very small or 0
- -- we compute the maximum error as a multiple of Model_Epsilon instead
- -- of Model_Epsilon and Expected.
- Rel_Error := MRE * abs Expected * Real'Model_Epsilon;
- Abs_Error := MRE * Real'Model_Epsilon;
- if Rel_Error > Abs_Error then
- Max_Error := Rel_Error;
- else
- Max_Error := Abs_Error;
- end if;
-
- if abs (Actual - Expected) > Max_Error then
- Report.Failed (Test_Name &
- " actual: " & Real'Image (Actual) &
- " expected: " & Real'Image (Expected) &
- " difference: " &
- Real'Image (Actual - Expected) &
- " mre:" & Real'Image (Max_Error) );
- elsif Verbose then
- if Actual = Expected then
- Report.Comment (Test_Name & " exact result");
- else
- Report.Comment (Test_Name & " passed");
- end if;
- end if;
- end Check;
-
-
- procedure Argument_Range_Check (A, B : Real;
- Test : String) is
- -- test a logarithmically distributed selection of
- -- arguments selected from the range A to B.
- X : Real;
- Expected : Real;
- Y : Real;
- C : Real := Log(B/A);
- Max_Samples : constant := 1000;
-
- begin
- for I in 1..Max_Samples loop
- Expected := A * Exp(C * Real (I) / Real (Max_Samples));
- X := Expected * Expected;
- Y := Sqrt (X);
-
- -- note that since the expected value is computed, we
- -- must take the error in that computation into account.
- Check (Y, Expected,
- "test " & Test & " -" &
- Integer'Image (I) &
- " of argument range",
- 3.0);
- end loop;
- exception
- when Constraint_Error =>
- Report.Failed
- ("Constraint_Error raised in argument range check");
- when others =>
- Report.Failed ("exception in argument range check");
- end Argument_Range_Check;
-
- procedure Do_Test is
- begin
-
- --- test 1 ---
- declare
- T : constant := (Real'Machine_EMax - 1) / 2;
- X : constant := (1.0 * Real'Machine_Radix) ** (2 * T);
- Expected : constant := (1.0 * Real'Machine_Radix) ** T;
- Y : Real;
- begin
- Y := Sqrt (X);
- Check (Y, Expected, "test 1 -- sqrt(radix**((emax-1)/2))");
- exception
- when Constraint_Error =>
- Report.Failed ("Constraint_Error raised in test 1");
- when others =>
- Report.Failed ("exception in test 1");
- end;
-
- --- test 2 ---
- declare
- T : constant := (Real'Model_EMin + 1) / 2;
- X : constant := (1.0 * Real'Machine_Radix) ** (2 * T);
- Expected : constant := (1.0 * Real'Machine_Radix) ** T;
- Y : Real;
- begin
- Y := Sqrt (X);
- Check (Y, Expected, "test 2 -- sqrt(radix**((emin+1)/2))");
- exception
- when Constraint_Error =>
- Report.Failed ("Constraint_Error raised in test 2");
- when others =>
- Report.Failed ("exception in test 2");
- end;
-
- --- test 3 ---
- declare
- X : constant := 1.0;
- Expected : constant := 1.0;
- Y : Real;
- begin
- Y := Sqrt(X);
- Check (Y, Expected, "test 3 -- sqrt(1.0)",
- 0.0); -- no error allowed
- exception
- when Constraint_Error =>
- Report.Failed ("Constraint_Error raised in test 3");
- when others =>
- Report.Failed ("exception in test 3");
- end;
-
- --- test 4 ---
- declare
- X : constant := 0.0;
- Expected : constant := 0.0;
- Y : Real;
- begin
- Y := Sqrt(X);
- Check (Y, Expected, "test 4 -- sqrt(0.0)",
- 0.0); -- no error allowed
- exception
- when Constraint_Error =>
- Report.Failed ("Constraint_Error raised in test 4");
- when others =>
- Report.Failed ("exception in test 4");
- end;
-
- --- test 5 ---
- declare
- X : constant := -1.0;
- Y : Real;
- begin
- Y := Sqrt(X);
- -- the following code should not be executed.
- -- The call to Check is to keep the call to Sqrt from
- -- appearing to be dead code.
- Check (Y, -1.0, "test 5 -- sqrt(-1)" );
- Report.Failed ("test 5 - argument_error expected");
- exception
- when Constraint_Error =>
- Report.Failed ("Constraint_Error raised in test 5");
- when Ada.Numerics.Argument_Error =>
- if Verbose then
- Report.Comment ("test 5 correctly got argument_error");
- end if;
- when others =>
- Report.Failed ("exception in test 5");
- end;
-
- --- test 6 ---
- declare
- X : constant := Ada.Numerics.Pi ** 2;
- Expected : constant := Ada.Numerics.Pi;
- Y : Real;
- begin
- Y := Sqrt (X);
- Check (Y, Expected, "test 6 -- sqrt(pi**2)");
- exception
- when Constraint_Error =>
- Report.Failed ("Constraint_Error raised in test 6");
- when others =>
- Report.Failed ("exception in test 6");
- end;
-
- --- test 7 & 8 ---
- Argument_Range_Check (1.0/Sqrt(Real(Real'Machine_Radix)),
- 1.0,
- "7");
- Argument_Range_Check (1.0,
- Sqrt(Real(Real'Machine_Radix)),
- "8");
- end Do_Test;
- end Float_Check;
-
- -----------------------------------------------------------------------
- -----------------------------------------------------------------------
- -- check the floating point type with the most digits
- type A_Long_Float is digits System.Max_Digits;
-
-
- package A_Long_Float_Check is
- subtype Real is A_Long_Float;
- procedure Do_Test;
- end A_Long_Float_Check;
-
- package body A_Long_Float_Check is
- package Elementary_Functions is new
- Ada.Numerics.Generic_Elementary_Functions (Real);
- function Sqrt (X : Real) return Real renames
- Elementary_Functions.Sqrt;
- function Log (X : Real) return Real renames
- Elementary_Functions.Log;
- function Exp (X : Real) return Real renames
- Elementary_Functions.Exp;
-
- -- The default Maximum Relative Error is the value specified
- -- in the LRM.
- Default_MRE : constant Real := 2.0;
-
- procedure Check (Actual, Expected : Real;
- Test_Name : String;
- MRE : Real := Default_MRE) is
- Rel_Error : Real;
- Abs_Error : Real;
- Max_Error : Real;
- begin
- -- In the case where the expected result is very small or 0
- -- we compute the maximum error as a multiple of Model_Epsilon instead
- -- of Model_Epsilon and Expected.
- Rel_Error := MRE * abs Expected * Real'Model_Epsilon;
- Abs_Error := MRE * Real'Model_Epsilon;
- if Rel_Error > Abs_Error then
- Max_Error := Rel_Error;
- else
- Max_Error := Abs_Error;
- end if;
-
- if abs (Actual - Expected) > Max_Error then
- Report.Failed (Test_Name &
- " actual: " & Real'Image (Actual) &
- " expected: " & Real'Image (Expected) &
- " difference: " &
- Real'Image (Actual - Expected) &
- " mre:" & Real'Image (Max_Error) );
- elsif Verbose then
- if Actual = Expected then
- Report.Comment (Test_Name & " exact result");
- else
- Report.Comment (Test_Name & " passed");
- end if;
- end if;
- end Check;
-
-
- procedure Argument_Range_Check (A, B : Real;
- Test : String) is
- -- test a logarithmically distributed selection of
- -- arguments selected from the range A to B.
- X : Real;
- Expected : Real;
- Y : Real;
- C : Real := Log(B/A);
- Max_Samples : constant := 1000;
-
- begin
- for I in 1..Max_Samples loop
- Expected := A * Exp(C * Real (I) / Real (Max_Samples));
- X := Expected * Expected;
- Y := Sqrt (X);
-
- -- note that since the expected value is computed, we
- -- must take the error in that computation into account.
- Check (Y, Expected,
- "test " & Test & " -" &
- Integer'Image (I) &
- " of argument range",
- 3.0);
- end loop;
- exception
- when Constraint_Error =>
- Report.Failed
- ("Constraint_Error raised in argument range check");
- when others =>
- Report.Failed ("exception in argument range check");
- end Argument_Range_Check;
-
-
- procedure Do_Test is
- begin
-
- --- test 1 ---
- declare
- T : constant := (Real'Machine_EMax - 1) / 2;
- X : constant := (1.0 * Real'Machine_Radix) ** (2 * T);
- Expected : constant := (1.0 * Real'Machine_Radix) ** T;
- Y : Real;
- begin
- Y := Sqrt (X);
- Check (Y, Expected, "test 1 -- sqrt(radix**((emax-1)/2))");
- exception
- when Constraint_Error =>
- Report.Failed ("Constraint_Error raised in test 1");
- when others =>
- Report.Failed ("exception in test 1");
- end;
-
- --- test 2 ---
- declare
- T : constant := (Real'Model_EMin + 1) / 2;
- X : constant := (1.0 * Real'Machine_Radix) ** (2 * T);
- Expected : constant := (1.0 * Real'Machine_Radix) ** T;
- Y : Real;
- begin
- Y := Sqrt (X);
- Check (Y, Expected, "test 2 -- sqrt(radix**((emin+1)/2))");
- exception
- when Constraint_Error =>
- Report.Failed ("Constraint_Error raised in test 2");
- when others =>
- Report.Failed ("exception in test 2");
- end;
-
- --- test 3 ---
- declare
- X : constant := 1.0;
- Expected : constant := 1.0;
- Y : Real;
- begin
- Y := Sqrt(X);
- Check (Y, Expected, "test 3 -- sqrt(1.0)",
- 0.0); -- no error allowed
- exception
- when Constraint_Error =>
- Report.Failed ("Constraint_Error raised in test 3");
- when others =>
- Report.Failed ("exception in test 3");
- end;
-
- --- test 4 ---
- declare
- X : constant := 0.0;
- Expected : constant := 0.0;
- Y : Real;
- begin
- Y := Sqrt(X);
- Check (Y, Expected, "test 4 -- sqrt(0.0)",
- 0.0); -- no error allowed
- exception
- when Constraint_Error =>
- Report.Failed ("Constraint_Error raised in test 4");
- when others =>
- Report.Failed ("exception in test 4");
- end;
-
- --- test 5 ---
- declare
- X : constant := -1.0;
- Y : Real;
- begin
- Y := Sqrt(X);
- -- the following code should not be executed.
- -- The call to Check is to keep the call to Sqrt from
- -- appearing to be dead code.
- Check (Y, -1.0, "test 5 -- sqrt(-1)" );
- Report.Failed ("test 5 - argument_error expected");
- exception
- when Constraint_Error =>
- Report.Failed ("Constraint_Error raised in test 5");
- when Ada.Numerics.Argument_Error =>
- if Verbose then
- Report.Comment ("test 5 correctly got argument_error");
- end if;
- when others =>
- Report.Failed ("exception in test 5");
- end;
-
- --- test 6 ---
- declare
- X : constant := Ada.Numerics.Pi ** 2;
- Expected : constant := Ada.Numerics.Pi;
- Y : Real;
- begin
- Y := Sqrt (X);
- Check (Y, Expected, "test 6 -- sqrt(pi**2)");
- exception
- when Constraint_Error =>
- Report.Failed ("Constraint_Error raised in test 6");
- when others =>
- Report.Failed ("exception in test 6");
- end;
-
- --- test 7 & 8 ---
- Argument_Range_Check (1.0/Sqrt(Real(Real'Machine_Radix)),
- 1.0,
- "7");
- Argument_Range_Check (1.0,
- Sqrt(Real(Real'Machine_Radix)),
- "8");
- end Do_Test;
- end A_Long_Float_Check;
-
- -----------------------------------------------------------------------
- -----------------------------------------------------------------------
-
- package Non_Generic_Check is
- procedure Do_Test;
- end Non_Generic_Check;
-
- package body Non_Generic_Check is
- package EF renames
- Ada.Numerics.Elementary_Functions;
- subtype Real is Float;
-
- -- The default Maximum Relative Error is the value specified
- -- in the LRM.
- Default_MRE : constant Real := 2.0;
-
- procedure Check (Actual, Expected : Real;
- Test_Name : String;
- MRE : Real := Default_MRE) is
- Rel_Error : Real;
- Abs_Error : Real;
- Max_Error : Real;
- begin
- -- In the case where the expected result is very small or 0
- -- we compute the maximum error as a multiple of Model_Epsilon instead
- -- of Model_Epsilon and Expected.
- Rel_Error := MRE * abs Expected * Real'Model_Epsilon;
- Abs_Error := MRE * Real'Model_Epsilon;
- if Rel_Error > Abs_Error then
- Max_Error := Rel_Error;
- else
- Max_Error := Abs_Error;
- end if;
-
- if abs (Actual - Expected) > Max_Error then
- Report.Failed (Test_Name &
- " actual: " & Real'Image (Actual) &
- " expected: " & Real'Image (Expected) &
- " difference: " &
- Real'Image (Actual - Expected) &
- " mre:" & Real'Image (Max_Error) );
- elsif Verbose then
- if Actual = Expected then
- Report.Comment (Test_Name & " exact result");
- else
- Report.Comment (Test_Name & " passed");
- end if;
- end if;
- end Check;
-
-
-
- procedure Argument_Range_Check (A, B : Float;
- Test : String) is
- -- test a logarithmically distributed selection of
- -- arguments selected from the range A to B.
- X : Float;
- Expected : Float;
- Y : Float;
- C : Float := EF.Log(B/A);
- Max_Samples : constant := 1000;
-
- begin
- for I in 1..Max_Samples loop
- Expected := A * EF.Exp(C * Float (I) / Float (Max_Samples));
- X := Expected * Expected;
- Y := EF.Sqrt (X);
-
- -- note that since the expected value is computed, we
- -- must take the error in that computation into account.
- Check (Y, Expected,
- "test " & Test & " -" &
- Integer'Image (I) &
- " of argument range",
- 3.0);
- end loop;
- exception
- when Constraint_Error =>
- Report.Failed
- ("Constraint_Error raised in argument range check");
- when others =>
- Report.Failed ("exception in argument range check");
- end Argument_Range_Check;
-
-
- procedure Do_Test is
- begin
-
- --- test 1 ---
- declare
- T : constant := (Float'Machine_EMax - 1) / 2;
- X : constant := (1.0 * Float'Machine_Radix) ** (2 * T);
- Expected : constant := (1.0 * Float'Machine_Radix) ** T;
- Y : Float;
- begin
- Y := EF.Sqrt (X);
- Check (Y, Expected, "test 1 -- sqrt(radix**((emax-1)/2))");
- exception
- when Constraint_Error =>
- Report.Failed ("Constraint_Error raised in test 1");
- when others =>
- Report.Failed ("exception in test 1");
- end;
-
- --- test 2 ---
- declare
- T : constant := (Float'Model_EMin + 1) / 2;
- X : constant := (1.0 * Float'Machine_Radix) ** (2 * T);
- Expected : constant := (1.0 * Float'Machine_Radix) ** T;
- Y : Float;
- begin
- Y := EF.Sqrt (X);
- Check (Y, Expected, "test 2 -- sqrt(radix**((emin+1)/2))");
- exception
- when Constraint_Error =>
- Report.Failed ("Constraint_Error raised in test 2");
- when others =>
- Report.Failed ("exception in test 2");
- end;
-
- --- test 3 ---
- declare
- X : constant := 1.0;
- Expected : constant := 1.0;
- Y : Float;
- begin
- Y := EF.Sqrt(X);
- Check (Y, Expected, "test 3 -- sqrt(1.0)",
- 0.0); -- no error allowed
- exception
- when Constraint_Error =>
- Report.Failed ("Constraint_Error raised in test 3");
- when others =>
- Report.Failed ("exception in test 3");
- end;
-
- --- test 4 ---
- declare
- X : constant := 0.0;
- Expected : constant := 0.0;
- Y : Float;
- begin
- Y := EF.Sqrt(X);
- Check (Y, Expected, "test 4 -- sqrt(0.0)",
- 0.0); -- no error allowed
- exception
- when Constraint_Error =>
- Report.Failed ("Constraint_Error raised in test 4");
- when others =>
- Report.Failed ("exception in test 4");
- end;
-
- --- test 5 ---
- declare
- X : constant := -1.0;
- Y : Float;
- begin
- Y := EF.Sqrt(X);
- -- the following code should not be executed.
- -- The call to Check is to keep the call to Sqrt from
- -- appearing to be dead code.
- Check (Y, -1.0, "test 5 -- sqrt(-1)" );
- Report.Failed ("test 5 - argument_error expected");
- exception
- when Constraint_Error =>
- Report.Failed ("Constraint_Error raised in test 5");
- when Ada.Numerics.Argument_Error =>
- if Verbose then
- Report.Comment ("test 5 correctly got argument_error");
- end if;
- when others =>
- Report.Failed ("exception in test 5");
- end;
-
- --- test 6 ---
- declare
- X : constant := Ada.Numerics.Pi ** 2;
- Expected : constant := Ada.Numerics.Pi;
- Y : Float;
- begin
- Y := EF.Sqrt (X);
- Check (Y, Expected, "test 6 -- sqrt(pi**2)");
- exception
- when Constraint_Error =>
- Report.Failed ("Constraint_Error raised in test 6");
- when others =>
- Report.Failed ("exception in test 6");
- end;
-
- --- test 7 & 8 ---
- Argument_Range_Check (1.0/EF.Sqrt(Float(Float'Machine_Radix)),
- 1.0,
- "7");
- Argument_Range_Check (1.0,
- EF.Sqrt(Float(Float'Machine_Radix)),
- "8");
- end Do_Test;
- end Non_Generic_Check;
-
- -----------------------------------------------------------------------
- -----------------------------------------------------------------------
-
-begin
- Report.Test ("CXG2003",
- "Check the accuracy of the sqrt function");
-
- if Verbose then
- Report.Comment ("checking Standard.Float");
- end if;
-
- Float_Check.Do_Test;
-
- if Verbose then
- Report.Comment ("checking a digits" &
- Integer'Image (System.Max_Digits) &
- " floating point type");
- end if;
-
- A_Long_Float_Check.Do_Test;
-
- if Verbose then
- Report.Comment ("checking non-generic package");
- end if;
-
- Non_Generic_Check.Do_Test;
-
- Report.Result;
-end CXG2003;
diff --git a/gcc/testsuite/ada/acats/tests/cxg/cxg2004.a b/gcc/testsuite/ada/acats/tests/cxg/cxg2004.a
deleted file mode 100644
index 2df296d3d42..00000000000
--- a/gcc/testsuite/ada/acats/tests/cxg/cxg2004.a
+++ /dev/null
@@ -1,499 +0,0 @@
--- CXG2004.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that the sin and cos functions return
--- results that are within the error bound allowed.
---
--- TEST DESCRIPTION:
--- This test consists of a generic package that is
--- instantiated to check both float and a long float type.
--- The test for each floating point type is divided into
--- the following parts:
--- Special value checks where the result is a known constant.
--- Checks using an identity relationship.
---
--- SPECIAL REQUIREMENTS
--- The Strict Mode for the numerical accuracy must be
--- selected. The method by which this mode is selected
--- is implementation dependent.
---
--- APPLICABILITY CRITERIA:
--- This test applies only to implementations supporting the
--- Numerics Annex.
--- This test only applies to the Strict Mode for numerical
--- accuracy.
---
---
--- CHANGE HISTORY:
--- 13 FEB 96 SAIC Initial release for 2.1
--- 22 APR 96 SAIC Changed to generic implementation.
--- 18 AUG 96 SAIC Improvements to commentary.
--- 23 OCT 96 SAIC Exact results are not required unless the
--- cycle is specified.
--- 28 FEB 97 PWB.CTA Removed checks where cycle 2.0*Pi is specified
--- 02 JUN 98 EDS Revised calculations to ensure that X is exactly
--- three times Y per advice of numerics experts.
---
--- CHANGE NOTE:
--- According to Ken Dritz, author of the Numerics Annex of the RM,
--- one should never specify the cycle 2.0*Pi for the trigonometric
--- functions. In particular, if the machine number for the first
--- argument is not an exact multiple of the machine number for the
--- explicit cycle, then the specified exact results cannot be
--- reasonably expected. The affected checks in this test have been
--- marked as comments, with the additional notation "pwb-math".
--- Phil Brashear
---!
-
---
--- References:
---
--- Software Manual for the Elementary Functions
--- William J. Cody, Jr. and William Waite
--- Prentice-Hall, 1980
---
--- CRC Standard Mathematical Tables
--- 23rd Edition
---
--- Implementation and Testing of Function Software
--- W. J. Cody
--- Problems and Methodologies in Mathematical Software Production
--- editors P. C. Messina and A. Murli
--- Lecture Notes in Computer Science Volume 142
--- Springer Verlag, 1982
---
--- The sin and cos checks are translated directly from
--- the netlib FORTRAN code that was written by W. Cody.
---
-
-with System;
-with Report;
-with Ada.Numerics.Generic_Elementary_Functions;
-with Ada.Numerics.Elementary_Functions;
-procedure CXG2004 is
- Verbose : constant Boolean := False;
- Number_Samples : constant := 1000;
-
- -- CRC Standard Mathematical Tables; 23rd Edition; pg 738
- Sqrt2 : constant :=
- 1.41421_35623_73095_04880_16887_24209_69807_85696_71875_37695;
- Sqrt3 : constant :=
- 1.73205_08075_68877_29352_74463_41505_87236_69428_05253_81039;
-
- Pi : constant := Ada.Numerics.Pi;
-
- generic
- type Real is digits <>;
- package Generic_Check is
- procedure Do_Test;
- end Generic_Check;
-
- package body Generic_Check is
- package Elementary_Functions is new
- Ada.Numerics.Generic_Elementary_Functions (Real);
-
- function Sin (X : Real) return Real renames
- Elementary_Functions.Sin;
- function Cos (X : Real) return Real renames
- Elementary_Functions.Cos;
- function Sin (X, Cycle : Real) return Real renames
- Elementary_Functions.Sin;
- function Cos (X, Cycle : Real) return Real renames
- Elementary_Functions.Cos;
-
- Accuracy_Error_Reported : Boolean := False;
-
- procedure Check (Actual, Expected : Real;
- Test_Name : String;
- MRE : Real) is
- Rel_Error,
- Abs_Error,
- Max_Error : Real;
- begin
-
- -- In the case where the expected result is very small or 0
- -- we compute the maximum error as a multiple of Model_Epsilon instead
- -- of Model_Epsilon and Expected.
- Rel_Error := MRE * abs Expected * Real'Model_Epsilon;
- Abs_Error := MRE * Real'Model_Epsilon;
- if Rel_Error > Abs_Error then
- Max_Error := Rel_Error;
- else
- Max_Error := Abs_Error;
- end if;
-
-
- -- in addition to the relative error checks we apply the
- -- criteria of G.2.4(16)
- if abs (Actual) > 1.0 then
- Accuracy_Error_Reported := True;
- Report.Failed (Test_Name & " result > 1.0");
- elsif abs (Actual - Expected) > Max_Error then
- Accuracy_Error_Reported := True;
- Report.Failed (Test_Name &
- " actual: " & Real'Image (Actual) &
- " expected: " & Real'Image (Expected) &
- " difference: " &
- Real'Image (Actual - Expected) &
- " mre:" &
- Real'Image (Max_Error) );
- elsif Verbose then
- if Actual = Expected then
- Report.Comment (Test_Name & " exact result");
- else
- Report.Comment (Test_Name & " passed");
- end if;
- end if;
- end Check;
-
-
- procedure Sin_Check (A, B : Real;
- Arg_Range : String) is
- -- test a selection of
- -- arguments selected from the range A to B.
- --
- -- This test uses the identity
- -- sin(x) = sin(x/3)*(3 - 4 * sin(x/3)**2)
- --
- -- Note that in this test we must take into account the
- -- error in the calculation of the expected result so
- -- the maximum relative error is larger than the
- -- accuracy required by the ARM.
-
- X, Y, ZZ : Real;
- Actual, Expected : Real;
- MRE : Real;
- Ran : Real;
- begin
- Accuracy_Error_Reported := False; -- reset
- for I in 1 .. Number_Samples loop
- -- Evenly distributed selection of arguments
- Ran := Real (I) / Real (Number_Samples);
-
- -- make sure x and x/3 are both exactly representable
- -- on the machine. See "Implementation and Testing of
- -- Function Software" page 44.
- X := (B - A) * Ran + A;
- Y := Real'Leading_Part
- ( X/3.0,
- Real'Machine_Mantissa - Real'Exponent (3.0) );
- X := Y * 3.0;
-
- Actual := Sin (X);
-
- ZZ := Sin(Y);
- Expected := ZZ * (3.0 - 4.0 * ZZ * ZZ);
-
- -- note that since the expected value is computed, we
- -- must take the error in that computation into account.
- -- See Cody pp 139-141.
- MRE := 4.0;
-
- Check (Actual, Expected,
- "sin test of range" & Arg_Range &
- Integer'Image (I),
- MRE);
- exit when Accuracy_Error_Reported;
- end loop;
- exception
- when Constraint_Error =>
- Report.Failed
- ("Constraint_Error raised in sin check");
- when others =>
- Report.Failed ("exception in sin check");
- end Sin_Check;
-
-
-
- procedure Cos_Check (A, B : Real;
- Arg_Range : String) is
- -- test a selection of
- -- arguments selected from the range A to B.
- --
- -- This test uses the identity
- -- cos(x) = cos(x/3)*(4 * cos(x/3)**2 - 3)
- --
- -- Note that in this test we must take into account the
- -- error in the calculation of the expected result so
- -- the maximum relative error is larger than the
- -- accuracy required by the ARM.
-
- X, Y, ZZ : Real;
- Actual, Expected : Real;
- MRE : Real;
- Ran : Real;
- begin
- Accuracy_Error_Reported := False; -- reset
- for I in 1 .. Number_Samples loop
- -- Evenly distributed selection of arguments
- Ran := Real (I) / Real (Number_Samples);
-
- -- make sure x and x/3 are both exactly representable
- -- on the machine. See "Implementation and Testing of
- -- Function Software" page 44.
- X := (B - A) * Ran + A;
- Y := Real'Leading_Part
- ( X/3.0,
- Real'Machine_Mantissa - Real'Exponent (3.0) );
- X := Y * 3.0;
-
- Actual := Cos (X);
-
- ZZ := Cos(Y);
- Expected := ZZ * (4.0 * ZZ * ZZ - 3.0);
-
- -- note that since the expected value is computed, we
- -- must take the error in that computation into account.
- -- See Cody pp 141-143.
- MRE := 6.0;
-
- Check (Actual, Expected,
- "cos test of range" & Arg_Range &
- Integer'Image (I),
- MRE);
- exit when Accuracy_Error_Reported;
- end loop;
- exception
- when Constraint_Error =>
- Report.Failed
- ("Constraint_Error raised in cos check");
- when others =>
- Report.Failed ("exception in cos check");
- end Cos_Check;
-
-
- procedure Special_Angle_Checks is
- type Data_Point is
- record
- Degrees,
- Radians,
- Sine,
- Cosine : Real;
- Sin_Result_Error,
- Cos_Result_Error : Boolean;
- end record;
-
- type Test_Data_Type is array (Positive range <>) of Data_Point;
-
- -- the values in the following table only involve static
- -- expressions to minimize any loss of precision. However,
- -- there are two sources of error that must be accounted for
- -- in the following tests.
- -- First, when a cycle is not specified there can be a roundoff
- -- error in the value of Pi used. This error does not apply
- -- when a cycle of 2.0 * Pi is explicitly provided.
- -- Second, the expected results that involve sqrt values also
- -- have a potential roundoff error.
- -- The amount of error due to error in the argument is computed
- -- as follows:
- -- sin(x+err) = sin(x)*cos(err) + cos(x)*sin(err)
- -- ~= sin(x) + err * cos(x)
- -- similarly for cos the error due to error in the argument is
- -- computed as follows:
- -- cos(x+err) = cos(x)*cos(err) - sin(x)*sin(err)
- -- ~= cos(x) - err * sin(x)
- -- In both cases the term "err" is bounded by 0.5 * argument.
-
- Test_Data : constant Test_Data_Type := (
--- degrees radians sine cosine sin_er cos_er test #
- ( 0.0, 0.0, 0.0, 1.0, False, False ), -- 1
- ( 30.0, Pi/6.0, 0.5, Sqrt3/2.0, False, True ), -- 2
- ( 60.0, Pi/3.0, Sqrt3/2.0, 0.5, True, False ), -- 3
- ( 90.0, Pi/2.0, 1.0, 0.0, False, False ), -- 4
- (120.0, 2.0*Pi/3.0, Sqrt3/2.0, -0.5, True, False ), -- 5
- (150.0, 5.0*Pi/6.0, 0.5, -Sqrt3/2.0, False, True ), -- 6
- (180.0, Pi, 0.0, -1.0, False, False ), -- 7
- (210.0, 7.0*Pi/6.0, -0.5, -Sqrt3/2.0, False, True ), -- 8
- (240.0, 8.0*Pi/6.0, -Sqrt3/2.0, -0.5, True, False ), -- 9
- (270.0, 9.0*Pi/6.0, -1.0, 0.0, False, False ), -- 10
- (300.0, 10.0*Pi/6.0, -Sqrt3/2.0, 0.5, True, False ), -- 11
- (330.0, 11.0*Pi/6.0, -0.5, Sqrt3/2.0, False, True ), -- 12
- (360.0, 2.0*Pi, 0.0, 1.0, False, False ), -- 13
- ( 45.0, Pi/4.0, Sqrt2/2.0, Sqrt2/2.0, True, True ), -- 14
- (135.0, 3.0*Pi/4.0, Sqrt2/2.0, -Sqrt2/2.0, True, True ), -- 15
- (225.0, 5.0*Pi/4.0, -Sqrt2/2.0, -Sqrt2/2.0, True, True ), -- 16
- (315.0, 7.0*Pi/4.0, -Sqrt2/2.0, Sqrt2/2.0, True, True ), -- 17
- (405.0, 9.0*Pi/4.0, Sqrt2/2.0, Sqrt2/2.0, True, True ) ); -- 18
-
-
- Y : Real;
- Sin_Arg_Err,
- Cos_Arg_Err,
- Sin_Result_Err,
- Cos_Result_Err : Real;
- begin
- for I in Test_Data'Range loop
- -- compute error components
- Sin_Arg_Err := abs Test_Data (I).Cosine *
- abs Test_Data (I).Radians / 2.0;
- Cos_Arg_Err := abs Test_Data (I).Sine *
- abs Test_Data (I).Radians / 2.0;
-
- if Test_Data (I).Sin_Result_Error then
- Sin_Result_Err := 0.5;
- else
- Sin_Result_Err := 0.0;
- end if;
-
- if Test_Data (I).Cos_Result_Error then
- Cos_Result_Err := 1.0;
- else
- Cos_Result_Err := 0.0;
- end if;
-
-
-
- Y := Sin (Test_Data (I).Radians);
- Check (Y, Test_Data (I).Sine,
- "test" & Integer'Image (I) & " sin(r)",
- 2.0 + Sin_Arg_Err + Sin_Result_Err);
- Y := Cos (Test_Data (I).Radians);
- Check (Y, Test_Data (I).Cosine,
- "test" & Integer'Image (I) & " cos(r)",
- 2.0 + Cos_Arg_Err + Cos_Result_Err);
- Y := Sin (Test_Data (I).Degrees, 360.0);
- Check (Y, Test_Data (I).Sine,
- "test" & Integer'Image (I) & " sin(d,360)",
- 2.0 + Sin_Result_Err);
- Y := Cos (Test_Data (I).Degrees, 360.0);
- Check (Y, Test_Data (I).Cosine,
- "test" & Integer'Image (I) & " cos(d,360)",
- 2.0 + Cos_Result_Err);
---pwb-math Y := Sin (Test_Data (I).Radians, 2.0*Pi);
---pwb-math Check (Y, Test_Data (I).Sine,
---pwb-math "test" & Integer'Image (I) & " sin(r,2pi)",
---pwb-math 2.0 + Sin_Result_Err);
---pwb-math Y := Cos (Test_Data (I).Radians, 2.0*Pi);
---pwb-math Check (Y, Test_Data (I).Cosine,
---pwb-math "test" & Integer'Image (I) & " cos(r,2pi)",
---pwb-math 2.0 + Cos_Result_Err);
- end loop;
- exception
- when Constraint_Error =>
- Report.Failed ("Constraint_Error raised in special angle test");
- when others =>
- Report.Failed ("exception in special angle test");
- end Special_Angle_Checks;
-
-
- -- check the rule of A.5.1(41);6.0 which requires that the
- -- result be exact if the mathematical result is 0.0, 1.0,
- -- or -1.0
- procedure Exact_Result_Checks is
- type Data_Point is
- record
- Degrees,
- Sine,
- Cosine : Real;
- end record;
-
- type Test_Data_Type is array (Positive range <>) of Data_Point;
- Test_Data : constant Test_Data_Type := (
- -- degrees sine cosine test #
- ( 0.0, 0.0, 1.0 ), -- 1
- ( 90.0, 1.0, 0.0 ), -- 2
- (180.0, 0.0, -1.0 ), -- 3
- (270.0, -1.0, 0.0 ), -- 4
- (360.0, 0.0, 1.0 ), -- 5
- ( 90.0 + 360.0, 1.0, 0.0 ), -- 6
- (180.0 + 360.0, 0.0, -1.0 ), -- 7
- (270.0 + 360.0,-1.0, 0.0 ), -- 8
- (360.0 + 360.0, 0.0, 1.0 ) ); -- 9
-
- Y : Real;
- begin
- for I in Test_Data'Range loop
- Y := Sin (Test_Data(I).Degrees, 360.0);
- if Y /= Test_Data(I).Sine then
- Report.Failed ("exact result for sin(" &
- Real'Image (Test_Data(I).Degrees) &
- ", 360.0) is not" &
- Real'Image (Test_Data(I).Sine) &
- " Difference is " &
- Real'Image (Y - Test_Data(I).Sine) );
- end if;
-
- Y := Cos (Test_Data(I).Degrees, 360.0);
- if Y /= Test_Data(I).Cosine then
- Report.Failed ("exact result for cos(" &
- Real'Image (Test_Data(I).Degrees) &
- ", 360.0) is not" &
- Real'Image (Test_Data(I).Cosine) &
- " Difference is " &
- Real'Image (Y - Test_Data(I).Cosine) );
- end if;
- end loop;
- exception
- when Constraint_Error =>
- Report.Failed ("Constraint_Error raised in exact result check");
- when others =>
- Report.Failed ("exception in exact result check");
- end Exact_Result_Checks;
-
-
- procedure Do_Test is
- begin
- Special_Angle_Checks;
- Sin_Check (0.0, Pi/2.0, "0..pi/2");
- Sin_Check (6.0*Pi, 6.5*Pi, "6pi..6.5pi");
- Cos_Check (7.0*Pi, 7.5*Pi, "7pi..7.5pi");
- Exact_Result_Checks;
- end Do_Test;
- end Generic_Check;
-
- -----------------------------------------------------------------------
- -----------------------------------------------------------------------
-
- package Float_Check is new Generic_Check (Float);
-
- -- check the floating point type with the most digits
- type A_Long_Float is digits System.Max_Digits;
- package A_Long_Float_Check is new Generic_Check (A_Long_Float);
-
- -----------------------------------------------------------------------
- -----------------------------------------------------------------------
-
-
-begin
- Report.Test ("CXG2004",
- "Check the accuracy of the sin and cos functions");
-
- if Verbose then
- Report.Comment ("checking Standard.Float");
- end if;
-
- Float_Check.Do_Test;
-
- if Verbose then
- Report.Comment ("checking a digits" &
- Integer'Image (System.Max_Digits) &
- " floating point type");
- end if;
-
- A_Long_Float_Check.Do_Test;
-
- Report.Result;
-end CXG2004;
diff --git a/gcc/testsuite/ada/acats/tests/cxg/cxg2005.a b/gcc/testsuite/ada/acats/tests/cxg/cxg2005.a
deleted file mode 100644
index 4054b83d88a..00000000000
--- a/gcc/testsuite/ada/acats/tests/cxg/cxg2005.a
+++ /dev/null
@@ -1,204 +0,0 @@
--- CXG2005.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that floating point addition and multiplication
--- have the required accuracy.
---
--- TEST DESCRIPTION:
--- The check for the required precision is essentially a
--- check that a guard digit is used for the operations.
--- This test uses a generic package to check the addition
--- and multiplication results. The
--- generic package is instantiated with the standard FLOAT
--- type and a floating point type for the maximum number
--- of digits of precision.
---
--- APPLICABILITY CRITERIA:
--- This test applies only to implementations supporting the
--- Numerics Annex.
---
---
--- CHANGE HISTORY:
--- 14 FEB 96 SAIC Initial Release for 2.1
--- 16 SEP 99 RLB Repaired to avoid printing thousands of (almost)
--- identical failure messages.
---!
-
--- References:
---
--- Basic Concepts for Computational Software
--- W. J. Cody
--- Problems and Methodologies in Mathematical Software Production
--- editors P. C. Messina and A. Murli
--- Lecture Notes in Computer Science Vol 142
--- Springer Verlag, 1982
---
--- Software Manual for the Elementary Functions
--- William J. Cody and William Waite
--- Prentice-Hall, 1980
---
-
-with System;
-with Report;
-procedure CXG2005 is
- Verbose : constant Boolean := False;
-
- generic
- type Real is digits <>;
- package Guard_Digit_Check is
- procedure Do_Test;
- end Guard_Digit_Check;
-
- package body Guard_Digit_Check is
- -- made global so that the compiler will be more likely
- -- to keep the values in memory instead of in higher
- -- precision registers.
- X, Y, Z : Real;
- OneX : Real;
- Eps, BN : Real;
-
- -- special constants - not declared as constants so that
- -- the "stored" precision will be used instead of a "register"
- -- precision.
- Zero : Real := 0.0;
- One : Real := 1.0;
- Two : Real := 2.0;
-
- Failure_Count : Natural := 0;
-
- procedure Thwart_Optimization is
- -- the purpose of this procedure is to reference the
- -- global variables used by the test so
- -- that the compiler is not likely to keep them in
- -- a higher precision register for their entire lifetime.
- begin
- if Report.Ident_Bool (False) then
- -- never executed
- X := X + 5.0;
- Y := Y + 6.0;
- Z := Z + 1.0;
- Eps := Eps + 2.0;
- BN := BN + 2.0;
- OneX := X + Y;
- One := 12.34; Two := 56.78; Zero := 90.12;
- end if;
- end Thwart_Optimization;
-
-
- procedure Addition_Test is
- begin
- for K in 1..10 loop
- Eps := Real (K) * Real'Model_Epsilon;
- for N in 1.. Real'Machine_EMax - 1 loop
- BN := Real(Real'Machine_Radix) ** N;
- X := (One + Eps) * BN;
- Y := (One - Eps) * BN;
- Z := X - Y; -- true value for Z is 2*Eps*BN
-
- if Z /= Eps*BN + Eps*BN then
- Report.Failed ("addition check failed. K=" &
- Integer'Image (K) &
- " N=" & Integer'Image (N) &
- " difference=" & Real'Image (Z - 2.0*Eps*BN) &
- " Eps*BN=" & Real'Image (Eps*BN) );
- Failure_Count := Failure_Count + 1;
- exit when Failure_Count > K*4; -- Avoid displaying dozens of messages.
- end if;
- end loop;
- end loop;
- exception
- when others =>
- Thwart_Optimization;
- Report.Failed ("unexpected exception in addition test");
- end Addition_Test;
-
-
- procedure Multiplication_Test is
- begin
- X := Real (Real'Machine_Radix) ** (Real'Machine_EMax - 1);
- OneX := One * X;
- Thwart_Optimization;
- if OneX /= X then
- Report.Failed ("multiplication for large values");
- end if;
-
- X := Real (Real'Machine_Radix) ** (Real'Model_EMin + 1);
- OneX := One * X;
- Thwart_Optimization;
- if OneX /= X then
- Report.Failed ("multiplication for small values");
- end if;
-
- -- selection of "random" values between 1/radix and radix
- Y := One / Real (Real'Machine_Radix);
- Z := Real(Real'Machine_Radix) - One/Real(Real'Machine_Radix);
- for I in 0..100 loop
- X := Y + Real (I) / 100.0 * Z;
- OneX := One * X;
- Thwart_Optimization;
- if OneX /= X then
- Report.Failed ("multiplication for case" & Integer'Image (I));
- exit when Failure_Count > 40+8; -- Avoid displaying dozens of messages.
- end if;
- end loop;
- exception
- when others =>
- Thwart_Optimization;
- Report.Failed ("unexpected exception in multiplication test");
- end Multiplication_Test;
-
-
- procedure Do_Test is
- begin
- Addition_Test;
- Multiplication_Test;
- end Do_Test;
- end Guard_Digit_Check;
-
- package Chk_Float is new Guard_Digit_Check (Float);
-
- -- check the floating point type with the most digits
- type A_Long_Float is digits System.Max_Digits;
- package Chk_A_Long_Float is new Guard_Digit_Check (A_Long_Float);
-begin
- Report.Test ("CXG2005",
- "Check the accuracy of floating point" &
- " addition and multiplication");
-
- if Verbose then
- Report.Comment ("checking Standard.Float");
- end if;
- Chk_Float.Do_Test;
-
- if Verbose then
- Report.Comment ("checking a digits" &
- Integer'Image (System.Max_Digits) &
- " floating point type");
- end if;
- Chk_A_Long_Float.Do_Test;
-
- Report.Result;
-end CXG2005;
diff --git a/gcc/testsuite/ada/acats/tests/cxg/cxg2006.a b/gcc/testsuite/ada/acats/tests/cxg/cxg2006.a
deleted file mode 100644
index da15dc3be67..00000000000
--- a/gcc/testsuite/ada/acats/tests/cxg/cxg2006.a
+++ /dev/null
@@ -1,281 +0,0 @@
--- CXG2006.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that the complex Argument function returns
--- results that are within the error bound allowed.
--- Check that Argument_Error is raised if the Cycle parameter
--- is less than or equal to zero.
---
--- TEST DESCRIPTION:
--- This test uses a generic package to compute and check the
--- values of the Argument function.
--- Of special interest is the case where either the real or
--- the imaginary part of the parameter is very large while the
--- other part is very small or 0.
---
--- SPECIAL REQUIREMENTS
--- The Strict Mode for the numerical accuracy must be
--- selected. The method by which this mode is selected
--- is implementation dependent.
---
--- APPLICABILITY CRITERIA:
--- This test applies only to implementations supporting the
--- Numerics Annex.
--- This test only applies to the Strict Mode for numerical
--- accuracy.
---
---
--- CHANGE HISTORY:
--- 15 FEB 96 SAIC Initial release for 2.1
--- 03 MAR 97 PWB.CTA Removed checks involving explicit cycle => 2.0*Pi
---
--- CHANGE NOTE:
--- According to Ken Dritz, author of the Numerics Annex of the RM,
--- one should never specify the cycle 2.0*Pi for the trigonometric
--- functions. In particular, if the machine number for the first
--- argument is not an exact multiple of the machine number for the
--- explicit cycle, then the specified exact results cannot be
--- reasonably expected. The affected checks in this test have been
--- marked as comments, with the additional notation "pwb-math".
--- Phil Brashear
---!
-
---
--- Reference:
--- Problems and Methodologies in Mathematical Software Production;
--- editors: P. C. Messina and A Murli;
--- Lecture Notes in Computer Science
--- Volume 142
--- Springer Verlag 1982
---
-
-with System;
-with Report;
-with ImpDef.Annex_G;
-with Ada.Numerics;
-with Ada.Numerics.Generic_Complex_Types;
-with Ada.Numerics.Complex_Types;
-procedure CXG2006 is
- Verbose : constant Boolean := False;
-
-
- -- CRC Standard Mathematical Tables; 23rd Edition; pg 738
- Sqrt2 : constant :=
- 1.41421_35623_73095_04880_16887_24209_69807_85696_71875_37695;
- Sqrt3 : constant :=
- 1.73205_08075_68877_29352_74463_41505_87236_69428_05253_81039;
-
- Pi : constant := Ada.Numerics.Pi;
-
- generic
- type Real is digits <>;
- package Generic_Check is
- procedure Do_Test;
- end Generic_Check;
-
- package body Generic_Check is
- package Complex_Types is new
- Ada.Numerics.Generic_Complex_Types (Real);
- use Complex_Types;
-
-
- procedure Check (Actual, Expected : Real;
- Test_Name : String;
- MRE : Real) is
- Rel_Error : Real;
- Abs_Error : Real;
- Max_Error : Real;
- begin
- -- In the case where the expected result is very small or 0
- -- we compute the maximum error as a multiple of Model_Epsilon instead
- -- of Model_Epsilon and Expected.
- Rel_Error := MRE * abs Expected * Real'Model_Epsilon;
- Abs_Error := MRE * Real'Model_Epsilon;
- if Rel_Error > Abs_Error then
- Max_Error := Rel_Error;
- else
- Max_Error := Abs_Error;
- end if;
-
- if abs (Actual - Expected) > Max_Error then
- Report.Failed (Test_Name &
- " actual: " & Real'Image (Actual) &
- " expected: " & Real'Image (Expected) &
- " difference: " &
- Real'Image (Actual - Expected) &
- " mre:" & Real'Image (Max_Error) );
- elsif Verbose then
- if Actual = Expected then
- Report.Comment (Test_Name & " exact result");
- else
- Report.Comment (Test_Name & " passed");
- end if;
- end if;
- end Check;
-
-
- procedure Special_Cases is
- type Data_Point is
- record
- Re,
- Im,
- Radians,
- Degrees,
- Error_Bound : Real;
- end record;
-
- type Test_Data_Type is array (Positive range <>) of Data_Point;
-
- -- the values in the following table only involve static
- -- expressions to minimize errors in precision introduced by the
- -- test. For cases where Pi is used in the argument we must
- -- allow an extra 1.0*MRE to account for roundoff error in the
- -- argument. Where the result involves a square root we allow
- -- an extra 0.5*MRE to allow for roundoff error.
- Test_Data : constant Test_Data_Type := (
--- Re Im Radians Degrees Err Test #
- (0.0, 0.0, 0.0, 0.0, 4.0 ), -- 1
- (1.0, 0.0, 0.0, 0.0, 4.0 ), -- 2
- (Real'Safe_Last, 0.0, 0.0, 0.0, 4.0 ), -- 3
- (Real'Model_Small, 0.0, 0.0, 0.0, 4.0 ), -- 4
- (1.0, 1.0, Pi/4.0, 45.0, 5.0 ), -- 5
- (1.0, -1.0, -Pi/4.0, -45.0, 5.0 ), -- 6
- (-1.0, -1.0, -3.0*Pi/4.0,-135.0, 5.0 ), -- 7
- (-1.0, 1.0, 3.0*Pi/4.0, 135.0, 5.0 ), -- 8
- (Sqrt3, 1.0, Pi/6.0, 30.0, 5.5 ), -- 9
- (-Sqrt3, 1.0, 5.0*Pi/6.0, 150.0, 5.5 ), -- 10
- (Sqrt3, -1.0, -Pi/6.0, -30.0, 5.5 ), -- 11
- (-Sqrt3, -1.0, -5.0*Pi/6.0,-150.0, 5.5 ), -- 12
- (Real'Model_Small, Real'Model_Small, Pi/4.0, 45.0, 5.0 ), -- 13
- (-Real'Safe_Last, 0.0, Pi, 180.0, 5.0 ), -- 14
- (-Real'Safe_Last, -Real'Model_Small, -Pi,-180.0, 5.0 ), -- 15
- (100000.0, 100000.0, Pi/4.0, 45.0, 5.0 )); -- 16
-
- X : Real;
- Z : Complex;
- begin
- for I in Test_Data'Range loop
- begin
- Z := (Test_Data(I).Re, Test_Data(I).Im);
- X := Argument (Z);
- Check (X, Test_Data(I).Radians,
- "test" & Integer'Image (I) & " argument(z)",
- Test_Data (I).Error_Bound);
---pwb-math X := Argument (Z, 2.0*Pi);
---pwb-math Check (X, Test_Data(I).Radians,
---pwb-math "test" & Integer'Image (I) & " argument(z, 2pi)",
---pwb-math Test_Data (I).Error_Bound);
- X := Argument (Z, 360.0);
- Check (X, Test_Data(I).Degrees,
- "test" & Integer'Image (I) & " argument(z, 360)",
- Test_Data (I).Error_Bound);
-
- exception
- when Constraint_Error =>
- Report.Failed ("Constraint_Error raised in test" &
- Integer'Image (I));
- when others =>
- Report.Failed ("exception in test" &
- Integer'Image (I));
- end;
- end loop;
-
- if Real'Signed_Zeros then
- begin
- X := Argument ((-1.0, Real(ImpDef.Annex_G.Negative_Zero)));
- Check (X, -Pi, "test of arg((-1,-0)", 4.0);
- exception
- when others =>
- Report.Failed ("exception in signed zero test");
- end;
- end if;
- end Special_Cases;
-
-
- procedure Exception_Cases is
- -- check that Argument_Error is raised if Cycle is <= 0
- Z : Complex := (1.0, 1.0);
- X : Real;
- Y : Real;
- begin
- begin
- X := Argument (Z, Cycle => 0.0);
- Report.Failed ("no exception for cycle = 0.0");
- exception
- when Ada.Numerics.Argument_Error => null;
- when others =>
- Report.Failed ("wrong exception for cycle = 0.0");
- end;
-
- begin
- Y := Argument (Z, Cycle => -3.0);
- Report.Failed ("no exception for cycle < 0.0");
- exception
- when Ada.Numerics.Argument_Error => null;
- when others =>
- Report.Failed ("wrong exception for cycle < 0.0");
- end;
-
- if Report.Ident_Int (2) = 1 then
- -- optimization thwarting code - never executed
- Report.Failed("2=1" & Real'Image (X+Y));
- end if;
- end Exception_Cases;
-
-
- procedure Do_Test is
- begin
- Special_Cases;
- Exception_Cases;
- end Do_Test;
- end Generic_Check;
-
- package Chk_Float is new Generic_Check (Float);
-
- -- check the floating point type with the most digits
- type A_Long_Float is digits System.Max_Digits;
- package Chk_A_Long_Float is new Generic_Check (A_Long_Float);
-begin
- Report.Test ("CXG2006",
- "Check the accuracy of the complex argument" &
- " function");
-
- if Verbose then
- Report.Comment ("checking Standard.Float");
- end if;
-
- Chk_Float.Do_Test;
-
- if Verbose then
- Report.Comment ("checking a digits" &
- Integer'Image (System.Max_Digits) &
- " floating point type");
- end if;
-
- Chk_A_Long_Float.Do_Test;
-
- Report.Result;
-end CXG2006;
diff --git a/gcc/testsuite/ada/acats/tests/cxg/cxg2007.a b/gcc/testsuite/ada/acats/tests/cxg/cxg2007.a
deleted file mode 100644
index ba07df29d52..00000000000
--- a/gcc/testsuite/ada/acats/tests/cxg/cxg2007.a
+++ /dev/null
@@ -1,291 +0,0 @@
--- CXG2007.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that the complex Compose_From_Polar function returns
--- results that are within the error bound allowed.
--- Check that Argument_Error is raised if the Cycle parameter
--- is less than or equal to zero.
---
--- TEST DESCRIPTION:
--- This test uses a generic package to compute and check the
--- values of the Compose_From_Polar function.
---
--- SPECIAL REQUIREMENTS
--- The Strict Mode for the numerical accuracy must be
--- selected. The method by which this mode is selected
--- is implementation dependent.
---
--- APPLICABILITY CRITERIA:
--- This test applies only to implementations supporting the
--- Numerics Annex.
--- This test only applies to the Strict Mode for numerical
--- accuracy.
---
---
--- CHANGE HISTORY:
--- 23 FEB 96 SAIC Initial release for 2.1
--- 23 APR 96 SAIC Fixed error checking
--- 03 MAR 97 PWB.CTA Deleted checks with explicit Cycle => 2.0*Pi
---
--- CHANGE NOTE:
--- According to Ken Dritz, author of the Numerics Annex of the RM,
--- one should never specify the cycle 2.0*Pi for the trigonometric
--- functions. In particular, if the machine number for the first
--- argument is not an exact multiple of the machine number for the
--- explicit cycle, then the specified exact results cannot be
--- reasonably expected. The affected checks in this test have been
--- marked as comments, with the additional notation "pwb-math".
--- Phil Brashear
---!
-
-with System;
-with Report;
-with Ada.Numerics;
-with Ada.Numerics.Generic_Complex_Types;
-procedure CXG2007 is
- Verbose : constant Boolean := False;
-
-
- -- CRC Standard Mathematical Tables; 23rd Edition; pg 738
- Sqrt2 : constant :=
- 1.41421_35623_73095_04880_16887_24209_69807_85696_71875_37695;
- Sqrt3 : constant :=
- 1.73205_08075_68877_29352_74463_41505_87236_69428_05253_81039;
-
- Pi : constant := Ada.Numerics.Pi;
-
- generic
- type Real is digits <>;
- package Generic_Check is
- procedure Do_Test;
- end Generic_Check;
-
- package body Generic_Check is
- package Complex_Types is new
- Ada.Numerics.Generic_Complex_Types (Real);
- use Complex_Types;
-
- Maximum_Relative_Error : constant Real := 3.0;
-
- procedure Check (Actual, Expected : Real;
- Test_Name : String;
- MRE : Real;
- Arg_Error : Real) is
- -- Arg_Error is additional absolute error that is allowed beyond
- -- the MRE to account for error in the result that can be
- -- attributed to error in the arguments.
- Max_Error : Real;
- Rel_Error : Real;
- Abs_Error : Real;
- begin
- -- In the case where the expected result is very small or 0
- -- we compute the maximum error as a multiple of Model_Small instead
- -- of Model_Epsilon and Expected.
- Rel_Error := MRE * abs Expected * Real'Model_Epsilon;
- Abs_Error := MRE * Real'Model_Epsilon;
- if Rel_Error > Abs_Error then
- Max_Error := Rel_Error;
- else
- Max_Error := Abs_Error;
- end if;
- Max_Error := Max_Error + Arg_Error;
-
- if abs (Actual - Expected) > Max_Error then
- Report.Failed (Test_Name &
- " actual: " & Real'Image (Actual) &
- " expected: " & Real'Image (Expected) &
- " difference: " & Real'Image (Actual - Expected) &
- " max err:" & Real'Image (Max_Error) );
- elsif Verbose then
- if Actual = Expected then
- Report.Comment (Test_Name & " exact result");
- else
- Report.Comment (Test_Name & " passed");
- end if;
- end if;
- end Check;
-
-
- procedure Check (Actual, Expected : Complex;
- Test_Name : String;
- MRE : Real;
- Arg_Error : Real) is
- -- Arg_Error is additional absolute error that is allowed beyond
- -- the MRE to account for error in the result that can be
- -- attributed to error in the arguments.
- begin
- Check (Actual.Re, Expected.Re,
- Test_Name & " real part",
- MRE, Arg_Error);
- Check (Actual.Im, Expected.Im,
- Test_Name & " imaginary part",
- MRE, Arg_Error);
- end Check;
-
-
- procedure Special_Cases is
- type Data_Point is
- record
- Re,
- Im,
- Modulus,
- Radians,
- Degrees,
- Arg_Error : Real;
- end record;
-
- -- shorthand names for various constants
- P4 : constant := Pi/4.0;
- P6 : constant := Pi/6.0;
-
- MER2 : constant Real := Real'Model_Epsilon * Sqrt2;
-
- type Test_Data_Type is array (Positive range <>) of Data_Point;
-
- -- the values in the following table only involve static
- -- expressions so no loss of precision occurs.
- Test_Data : constant Test_Data_Type := (
- --Re Im Modulus Radians Degrees Arg_Err
- ( 0.0, 0.0, 0.0, 0.0, 0.0, 0.0 ), -- 1
- ( 0.0, 0.0, 0.0, Pi, 180.0, 0.0 ), -- 2
-
- ( 1.0, 0.0, 1.0, 0.0, 0.0, 0.0 ), -- 3
- (-1.0, 0.0, -1.0, 0.0, 0.0, 0.0 ), -- 4
-
- ( 1.0, 1.0, Sqrt2, P4, 45.0, MER2), -- 5
- (-1.0, 1.0, -Sqrt2, -P4, -45.0, MER2), -- 6
- ( 1.0, -1.0, Sqrt2, -P4, -45.0, MER2), -- 7
- (-1.0, -1.0, -Sqrt2, P4, 45.0, MER2), -- 8
- (-1.0, -1.0, Sqrt2, -3.0*P4,-135.0, MER2), -- 9
- (-1.0, 1.0, Sqrt2, 3.0*P4, 135.0, MER2), -- 10
- ( 1.0, -1.0, -Sqrt2, 3.0*P4, 135.0, MER2), -- 11
-
- (-1.0, 0.0, 1.0, Pi, 180.0, 0.0 ), -- 12
- ( 1.0, 0.0, -1.0, Pi, 180.0, 0.0 ) ); -- 13
-
-
- Z : Complex;
- Exp : Complex;
- begin
- for I in Test_Data'Range loop
- begin
- Exp := (Test_Data (I).Re, Test_Data (I).Im);
-
- Z := Compose_From_Polar (Test_Data (I).Modulus,
- Test_Data (I).Radians);
- Check (Z, Exp,
- "test" & Integer'Image (I) & " compose_from_polar(m,r)",
- Maximum_Relative_Error, Test_Data (I).Arg_Error);
-
---pwb-math Z := Compose_From_Polar (Test_Data (I).Modulus,
---pwb-math Test_Data (I).Radians,
---pwb-math 2.0*Pi);
---pwb-math Check (Z, Exp,
---pwb-math "test" & Integer'Image (I) & " compose_from_polar(m,r,2pi)",
---pwb-math Maximum_Relative_Error, Test_Data (I).Arg_Error);
-
- Z := Compose_From_Polar (Test_Data (I).Modulus,
- Test_Data (I).Degrees,
- 360.0);
- Check (Z, Exp,
- "test" & Integer'Image (I) & " compose_from_polar(m,d,360)",
- Maximum_Relative_Error, Test_Data (I).Arg_Error);
-
- exception
- when Constraint_Error =>
- Report.Failed ("Constraint_Error raised in test" &
- Integer'Image (I));
- when others =>
- Report.Failed ("exception in test" &
- Integer'Image (I));
- end;
- end loop;
- end Special_Cases;
-
-
- procedure Exception_Cases is
- -- check that Argument_Error is raised if Cycle is <= 0
- Z : Complex;
- W : Complex;
- begin
- begin
- Z := Compose_From_Polar (3.0, 0.0, Cycle => 0.0);
- Report.Failed ("no exception for cycle = 0.0");
- exception
- when Ada.Numerics.Argument_Error => null;
- when others =>
- Report.Failed ("wrong exception for cycle = 0.0");
- end;
-
- begin
- W := Compose_From_Polar (6.0, 1.0, Cycle => -10.0);
- Report.Failed ("no exception for cycle < 0.0");
- exception
- when Ada.Numerics.Argument_Error => null;
- when others =>
- Report.Failed ("wrong exception for cycle < 0.0");
- end;
-
- if Report.Ident_Int (1) = 2 then
- -- not executed - used to make it appear that we use the
- -- results of the above computation
- Z := Z * W;
- Report.Failed(Real'Image (Z.Re + Z.Im));
- end if;
- end Exception_Cases;
-
-
- procedure Do_Test is
- begin
- Special_Cases;
- Exception_Cases;
- end Do_Test;
- end Generic_Check;
-
- package Chk_Float is new Generic_Check (Float);
-
- -- check the floating point type with the most digits
- type A_Long_Float is digits System.Max_Digits;
- package Chk_A_Long_Float is new Generic_Check (A_Long_Float);
-begin
- Report.Test ("CXG2007",
- "Check the accuracy of the Compose_From_Polar" &
- " function");
-
- if Verbose then
- Report.Comment ("checking Standard.Float");
- end if;
- Chk_Float.Do_Test;
-
- if Verbose then
- Report.Comment ("checking a digits" &
- Integer'Image (System.Max_Digits) &
- " floating point type");
- end if;
- Chk_A_Long_Float.Do_Test;
-
- Report.Result;
-end CXG2007;
diff --git a/gcc/testsuite/ada/acats/tests/cxg/cxg2008.a b/gcc/testsuite/ada/acats/tests/cxg/cxg2008.a
deleted file mode 100644
index 58cf367f61c..00000000000
--- a/gcc/testsuite/ada/acats/tests/cxg/cxg2008.a
+++ /dev/null
@@ -1,948 +0,0 @@
--- CXG2008.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that the complex multiplication and division
--- operations return results that are within the allowed
--- error bound.
--- Check that all the required pure Numerics packages are pure.
---
--- TEST DESCRIPTION:
--- This test contains three test packages that are almost
--- identical. The first two packages differ only in the
--- floating point type that is being tested. The first
--- and third package differ only in whether the generic
--- complex types package or the pre-instantiated
--- package is used.
--- The test package is not generic so that the arguments
--- and expected results for some of the test values
--- can be expressed as universal real instead of being
--- computed at runtime.
---
--- SPECIAL REQUIREMENTS
--- The Strict Mode for the numerical accuracy must be
--- selected. The method by which this mode is selected
--- is implementation dependent.
---
--- APPLICABILITY CRITERIA:
--- This test applies only to implementations supporting the
--- Numerics Annex.
--- This test only applies to the Strict Mode for numerical
--- accuracy.
---
---
--- CHANGE HISTORY:
--- 24 FEB 96 SAIC Initial release for 2.1
--- 03 JUN 98 EDS Correct the test program's incorrect assumption
--- that Constraint_Error must be raised by complex
--- division by zero, which is contrary to the
--- allowance given by the Ada 95 standard G.1.1(40).
--- 13 MAR 01 RLB Replaced commented out Pure check on non-generic
--- packages, as required by Defect Report
--- 8652/0020 and as reflected in Technical
--- Corrigendum 1.
---!
-
-------------------------------------------------------------------------------
--- Check that the required pure packages are pure by withing them from a
--- pure package. The non-generic versions of those packages are required to
--- be pure by Defect Report 8652/0020, Technical Corrigendum 1 [A.5.1(9/1) and
--- G.1.1(25/1)].
-with Ada.Numerics.Generic_Elementary_Functions;
-with Ada.Numerics.Elementary_Functions;
-with Ada.Numerics.Generic_Complex_Types;
-with Ada.Numerics.Complex_Types;
-with Ada.Numerics.Generic_Complex_Elementary_Functions;
-with Ada.Numerics.Complex_Elementary_Functions;
-package CXG2008_0 is
- pragma Pure;
- -- CRC Standard Mathematical Tables; 23rd Edition; pg 738
- Sqrt2 : constant :=
- 1.41421_35623_73095_04880_16887_24209_69807_85696_71875_37695;
- Sqrt3 : constant :=
- 1.73205_08075_68877_29352_74463_41505_87236_69428_05253_81039;
-end CXG2008_0;
-
-------------------------------------------------------------------------------
-
-with System;
-with Report;
-with Ada.Numerics.Generic_Complex_Types;
-with Ada.Numerics.Complex_Types;
-with CXG2008_0; use CXG2008_0;
-procedure CXG2008 is
- Verbose : constant Boolean := False;
-
- package Float_Check is
- subtype Real is Float;
- procedure Do_Test;
- end Float_Check;
-
- package body Float_Check is
- package Complex_Types is new
- Ada.Numerics.Generic_Complex_Types (Real);
- use Complex_Types;
-
- -- keep track if an accuracy failure has occurred so the test
- -- can be short-circuited to avoid thousands of error messages.
- Failure_Detected : Boolean := False;
-
- Mult_MBE : constant Real := 5.0;
- Divide_MBE : constant Real := 13.0;
-
-
- procedure Check (Actual, Expected : Complex;
- Test_Name : String;
- MBE : Real) is
- Rel_Error : Real;
- Abs_Error : Real;
- Max_Error : Real;
- begin
- -- In the case where the expected result is very small or 0
- -- we compute the maximum error as a multiple of Model_Epsilon instead
- -- of Model_Epsilon and Expected.
- Rel_Error := MBE * abs Expected.Re * Real'Model_Epsilon;
- Abs_Error := MBE * Real'Model_Epsilon;
- if Rel_Error > Abs_Error then
- Max_Error := Rel_Error;
- else
- Max_Error := Abs_Error;
- end if;
-
- if abs (Actual.Re - Expected.Re) > Max_Error then
- Failure_Detected := True;
- Report.Failed (Test_Name &
- " actual.re: " & Real'Image (Actual.Re) &
- " expected.re: " & Real'Image (Expected.Re) &
- " difference.re " &
- Real'Image (Actual.Re - Expected.Re) &
- " mre:" & Real'Image (Max_Error) );
- elsif Verbose then
- if Actual = Expected then
- Report.Comment (Test_Name & " exact result for real part");
- else
- Report.Comment (Test_Name & " passed for real part");
- end if;
- end if;
-
- Rel_Error := MBE * abs Expected.Im * Real'Model_Epsilon;
- if Rel_Error > Abs_Error then
- Max_Error := Rel_Error;
- else
- Max_Error := Abs_Error;
- end if;
- if abs (Actual.Im - Expected.Im) > Max_Error then
- Failure_Detected := True;
- Report.Failed (Test_Name &
- " actual.im: " & Real'Image (Actual.Im) &
- " expected.im: " & Real'Image (Expected.Im) &
- " difference.im " &
- Real'Image (Actual.Im - Expected.Im) &
- " mre:" & Real'Image (Max_Error) );
- elsif Verbose then
- if Actual = Expected then
- Report.Comment (Test_Name & " exact result for imaginary part");
- else
- Report.Comment (Test_Name & " passed for imaginary part");
- end if;
- end if;
- end Check;
-
-
- procedure Special_Values is
- begin
-
- --- test 1 ---
- declare
- T : constant := (Real'Machine_EMax - 1) / 2;
- Big : constant := (1.0 * Real'Machine_Radix) ** (2 * T);
- Expected : Complex := (0.0, 0.0);
- X : Complex := (0.0, 0.0);
- Y : Complex := (Big, Big);
- Z : Complex;
- begin
- Z := X * Y;
- Check (Z, Expected, "test 1a -- (0+0i) * (big+big*i)",
- Mult_MBE);
- Z := Y * X;
- Check (Z, Expected, "test 1b -- (big+big*i) * (0+0i)",
- Mult_MBE);
- exception
- when Constraint_Error =>
- Report.Failed ("Constraint_Error raised in test 1");
- when others =>
- Report.Failed ("exception in test 1");
- end;
-
- --- test 2 ---
- declare
- T : constant := Real'Model_EMin + 1;
- Tiny : constant := (1.0 * Real'Machine_Radix) ** T;
- U : Complex := (Tiny, Tiny);
- X : Complex := (0.0, 0.0);
- Expected : Complex := (0.0, 0.0);
- Z : Complex;
- begin
- Z := U * X;
- Check (Z, Expected, "test 2 -- (tiny,tiny) * (0,0)",
- Mult_MBE);
- exception
- when Constraint_Error =>
- Report.Failed ("Constraint_Error raised in test 2");
- when others =>
- Report.Failed ("exception in test 2");
- end;
-
- --- test 3 ---
- declare
- T : constant := (Real'Machine_EMax - 1) / 2;
- Big : constant := (1.0 * Real'Machine_Radix) ** (2 * T);
- B : Complex := (Big, Big);
- X : Complex := (0.0, 0.0);
- Z : Complex;
- begin
- if Real'Machine_Overflows then
- Z := B / X;
- Report.Failed ("test 3 - Constraint_Error not raised");
- Check (Z, Z, "not executed - optimizer thwarting", 0.0);
- end if;
- exception
- when Constraint_Error => null; -- expected
- when others =>
- Report.Failed ("exception in test 3");
- end;
-
- --- test 4 ---
- declare
- T : constant := Real'Model_EMin + 1;
- Tiny : constant := (1.0 * Real'Machine_Radix) ** T;
- U : Complex := (Tiny, Tiny);
- X : Complex := (0.0, 0.0);
- Z : Complex;
- begin
- if Real'Machine_Overflows then
- Z := U / X;
- Report.Failed ("test 4 - Constraint_Error not raised");
- Check (Z, Z, "not executed - optimizer thwarting", 0.0);
- end if;
- exception
- when Constraint_Error => null; -- expected
- when others =>
- Report.Failed ("exception in test 4");
- end;
-
-
- --- test 5 ---
- declare
- X : Complex := (Sqrt2, Sqrt2);
- Z : Complex;
- Expected : constant Complex := (0.0, 4.0);
- begin
- Z := X * X;
- Check (Z, Expected, "test 5 -- (sqrt2,sqrt2) * (sqrt2,sqrt2)",
- Mult_MBE);
- exception
- when Constraint_Error =>
- Report.Failed ("Constraint_Error raised in test 5");
- when others =>
- Report.Failed ("exception in test 5");
- end;
-
- --- test 6 ---
- declare
- X : Complex := Sqrt3 - Sqrt3 * i;
- Z : Complex;
- Expected : constant Complex := (0.0, -6.0);
- begin
- Z := X * X;
- Check (Z, Expected, "test 6 -- (sqrt3,-sqrt3) * (sqrt3,-sqrt3)",
- Mult_MBE);
- exception
- when Constraint_Error =>
- Report.Failed ("Constraint_Error raised in test 6");
- when others =>
- Report.Failed ("exception in test 6");
- end;
-
- --- test 7 ---
- declare
- X : Complex := Sqrt2 + Sqrt2 * i;
- Y : Complex := Sqrt2 - Sqrt2 * i;
- Z : Complex;
- Expected : constant Complex := 0.0 + i;
- begin
- Z := X / Y;
- Check (Z, Expected, "test 7 -- (sqrt2,sqrt2) / (sqrt2,-sqrt2)",
- Divide_MBE);
- exception
- when Constraint_Error =>
- Report.Failed ("Constraint_Error raised in test 7");
- when others =>
- Report.Failed ("exception in test 7");
- end;
- end Special_Values;
-
-
- procedure Do_Mult_Div (X, Y : Complex) is
- Z : Complex;
- Args : constant String :=
- "X=(" & Real'Image (X.Re) & "," & Real'Image (X.Im) & ") " &
- "Y=(" & Real'Image (Y.Re) & "," & Real'Image (Y.Im) & ") " ;
- begin
- Z := (X * X) / X;
- Check (Z, X, "X*X/X " & Args, Mult_MBE + Divide_MBE);
- Z := (X * Y) / X;
- Check (Z, Y, "X*Y/X " & Args, Mult_MBE + Divide_MBE);
- Z := (X * Y) / Y;
- Check (Z, X, "X*Y/Y " & Args, Mult_MBE + Divide_MBE);
- exception
- when Constraint_Error =>
- Report.Failed ("Constraint_Error in Do_Mult_Div for " & Args);
- when others =>
- Report.Failed ("exception in Do_Mult_Div for " & Args);
- end Do_Mult_Div;
-
- -- select complex values X and Y where the real and imaginary
- -- parts are selected from the ranges (1/radix..1) and
- -- (1..radix). This translates into quite a few combinations.
- procedure Mult_Div_Check is
- Samples : constant := 17;
- Radix : constant Real := Real(Real'Machine_Radix);
- Inv_Radix : constant Real := 1.0 / Real(Real'Machine_Radix);
- Low_Sample : Real; -- (1/radix .. 1)
- High_Sample : Real; -- (1 .. radix)
- Sample : array (1..2) of Real;
- X, Y : Complex;
- begin
- for I in 1 .. Samples loop
- Low_Sample := (1.0 - Inv_Radix) / Real (Samples) * Real (I) +
- Inv_Radix;
- Sample (1) := Low_Sample;
- for J in 1 .. Samples loop
- High_Sample := (Radix - 1.0) / Real (Samples) * Real (I) +
- Radix;
- Sample (2) := High_Sample;
- for K in 1 .. 2 loop
- for L in 1 .. 2 loop
- X := Complex'(Sample (K), Sample (L));
- Y := Complex'(Sample (L), Sample (K));
- Do_Mult_Div (X, Y);
- if Failure_Detected then
- return; -- minimize flood of error messages
- end if;
- end loop;
- end loop;
- end loop; -- J
- end loop; -- I
- end Mult_Div_Check;
-
-
- procedure Do_Test is
- begin
- Special_Values;
- Mult_Div_Check;
- end Do_Test;
- end Float_Check;
-
- -----------------------------------------------------------------------
- -----------------------------------------------------------------------
- -- check the floating point type with the most digits
-
- package A_Long_Float_Check is
- type A_Long_Float is digits System.Max_Digits;
- subtype Real is A_Long_Float;
- procedure Do_Test;
- end A_Long_Float_Check;
-
- package body A_Long_Float_Check is
-
- package Complex_Types is new
- Ada.Numerics.Generic_Complex_Types (Real);
- use Complex_Types;
-
- -- keep track if an accuracy failure has occurred so the test
- -- can be short-circuited to avoid thousands of error messages.
- Failure_Detected : Boolean := False;
-
- Mult_MBE : constant Real := 5.0;
- Divide_MBE : constant Real := 13.0;
-
-
- procedure Check (Actual, Expected : Complex;
- Test_Name : String;
- MBE : Real) is
- Rel_Error : Real;
- Abs_Error : Real;
- Max_Error : Real;
- begin
- -- In the case where the expected result is very small or 0
- -- we compute the maximum error as a multiple of Model_Epsilon instead
- -- of Model_Epsilon and Expected.
- Rel_Error := MBE * abs Expected.Re * Real'Model_Epsilon;
- Abs_Error := MBE * Real'Model_Epsilon;
- if Rel_Error > Abs_Error then
- Max_Error := Rel_Error;
- else
- Max_Error := Abs_Error;
- end if;
-
- if abs (Actual.Re - Expected.Re) > Max_Error then
- Failure_Detected := True;
- Report.Failed (Test_Name &
- " actual.re: " & Real'Image (Actual.Re) &
- " expected.re: " & Real'Image (Expected.Re) &
- " difference.re " &
- Real'Image (Actual.Re - Expected.Re) &
- " mre:" & Real'Image (Max_Error) );
- elsif Verbose then
- if Actual = Expected then
- Report.Comment (Test_Name & " exact result for real part");
- else
- Report.Comment (Test_Name & " passed for real part");
- end if;
- end if;
-
- Rel_Error := MBE * abs Expected.Im * Real'Model_Epsilon;
- if Rel_Error > Abs_Error then
- Max_Error := Rel_Error;
- else
- Max_Error := Abs_Error;
- end if;
- if abs (Actual.Im - Expected.Im) > Max_Error then
- Failure_Detected := True;
- Report.Failed (Test_Name &
- " actual.im: " & Real'Image (Actual.Im) &
- " expected.im: " & Real'Image (Expected.Im) &
- " difference.im " &
- Real'Image (Actual.Im - Expected.Im) &
- " mre:" & Real'Image (Max_Error) );
- elsif Verbose then
- if Actual = Expected then
- Report.Comment (Test_Name & " exact result for imaginary part");
- else
- Report.Comment (Test_Name & " passed for imaginary part");
- end if;
- end if;
- end Check;
-
-
- procedure Special_Values is
- begin
-
- --- test 1 ---
- declare
- T : constant := (Real'Machine_EMax - 1) / 2;
- Big : constant := (1.0 * Real'Machine_Radix) ** (2 * T);
- Expected : Complex := (0.0, 0.0);
- X : Complex := (0.0, 0.0);
- Y : Complex := (Big, Big);
- Z : Complex;
- begin
- Z := X * Y;
- Check (Z, Expected, "test 1a -- (0+0i) * (big+big*i)",
- Mult_MBE);
- Z := Y * X;
- Check (Z, Expected, "test 1b -- (big+big*i) * (0+0i)",
- Mult_MBE);
- exception
- when Constraint_Error =>
- Report.Failed ("Constraint_Error raised in test 1");
- when others =>
- Report.Failed ("exception in test 1");
- end;
-
- --- test 2 ---
- declare
- T : constant := Real'Model_EMin + 1;
- Tiny : constant := (1.0 * Real'Machine_Radix) ** T;
- U : Complex := (Tiny, Tiny);
- X : Complex := (0.0, 0.0);
- Expected : Complex := (0.0, 0.0);
- Z : Complex;
- begin
- Z := U * X;
- Check (Z, Expected, "test 2 -- (tiny,tiny) * (0,0)",
- Mult_MBE);
- exception
- when Constraint_Error =>
- Report.Failed ("Constraint_Error raised in test 2");
- when others =>
- Report.Failed ("exception in test 2");
- end;
-
- --- test 3 ---
- declare
- T : constant := (Real'Machine_EMax - 1) / 2;
- Big : constant := (1.0 * Real'Machine_Radix) ** (2 * T);
- B : Complex := (Big, Big);
- X : Complex := (0.0, 0.0);
- Z : Complex;
- begin
- if Real'Machine_Overflows then
- Z := B / X;
- Report.Failed ("test 3 - Constraint_Error not raised");
- Check (Z, Z, "not executed - optimizer thwarting", 0.0);
- end if;
- exception
- when Constraint_Error => null; -- expected
- when others =>
- Report.Failed ("exception in test 3");
- end;
-
- --- test 4 ---
- declare
- T : constant := Real'Model_EMin + 1;
- Tiny : constant := (1.0 * Real'Machine_Radix) ** T;
- U : Complex := (Tiny, Tiny);
- X : Complex := (0.0, 0.0);
- Z : Complex;
- begin
- if Real'Machine_Overflows then
- Z := U / X;
- Report.Failed ("test 4 - Constraint_Error not raised");
- Check (Z, Z, "not executed - optimizer thwarting", 0.0);
- end if;
- exception
- when Constraint_Error => null; -- expected
- when others =>
- Report.Failed ("exception in test 4");
- end;
-
-
- --- test 5 ---
- declare
- X : Complex := (Sqrt2, Sqrt2);
- Z : Complex;
- Expected : constant Complex := (0.0, 4.0);
- begin
- Z := X * X;
- Check (Z, Expected, "test 5 -- (sqrt2,sqrt2) * (sqrt2,sqrt2)",
- Mult_MBE);
- exception
- when Constraint_Error =>
- Report.Failed ("Constraint_Error raised in test 5");
- when others =>
- Report.Failed ("exception in test 5");
- end;
-
- --- test 6 ---
- declare
- X : Complex := Sqrt3 - Sqrt3 * i;
- Z : Complex;
- Expected : constant Complex := (0.0, -6.0);
- begin
- Z := X * X;
- Check (Z, Expected, "test 6 -- (sqrt3,-sqrt3) * (sqrt3,-sqrt3)",
- Mult_MBE);
- exception
- when Constraint_Error =>
- Report.Failed ("Constraint_Error raised in test 6");
- when others =>
- Report.Failed ("exception in test 6");
- end;
-
- --- test 7 ---
- declare
- X : Complex := Sqrt2 + Sqrt2 * i;
- Y : Complex := Sqrt2 - Sqrt2 * i;
- Z : Complex;
- Expected : constant Complex := 0.0 + i;
- begin
- Z := X / Y;
- Check (Z, Expected, "test 7 -- (sqrt2,sqrt2) / (sqrt2,-sqrt2)",
- Divide_MBE);
- exception
- when Constraint_Error =>
- Report.Failed ("Constraint_Error raised in test 7");
- when others =>
- Report.Failed ("exception in test 7");
- end;
- end Special_Values;
-
-
- procedure Do_Mult_Div (X, Y : Complex) is
- Z : Complex;
- Args : constant String :=
- "X=(" & Real'Image (X.Re) & "," & Real'Image (X.Im) & ") " &
- "Y=(" & Real'Image (Y.Re) & "," & Real'Image (Y.Im) & ") " ;
- begin
- Z := (X * X) / X;
- Check (Z, X, "X*X/X " & Args, Mult_MBE + Divide_MBE);
- Z := (X * Y) / X;
- Check (Z, Y, "X*Y/X " & Args, Mult_MBE + Divide_MBE);
- Z := (X * Y) / Y;
- Check (Z, X, "X*Y/Y " & Args, Mult_MBE + Divide_MBE);
- exception
- when Constraint_Error =>
- Report.Failed ("Constraint_Error in Do_Mult_Div for " & Args);
- when others =>
- Report.Failed ("exception in Do_Mult_Div for " & Args);
- end Do_Mult_Div;
-
- -- select complex values X and Y where the real and imaginary
- -- parts are selected from the ranges (1/radix..1) and
- -- (1..radix). This translates into quite a few combinations.
- procedure Mult_Div_Check is
- Samples : constant := 17;
- Radix : constant Real := Real(Real'Machine_Radix);
- Inv_Radix : constant Real := 1.0 / Real(Real'Machine_Radix);
- Low_Sample : Real; -- (1/radix .. 1)
- High_Sample : Real; -- (1 .. radix)
- Sample : array (1..2) of Real;
- X, Y : Complex;
- begin
- for I in 1 .. Samples loop
- Low_Sample := (1.0 - Inv_Radix) / Real (Samples) * Real (I) +
- Inv_Radix;
- Sample (1) := Low_Sample;
- for J in 1 .. Samples loop
- High_Sample := (Radix - 1.0) / Real (Samples) * Real (I) +
- Radix;
- Sample (2) := High_Sample;
- for K in 1 .. 2 loop
- for L in 1 .. 2 loop
- X := Complex'(Sample (K), Sample (L));
- Y := Complex'(Sample (L), Sample (K));
- Do_Mult_Div (X, Y);
- if Failure_Detected then
- return; -- minimize flood of error messages
- end if;
- end loop;
- end loop;
- end loop; -- J
- end loop; -- I
- end Mult_Div_Check;
-
-
- procedure Do_Test is
- begin
- Special_Values;
- Mult_Div_Check;
- end Do_Test;
- end A_Long_Float_Check;
-
- -----------------------------------------------------------------------
- -----------------------------------------------------------------------
-
- package Non_Generic_Check is
- subtype Real is Float;
- procedure Do_Test;
- end Non_Generic_Check;
-
- package body Non_Generic_Check is
-
- use Ada.Numerics.Complex_Types;
-
- -- keep track if an accuracy failure has occurred so the test
- -- can be short-circuited to avoid thousands of error messages.
- Failure_Detected : Boolean := False;
-
- Mult_MBE : constant Real := 5.0;
- Divide_MBE : constant Real := 13.0;
-
-
- procedure Check (Actual, Expected : Complex;
- Test_Name : String;
- MBE : Real) is
- Rel_Error : Real;
- Abs_Error : Real;
- Max_Error : Real;
- begin
- -- In the case where the expected result is very small or 0
- -- we compute the maximum error as a multiple of Model_Epsilon instead
- -- of Model_Epsilon and Expected.
- Rel_Error := MBE * abs Expected.Re * Real'Model_Epsilon;
- Abs_Error := MBE * Real'Model_Epsilon;
- if Rel_Error > Abs_Error then
- Max_Error := Rel_Error;
- else
- Max_Error := Abs_Error;
- end if;
-
- if abs (Actual.Re - Expected.Re) > Max_Error then
- Failure_Detected := True;
- Report.Failed (Test_Name &
- " actual.re: " & Real'Image (Actual.Re) &
- " expected.re: " & Real'Image (Expected.Re) &
- " difference.re " &
- Real'Image (Actual.Re - Expected.Re) &
- " mre:" & Real'Image (Max_Error) );
- elsif Verbose then
- if Actual = Expected then
- Report.Comment (Test_Name & " exact result for real part");
- else
- Report.Comment (Test_Name & " passed for real part");
- end if;
- end if;
-
- Rel_Error := MBE * abs Expected.Im * Real'Model_Epsilon;
- if Rel_Error > Abs_Error then
- Max_Error := Rel_Error;
- else
- Max_Error := Abs_Error;
- end if;
- if abs (Actual.Im - Expected.Im) > Max_Error then
- Failure_Detected := True;
- Report.Failed (Test_Name &
- " actual.im: " & Real'Image (Actual.Im) &
- " expected.im: " & Real'Image (Expected.Im) &
- " difference.im " &
- Real'Image (Actual.Im - Expected.Im) &
- " mre:" & Real'Image (Max_Error) );
- elsif Verbose then
- if Actual = Expected then
- Report.Comment (Test_Name & " exact result for imaginary part");
- else
- Report.Comment (Test_Name & " passed for imaginary part");
- end if;
- end if;
- end Check;
-
-
- procedure Special_Values is
- begin
-
- --- test 1 ---
- declare
- T : constant := (Real'Machine_EMax - 1) / 2;
- Big : constant := (1.0 * Real'Machine_Radix) ** (2 * T);
- Expected : Complex := (0.0, 0.0);
- X : Complex := (0.0, 0.0);
- Y : Complex := (Big, Big);
- Z : Complex;
- begin
- Z := X * Y;
- Check (Z, Expected, "test 1a -- (0+0i) * (big+big*i)",
- Mult_MBE);
- Z := Y * X;
- Check (Z, Expected, "test 1b -- (big+big*i) * (0+0i)",
- Mult_MBE);
- exception
- when Constraint_Error =>
- Report.Failed ("Constraint_Error raised in test 1");
- when others =>
- Report.Failed ("exception in test 1");
- end;
-
- --- test 2 ---
- declare
- T : constant := Real'Model_EMin + 1;
- Tiny : constant := (1.0 * Real'Machine_Radix) ** T;
- U : Complex := (Tiny, Tiny);
- X : Complex := (0.0, 0.0);
- Expected : Complex := (0.0, 0.0);
- Z : Complex;
- begin
- Z := U * X;
- Check (Z, Expected, "test 2 -- (tiny,tiny) * (0,0)",
- Mult_MBE);
- exception
- when Constraint_Error =>
- Report.Failed ("Constraint_Error raised in test 2");
- when others =>
- Report.Failed ("exception in test 2");
- end;
-
- --- test 3 ---
- declare
- T : constant := (Real'Machine_EMax - 1) / 2;
- Big : constant := (1.0 * Real'Machine_Radix) ** (2 * T);
- B : Complex := (Big, Big);
- X : Complex := (0.0, 0.0);
- Z : Complex;
- begin
- if Real'Machine_Overflows then
- Z := B / X;
- Report.Failed ("test 3 - Constraint_Error not raised");
- Check (Z, Z, "not executed - optimizer thwarting", 0.0);
- end if;
- exception
- when Constraint_Error => null; -- expected
- when others =>
- Report.Failed ("exception in test 3");
- end;
-
- --- test 4 ---
- declare
- T : constant := Real'Model_EMin + 1;
- Tiny : constant := (1.0 * Real'Machine_Radix) ** T;
- U : Complex := (Tiny, Tiny);
- X : Complex := (0.0, 0.0);
- Z : Complex;
- begin
- if Real'Machine_Overflows then
- Z := U / X;
- Report.Failed ("test 4 - Constraint_Error not raised");
- Check (Z, Z, "not executed - optimizer thwarting", 0.0);
- end if;
- exception
- when Constraint_Error => null; -- expected
- when others =>
- Report.Failed ("exception in test 4");
- end;
-
-
- --- test 5 ---
- declare
- X : Complex := (Sqrt2, Sqrt2);
- Z : Complex;
- Expected : constant Complex := (0.0, 4.0);
- begin
- Z := X * X;
- Check (Z, Expected, "test 5 -- (sqrt2,sqrt2) * (sqrt2,sqrt2)",
- Mult_MBE);
- exception
- when Constraint_Error =>
- Report.Failed ("Constraint_Error raised in test 5");
- when others =>
- Report.Failed ("exception in test 5");
- end;
-
- --- test 6 ---
- declare
- X : Complex := Sqrt3 - Sqrt3 * i;
- Z : Complex;
- Expected : constant Complex := (0.0, -6.0);
- begin
- Z := X * X;
- Check (Z, Expected, "test 6 -- (sqrt3,-sqrt3) * (sqrt3,-sqrt3)",
- Mult_MBE);
- exception
- when Constraint_Error =>
- Report.Failed ("Constraint_Error raised in test 6");
- when others =>
- Report.Failed ("exception in test 6");
- end;
-
- --- test 7 ---
- declare
- X : Complex := Sqrt2 + Sqrt2 * i;
- Y : Complex := Sqrt2 - Sqrt2 * i;
- Z : Complex;
- Expected : constant Complex := 0.0 + i;
- begin
- Z := X / Y;
- Check (Z, Expected, "test 7 -- (sqrt2,sqrt2) / (sqrt2,-sqrt2)",
- Divide_MBE);
- exception
- when Constraint_Error =>
- Report.Failed ("Constraint_Error raised in test 7");
- when others =>
- Report.Failed ("exception in test 7");
- end;
- end Special_Values;
-
-
- procedure Do_Mult_Div (X, Y : Complex) is
- Z : Complex;
- Args : constant String :=
- "X=(" & Real'Image (X.Re) & "," & Real'Image (X.Im) & ") " &
- "Y=(" & Real'Image (Y.Re) & "," & Real'Image (Y.Im) & ") " ;
- begin
- Z := (X * X) / X;
- Check (Z, X, "X*X/X " & Args, Mult_MBE + Divide_MBE);
- Z := (X * Y) / X;
- Check (Z, Y, "X*Y/X " & Args, Mult_MBE + Divide_MBE);
- Z := (X * Y) / Y;
- Check (Z, X, "X*Y/Y " & Args, Mult_MBE + Divide_MBE);
- exception
- when Constraint_Error =>
- Report.Failed ("Constraint_Error in Do_Mult_Div for " & Args);
- when others =>
- Report.Failed ("exception in Do_Mult_Div for " & Args);
- end Do_Mult_Div;
-
- -- select complex values X and Y where the real and imaginary
- -- parts are selected from the ranges (1/radix..1) and
- -- (1..radix). This translates into quite a few combinations.
- procedure Mult_Div_Check is
- Samples : constant := 17;
- Radix : constant Real := Real(Real'Machine_Radix);
- Inv_Radix : constant Real := 1.0 / Real(Real'Machine_Radix);
- Low_Sample : Real; -- (1/radix .. 1)
- High_Sample : Real; -- (1 .. radix)
- Sample : array (1..2) of Real;
- X, Y : Complex;
- begin
- for I in 1 .. Samples loop
- Low_Sample := (1.0 - Inv_Radix) / Real (Samples) * Real (I) +
- Inv_Radix;
- Sample (1) := Low_Sample;
- for J in 1 .. Samples loop
- High_Sample := (Radix - 1.0) / Real (Samples) * Real (I) +
- Radix;
- Sample (2) := High_Sample;
- for K in 1 .. 2 loop
- for L in 1 .. 2 loop
- X := Complex'(Sample (K), Sample (L));
- Y := Complex'(Sample (L), Sample (K));
- Do_Mult_Div (X, Y);
- if Failure_Detected then
- return; -- minimize flood of error messages
- end if;
- end loop;
- end loop;
- end loop; -- J
- end loop; -- I
- end Mult_Div_Check;
-
-
- procedure Do_Test is
- begin
- Special_Values;
- Mult_Div_Check;
- end Do_Test;
- end Non_Generic_Check;
-
- -----------------------------------------------------------------------
- -----------------------------------------------------------------------
-
-begin
- Report.Test ("CXG2008",
- "Check the accuracy of the complex multiplication and" &
- " division operators");
-
- if Verbose then
- Report.Comment ("checking Standard.Float");
- end if;
-
- Float_Check.Do_Test;
-
- if Verbose then
- Report.Comment ("checking a digits" &
- Integer'Image (System.Max_Digits) &
- " floating point type");
- end if;
-
- A_Long_Float_Check.Do_Test;
-
- if Verbose then
- Report.Comment ("checking non-generic package");
- end if;
-
- Non_Generic_Check.Do_Test;
-
- Report.Result;
-end CXG2008;
diff --git a/gcc/testsuite/ada/acats/tests/cxg/cxg2009.a b/gcc/testsuite/ada/acats/tests/cxg/cxg2009.a
deleted file mode 100644
index 0b11ca53887..00000000000
--- a/gcc/testsuite/ada/acats/tests/cxg/cxg2009.a
+++ /dev/null
@@ -1,421 +0,0 @@
--- CXG2009.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that the real sqrt and complex modulus functions
--- return results that are within the allowed
--- error bound.
---
--- TEST DESCRIPTION:
--- This test checks the accuracy of the sqrt and modulus functions
--- by computing the norm of various vectors where the result
--- is known in advance.
--- This test uses real and complex math together as would an
--- actual application. Considerable use of generics is also
--- employed.
---
--- SPECIAL REQUIREMENTS
--- The Strict Mode for the numerical accuracy must be
--- selected. The method by which this mode is selected
--- is implementation dependent.
---
--- APPLICABILITY CRITERIA:
--- This test applies only to implementations supporting the
--- Numerics Annex.
--- This test only applies to the Strict Mode for numerical
--- accuracy.
---
---
--- CHANGE HISTORY:
--- 26 FEB 96 SAIC Initial release for 2.1
--- 22 AUG 96 SAIC Revised Check procedure
---
---!
-
-------------------------------------------------------------------------------
-
-with System;
-with Report;
-with Ada.Numerics.Generic_Complex_Types;
-with Ada.Numerics.Generic_Elementary_Functions;
-procedure CXG2009 is
- Verbose : constant Boolean := False;
-
- --=====================================================================
-
- generic
- type Real is digits <>;
- package Generic_Real_Norm_Check is
- procedure Do_Test;
- end Generic_Real_Norm_Check;
-
- -----------------------------------------------------------------------
-
- package body Generic_Real_Norm_Check is
- type Vector is array (Integer range <>) of Real;
-
- package GEF is new Ada.Numerics.Generic_Elementary_Functions (Real);
- function Sqrt (X : Real) return Real renames GEF.Sqrt;
-
- function One_Norm (V : Vector) return Real is
- -- sum of absolute values of the elements of the vector
- Result : Real := 0.0;
- begin
- for I in V'Range loop
- Result := Result + abs V(I);
- end loop;
- return Result;
- end One_Norm;
-
- function Inf_Norm (V : Vector) return Real is
- -- greatest absolute vector element
- Result : Real := 0.0;
- begin
- for I in V'Range loop
- if abs V(I) > Result then
- Result := abs V(I);
- end if;
- end loop;
- return Result;
- end Inf_Norm;
-
- function Two_Norm (V : Vector) return Real is
- -- if greatest absolute vector element is 0 then return 0
- -- else return greatest * sqrt (sum((element / greatest) ** 2)))
- -- where greatest is Inf_Norm of the vector
- Inf_N : Real;
- Sum_Squares : Real;
- Term : Real;
- begin
- Inf_N := Inf_Norm (V);
- if Inf_N = 0.0 then
- return 0.0;
- end if;
- Sum_Squares := 0.0;
- for I in V'Range loop
- Term := V (I) / Inf_N;
- Sum_Squares := Sum_Squares + Term * Term;
- end loop;
- return Inf_N * Sqrt (Sum_Squares);
- end Two_Norm;
-
-
- procedure Check (Actual, Expected : Real;
- Test_Name : String;
- MRE : Real;
- Vector_Length : Integer) is
- Rel_Error : Real;
- Abs_Error : Real;
- Max_Error : Real;
- begin
- -- In the case where the expected result is very small or 0
- -- we compute the maximum error as a multiple of Model_Epsilon instead
- -- of Model_Epsilon and Expected.
- Rel_Error := MRE * abs Expected * Real'Model_Epsilon;
- Abs_Error := MRE * Real'Model_Epsilon;
- if Rel_Error > Abs_Error then
- Max_Error := Rel_Error;
- else
- Max_Error := Abs_Error;
- end if;
-
- if abs (Actual - Expected) > Max_Error then
- Report.Failed (Test_Name &
- " VectLength:" &
- Integer'Image (Vector_Length) &
- " actual: " & Real'Image (Actual) &
- " expected: " & Real'Image (Expected) &
- " difference: " &
- Real'Image (Actual - Expected) &
- " mre:" & Real'Image (Max_Error) );
- elsif Verbose then
- Report.Comment (Test_Name & " vector length" &
- Integer'Image (Vector_Length));
- end if;
- end Check;
-
-
- procedure Do_Test is
- begin
- for Vector_Length in 1 .. 10 loop
- declare
- V : Vector (1..Vector_Length) := (1..Vector_Length => 0.0);
- V1 : Vector (1..Vector_Length) := (1..Vector_Length => 1.0);
- begin
- Check (One_Norm (V), 0.0, "one_norm (z)", 0.0, Vector_Length);
- Check (Inf_Norm (V), 0.0, "inf_norm (z)", 0.0, Vector_Length);
-
- for J in 1..Vector_Length loop
- V := (1..Vector_Length => 0.0);
- V (J) := 1.0;
- Check (One_Norm (V), 1.0, "one_norm (010)",
- 0.0, Vector_Length);
- Check (Inf_Norm (V), 1.0, "inf_norm (010)",
- 0.0, Vector_Length);
- Check (Two_Norm (V), 1.0, "two_norm (010)",
- 0.0, Vector_Length);
- end loop;
-
- Check (One_Norm (V1), Real (Vector_Length), "one_norm (1)",
- 0.0, Vector_Length);
- Check (Inf_Norm (V1), 1.0, "inf_norm (1)",
- 0.0, Vector_Length);
-
- -- error in computing Two_Norm and expected result
- -- are as follows (ME is Model_Epsilon * Expected_Value):
- -- 2ME from expected Sqrt
- -- 2ME from Sqrt in Two_Norm times the error in the
- -- vector calculation.
- -- The vector calculation contains the following error
- -- based upon the length N of the vector:
- -- N*1ME from squaring terms in Two_Norm
- -- N*1ME from the division of each term in Two_Norm
- -- (N-1)*1ME from the sum of the terms
- -- This gives (2 + 2 * (N + N + (N-1)) ) * ME
- -- which simplifies to (2 + 2N + 2N + 2N - 2) * ME
- -- or 6*N*ME
- Check (Two_Norm (V1), Sqrt (Real(Vector_Length)),
- "two_norm (1)",
- (Real (6 * Vector_Length)),
- Vector_Length);
- exception
- when others => Report.Failed ("exception for vector length" &
- Integer'Image (Vector_Length) );
- end;
- end loop;
- end Do_Test;
- end Generic_Real_Norm_Check;
-
- --=====================================================================
-
- generic
- type Real is digits <>;
- package Generic_Complex_Norm_Check is
- procedure Do_Test;
- end Generic_Complex_Norm_Check;
-
- -----------------------------------------------------------------------
-
- package body Generic_Complex_Norm_Check is
- package Complex_Types is new Ada.Numerics.Generic_Complex_Types (Real);
- use Complex_Types;
- type Vector is array (Integer range <>) of Complex;
-
- package GEF is new Ada.Numerics.Generic_Elementary_Functions (Real);
- function Sqrt (X : Real) return Real renames GEF.Sqrt;
-
- function One_Norm (V : Vector) return Real is
- Result : Real := 0.0;
- begin
- for I in V'Range loop
- Result := Result + abs V(I);
- end loop;
- return Result;
- end One_Norm;
-
- function Inf_Norm (V : Vector) return Real is
- Result : Real := 0.0;
- begin
- for I in V'Range loop
- if abs V(I) > Result then
- Result := abs V(I);
- end if;
- end loop;
- return Result;
- end Inf_Norm;
-
- function Two_Norm (V : Vector) return Real is
- Inf_N : Real;
- Sum_Squares : Real;
- Term : Real;
- begin
- Inf_N := Inf_Norm (V);
- if Inf_N = 0.0 then
- return 0.0;
- end if;
- Sum_Squares := 0.0;
- for I in V'Range loop
- Term := abs (V (I) / Inf_N );
- Sum_Squares := Sum_Squares + Term * Term;
- end loop;
- return Inf_N * Sqrt (Sum_Squares);
- end Two_Norm;
-
-
- procedure Check (Actual, Expected : Real;
- Test_Name : String;
- MRE : Real;
- Vector_Length : Integer) is
- Rel_Error : Real;
- Abs_Error : Real;
- Max_Error : Real;
- begin
- -- In the case where the expected result is very small or 0
- -- we compute the maximum error as a multiple of Model_Epsilon instead
- -- of Model_Epsilon and Expected.
- Rel_Error := MRE * abs Expected * Real'Model_Epsilon;
- Abs_Error := MRE * Real'Model_Epsilon;
- if Rel_Error > Abs_Error then
- Max_Error := Rel_Error;
- else
- Max_Error := Abs_Error;
- end if;
-
- if abs (Actual - Expected) > Max_Error then
- Report.Failed (Test_Name &
- " VectLength:" &
- Integer'Image (Vector_Length) &
- " actual: " & Real'Image (Actual) &
- " expected: " & Real'Image (Expected) &
- " difference: " &
- Real'Image (Actual - Expected) &
- " mre:" & Real'Image (Max_Error) );
- elsif Verbose then
- Report.Comment (Test_Name & " vector length" &
- Integer'Image (Vector_Length));
- end if;
- end Check;
-
-
- procedure Do_Test is
- begin
- for Vector_Length in 1 .. 10 loop
- declare
- V : Vector (1..Vector_Length) :=
- (1..Vector_Length => (0.0, 0.0));
- X, Y : Vector (1..Vector_Length);
- begin
- Check (One_Norm (V), 0.0, "one_norm (z)", 0.0, Vector_Length);
- Check (Inf_Norm (V), 0.0, "inf_norm (z)", 0.0, Vector_Length);
-
- for J in 1..Vector_Length loop
- X := (1..Vector_Length => (0.0, 0.0) );
- Y := X; -- X and Y are now both zeroed
- X (J).Re := 1.0;
- Y (J).Im := 1.0;
- Check (One_Norm (X), 1.0, "one_norm (0x0)",
- 0.0, Vector_Length);
- Check (Inf_Norm (X), 1.0, "inf_norm (0x0)",
- 0.0, Vector_Length);
- Check (Two_Norm (X), 1.0, "two_norm (0x0)",
- 0.0, Vector_Length);
- Check (One_Norm (Y), 1.0, "one_norm (0y0)",
- 0.0, Vector_Length);
- Check (Inf_Norm (Y), 1.0, "inf_norm (0y0)",
- 0.0, Vector_Length);
- Check (Two_Norm (Y), 1.0, "two_norm (0y0)",
- 0.0, Vector_Length);
- end loop;
-
- V := (1..Vector_Length => (3.0, 4.0));
-
- -- error in One_Norm is 3*N*ME for abs computation +
- -- (N-1)*ME for the additions
- -- which gives (4N-1) * ME
- Check (One_Norm (V), 5.0 * Real (Vector_Length),
- "one_norm ((3,4))",
- Real (4*Vector_Length - 1),
- Vector_Length);
-
- -- error in Inf_Norm is from abs of single element (3ME)
- Check (Inf_Norm (V), 5.0,
- "inf_norm ((3,4))",
- 3.0,
- Vector_Length);
-
- -- error in following comes from:
- -- 2ME in sqrt of expected result
- -- 3ME in Inf_Norm calculation
- -- 2ME in sqrt of vector calculation
- -- vector calculation has following error
- -- 3N*ME for abs
- -- N*ME for squaring
- -- N*ME for division
- -- (N-1)ME for sum
- -- this results in [2 + 3 + 2(6N-1) ] * ME
- -- or (12N + 3)ME
- Check (Two_Norm (V), 5.0 * Sqrt (Real(Vector_Length)),
- "two_norm ((3,4))",
- (12.0 * Real (Vector_Length) + 3.0),
- Vector_Length);
- exception
- when others => Report.Failed ("exception for complex " &
- "vector length" &
- Integer'Image (Vector_Length) );
- end;
- end loop;
- end Do_Test;
- end Generic_Complex_Norm_Check;
-
- --=====================================================================
-
- generic
- type Real is digits <>;
- package Generic_Norm_Check is
- procedure Do_Test;
- end Generic_Norm_Check;
-
- -----------------------------------------------------------------------
-
- package body Generic_Norm_Check is
- package RNC is new Generic_Real_Norm_Check (Real);
- package CNC is new Generic_Complex_Norm_Check (Real);
- procedure Do_Test is
- begin
- RNC.Do_Test;
- CNC.Do_Test;
- end Do_Test;
- end Generic_Norm_Check;
-
- --=====================================================================
-
- package Float_Check is new Generic_Norm_Check (Float);
-
- type A_Long_Float is digits System.Max_Digits;
- package A_Long_Float_Check is new Generic_Norm_Check (A_Long_Float);
-
- -----------------------------------------------------------------------
-
-begin
- Report.Test ("CXG2009",
- "Check the accuracy of the real sqrt and complex " &
- " modulus functions");
-
- if Verbose then
- Report.Comment ("checking Standard.Float");
- end if;
-
- Float_Check.Do_Test;
-
- if Verbose then
- Report.Comment ("checking a digits" &
- Integer'Image (System.Max_Digits) &
- " floating point type");
- end if;
-
- A_Long_Float_Check.Do_Test;
-
- Report.Result;
-end CXG2009;
diff --git a/gcc/testsuite/ada/acats/tests/cxg/cxg2010.a b/gcc/testsuite/ada/acats/tests/cxg/cxg2010.a
deleted file mode 100644
index 4140a487526..00000000000
--- a/gcc/testsuite/ada/acats/tests/cxg/cxg2010.a
+++ /dev/null
@@ -1,892 +0,0 @@
--- CXG2010.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that the exp function returns
--- results that are within the error bound allowed.
---
--- TEST DESCRIPTION:
--- This test contains three test packages that are almost
--- identical. The first two packages differ only in the
--- floating point type that is being tested. The first
--- and third package differ only in whether the generic
--- elementary functions package or the pre-instantiated
--- package is used.
--- The test package is not generic so that the arguments
--- and expected results for some of the test values
--- can be expressed as universal real instead of being
--- computed at runtime.
---
--- SPECIAL REQUIREMENTS
--- The Strict Mode for the numerical accuracy must be
--- selected. The method by which this mode is selected
--- is implementation dependent.
---
--- APPLICABILITY CRITERIA:
--- This test applies only to implementations supporting the
--- Numerics Annex and where the Machine_Radix is 2, 4, 8, or 16.
--- This test only applies to the Strict Mode for numerical
--- accuracy.
---
---
--- CHANGE HISTORY:
--- 1 Mar 96 SAIC Initial release for 2.1
--- 2 Sep 96 SAIC Improved check routine
---
---!
-
---
--- References:
---
--- Software Manual for the Elementary Functions
--- William J. Cody, Jr. and William Waite
--- Prentice-Hall, 1980
---
--- CRC Standard Mathematical Tables
--- 23rd Edition
---
--- Implementation and Testing of Function Software
--- W. J. Cody
--- Problems and Methodologies in Mathematical Software Production
--- editors P. C. Messina and A. Murli
--- Lecture Notes in Computer Science Volume 142
--- Springer Verlag, 1982
---
-
---
--- Notes on derivation of error bound for exp(p)*exp(-p)
---
--- Let a = true value of exp(p) and ac be the computed value.
--- Then a = ac(1+e1), where |e1| <= 4*Model_Epsilon.
--- Similarly, let b = true value of exp(-p) and bc be the computed value.
--- Then b = bc(1+e2), where |e2| <= 4*ME.
---
--- The product of x and y is (x*y)(1+e3), where |e3| <= 1.0ME
---
--- Hence, the computed ab is [ac(1+e1)*bc(1+e2)](1+e3) =
--- (ac*bc)[1 + e1 + e2 + e3 + e1e2 + e1e3 + e2e3 + e1e2e3).
---
--- Throwing away the last four tiny terms, we have (ac*bc)(1 + eta),
---
--- where |eta| <= (4+4+1)ME = 9.0Model_Epsilon.
-
-with System;
-with Report;
-with Ada.Numerics.Generic_Elementary_Functions;
-with Ada.Numerics.Elementary_Functions;
-procedure CXG2010 is
- Verbose : constant Boolean := False;
- Max_Samples : constant := 1000;
- Accuracy_Error_Reported : Boolean := False;
-
- package Float_Check is
- subtype Real is Float;
- procedure Do_Test;
- end Float_Check;
-
- package body Float_Check is
- package Elementary_Functions is new
- Ada.Numerics.Generic_Elementary_Functions (Real);
- function Sqrt (X : Real) return Real renames
- Elementary_Functions.Sqrt;
- function Exp (X : Real) return Real renames
- Elementary_Functions.Exp;
-
-
- -- The following value is a lower bound on the accuracy
- -- required. It is normally 0.0 so that the lower bound
- -- is computed from Model_Epsilon. However, for tests
- -- where the expected result is only known to a certain
- -- amount of precision this bound takes on a non-zero
- -- value to account for that level of precision.
- Error_Low_Bound : Real := 0.0;
-
- procedure Check (Actual, Expected : Real;
- Test_Name : String;
- MRE : Real) is
- Max_Error : Real;
- Rel_Error : Real;
- Abs_Error : Real;
- begin
- -- In the case where the expected result is very small or 0
- -- we compute the maximum error as a multiple of Model_Epsilon
- -- instead of Model_Epsilon and Expected.
- Rel_Error := MRE * abs Expected * Real'Model_Epsilon;
- Abs_Error := MRE * Real'Model_Epsilon;
- if Rel_Error > Abs_Error then
- Max_Error := Rel_Error;
- else
- Max_Error := Abs_Error;
- end if;
-
- -- take into account the low bound on the error
- if Max_Error < Error_Low_Bound then
- Max_Error := Error_Low_Bound;
- end if;
-
- if abs (Actual - Expected) > Max_Error then
- Accuracy_Error_Reported := True;
- Report.Failed (Test_Name &
- " actual: " & Real'Image (Actual) &
- " expected: " & Real'Image (Expected) &
- " difference: " & Real'Image (Actual - Expected) &
- " max err:" & Real'Image (Max_Error) );
- elsif Verbose then
- if Actual = Expected then
- Report.Comment (Test_Name & " exact result");
- else
- Report.Comment (Test_Name & " passed");
- end if;
- end if;
- end Check;
-
-
- procedure Argument_Range_Check_1 (A, B : Real;
- Test : String) is
- -- test a evenly distributed selection of
- -- arguments selected from the range A to B.
- -- Test using identity: EXP(X-V) = EXP(X) * EXP (-V)
- -- The parameter One_Minus_Exp_Minus_V is the value
- -- 1.0 - Exp (-V)
- -- accurate to machine precision.
- -- This procedure is a translation of part of Cody's test
- X : Real;
- Y : Real;
- ZX, ZY : Real;
- V : constant := 1.0 / 16.0;
- One_Minus_Exp_Minus_V : constant := 6.058693718652421388E-2;
-
- begin
- Accuracy_Error_Reported := False;
- for I in 1..Max_Samples loop
- X := (B - A) * Real (I) / Real (Max_Samples) + A;
- Y := X - V;
- if Y < 0.0 then
- X := Y + V;
- end if;
-
- ZX := Exp (X);
- ZY := Exp (Y);
-
- -- ZX := Exp(X) - Exp(X) * (1 - Exp(-V);
- -- which simplifies to ZX := Exp (X-V);
- ZX := ZX - ZX * One_Minus_Exp_Minus_V;
-
- -- note that since the expected value is computed, we
- -- must take the error in that computation into account.
- Check (ZY, ZX,
- "test " & Test & " -" &
- Integer'Image (I) &
- " exp (" & Real'Image (X) & ")",
- 9.0);
- exit when Accuracy_Error_Reported;
- end loop;
- exception
- when Constraint_Error =>
- Report.Failed
- ("Constraint_Error raised in argument range check 1");
- when others =>
- Report.Failed ("exception in argument range check 1");
- end Argument_Range_Check_1;
-
-
-
- procedure Argument_Range_Check_2 (A, B : Real;
- Test : String) is
- -- test a evenly distributed selection of
- -- arguments selected from the range A to B.
- -- Test using identity: EXP(X-V) = EXP(X) * EXP (-V)
- -- The parameter One_Minus_Exp_Minus_V is the value
- -- 1.0 - Exp (-V)
- -- accurate to machine precision.
- -- This procedure is a translation of part of Cody's test
- X : Real;
- Y : Real;
- ZX, ZY : Real;
- V : constant := 45.0 / 16.0;
- -- 1/16 - Exp(45/16)
- Coeff : constant := 2.4453321046920570389E-3;
-
- begin
- Accuracy_Error_Reported := False;
- for I in 1..Max_Samples loop
- X := (B - A) * Real (I) / Real (Max_Samples) + A;
- Y := X - V;
- if Y < 0.0 then
- X := Y + V;
- end if;
-
- ZX := Exp (X);
- ZY := Exp (Y);
-
- -- ZX := Exp(X) * 1/16 - Exp(X) * Coeff;
- -- where Coeff is 1/16 - Exp(45/16)
- -- which simplifies to ZX := Exp (X-V);
- ZX := ZX * 0.0625 - ZX * Coeff;
-
- -- note that since the expected value is computed, we
- -- must take the error in that computation into account.
- Check (ZY, ZX,
- "test " & Test & " -" &
- Integer'Image (I) &
- " exp (" & Real'Image (X) & ")",
- 9.0);
- exit when Accuracy_Error_Reported;
- end loop;
- exception
- when Constraint_Error =>
- Report.Failed
- ("Constraint_Error raised in argument range check 2");
- when others =>
- Report.Failed ("exception in argument range check 2");
- end Argument_Range_Check_2;
-
-
- procedure Do_Test is
- begin
-
- --- test 1 ---
- declare
- Y : Real;
- begin
- Y := Exp(1.0);
- -- normal accuracy requirements
- Check (Y, Ada.Numerics.e, "test 1 -- exp(1)", 4.0);
- exception
- when Constraint_Error =>
- Report.Failed ("Constraint_Error raised in test 1");
- when others =>
- Report.Failed ("exception in test 1");
- end;
-
- --- test 2 ---
- declare
- Y : Real;
- begin
- Y := Exp(16.0) * Exp(-16.0);
- Check (Y, 1.0, "test 2 -- exp(16)*exp(-16)", 9.0);
- exception
- when Constraint_Error =>
- Report.Failed ("Constraint_Error raised in test 2");
- when others =>
- Report.Failed ("exception in test 2");
- end;
-
- --- test 3 ---
- declare
- Y : Real;
- begin
- Y := Exp (Ada.Numerics.Pi) * Exp (-Ada.Numerics.Pi);
- Check (Y, 1.0, "test 3 -- exp(pi)*exp(-pi)", 9.0);
- exception
- when Constraint_Error =>
- Report.Failed ("Constraint_Error raised in test 3");
- when others =>
- Report.Failed ("exception in test 3");
- end;
-
- --- test 4 ---
- declare
- Y : Real;
- begin
- Y := Exp(0.0);
- Check (Y, 1.0, "test 4 -- exp(0.0)",
- 0.0); -- no error allowed
- exception
- when Constraint_Error =>
- Report.Failed ("Constraint_Error raised in test 4");
- when others =>
- Report.Failed ("exception in test 4");
- end;
-
- --- test 5 ---
- -- constants used here only have 19 digits of precision
- if Real'Digits > 19 then
- Error_Low_Bound := 0.00000_00000_00000_0001;
- Report.Comment ("exp accuracy checked to 19 digits");
- end if;
-
- Argument_Range_Check_1 ( 1.0/Sqrt(Real(Real'Machine_Radix)),
- 1.0,
- "5");
- Error_Low_Bound := 0.0; -- reset
-
- --- test 6 ---
- -- constants used here only have 19 digits of precision
- if Real'Digits > 19 then
- Error_Low_Bound := 0.00000_00000_00000_0001;
- Report.Comment ("exp accuracy checked to 19 digits");
- end if;
-
- Argument_Range_Check_2 (1.0,
- Sqrt(Real(Real'Machine_Radix)),
- "6");
- Error_Low_Bound := 0.0; -- reset
-
- end Do_Test;
- end Float_Check;
-
- -----------------------------------------------------------------------
- -----------------------------------------------------------------------
- -- check the floating point type with the most digits
- type A_Long_Float is digits System.Max_Digits;
-
-
- package A_Long_Float_Check is
- subtype Real is A_Long_Float;
- procedure Do_Test;
- end A_Long_Float_Check;
-
- package body A_Long_Float_Check is
- package Elementary_Functions is new
- Ada.Numerics.Generic_Elementary_Functions (Real);
- function Sqrt (X : Real) return Real renames
- Elementary_Functions.Sqrt;
- function Exp (X : Real) return Real renames
- Elementary_Functions.Exp;
-
-
- -- The following value is a lower bound on the accuracy
- -- required. It is normally 0.0 so that the lower bound
- -- is computed from Model_Epsilon. However, for tests
- -- where the expected result is only known to a certain
- -- amount of precision this bound takes on a non-zero
- -- value to account for that level of precision.
- Error_Low_Bound : Real := 0.0;
-
- procedure Check (Actual, Expected : Real;
- Test_Name : String;
- MRE : Real) is
- Max_Error : Real;
- Rel_Error : Real;
- Abs_Error : Real;
- begin
- -- In the case where the expected result is very small or 0
- -- we compute the maximum error as a multiple of Model_Epsilon
- -- instead of Model_Epsilon and Expected.
- Rel_Error := MRE * abs Expected * Real'Model_Epsilon;
- Abs_Error := MRE * Real'Model_Epsilon;
- if Rel_Error > Abs_Error then
- Max_Error := Rel_Error;
- else
- Max_Error := Abs_Error;
- end if;
-
- -- take into account the low bound on the error
- if Max_Error < Error_Low_Bound then
- Max_Error := Error_Low_Bound;
- end if;
-
- if abs (Actual - Expected) > Max_Error then
- Accuracy_Error_Reported := True;
- Report.Failed (Test_Name &
- " actual: " & Real'Image (Actual) &
- " expected: " & Real'Image (Expected) &
- " difference: " & Real'Image (Actual - Expected) &
- " max err:" & Real'Image (Max_Error) );
- elsif Verbose then
- if Actual = Expected then
- Report.Comment (Test_Name & " exact result");
- else
- Report.Comment (Test_Name & " passed");
- end if;
- end if;
- end Check;
-
-
- procedure Argument_Range_Check_1 (A, B : Real;
- Test : String) is
- -- test a evenly distributed selection of
- -- arguments selected from the range A to B.
- -- Test using identity: EXP(X-V) = EXP(X) * EXP (-V)
- -- The parameter One_Minus_Exp_Minus_V is the value
- -- 1.0 - Exp (-V)
- -- accurate to machine precision.
- -- This procedure is a translation of part of Cody's test
- X : Real;
- Y : Real;
- ZX, ZY : Real;
- V : constant := 1.0 / 16.0;
- One_Minus_Exp_Minus_V : constant := 6.058693718652421388E-2;
-
- begin
- Accuracy_Error_Reported := False;
- for I in 1..Max_Samples loop
- X := (B - A) * Real (I) / Real (Max_Samples) + A;
- Y := X - V;
- if Y < 0.0 then
- X := Y + V;
- end if;
-
- ZX := Exp (X);
- ZY := Exp (Y);
-
- -- ZX := Exp(X) - Exp(X) * (1 - Exp(-V);
- -- which simplifies to ZX := Exp (X-V);
- ZX := ZX - ZX * One_Minus_Exp_Minus_V;
-
- -- note that since the expected value is computed, we
- -- must take the error in that computation into account.
- Check (ZY, ZX,
- "test " & Test & " -" &
- Integer'Image (I) &
- " exp (" & Real'Image (X) & ")",
- 9.0);
- exit when Accuracy_Error_Reported;
- end loop;
- exception
- when Constraint_Error =>
- Report.Failed
- ("Constraint_Error raised in argument range check 1");
- when others =>
- Report.Failed ("exception in argument range check 1");
- end Argument_Range_Check_1;
-
-
-
- procedure Argument_Range_Check_2 (A, B : Real;
- Test : String) is
- -- test a evenly distributed selection of
- -- arguments selected from the range A to B.
- -- Test using identity: EXP(X-V) = EXP(X) * EXP (-V)
- -- The parameter One_Minus_Exp_Minus_V is the value
- -- 1.0 - Exp (-V)
- -- accurate to machine precision.
- -- This procedure is a translation of part of Cody's test
- X : Real;
- Y : Real;
- ZX, ZY : Real;
- V : constant := 45.0 / 16.0;
- -- 1/16 - Exp(45/16)
- Coeff : constant := 2.4453321046920570389E-3;
-
- begin
- Accuracy_Error_Reported := False;
- for I in 1..Max_Samples loop
- X := (B - A) * Real (I) / Real (Max_Samples) + A;
- Y := X - V;
- if Y < 0.0 then
- X := Y + V;
- end if;
-
- ZX := Exp (X);
- ZY := Exp (Y);
-
- -- ZX := Exp(X) * 1/16 - Exp(X) * Coeff;
- -- where Coeff is 1/16 - Exp(45/16)
- -- which simplifies to ZX := Exp (X-V);
- ZX := ZX * 0.0625 - ZX * Coeff;
-
- -- note that since the expected value is computed, we
- -- must take the error in that computation into account.
- Check (ZY, ZX,
- "test " & Test & " -" &
- Integer'Image (I) &
- " exp (" & Real'Image (X) & ")",
- 9.0);
- exit when Accuracy_Error_Reported;
- end loop;
- exception
- when Constraint_Error =>
- Report.Failed
- ("Constraint_Error raised in argument range check 2");
- when others =>
- Report.Failed ("exception in argument range check 2");
- end Argument_Range_Check_2;
-
-
- procedure Do_Test is
- begin
-
- --- test 1 ---
- declare
- Y : Real;
- begin
- Y := Exp(1.0);
- -- normal accuracy requirements
- Check (Y, Ada.Numerics.e, "test 1 -- exp(1)", 4.0);
- exception
- when Constraint_Error =>
- Report.Failed ("Constraint_Error raised in test 1");
- when others =>
- Report.Failed ("exception in test 1");
- end;
-
- --- test 2 ---
- declare
- Y : Real;
- begin
- Y := Exp(16.0) * Exp(-16.0);
- Check (Y, 1.0, "test 2 -- exp(16)*exp(-16)", 9.0);
- exception
- when Constraint_Error =>
- Report.Failed ("Constraint_Error raised in test 2");
- when others =>
- Report.Failed ("exception in test 2");
- end;
-
- --- test 3 ---
- declare
- Y : Real;
- begin
- Y := Exp (Ada.Numerics.Pi) * Exp (-Ada.Numerics.Pi);
- Check (Y, 1.0, "test 3 -- exp(pi)*exp(-pi)", 9.0);
- exception
- when Constraint_Error =>
- Report.Failed ("Constraint_Error raised in test 3");
- when others =>
- Report.Failed ("exception in test 3");
- end;
-
- --- test 4 ---
- declare
- Y : Real;
- begin
- Y := Exp(0.0);
- Check (Y, 1.0, "test 4 -- exp(0.0)",
- 0.0); -- no error allowed
- exception
- when Constraint_Error =>
- Report.Failed ("Constraint_Error raised in test 4");
- when others =>
- Report.Failed ("exception in test 4");
- end;
-
- --- test 5 ---
- -- constants used here only have 19 digits of precision
- if Real'Digits > 19 then
- Error_Low_Bound := 0.00000_00000_00000_0001;
- Report.Comment ("exp accuracy checked to 19 digits");
- end if;
-
- Argument_Range_Check_1 ( 1.0/Sqrt(Real(Real'Machine_Radix)),
- 1.0,
- "5");
- Error_Low_Bound := 0.0; -- reset
-
- --- test 6 ---
- -- constants used here only have 19 digits of precision
- if Real'Digits > 19 then
- Error_Low_Bound := 0.00000_00000_00000_0001;
- Report.Comment ("exp accuracy checked to 19 digits");
- end if;
-
- Argument_Range_Check_2 (1.0,
- Sqrt(Real(Real'Machine_Radix)),
- "6");
- Error_Low_Bound := 0.0; -- reset
-
- end Do_Test;
- end A_Long_Float_Check;
-
- -----------------------------------------------------------------------
- -----------------------------------------------------------------------
-
- package Non_Generic_Check is
- procedure Do_Test;
- subtype Real is Float;
- end Non_Generic_Check;
-
- package body Non_Generic_Check is
-
- package Elementary_Functions renames
- Ada.Numerics.Elementary_Functions;
- function Sqrt (X : Real) return Real renames
- Elementary_Functions.Sqrt;
- function Exp (X : Real) return Real renames
- Elementary_Functions.Exp;
-
-
- -- The following value is a lower bound on the accuracy
- -- required. It is normally 0.0 so that the lower bound
- -- is computed from Model_Epsilon. However, for tests
- -- where the expected result is only known to a certain
- -- amount of precision this bound takes on a non-zero
- -- value to account for that level of precision.
- Error_Low_Bound : Real := 0.0;
-
- procedure Check (Actual, Expected : Real;
- Test_Name : String;
- MRE : Real) is
- Max_Error : Real;
- Rel_Error : Real;
- Abs_Error : Real;
- begin
- -- In the case where the expected result is very small or 0
- -- we compute the maximum error as a multiple of Model_Epsilon
- -- instead of Model_Epsilon and Expected.
- Rel_Error := MRE * abs Expected * Real'Model_Epsilon;
- Abs_Error := MRE * Real'Model_Epsilon;
- if Rel_Error > Abs_Error then
- Max_Error := Rel_Error;
- else
- Max_Error := Abs_Error;
- end if;
-
- -- take into account the low bound on the error
- if Max_Error < Error_Low_Bound then
- Max_Error := Error_Low_Bound;
- end if;
-
- if abs (Actual - Expected) > Max_Error then
- Accuracy_Error_Reported := True;
- Report.Failed (Test_Name &
- " actual: " & Real'Image (Actual) &
- " expected: " & Real'Image (Expected) &
- " difference: " & Real'Image (Actual - Expected) &
- " max err:" & Real'Image (Max_Error) );
- elsif Verbose then
- if Actual = Expected then
- Report.Comment (Test_Name & " exact result");
- else
- Report.Comment (Test_Name & " passed");
- end if;
- end if;
- end Check;
-
-
- procedure Argument_Range_Check_1 (A, B : Real;
- Test : String) is
- -- test a evenly distributed selection of
- -- arguments selected from the range A to B.
- -- Test using identity: EXP(X-V) = EXP(X) * EXP (-V)
- -- The parameter One_Minus_Exp_Minus_V is the value
- -- 1.0 - Exp (-V)
- -- accurate to machine precision.
- -- This procedure is a translation of part of Cody's test
- X : Real;
- Y : Real;
- ZX, ZY : Real;
- V : constant := 1.0 / 16.0;
- One_Minus_Exp_Minus_V : constant := 6.058693718652421388E-2;
-
- begin
- Accuracy_Error_Reported := False;
- for I in 1..Max_Samples loop
- X := (B - A) * Real (I) / Real (Max_Samples) + A;
- Y := X - V;
- if Y < 0.0 then
- X := Y + V;
- end if;
-
- ZX := Exp (X);
- ZY := Exp (Y);
-
- -- ZX := Exp(X) - Exp(X) * (1 - Exp(-V);
- -- which simplifies to ZX := Exp (X-V);
- ZX := ZX - ZX * One_Minus_Exp_Minus_V;
-
- -- note that since the expected value is computed, we
- -- must take the error in that computation into account.
- Check (ZY, ZX,
- "test " & Test & " -" &
- Integer'Image (I) &
- " exp (" & Real'Image (X) & ")",
- 9.0);
- exit when Accuracy_Error_Reported;
- end loop;
- exception
- when Constraint_Error =>
- Report.Failed
- ("Constraint_Error raised in argument range check 1");
- when others =>
- Report.Failed ("exception in argument range check 1");
- end Argument_Range_Check_1;
-
-
-
- procedure Argument_Range_Check_2 (A, B : Real;
- Test : String) is
- -- test a evenly distributed selection of
- -- arguments selected from the range A to B.
- -- Test using identity: EXP(X-V) = EXP(X) * EXP (-V)
- -- The parameter One_Minus_Exp_Minus_V is the value
- -- 1.0 - Exp (-V)
- -- accurate to machine precision.
- -- This procedure is a translation of part of Cody's test
- X : Real;
- Y : Real;
- ZX, ZY : Real;
- V : constant := 45.0 / 16.0;
- -- 1/16 - Exp(45/16)
- Coeff : constant := 2.4453321046920570389E-3;
-
- begin
- Accuracy_Error_Reported := False;
- for I in 1..Max_Samples loop
- X := (B - A) * Real (I) / Real (Max_Samples) + A;
- Y := X - V;
- if Y < 0.0 then
- X := Y + V;
- end if;
-
- ZX := Exp (X);
- ZY := Exp (Y);
-
- -- ZX := Exp(X) * 1/16 - Exp(X) * Coeff;
- -- where Coeff is 1/16 - Exp(45/16)
- -- which simplifies to ZX := Exp (X-V);
- ZX := ZX * 0.0625 - ZX * Coeff;
-
- -- note that since the expected value is computed, we
- -- must take the error in that computation into account.
- Check (ZY, ZX,
- "test " & Test & " -" &
- Integer'Image (I) &
- " exp (" & Real'Image (X) & ")",
- 9.0);
- exit when Accuracy_Error_Reported;
- end loop;
- exception
- when Constraint_Error =>
- Report.Failed
- ("Constraint_Error raised in argument range check 2");
- when others =>
- Report.Failed ("exception in argument range check 2");
- end Argument_Range_Check_2;
-
-
- procedure Do_Test is
- begin
-
- --- test 1 ---
- declare
- Y : Real;
- begin
- Y := Exp(1.0);
- -- normal accuracy requirements
- Check (Y, Ada.Numerics.e, "test 1 -- exp(1)", 4.0);
- exception
- when Constraint_Error =>
- Report.Failed ("Constraint_Error raised in test 1");
- when others =>
- Report.Failed ("exception in test 1");
- end;
-
- --- test 2 ---
- declare
- Y : Real;
- begin
- Y := Exp(16.0) * Exp(-16.0);
- Check (Y, 1.0, "test 2 -- exp(16)*exp(-16)", 9.0);
- exception
- when Constraint_Error =>
- Report.Failed ("Constraint_Error raised in test 2");
- when others =>
- Report.Failed ("exception in test 2");
- end;
-
- --- test 3 ---
- declare
- Y : Real;
- begin
- Y := Exp (Ada.Numerics.Pi) * Exp (-Ada.Numerics.Pi);
- Check (Y, 1.0, "test 3 -- exp(pi)*exp(-pi)", 9.0);
- exception
- when Constraint_Error =>
- Report.Failed ("Constraint_Error raised in test 3");
- when others =>
- Report.Failed ("exception in test 3");
- end;
-
- --- test 4 ---
- declare
- Y : Real;
- begin
- Y := Exp(0.0);
- Check (Y, 1.0, "test 4 -- exp(0.0)",
- 0.0); -- no error allowed
- exception
- when Constraint_Error =>
- Report.Failed ("Constraint_Error raised in test 4");
- when others =>
- Report.Failed ("exception in test 4");
- end;
-
- --- test 5 ---
- -- constants used here only have 19 digits of precision
- if Real'Digits > 19 then
- Error_Low_Bound := 0.00000_00000_00000_0001;
- Report.Comment ("exp accuracy checked to 19 digits");
- end if;
-
- Argument_Range_Check_1 ( 1.0/Sqrt(Real(Real'Machine_Radix)),
- 1.0,
- "5");
- Error_Low_Bound := 0.0; -- reset
-
- --- test 6 ---
- -- constants used here only have 19 digits of precision
- if Real'Digits > 19 then
- Error_Low_Bound := 0.00000_00000_00000_0001;
- Report.Comment ("exp accuracy checked to 19 digits");
- end if;
-
- Argument_Range_Check_2 (1.0,
- Sqrt(Real(Real'Machine_Radix)),
- "6");
- Error_Low_Bound := 0.0; -- reset
-
- end Do_Test;
- end Non_Generic_Check;
-
- -----------------------------------------------------------------------
- -----------------------------------------------------------------------
-
-begin
- Report.Test ("CXG2010",
- "Check the accuracy of the exp function");
-
- -- the test only applies to machines with a radix of 2,4,8, or 16
- case Float'Machine_Radix is
- when 2 | 4 | 8 | 16 => null;
- when others =>
- Report.Not_Applicable ("only applicable to binary radix");
- Report.Result;
- return;
- end case;
-
- if Verbose then
- Report.Comment ("checking Standard.Float");
- end if;
-
- Float_Check.Do_Test;
-
- if Verbose then
- Report.Comment ("checking a digits" &
- Integer'Image (System.Max_Digits) &
- " floating point type");
- end if;
-
- A_Long_Float_Check.Do_Test;
-
- if Verbose then
- Report.Comment ("checking non-generic package");
- end if;
-
- Non_Generic_Check.Do_Test;
-
- Report.Result;
-end CXG2010;
diff --git a/gcc/testsuite/ada/acats/tests/cxg/cxg2011.a b/gcc/testsuite/ada/acats/tests/cxg/cxg2011.a
deleted file mode 100644
index 2c018b1321e..00000000000
--- a/gcc/testsuite/ada/acats/tests/cxg/cxg2011.a
+++ /dev/null
@@ -1,490 +0,0 @@
--- CXG2011.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that the log function returns
--- results that are within the error bound allowed.
---
--- TEST DESCRIPTION:
--- This test consists of a generic package that is
--- instantiated to check both Float and a long float type.
--- The test for each floating point type is divided into
--- several parts:
--- Special value checks where the result is a known constant.
--- Checks in a range where a Taylor series can be used to compute
--- the expected result.
--- Checks that use an identity for determining the result.
--- Exception checks.
---
--- SPECIAL REQUIREMENTS
--- The Strict Mode for the numerical accuracy must be
--- selected. The method by which this mode is selected
--- is implementation dependent.
---
--- APPLICABILITY CRITERIA:
--- This test applies only to implementations supporting the
--- Numerics Annex.
--- This test only applies to the Strict Mode for numerical
--- accuracy.
---
---
--- CHANGE HISTORY:
--- 1 Mar 96 SAIC Initial release for 2.1
--- 22 Aug 96 SAIC Improved Check routine
--- 02 DEC 97 EDS Log (0.0) must raise Constraint_Error,
--- not Argument_Error
---!
-
---
--- References:
---
--- Software Manual for the Elementary Functions
--- William J. Cody, Jr. and William Waite
--- Prentice-Hall, 1980
---
--- CRC Standard Mathematical Tables
--- 23rd Edition
---
--- Implementation and Testing of Function Software
--- W. J. Cody
--- Problems and Methodologies in Mathematical Software Production
--- editors P. C. Messina and A. Murli
--- Lecture Notes in Computer Science Volume 142
--- Springer Verlag, 1982
---
-
-with System;
-with Report;
-with Ada.Numerics.Generic_Elementary_Functions;
-procedure CXG2011 is
- Verbose : constant Boolean := False;
- Max_Samples : constant := 1000;
-
- -- CRC Handbook Page 738
- Ln10 : constant := 2.30258_50929_94045_68401_79914_54684_36420_76011_01489;
- Ln2 : constant := 0.69314_71805_59945_30941_72321_21458_17656_80755_00134;
-
- generic
- type Real is digits <>;
- package Generic_Check is
- procedure Do_Test;
- end Generic_Check;
-
- package body Generic_Check is
- package Elementary_Functions is new
- Ada.Numerics.Generic_Elementary_Functions (Real);
- function Sqrt (X : Real'Base) return Real'Base renames
- Elementary_Functions.Sqrt;
- function Exp (X : Real'Base) return Real'Base renames
- Elementary_Functions.Exp;
- function Log (X : Real'Base) return Real'Base renames
- Elementary_Functions.Log;
- function Log (X, Base : Real'Base) return Real'Base renames
- Elementary_Functions.Log;
-
- -- flag used to terminate some tests early
- Accuracy_Error_Reported : Boolean := False;
-
-
- -- The following value is a lower bound on the accuracy
- -- required. It is normally 0.0 so that the lower bound
- -- is computed from Model_Epsilon. However, for tests
- -- where the expected result is only known to a certain
- -- amount of precision this bound takes on a non-zero
- -- value to account for that level of precision.
- Error_Low_Bound : Real := 0.0;
-
- procedure Check (Actual, Expected : Real;
- Test_Name : String;
- MRE : Real) is
- Max_Error : Real;
- Rel_Error : Real;
- Abs_Error : Real;
- begin
- -- In the case where the expected result is very small or 0
- -- we compute the maximum error as a multiple of Model_Epsilon
- -- instead of Model_Epsilon and Expected.
- Rel_Error := MRE * abs Expected * Real'Model_Epsilon;
- Abs_Error := MRE * Real'Model_Epsilon;
- if Rel_Error > Abs_Error then
- Max_Error := Rel_Error;
- else
- Max_Error := Abs_Error;
- end if;
-
- -- take into account the low bound on the error
- if Max_Error < Error_Low_Bound then
- Max_Error := Error_Low_Bound;
- end if;
-
- if abs (Actual - Expected) > Max_Error then
- Accuracy_Error_Reported := True;
- Report.Failed (Test_Name &
- " actual: " & Real'Image (Actual) &
- " expected: " & Real'Image (Expected) &
- " difference: " & Real'Image (Actual - Expected) &
- " max err:" & Real'Image (Max_Error) );
- elsif Verbose then
- if Actual = Expected then
- Report.Comment (Test_Name & " exact result");
- else
- Report.Comment (Test_Name & " passed");
- end if;
- end if;
- end Check;
-
-
- procedure Special_Value_Test is
- begin
-
- --- test 1 ---
- declare
- Y : Real;
- begin
- Y := Log(1.0);
- Check (Y, 0.0, "special value test 1 -- log(1)",
- 0.0); -- no error allowed
- exception
- when Constraint_Error =>
- Report.Failed ("Constraint_Error raised in test 1");
- when others =>
- Report.Failed ("exception in test 1");
- end;
-
- --- test 2 ---
- declare
- Y : Real;
- begin
- Y := Log(10.0);
- Check (Y, Ln10, "special value test 2 -- log(10)", 4.0);
- exception
- when Constraint_Error =>
- Report.Failed ("Constraint_Error raised in test 2");
- when others =>
- Report.Failed ("exception in test 2");
- end;
-
- --- test 3 ---
- declare
- Y : Real;
- begin
- Y := Log (2.0);
- Check (Y, Ln2, "special value test 3 -- log(2)", 4.0);
- exception
- when Constraint_Error =>
- Report.Failed ("Constraint_Error raised in test 3");
- when others =>
- Report.Failed ("exception in test 3");
- end;
-
- --- test 4 ---
- declare
- Y : Real;
- begin
- Y := Log (2.0 ** 18, 2.0);
- Check (Y, 18.0, "special value test 4 -- log(2**18,2)", 4.0);
- exception
- when Constraint_Error =>
- Report.Failed ("Constraint_Error raised in test 4");
- when others =>
- Report.Failed ("exception in test 4");
- end;
- end Special_Value_Test;
-
-
- procedure Taylor_Series_Test is
- -- Use a 4 term taylor series expansion to check a selection of
- -- arguments very near 1.0.
- -- The range is chosen so that the 4 term taylor series will
- -- provide accuracy to machine precision. Cody pg 49-50.
- Half_Range : constant Real := Real'Model_Epsilon * 50.0;
- A : constant Real := 1.0 - Half_Range;
- B : constant Real := 1.0 + Half_Range;
- X : Real;
- Xm1 : Real;
- Expected : Real;
- Actual : Real;
-
- begin
- Accuracy_Error_Reported := False; -- reset
- for I in 1..Max_Samples loop
- X := (B - A) * Real (I) / Real (Max_Samples) + A;
-
- Xm1 := X - 1.0;
- -- The following is the first 4 terms of the taylor series
- -- that has been rearranged to minimize error in the calculation
- Expected := (Xm1 * (1.0/3.0 - Xm1/4.0) - 0.5) * Xm1 * Xm1 + Xm1;
-
- Actual := Log (X);
- Check (Actual, Expected,
- "Taylor Series Test -" &
- Integer'Image (I) &
- " log (" & Real'Image (X) & ")",
- 4.0);
- if Accuracy_Error_Reported then
- -- only report the first error in this test in order to keep
- -- lots of failures from producing a huge error log
- return;
- end if;
- end loop;
- exception
- when Constraint_Error =>
- Report.Failed
- ("Constraint_Error raised in Taylor Series Test");
- when others =>
- Report.Failed ("exception in Taylor Series Test");
- end Taylor_Series_Test;
-
-
-
- procedure Log_Difference_Identity is
- -- Check using the identity ln(x) = ln(17x/16) - ln(17/16)
- -- over the range A to B.
- -- The selected range assures that both X and 17x/16 will
- -- have the same exponents and neither argument gets too close
- -- to 1. Cody pg 50.
- A : constant Real := 1.0 / Sqrt (2.0);
- B : constant Real := 15.0 / 16.0;
- X : Real;
- Expected : Real;
- Actual : Real;
- begin
- Accuracy_Error_Reported := False; -- reset
- for I in 1..Max_Samples loop
- X := (B - A) * Real (I) / Real (Max_Samples) + A;
- -- magic argument purification
- X := Real'Machine (Real'Machine (X+8.0) - 8.0);
-
- Expected := Log (X + X / 16.0) - Log (17.0/16.0);
-
- Actual := Log (X);
- Check (Actual, Expected,
- "Log Difference Identity -" &
- Integer'Image (I) &
- " log (" & Real'Image (X) & ")",
- 4.0);
-
- if Accuracy_Error_Reported then
- -- only report the first error in this test in order to keep
- -- lots of failures from producing a huge error log
- return;
- end if;
- end loop;
- exception
- when Constraint_Error =>
- Report.Failed
- ("Constraint_Error raised in Log Difference Identity Test");
- when others =>
- Report.Failed ("exception in Log Difference Identity Test");
- end Log_Difference_Identity;
-
-
- procedure Log_Product_Identity is
- -- Check using the identity ln(x**2) = 2ln(x)
- -- over the range A to B.
- -- This large range is chosen to minimize the possibility of
- -- undetected systematic errors. Cody pg 53.
- A : constant Real := 16.0;
- B : constant Real := 240.0;
- X : Real;
- Expected : Real;
- Actual : Real;
- begin
- Accuracy_Error_Reported := False; -- reset
- for I in 1..Max_Samples loop
- X := (B - A) * Real (I) / Real (Max_Samples) + A;
- -- magic argument purification
- X := Real'Machine (Real'Machine (X+8.0) - 8.0);
-
- Expected := 2.0 * Log (X);
-
- Actual := Log (X*X);
- Check (Actual, Expected,
- "Log Product Identity -" &
- Integer'Image (I) &
- " log (" & Real'Image (X) & ")",
- 4.0);
- if Accuracy_Error_Reported then
- -- only report the first error in this test in order to keep
- -- lots of failures from producing a huge error log
- return;
- end if;
- end loop;
- exception
- when Constraint_Error =>
- Report.Failed
- ("Constraint_Error raised in Log Product Identity Test");
- when others =>
- Report.Failed ("exception in Log Product Identity Test");
- end Log_Product_Identity;
-
-
- procedure Log10_Test is
- -- Check using the identity log(x) = log(11x/10) - log(1.1)
- -- over the range A to B. See Cody pg 52.
- A : constant Real := 1.0 / Sqrt (10.0);
- B : constant Real := 0.9;
- X : Real;
- Expected : Real;
- Actual : Real;
- begin
- if Real'Digits > 17 then
- -- constant used below is accuract to 17 digits
- Error_Low_Bound := 0.00000_00000_00000_01;
- Report.Comment ("log accuracy checked to 19 digits");
- end if;
- Accuracy_Error_Reported := False; -- reset
- for I in 1..Max_Samples loop
- X := (B - A) * Real (I) / Real (Max_Samples) + A;
-
- Expected := Log (X + X/10.0, 10.0)
- - 3.77060_15822_50407_5E-4 - 21.0 / 512.0;
-
- Actual := Log (X, 10.0);
- Check (Actual, Expected,
- "Log 10 Test -" &
- Integer'Image (I) &
- " log (" & Real'Image (X) & ")",
- 4.0);
-
- -- only report the first error in this test in order to keep
- -- lots of failures from producing a huge error log
- exit when Accuracy_Error_Reported;
- end loop;
- Error_Low_Bound := 0.0; -- reset
-
- exception
- when Constraint_Error =>
- Report.Failed
- ("Constraint_Error raised in Log 10 Test");
- when others =>
- Report.Failed ("exception in Log 10 Test");
- end Log10_Test;
-
-
- procedure Exception_Test is
- X1, X2, X3, X4 : Real;
- begin
- begin
- X1 := Log (0.0);
- Report.Failed ("exception not raised for LOG(0)");
- exception
- -- Log (0.0) must raise Constraint_Error, not Argument_Error,
- -- as per A.5.1(28,29). Was incorrect in ACVC 2.1 release.
- when Ada.Numerics.Argument_Error =>
- Report.Failed ("Argument_Error raised instead of" &
- " Constraint_Error for LOG(0)--A.5.1(28,29)");
- when Constraint_Error => null; -- ok
- when others =>
- Report.Failed ("wrong exception raised for LOG(0)");
- end;
-
- begin
- X2 := Log ( 1.0, 0.0);
- Report.Failed ("exception not raised for LOG(1,0)");
- exception
- when Ada.Numerics.Argument_Error => null; -- ok
- when Constraint_Error =>
- Report.Failed ("constraint_error raised instead of" &
- " argument_error for LOG(1,0)");
- when others =>
- Report.Failed ("wrong exception raised for LOG(1,0)");
- end;
-
- begin
- X3 := Log (1.0, 1.0);
- Report.Failed ("exception not raised for LOG(1,1)");
- exception
- when Ada.Numerics.Argument_Error => null; -- ok
- when Constraint_Error =>
- Report.Failed ("constraint_error raised instead of" &
- " argument_error for LOG(1,1)");
- when others =>
- Report.Failed ("wrong exception raised for LOG(1,1)");
- end;
-
- begin
- X4 := Log (1.0, -10.0);
- Report.Failed ("exception not raised for LOG(1,-10)");
- exception
- when Ada.Numerics.Argument_Error => null; -- ok
- when Constraint_Error =>
- Report.Failed ("constraint_error raised instead of" &
- " argument_error for LOG(1,-10)");
- when others =>
- Report.Failed ("wrong exception raised for LOG(1,-10)");
- end;
-
- -- optimizer thwarting
- if Report.Ident_Bool (False) then
- Report.Comment (Real'Image (X1+X2+X3+X4));
- end if;
- end Exception_Test;
-
-
- procedure Do_Test is
- begin
- Special_Value_Test;
- Taylor_Series_Test;
- Log_Difference_Identity;
- Log_Product_Identity;
- Log10_Test;
- Exception_Test;
- end Do_Test;
- end Generic_Check;
-
- -----------------------------------------------------------------------
- -----------------------------------------------------------------------
- package Float_Check is new Generic_Check (Float);
-
- -- check the floating point type with the most digits
- type A_Long_Float is digits System.Max_Digits;
- package A_Long_Float_Check is new Generic_Check (A_Long_Float);
-
- -----------------------------------------------------------------------
- -----------------------------------------------------------------------
-
-
-begin
- Report.Test ("CXG2011",
- "Check the accuracy of the log function");
-
- if Verbose then
- Report.Comment ("checking Standard.Float");
- end if;
-
- Float_Check.Do_Test;
-
- if Verbose then
- Report.Comment ("checking a digits" &
- Integer'Image (System.Max_Digits) &
- " floating point type");
- end if;
-
- A_Long_Float_Check.Do_Test;
-
-
- Report.Result;
-end CXG2011;
diff --git a/gcc/testsuite/ada/acats/tests/cxg/cxg2012.a b/gcc/testsuite/ada/acats/tests/cxg/cxg2012.a
deleted file mode 100644
index 6a665d0e077..00000000000
--- a/gcc/testsuite/ada/acats/tests/cxg/cxg2012.a
+++ /dev/null
@@ -1,438 +0,0 @@
--- CXG2012.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that the exponentiation operator returns
--- results that are within the error bound allowed.
---
--- TEST DESCRIPTION:
--- This test consists of a generic package that is
--- instantiated to check both Float and a long float type.
--- The test for each floating point type is divided into
--- several parts:
--- Special value checks where the result is a known constant.
--- Checks that use an identity for determining the result.
--- Exception checks.
--- While this test concentrates on the "**" operator
--- defined in Generic_Elementary_Functions, a check is also
--- performed on the standard "**" operator.
---
--- SPECIAL REQUIREMENTS
--- The Strict Mode for the numerical accuracy must be
--- selected. The method by which this mode is selected
--- is implementation dependent.
---
--- APPLICABILITY CRITERIA:
--- This test applies only to implementations supporting the
--- Numerics Annex.
--- This test only applies to the Strict Mode for numerical
--- accuracy.
---
---
--- CHANGE HISTORY:
--- 7 Mar 96 SAIC Initial release for 2.1
--- 2 Sep 96 SAIC Improvements as suggested by reviewers
--- 3 Jun 98 EDS Add parens to ensure that the expression is not
--- evaluated by multiplying its two large terms
--- together and overflowing.
--- 3 Dec 01 RLB Added 'Machine to insure that equality tests
--- are certain to work.
---
---!
-
---
--- References:
---
--- Software Manual for the Elementary Functions
--- William J. Cody, Jr. and William Waite
--- Prentice-Hall, 1980
---
--- CRC Standard Mathematical Tables
--- 23rd Edition
---
--- Implementation and Testing of Function Software
--- W. J. Cody
--- Problems and Methodologies in Mathematical Software Production
--- editors P. C. Messina and A. Murli
--- Lecture Notes in Computer Science Volume 142
--- Springer Verlag, 1982
---
-
-with System;
-with Report;
-with Ada.Numerics.Generic_Elementary_Functions;
-procedure CXG2012 is
- Verbose : constant Boolean := False;
- Max_Samples : constant := 1000;
-
- -- CRC Standard Mathematical Tables; 23rd Edition; pg 738
- Sqrt2 : constant :=
- 1.41421_35623_73095_04880_16887_24209_69807_85696_71875_37695;
- Sqrt3 : constant :=
- 1.73205_08075_68877_29352_74463_41505_87236_69428_05253_81039;
-
-
- generic
- type Real is digits <>;
- package Generic_Check is
- procedure Do_Test;
- end Generic_Check;
-
- package body Generic_Check is
- package Elementary_Functions is new
- Ada.Numerics.Generic_Elementary_Functions (Real);
- function Sqrt (X : Real) return Real renames
- Elementary_Functions.Sqrt;
- function Exp (X : Real) return Real renames
- Elementary_Functions.Exp;
- function Log (X : Real) return Real renames
- Elementary_Functions.Log;
- function "**" (L, R : Real) return Real renames
- Elementary_Functions."**";
-
- -- flag used to terminate some tests early
- Accuracy_Error_Reported : Boolean := False;
-
-
-
- procedure Check (Actual, Expected : Real;
- Test_Name : String;
- MRE : Real) is
- Max_Error : Real;
- Rel_Error : Real;
- Abs_Error : Real;
- begin
- -- In the case where the expected result is very small or 0
- -- we compute the maximum error as a multiple of Model_Epsilon
- -- instead of Model_Epsilon and Expected.
- Rel_Error := MRE * (abs Expected * Real'Model_Epsilon);
- Abs_Error := MRE * Real'Model_Epsilon;
- if Rel_Error > Abs_Error then
- Max_Error := Rel_Error;
- else
- Max_Error := Abs_Error;
- end if;
-
- if abs (Actual - Expected) > Max_Error then
- Accuracy_Error_Reported := True;
- Report.Failed (Test_Name &
- " actual: " & Real'Image (Actual) &
- " expected: " & Real'Image (Expected) &
- " difference: " & Real'Image (Actual - Expected) &
- " max err:" & Real'Image (Max_Error) );
- elsif Verbose then
- if Actual = Expected then
- Report.Comment (Test_Name & " exact result");
- else
- Report.Comment (Test_Name & " passed");
- end if;
- end if;
- end Check;
-
-
- -- the following version of Check computes the allowed error bound
- -- using the operands
- procedure Check (Actual, Expected : Real;
- Left, Right : Real;
- Test_Name : String;
- MRE_Factor : Real := 1.0) is
- MRE : Real;
- begin
- MRE := MRE_Factor * (4.0 + abs (Right * Log(Left)) / 32.0);
- Check (Actual, Expected, Test_Name, MRE);
- end Check;
-
-
- procedure Real_To_Integer_Test is
- type Int_Check is
- record
- Left : Real;
- Right : Integer;
- Expected : Real;
- end record;
- type Int_Checks is array (Positive range <>) of Int_Check;
-
- -- the following tests use only model numbers so the result
- -- is expected to be exact.
- IC : constant Int_Checks :=
- ( ( 2.0, 5, 32.0),
- ( -2.0, 5, -32.0),
- ( 0.5, -5, 32.0),
- ( 2.0, 0, 1.0),
- ( 0.0, 0, 1.0) );
- begin
- for I in IC'Range loop
- declare
- Y : Real;
- begin
- Y := IC (I).Left ** IC (I).Right;
- Check (Y, IC (I).Expected,
- "real to integer test" &
- Real'Image (IC (I).Left) & " ** " &
- Integer'Image (IC (I).Right),
- 0.0); -- no error allowed
- exception
- when Constraint_Error =>
- Report.Failed ("Constraint_Error raised in rtoi test " &
- Integer'Image (I));
- when others =>
- Report.Failed ("exception in rtoi test " &
- Integer'Image (I));
- end;
- end loop;
- end Real_To_Integer_Test;
-
-
- procedure Special_Value_Test is
- No_Error : constant := 0.0;
- begin
- Check (0.0 ** 1.0, 0.0, "0**1", No_Error);
- Check (1.0 ** 0.0, 1.0, "1**0", No_Error);
-
- Check ( 2.0 ** 5.0, 32.0, 2.0, 5.0, "2**5");
- Check ( 0.5**(-5.0), 32.0, 0.5, -5.0, "0.5**-5");
-
- Check (Sqrt2 ** 4.0, 4.0, Sqrt2, 4.0, "Sqrt2**4");
- Check (Sqrt3 ** 6.0, 27.0, Sqrt3, 6.0, "Sqrt3**6");
-
- Check (2.0 ** 0.5, Sqrt2, 2.0, 0.5, "2.0**0.5");
-
- exception
- when Constraint_Error =>
- Report.Failed ("Constraint_Error raised in Special Value Test");
- when others =>
- Report.Failed ("exception in Special Value Test");
- end Special_Value_Test;
-
-
- procedure Small_Range_Test is
- -- Several checks over the range 1/radix .. 1
- A : constant Real := 1.0 / Real (Real'Machine_Radix);
- B : constant Real := 1.0;
- X : Real;
- -- In the cases below where the expected result is
- -- inexact we allow an additional error amount of
- -- 1.0 * Model_Epsilon to account for that error.
- -- This is accomplished by the factor of 1.25 times
- -- the computed error bound (which is > 4.0) thus
- -- increasing the error bound by at least
- -- 1.0 * Model_Epsilon
- begin
- Accuracy_Error_Reported := False; -- reset
- for I in 0..Max_Samples loop
- X := Real'Machine((B - A) * Real (I) / Real (Max_Samples) + A);
-
- Check (X ** 1.0, X, -- exact result required
- "Small range" & Integer'Image (I) & ": " &
- Real'Image (X) & " ** 1.0",
- 0.0);
-
- Check ((X*X) ** 1.5, X**3, X*X, 1.5,
- "Small range" & Integer'Image (I) & ": " &
- Real'Image (X*X) & " ** 1.5",
- 1.25);
-
- Check (X ** 13.5, 1.0 / (X ** (-13.5)), X, 13.5,
- "Small range" & Integer'Image (I) & ": " &
- Real'Image (X) & " ** 13.5",
- 2.0); -- 2 ** computations
-
- Check ((X*X) ** 1.25, X**(2.5), X*X, 1.25,
- "Small range" & Integer'Image (I) & ": " &
- Real'Image (X*X) & " ** 1.25",
- 2.0); -- 2 ** computations
-
- if Accuracy_Error_Reported then
- -- only report the first error in this test in order to keep
- -- lots of failures from producing a huge error log
- return;
- end if;
-
- end loop;
-
- exception
- when Constraint_Error =>
- Report.Failed
- ("Constraint_Error raised in Small Range Test");
- when others =>
- Report.Failed ("exception in Small Range Test");
- end Small_Range_Test;
-
-
- procedure Large_Range_Test is
- -- Check over the range A to B where A is 1.0 and
- -- B is a large value.
- A : constant Real := 1.0;
- B : Real;
- X : Real;
- Iteration : Integer := 0;
- Subtest : Character := 'X';
- begin
- -- upper bound of range should be as large as possible where
- -- B**3 is still valid.
- B := Real'Safe_Last ** 0.333;
- Accuracy_Error_Reported := False; -- reset
- for I in 0..Max_Samples loop
- Iteration := I;
- Subtest := 'X';
- X := Real'Machine((B - A) * (Real (I) / Real (Max_Samples)) + A);
-
- Subtest := 'A';
- Check (X ** 1.0, X, -- exact result required
- "Large range" & Integer'Image (I) & ": " &
- Real'Image (X) & " ** 1.0",
- 0.0);
-
- Subtest := 'B';
- Check ((X*X) ** 1.5, X**3, X*X, 1.5,
- "Large range" & Integer'Image (I) & ": " &
- Real'Image (X*X) & " ** 1.5",
- 1.25); -- inexact expected result
-
- Subtest := 'C';
- Check ((X*X) ** 1.25, X**(2.5), X*X, 1.25,
- "Large range" & Integer'Image (I) & ": " &
- Real'Image (X*X) & " ** 1.25",
- 2.0); -- two ** operators
-
- if Accuracy_Error_Reported then
- -- only report the first error in this test in order to keep
- -- lots of failures from producing a huge error log
- return;
- end if;
-
- end loop;
- exception
- when Constraint_Error =>
- Report.Failed
- ("Constraint_Error raised in Large Range Test" &
- Integer'Image (Iteration) & Subtest);
- when others =>
- Report.Failed ("exception in Large Range Test" &
- Integer'Image (Iteration) & Subtest);
- end Large_Range_Test;
-
-
- procedure Exception_Test is
- X1, X2, X3, X4 : Real;
- begin
- begin
- X1 := 0.0 ** (-1.0);
- Report.Failed ("exception not raised for 0**-1");
- exception
- when Ada.Numerics.Argument_Error =>
- Report.Failed ("argument_error raised instead of" &
- " constraint_error for 0**-1");
- when Constraint_Error => null; -- ok
- when others =>
- Report.Failed ("wrong exception raised for 0**-1");
- end;
-
- begin
- X2 := 0.0 ** 0.0;
- Report.Failed ("exception not raised for 0**0");
- exception
- when Ada.Numerics.Argument_Error => null; -- ok
- when Constraint_Error =>
- Report.Failed ("constraint_error raised instead of" &
- " argument_error for 0**0");
- when others =>
- Report.Failed ("wrong exception raised for 0**0");
- end;
-
- begin
- X3 := (-1.0) ** 1.0;
- Report.Failed ("exception not raised for -1**1");
- exception
- when Ada.Numerics.Argument_Error => null; -- ok
- when Constraint_Error =>
- Report.Failed ("constraint_error raised instead of" &
- " argument_error for -1**1");
- when others =>
- Report.Failed ("wrong exception raised for -1**1");
- end;
-
- begin
- X4 := (-2.0) ** 2.0;
- Report.Failed ("exception not raised for -2**2");
- exception
- when Ada.Numerics.Argument_Error => null; -- ok
- when Constraint_Error =>
- Report.Failed ("constraint_error raised instead of" &
- " argument_error for -2**2");
- when others =>
- Report.Failed ("wrong exception raised for -2**2");
- end;
-
- -- optimizer thwarting
- if Report.Ident_Bool (False) then
- Report.Comment (Real'Image (X1+X2+X3+X4));
- end if;
- end Exception_Test;
-
-
- procedure Do_Test is
- begin
- Real_To_Integer_Test;
- Special_Value_Test;
- Small_Range_Test;
- Large_Range_Test;
- Exception_Test;
- end Do_Test;
- end Generic_Check;
-
- -----------------------------------------------------------------------
- -----------------------------------------------------------------------
- package Float_Check is new Generic_Check (Float);
-
- -- check the floating point type with the most digits
- type A_Long_Float is digits System.Max_Digits;
- package A_Long_Float_Check is new Generic_Check (A_Long_Float);
-
- -----------------------------------------------------------------------
- -----------------------------------------------------------------------
-
-
-begin
- Report.Test ("CXG2012",
- "Check the accuracy of the ** operator");
-
- if Verbose then
- Report.Comment ("checking Standard.Float");
- end if;
-
- Float_Check.Do_Test;
-
- if Verbose then
- Report.Comment ("checking a digits" &
- Integer'Image (System.Max_Digits) &
- " floating point type");
- end if;
-
- A_Long_Float_Check.Do_Test;
-
-
- Report.Result;
-end CXG2012;
diff --git a/gcc/testsuite/ada/acats/tests/cxg/cxg2013.a b/gcc/testsuite/ada/acats/tests/cxg/cxg2013.a
deleted file mode 100644
index 94f180b804d..00000000000
--- a/gcc/testsuite/ada/acats/tests/cxg/cxg2013.a
+++ /dev/null
@@ -1,367 +0,0 @@
--- CXG2013.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that the TAN and COT functions return
--- results that are within the error bound allowed.
---
--- TEST DESCRIPTION:
--- This test consists of a generic package that is
--- instantiated to check both Float and a long float type.
--- The test for each floating point type is divided into
--- several parts:
--- Special value checks where the result is a known constant.
--- Checks that use an identity for determining the result.
--- Exception checks.
---
--- SPECIAL REQUIREMENTS
--- The Strict Mode for the numerical accuracy must be
--- selected. The method by which this mode is selected
--- is implementation dependent.
---
--- APPLICABILITY CRITERIA:
--- This test applies only to implementations supporting the
--- Numerics Annex.
--- This test only applies to the Strict Mode for numerical
--- accuracy.
---
---
--- CHANGE HISTORY:
--- 11 Mar 96 SAIC Initial release for 2.1
--- 17 Aug 96 SAIC Commentary fixes.
--- 03 Feb 97 PWB.CTA Removed checks with explicit Cycle => 2.0*Pi
--- 02 DEC 97 EDS Change Max_Samples constant to 1001.
--- 29 JUN 98 EDS Deleted Special_Angle_Test as fatally flawed.
-
---!
-
---
--- References:
---
--- Software Manual for the Elementary Functions
--- William J. Cody, Jr. and William Waite
--- Prentice-Hall, 1980
---
--- CRC Standard Mathematical Tables
--- 23rd Edition
---
--- Implementation and Testing of Function Software
--- W. J. Cody
--- Problems and Methodologies in Mathematical Software Production
--- editors P. C. Messina and A. Murli
--- Lecture Notes in Computer Science Volume 142
--- Springer Verlag, 1982
---
-
-with System;
-with Report;
-with Ada.Numerics.Generic_Elementary_Functions;
-procedure CXG2013 is
- Verbose : constant Boolean := False;
- Max_Samples : constant := 1001;
-
- -- CRC Standard Mathematical Tables; 23rd Edition; pg 738
- Sqrt2 : constant :=
- 1.41421_35623_73095_04880_16887_24209_69807_85696_71875_37695;
- Sqrt3 : constant :=
- 1.73205_08075_68877_29352_74463_41505_87236_69428_05253_81039;
-
- Pi : constant := Ada.Numerics.Pi;
-
- generic
- type Real is digits <>;
- package Generic_Check is
- procedure Do_Test;
- end Generic_Check;
-
- package body Generic_Check is
- package Elementary_Functions is new
- Ada.Numerics.Generic_Elementary_Functions (Real);
- function Sqrt (X : Real) return Real renames
- Elementary_Functions.Sqrt;
- function Tan (X : Real) return Real renames
- Elementary_Functions.Tan;
- function Cot (X : Real) return Real renames
- Elementary_Functions.Cot;
- function Tan (X, Cycle : Real) return Real renames
- Elementary_Functions.Tan;
- function Cot (X, Cycle : Real) return Real renames
- Elementary_Functions.Cot;
-
- -- flag used to terminate some tests early
- Accuracy_Error_Reported : Boolean := False;
-
- -- factor to be applied in computing MRE
- Maximum_Relative_Error : constant Real := 4.0;
-
- procedure Check (Actual, Expected : Real;
- Test_Name : String;
- MRE : Real) is
- Max_Error : Real;
- Rel_Error : Real;
- Abs_Error : Real;
- begin
- -- In the case where the expected result is very small or 0
- -- we compute the maximum error as a multiple of Model_Epsilon instead
- -- of Model_Epsilon and Expected.
- Rel_Error := MRE * abs Expected * Real'Model_Epsilon;
- Abs_Error := MRE * Real'Model_Epsilon;
- if Rel_Error > Abs_Error then
- Max_Error := Rel_Error;
- else
- Max_Error := Abs_Error;
- end if;
-
- if abs (Actual - Expected) > Max_Error then
- Accuracy_Error_Reported := True;
- Report.Failed (Test_Name &
- " actual: " & Real'Image (Actual) &
- " expected: " & Real'Image (Expected) &
- " difference: " & Real'Image (Actual - Expected) &
- " max err:" & Real'Image (Max_Error) );
- elsif Verbose then
- if Actual = Expected then
- Report.Comment (Test_Name & " exact result");
- else
- Report.Comment (Test_Name & " passed");
- end if;
- end if;
- end Check;
-
-
-
- procedure Exact_Result_Test is
- No_Error : constant := 0.0;
- begin
- -- A.5.1(38);6.0
- Check (Tan (0.0), 0.0, "tan(0)", No_Error);
-
- -- A.5.1(41);6.0
- Check (Tan (180.0, 360.0), 0.0, "tan(180,360)", No_Error);
- Check (Tan (360.0, 360.0), 0.0, "tan(360,360)", No_Error);
- Check (Tan (720.0, 360.0), 0.0, "tan(720,360)", No_Error);
-
- -- A.5.1(41);6.0
- Check (Cot ( 90.0, 360.0), 0.0, "cot( 90,360)", No_Error);
- Check (Cot (270.0, 360.0), 0.0, "cot(270,360)", No_Error);
- Check (Cot (810.0, 360.0), 0.0, "cot(810,360)", No_Error);
-
- exception
- when Constraint_Error =>
- Report.Failed ("Constraint_Error raised in Exact_Result Test");
- when others =>
- Report.Failed ("exception in Exact_Result Test");
- end Exact_Result_Test;
-
-
- procedure Tan_Test (A, B : Real) is
- -- Use identity Tan(X) = [2*Tan(x/2)]/[1-Tan(x/2) ** 2]
- -- checks over the range -pi/4 .. pi/4 require no argument reduction
- -- checks over the range 7pi/8 .. 9pi/8 require argument reduction
- X, Y : Real;
- Actual1, Actual2 : Real;
- begin
- Accuracy_Error_Reported := False; -- reset
- for I in 1..Max_Samples loop
- X := (B - A) * Real (I) / Real (Max_Samples) + A;
- -- argument purification to insure x and x/2 are exact
- -- See Cody page 170.
- Y := Real'Machine (X*0.5);
- X := Real'Machine (Y + Y);
-
- Actual1 := Tan(X);
- Actual2 := (2.0 * Tan (Y)) / (1.0 - Tan (Y) ** 2);
-
- if abs (X - Pi) > ( (B-A)/Real(2*Max_Samples) ) then
- Check (Actual1, Actual2,
- "Tan_Test " & Integer'Image (I) & ": tan(" &
- Real'Image (X) & ") ",
- (1.0 + Sqrt2) * Maximum_Relative_Error);
- -- see Cody pg 165 for error bound info
- end if;
-
- if Accuracy_Error_Reported then
- -- only report the first error in this test in order to keep
- -- lots of failures from producing a huge error log
- return;
- end if;
-
- end loop;
-
- exception
- when Constraint_Error =>
- Report.Failed
- ("Constraint_Error raised in Tan_Test");
- when others =>
- Report.Failed ("exception in Tan_Test");
- end Tan_Test;
-
-
-
- procedure Cot_Test is
- -- Use identity Cot(X) = [Cot(X/2)**2 - 1]/[2*Cot(X/2)]
- A : constant := 6.0 * Pi;
- B : constant := 25.0 / 4.0 * Pi;
- X, Y : Real;
- Actual1, Actual2 : Real;
- begin
- Accuracy_Error_Reported := False; -- reset
- for I in 1..Max_Samples loop
- X := (B - A) * Real (I) / Real (Max_Samples) + A;
- -- argument purification to insure x and x/2 are exact.
- -- See Cody page 170.
- Y := Real'Machine (X*0.5);
- X := Real'Machine (Y + Y);
-
- Actual1 := Cot(X);
- Actual2 := (Cot (Y) ** 2 - 1.0) / (2.0 * Cot (Y));
-
- Check (Actual1, Actual2,
- "Cot_Test " & Integer'Image (I) & ": cot(" &
- Real'Image (X) & ") ",
- (1.0 + Sqrt2) * Maximum_Relative_Error);
- -- see Cody pg 165 for error bound info
-
- if Accuracy_Error_Reported then
- -- only report the first error in this test in order to keep
- -- lots of failures from producing a huge error log
- return;
- end if;
-
- end loop;
-
- exception
- when Constraint_Error =>
- Report.Failed
- ("Constraint_Error raised in Cot_Test");
- when others =>
- Report.Failed ("exception in Cot_Test");
- end Cot_Test;
-
-
- procedure Exception_Test is
- X1, X2, X3, X4, X5 : Real := 0.0;
- begin
-
-
- begin -- A.5.1(20);6.0
- X1 := Tan (0.0, Cycle => 0.0);
- Report.Failed ("no exception for cycle = 0.0");
- exception
- when Ada.Numerics.Argument_Error => null;
- when others =>
- Report.Failed ("wrong exception for cycle = 0.0");
- end;
-
- begin -- A.5.1(20);6.0
- X2 := Cot (1.0, Cycle => -3.0);
- Report.Failed ("no exception for cycle < 0.0");
- exception
- when Ada.Numerics.Argument_Error => null;
- when others =>
- Report.Failed ("wrong exception for cycle < 0.0");
- end;
-
- -- the remaining tests only apply to machines that overflow
- if Real'Machine_Overflows then -- A.5.1(28);6.0
-
- begin -- A.5.1(29);6.0
- X3 := Cot (0.0);
- Report.Failed ("exception not raised for cot(0)");
- exception
- when Constraint_Error => null; -- ok
- when others =>
- Report.Failed ("wrong exception raised for cot(0)");
- end;
-
- begin -- A.5.1(31);6.0
- X4 := Tan (90.0, 360.0);
- Report.Failed ("exception not raised for tan(90,360)");
- exception
- when Constraint_Error => null; -- ok
- when others =>
- Report.Failed ("wrong exception raised for tan(90,360)");
- end;
-
- begin -- A.5.1(32);6.0
- X5 := Cot (180.0, 360.0);
- Report.Failed ("exception not raised for cot(180,360)");
- exception
- when Constraint_Error => null; -- ok
- when others =>
- Report.Failed ("wrong exception raised for cot(180,360)");
- end;
- end if;
-
- -- optimizer thwarting
- if Report.Ident_Bool (False) then
- Report.Comment (Real'Image (X1+X2+X3+X4+X5));
- end if;
- end Exception_Test;
-
-
- procedure Do_Test is
- begin
- Exact_Result_Test;
- Tan_Test (-Pi/4.0, Pi/4.0);
- Tan_Test (7.0*Pi/8.0, 9.0*Pi/8.0);
- Cot_Test;
- Exception_Test;
- end Do_Test;
- end Generic_Check;
-
- -----------------------------------------------------------------------
- -----------------------------------------------------------------------
- package Float_Check is new Generic_Check (Float);
-
- -- check the floating point type with the most digits
- type A_Long_Float is digits System.Max_Digits;
- package A_Long_Float_Check is new Generic_Check (A_Long_Float);
-
- -----------------------------------------------------------------------
- -----------------------------------------------------------------------
-
-
-begin
- Report.Test ("CXG2013",
- "Check the accuracy of the TAN and COT functions");
-
- if Verbose then
- Report.Comment ("checking Standard.Float");
- end if;
-
- Float_Check.Do_Test;
-
- if Verbose then
- Report.Comment ("checking a digits" &
- Integer'Image (System.Max_Digits) &
- " floating point type");
- end if;
-
- A_Long_Float_Check.Do_Test;
-
-
- Report.Result;
-end CXG2013;
diff --git a/gcc/testsuite/ada/acats/tests/cxg/cxg2014.a b/gcc/testsuite/ada/acats/tests/cxg/cxg2014.a
deleted file mode 100644
index 48499a2556f..00000000000
--- a/gcc/testsuite/ada/acats/tests/cxg/cxg2014.a
+++ /dev/null
@@ -1,399 +0,0 @@
--- CXG2014.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that the SINH and COSH functions return
--- results that are within the error bound allowed.
---
--- TEST DESCRIPTION:
--- This test consists of a generic package that is
--- instantiated to check both Float and a long float type.
--- The test for each floating point type is divided into
--- several parts:
--- Special value checks where the result is a known constant.
--- Checks that use an identity for determining the result.
--- Exception checks.
---
--- SPECIAL REQUIREMENTS
--- The Strict Mode for the numerical accuracy must be
--- selected. The method by which this mode is selected
--- is implementation dependent.
---
--- APPLICABILITY CRITERIA:
--- This test applies only to implementations supporting the
--- Numerics Annex.
--- This test only applies to the Strict Mode for numerical
--- accuracy.
---
---
--- CHANGE HISTORY:
--- 15 Mar 96 SAIC Initial release for 2.1
--- 03 Jun 98 EDS In line 80, change 1000 to 1024, making it a model
--- number. Add Taylor Series terms in line 281.
--- 15 Feb 99 RLB Repaired Subtraction_Error_Test to avoid precision
--- problems.
---!
-
---
--- References:
---
--- Software Manual for the Elementary Functions
--- William J. Cody, Jr. and William Waite
--- Prentice-Hall, 1980
---
--- CRC Standard Mathematical Tables
--- 23rd Edition
---
--- Implementation and Testing of Function Software
--- W. J. Cody
--- Problems and Methodologies in Mathematical Software Production
--- editors P. C. Messina and A. Murli
--- Lecture Notes in Computer Science Volume 142
--- Springer Verlag, 1982
---
-
-with System;
-with Report;
-with Ada.Numerics.Generic_Elementary_Functions;
-procedure CXG2014 is
- Verbose : constant Boolean := False;
- Max_Samples : constant := 1024;
-
- E : constant := Ada.Numerics.E;
- Cosh1 : constant := (E + 1.0 / E) / 2.0; -- cosh(1.0)
-
- generic
- type Real is digits <>;
- package Generic_Check is
- procedure Do_Test;
- end Generic_Check;
-
- package body Generic_Check is
- package Elementary_Functions is new
- Ada.Numerics.Generic_Elementary_Functions (Real);
- function Sinh (X : Real) return Real renames
- Elementary_Functions.Sinh;
- function Cosh (X : Real) return Real renames
- Elementary_Functions.Cosh;
- function Log (X : Real) return Real renames
- Elementary_Functions.Log;
-
- -- flag used to terminate some tests early
- Accuracy_Error_Reported : Boolean := False;
-
-
- procedure Check (Actual, Expected : Real;
- Test_Name : String;
- MRE : Real) is
- Max_Error : Real;
- Rel_Error : Real;
- Abs_Error : Real;
- begin
- -- In the case where the expected result is very small or 0
- -- we compute the maximum error as a multiple of Model_Small instead
- -- of Model_Epsilon and Expected.
- Rel_Error := MRE * abs Expected * Real'Model_Epsilon;
- Abs_Error := MRE * Real'Model_Small;
- if Rel_Error > Abs_Error then
- Max_Error := Rel_Error;
- else
- Max_Error := Abs_Error;
- end if;
-
- if abs (Actual - Expected) > Max_Error then
- Accuracy_Error_Reported := True;
- Report.Failed (Test_Name &
- " actual: " & Real'Image (Actual) &
- " expected: " & Real'Image (Expected) &
- " difference: " & Real'Image (Actual - Expected) &
- " max err:" & Real'Image (Max_Error) );
- elsif Verbose then
- if Actual = Expected then
- Report.Comment (Test_Name & " exact result");
- else
- Report.Comment (Test_Name & " passed");
- end if;
- end if;
- end Check;
-
-
- procedure Special_Value_Test is
- -- In the following tests the expected result is accurate
- -- to the machine precision so the minimum guaranteed error
- -- bound can be used.
- Minimum_Error : constant := 8.0;
- begin
- Check (Sinh (1.0),
- (E - 1.0 / E) / 2.0,
- "sinh(1)",
- Minimum_Error);
- Check (Cosh (1.0),
- Cosh1,
- "cosh(1)",
- Minimum_Error);
- Check (Sinh (2.0),
- (E * E - (1.0 / (E * E))) / 2.0,
- "sinh(2)",
- Minimum_Error);
- Check (Cosh (2.0),
- (E * E + (1.0 / (E * E))) / 2.0,
- "cosh(2)",
- Minimum_Error);
- Check (Sinh (-1.0),
- (1.0 / E - E) / 2.0,
- "sinh(-1)",
- Minimum_Error);
- exception
- when Constraint_Error =>
- Report.Failed ("Constraint_Error raised in special value test");
- when others =>
- Report.Failed ("exception in special value test");
- end Special_Value_Test;
-
-
-
- procedure Exact_Result_Test is
- No_Error : constant := 0.0;
- begin
- -- A.5.1(38);6.0
- Check (Sinh (0.0), 0.0, "sinh(0)", No_Error);
- Check (Cosh (0.0), 1.0, "cosh(0)", No_Error);
- exception
- when Constraint_Error =>
- Report.Failed ("Constraint_Error raised in Exact_Result Test");
- when others =>
- Report.Failed ("exception in Exact_Result Test");
- end Exact_Result_Test;
-
-
- procedure Identity_1_Test is
- -- For the Sinh test use the identity
- -- 2 * Sinh(x) * Cosh(1) = Sinh(x+1) + Sinh (x-1)
- -- which is transformed to
- -- Sinh(x) = ((Sinh(x+1) + Sinh(x-1)) * C
- -- where C = 1/(2*Cosh(1))
- --
- -- For the Cosh test use the identity
- -- 2 * Cosh(x) * Cosh(1) = Cosh(x+1) + Cosh(x-1)
- -- which is transformed to
- -- Cosh(x) = C * (Cosh(x+1) + Cosh(x-1))
- -- where C is the same as above
- --
- -- see Cody pg 230-231 for details on the error analysis.
- -- The net result is a relative error bound of 16 * Model_Epsilon.
-
- A : constant := 3.0;
- -- large upper bound but not so large as to cause Cosh(B)
- -- to overflow
- B : constant Real := Log(Real'Safe_Last) - 2.0;
- X_Minus_1, X, X_Plus_1 : Real;
- Actual1, Actual2 : Real;
- C : constant := 1.0 / (2.0 * Cosh1);
- begin
- Accuracy_Error_Reported := False; -- reset
- for I in 1..Max_Samples loop
- -- make sure there is no error in x-1, x, and x+1
- X_Plus_1 := (B - A) * Real (I) / Real (Max_Samples) + A;
- X_Plus_1 := Real'Machine (X_Plus_1);
- X := Real'Machine (X_Plus_1 - 1.0);
- X_Minus_1 := Real'Machine (X - 1.0);
-
- -- Sinh(x) = ((Sinh(x+1) + Sinh(x-1)) * C
- Actual1 := Sinh(X);
- Actual2 := C * (Sinh(X_Plus_1) + Sinh(X_Minus_1));
-
- Check (Actual1, Actual2,
- "Identity_1_Test " & Integer'Image (I) & ": sinh(" &
- Real'Image (X) & ") ",
- 16.0);
-
- -- Cosh(x) = C * (Cosh(x+1) + Cosh(x-1))
- Actual1 := Cosh (X);
- Actual2 := C * (Cosh(X_Plus_1) + Cosh (X_Minus_1));
- Check (Actual1, Actual2,
- "Identity_1_Test " & Integer'Image (I) & ": cosh(" &
- Real'Image (X) & ") ",
- 16.0);
-
- if Accuracy_Error_Reported then
- -- only report the first error in this test in order to keep
- -- lots of failures from producing a huge error log
- return;
- end if;
-
- end loop;
-
- exception
- when Constraint_Error =>
- Report.Failed
- ("Constraint_Error raised in Identity_1_Test" &
- " for X=" & Real'Image (X));
- when others =>
- Report.Failed ("exception in Identity_1_Test" &
- " for X=" & Real'Image (X));
- end Identity_1_Test;
-
-
-
- procedure Subtraction_Error_Test is
- -- This test detects the error resulting from subtraction if
- -- the obvious algorithm was used for computing sinh. That is,
- -- it it is computed as (e**x - e**-x)/2.
- -- We check the result by using a Taylor series expansion that
- -- will produce a result accurate to the machine precision for
- -- the range under test.
- --
- -- The maximum relative error bound for this test is
- -- 8 for the sinh operation and 7 for the Taylor series
- -- for a total of 15 * Model_Epsilon
- A : constant := 0.0;
- B : constant := 0.5;
- X : Real;
- X_Squared : Real;
- Actual, Expected : Real;
- begin
- if Real'digits > 15 then
- return; -- The approximation below is not accurate beyond
- -- 15 digits. Adding more terms makes the error
- -- larger, so it makes the test worse for more normal
- -- values. Thus, we skip this subtest for larger than
- -- 15 digits.
- end if;
- Accuracy_Error_Reported := False; -- reset
- for I in 1..Max_Samples loop
- X := (B - A) * Real (I) / Real (Max_Samples) + A;
- X_Squared := X * X;
-
- Actual := Sinh(X);
-
- -- The Taylor series regrouped a bit
- Expected :=
- X * (1.0 + (X_Squared / 6.0) *
- (1.0 + (X_Squared/20.0) *
- (1.0 + (X_Squared/42.0) *
- (1.0 + (X_Squared/72.0) *
- (1.0 + (X_Squared/110.0) *
- (1.0 + (X_Squared/156.0)
- ))))));
-
- Check (Actual, Expected,
- "Subtraction_Error_Test " & Integer'Image (I) & ": sinh(" &
- Real'Image (X) & ") ",
- 15.0);
-
- if Accuracy_Error_Reported then
- -- only report the first error in this test in order to keep
- -- lots of failures from producing a huge error log
- return;
- end if;
-
- end loop;
-
- exception
- when Constraint_Error =>
- Report.Failed
- ("Constraint_Error raised in Subtraction_Error_Test");
- when others =>
- Report.Failed ("exception in Subtraction_Error_Test");
- end Subtraction_Error_Test;
-
-
- procedure Exception_Test is
- X1, X2 : Real := 0.0;
- begin
- -- this part of the test is only applicable if 'Machine_Overflows
- -- is true.
- if Real'Machine_Overflows then
-
- begin
- X1 := Sinh (Real'Safe_Last / 2.0);
- Report.Failed ("no exception for sinh overflow");
- exception
- when Constraint_Error => null;
- when others =>
- Report.Failed ("wrong exception sinh overflow");
- end;
-
- begin
- X2 := Cosh (Real'Safe_Last / 2.0);
- Report.Failed ("no exception for cosh overflow");
- exception
- when Constraint_Error => null;
- when others =>
- Report.Failed ("wrong exception cosh overflow");
- end;
-
- end if;
-
- -- optimizer thwarting
- if Report.Ident_Bool (False) then
- Report.Comment (Real'Image (X1 + X2));
- end if;
- end Exception_Test;
-
-
- procedure Do_Test is
- begin
- Special_Value_Test;
- Exact_Result_Test;
- Identity_1_Test;
- Subtraction_Error_Test;
- Exception_Test;
- end Do_Test;
- end Generic_Check;
-
- -----------------------------------------------------------------------
- -----------------------------------------------------------------------
- package Float_Check is new Generic_Check (Float);
-
- -- check the floating point type with the most digits
- type A_Long_Float is digits System.Max_Digits;
- package A_Long_Float_Check is new Generic_Check (A_Long_Float);
-
- -----------------------------------------------------------------------
- -----------------------------------------------------------------------
-
-
-begin
- Report.Test ("CXG2014",
- "Check the accuracy of the SINH and COSH functions");
-
- if Verbose then
- Report.Comment ("checking Standard.Float");
- end if;
-
- Float_Check.Do_Test;
-
- if Verbose then
- Report.Comment ("checking a digits" &
- Integer'Image (System.Max_Digits) &
- " floating point type");
- end if;
-
- A_Long_Float_Check.Do_Test;
-
-
- Report.Result;
-end CXG2014;
diff --git a/gcc/testsuite/ada/acats/tests/cxg/cxg2015.a b/gcc/testsuite/ada/acats/tests/cxg/cxg2015.a
deleted file mode 100644
index 50fda5e1f4f..00000000000
--- a/gcc/testsuite/ada/acats/tests/cxg/cxg2015.a
+++ /dev/null
@@ -1,686 +0,0 @@
--- CXG2015.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that the ARCSIN and ARCCOS functions return
--- results that are within the error bound allowed.
---
--- TEST DESCRIPTION:
--- This test consists of a generic package that is
--- instantiated to check both Float and a long float type.
--- The test for each floating point type is divided into
--- several parts:
--- Special value checks where the result is a known constant.
--- Checks in a specific range where a Taylor series can be
--- used to compute an accurate result for comparison.
--- Exception checks.
--- The Taylor series tests are a direct translation of the
--- FORTRAN code found in the reference.
---
--- SPECIAL REQUIREMENTS
--- The Strict Mode for the numerical accuracy must be
--- selected. The method by which this mode is selected
--- is implementation dependent.
---
--- APPLICABILITY CRITERIA:
--- This test applies only to implementations supporting the
--- Numerics Annex.
--- This test only applies to the Strict Mode for numerical
--- accuracy.
---
---
--- CHANGE HISTORY:
--- 18 Mar 96 SAIC Initial release for 2.1
--- 24 Apr 96 SAIC Fixed error bounds.
--- 17 Aug 96 SAIC Added reference information and improved
--- checking for machines with more than 23
--- digits of precision.
--- 03 Feb 97 PWB.CTA Removed checks with explicit Cycle => 2.0*Pi
--- 22 Dec 99 RLB Added model range checking to "exact" results,
--- in order to avoid too strictly requiring a specific
--- result, and too weakly checking results.
---
--- CHANGE NOTE:
--- According to Ken Dritz, author of the Numerics Annex of the RM,
--- one should never specify the cycle 2.0*Pi for the trigonometric
--- functions. In particular, if the machine number for the first
--- argument is not an exact multiple of the machine number for the
--- explicit cycle, then the specified exact results cannot be
--- reasonably expected. The affected checks in this test have been
--- marked as comments, with the additional notation "pwb-math".
--- Phil Brashear
---!
-
---
--- References:
---
--- Software Manual for the Elementary Functions
--- William J. Cody, Jr. and William Waite
--- Prentice-Hall, 1980
---
--- CRC Standard Mathematical Tables
--- 23rd Edition
---
--- Implementation and Testing of Function Software
--- W. J. Cody
--- Problems and Methodologies in Mathematical Software Production
--- editors P. C. Messina and A. Murli
--- Lecture Notes in Computer Science Volume 142
--- Springer Verlag, 1982
---
--- CELEFUNT: A Portable Test Package for Complex Elementary Functions
--- ACM Collected Algorithms number 714
-
-with System;
-with Report;
-with Ada.Numerics.Generic_Elementary_Functions;
-procedure CXG2015 is
- Verbose : constant Boolean := False;
- Max_Samples : constant := 1000;
-
-
- -- CRC Standard Mathematical Tables; 23rd Edition; pg 738
- Sqrt2 : constant :=
- 1.41421_35623_73095_04880_16887_24209_69807_85696_71875_37695;
- Sqrt3 : constant :=
- 1.73205_08075_68877_29352_74463_41505_87236_69428_05253_81039;
-
- Pi : constant := Ada.Numerics.Pi;
-
- -- relative error bound from G.2.4(7);6.0
- Minimum_Error : constant := 4.0;
-
- generic
- type Real is digits <>;
- Half_PI_Low : in Real; -- The machine number closest to, but not greater
- -- than PI/2.0.
- Half_PI_High : in Real;-- The machine number closest to, but not less
- -- than PI/2.0.
- PI_Low : in Real; -- The machine number closest to, but not greater
- -- than PI.
- PI_High : in Real; -- The machine number closest to, but not less
- -- than PI.
- package Generic_Check is
- procedure Do_Test;
- end Generic_Check;
-
- package body Generic_Check is
- package Elementary_Functions is new
- Ada.Numerics.Generic_Elementary_Functions (Real);
-
- function Arcsin (X : Real) return Real renames
- Elementary_Functions.Arcsin;
- function Arcsin (X, Cycle : Real) return Real renames
- Elementary_Functions.Arcsin;
- function Arccos (X : Real) return Real renames
- Elementary_Functions.ArcCos;
- function Arccos (X, Cycle : Real) return Real renames
- Elementary_Functions.ArcCos;
-
- -- needed for support
- function Log (X, Base : Real) return Real renames
- Elementary_Functions.Log;
-
- -- flag used to terminate some tests early
- Accuracy_Error_Reported : Boolean := False;
-
- -- The following value is a lower bound on the accuracy
- -- required. It is normally 0.0 so that the lower bound
- -- is computed from Model_Epsilon. However, for tests
- -- where the expected result is only known to a certain
- -- amount of precision this bound takes on a non-zero
- -- value to account for that level of precision.
- Error_Low_Bound : Real := 0.0;
-
-
- procedure Check (Actual, Expected : Real;
- Test_Name : String;
- MRE : Real) is
- Max_Error : Real;
- Rel_Error : Real;
- Abs_Error : Real;
- begin
- -- In the case where the expected result is very small or 0
- -- we compute the maximum error as a multiple of Model_Epsilon instead
- -- of Model_Epsilon and Expected.
- Rel_Error := MRE * abs Expected * Real'Model_Epsilon;
- Abs_Error := MRE * Real'Model_Epsilon;
- if Rel_Error > Abs_Error then
- Max_Error := Rel_Error;
- else
- Max_Error := Abs_Error;
- end if;
-
- -- take into account the low bound on the error
- if Max_Error < Error_Low_Bound then
- Max_Error := Error_Low_Bound;
- end if;
-
- if abs (Actual - Expected) > Max_Error then
- Accuracy_Error_Reported := True;
- Report.Failed (Test_Name &
- " actual: " & Real'Image (Actual) &
- " expected: " & Real'Image (Expected) &
- " difference: " & Real'Image (Actual - Expected) &
- " max err:" & Real'Image (Max_Error) );
- elsif Verbose then
- if Actual = Expected then
- Report.Comment (Test_Name & " exact result");
- else
- Report.Comment (Test_Name & " passed");
- end if;
- end if;
- end Check;
-
-
- procedure Special_Value_Test is
- -- In the following tests the expected result is accurate
- -- to the machine precision so the minimum guaranteed error
- -- bound can be used.
-
- type Data_Point is
- record
- Degrees,
- Radians,
- Argument,
- Error_Bound : Real;
- end record;
-
- type Test_Data_Type is array (Positive range <>) of Data_Point;
-
- -- the values in the following tables only involve static
- -- expressions so no loss of precision occurs. However,
- -- rounding can be an issue with expressions involving Pi
- -- and square roots. The error bound specified in the
- -- table takes the sqrt error into account but not the
- -- error due to Pi. The Pi error is added in in the
- -- radians test below.
-
- Arcsin_Test_Data : constant Test_Data_Type := (
- -- degrees radians sine error_bound test #
- --( 0.0, 0.0, 0.0, 0.0 ), -- 1 - In Exact_Result_Test.
- ( 30.0, Pi/6.0, 0.5, 4.0 ), -- 2
- ( 60.0, Pi/3.0, Sqrt3/2.0, 5.0 ), -- 3
- --( 90.0, Pi/2.0, 1.0, 4.0 ), -- 4 - In Exact_Result_Test.
- --(-90.0, -Pi/2.0, -1.0, 4.0 ), -- 5 - In Exact_Result_Test.
- (-60.0, -Pi/3.0, -Sqrt3/2.0, 5.0 ), -- 6
- (-30.0, -Pi/6.0, -0.5, 4.0 ), -- 7
- ( 45.0, Pi/4.0, Sqrt2/2.0, 5.0 ), -- 8
- (-45.0, -Pi/4.0, -Sqrt2/2.0, 5.0 ) ); -- 9
-
- Arccos_Test_Data : constant Test_Data_Type := (
- -- degrees radians cosine error_bound test #
- --( 0.0, 0.0, 1.0, 0.0 ), -- 1 - In Exact_Result_Test.
- ( 30.0, Pi/6.0, Sqrt3/2.0, 5.0 ), -- 2
- ( 60.0, Pi/3.0, 0.5, 4.0 ), -- 3
- --( 90.0, Pi/2.0, 0.0, 4.0 ), -- 4 - In Exact_Result_Test.
- (120.0, 2.0*Pi/3.0, -0.5, 4.0 ), -- 5
- (150.0, 5.0*Pi/6.0, -Sqrt3/2.0, 5.0 ), -- 6
- --(180.0, Pi, -1.0, 4.0 ), -- 7 - In Exact_Result_Test.
- ( 45.0, Pi/4.0, Sqrt2/2.0, 5.0 ), -- 8
- (135.0, 3.0*Pi/4.0, -Sqrt2/2.0, 5.0 ) ); -- 9
-
- Cycle_Error,
- Radian_Error : Real;
- begin
- for I in Arcsin_Test_Data'Range loop
-
- -- note exact result requirements A.5.1(38);6.0 and
- -- G.2.4(12);6.0
- if Arcsin_Test_Data (I).Error_Bound = 0.0 then
- Cycle_Error := 0.0;
- Radian_Error := 0.0;
- else
- Cycle_Error := Arcsin_Test_Data (I).Error_Bound;
- -- allow for rounding error in the specification of Pi
- Radian_Error := Cycle_Error + 1.0;
- end if;
-
- Check (Arcsin (Arcsin_Test_Data (I).Argument),
- Arcsin_Test_Data (I).Radians,
- "test" & Integer'Image (I) &
- " arcsin(" &
- Real'Image (Arcsin_Test_Data (I).Argument) &
- ")",
- Radian_Error);
---pwb-math Check (Arcsin (Arcsin_Test_Data (I).Argument, 2.0 * Pi),
---pwb-math Arcsin_Test_Data (I).Radians,
---pwb-math "test" & Integer'Image (I) &
---pwb-math " arcsin(" &
---pwb-math Real'Image (Arcsin_Test_Data (I).Argument) &
---pwb-math ", 2pi)",
---pwb-math Cycle_Error);
- Check (Arcsin (Arcsin_Test_Data (I).Argument, 360.0),
- Arcsin_Test_Data (I).Degrees,
- "test" & Integer'Image (I) &
- " arcsin(" &
- Real'Image (Arcsin_Test_Data (I).Argument) &
- ", 360)",
- Cycle_Error);
- end loop;
-
-
- for I in Arccos_Test_Data'Range loop
-
- -- note exact result requirements A.5.1(39);6.0 and
- -- G.2.4(12);6.0
- if Arccos_Test_Data (I).Error_Bound = 0.0 then
- Cycle_Error := 0.0;
- Radian_Error := 0.0;
- else
- Cycle_Error := Arccos_Test_Data (I).Error_Bound;
- -- allow for rounding error in the specification of Pi
- Radian_Error := Cycle_Error + 1.0;
- end if;
-
- Check (Arccos (Arccos_Test_Data (I).Argument),
- Arccos_Test_Data (I).Radians,
- "test" & Integer'Image (I) &
- " arccos(" &
- Real'Image (Arccos_Test_Data (I).Argument) &
- ")",
- Radian_Error);
---pwb-math Check (Arccos (Arccos_Test_Data (I).Argument, 2.0 * Pi),
---pwb-math Arccos_Test_Data (I).Radians,
---pwb-math "test" & Integer'Image (I) &
---pwb-math " arccos(" &
---pwb-math Real'Image (Arccos_Test_Data (I).Argument) &
---pwb-math ", 2pi)",
---pwb-math Cycle_Error);
- Check (Arccos (Arccos_Test_Data (I).Argument, 360.0),
- Arccos_Test_Data (I).Degrees,
- "test" & Integer'Image (I) &
- " arccos(" &
- Real'Image (Arccos_Test_Data (I).Argument) &
- ", 360)",
- Cycle_Error);
- end loop;
-
- exception
- when Constraint_Error =>
- Report.Failed ("Constraint_Error raised in special value test");
- when others =>
- Report.Failed ("exception in special value test");
- end Special_Value_Test;
-
-
- procedure Check_Exact (Actual, Expected_Low, Expected_High : Real;
- Test_Name : String) is
- -- If the expected result is not a model number, then Expected_Low is
- -- the first machine number less than the (exact) expected
- -- result, and Expected_High is the first machine number greater than
- -- the (exact) expected result. If the expected result is a model
- -- number, Expected_Low = Expected_High = the result.
- Model_Expected_Low : Real := Expected_Low;
- Model_Expected_High : Real := Expected_High;
- begin
- -- Calculate the first model number nearest to, but below (or equal)
- -- to the expected result:
- while Real'Model (Model_Expected_Low) /= Model_Expected_Low loop
- -- Try the next machine number lower:
- Model_Expected_Low := Real'Adjacent(Model_Expected_Low, 0.0);
- end loop;
- -- Calculate the first model number nearest to, but above (or equal)
- -- to the expected result:
- while Real'Model (Model_Expected_High) /= Model_Expected_High loop
- -- Try the next machine number higher:
- Model_Expected_High := Real'Adjacent(Model_Expected_High, 100.0);
- end loop;
-
- if Actual < Model_Expected_Low or Actual > Model_Expected_High then
- Accuracy_Error_Reported := True;
- if Actual < Model_Expected_Low then
- Report.Failed (Test_Name &
- " actual: " & Real'Image (Actual) &
- " expected low: " & Real'Image (Model_Expected_Low) &
- " expected high: " & Real'Image (Model_Expected_High) &
- " difference: " & Real'Image (Actual - Expected_Low));
- else
- Report.Failed (Test_Name &
- " actual: " & Real'Image (Actual) &
- " expected low: " & Real'Image (Model_Expected_Low) &
- " expected high: " & Real'Image (Model_Expected_High) &
- " difference: " & Real'Image (Expected_High - Actual));
- end if;
- elsif Verbose then
- Report.Comment (Test_Name & " passed");
- end if;
- end Check_Exact;
-
-
- procedure Exact_Result_Test is
- begin
- -- A.5.1(38)
- Check_Exact (Arcsin (0.0), 0.0, 0.0, "arcsin(0)");
- Check_Exact (Arcsin (0.0, 45.0), 0.0, 0.0, "arcsin(0,45)");
-
- -- A.5.1(39)
- Check_Exact (Arccos (1.0), 0.0, 0.0, "arccos(1)");
- Check_Exact (Arccos (1.0, 75.0), 0.0, 0.0, "arccos(1,75)");
-
- -- G.2.4(11-13)
- Check_Exact (Arcsin (1.0), Half_PI_Low, Half_PI_High, "arcsin(1)");
- Check_Exact (Arcsin (1.0, 360.0), 90.0, 90.0, "arcsin(1,360)");
-
- Check_Exact (Arcsin (-1.0), -Half_PI_High, -Half_PI_Low, "arcsin(-1)");
- Check_Exact (Arcsin (-1.0, 360.0), -90.0, -90.0, "arcsin(-1,360)");
-
- Check_Exact (Arccos (0.0), Half_PI_Low, Half_PI_High, "arccos(0)");
- Check_Exact (Arccos (0.0, 360.0), 90.0, 90.0, "arccos(0,360)");
-
- Check_Exact (Arccos (-1.0), PI_Low, PI_High, "arccos(-1)");
- Check_Exact (Arccos (-1.0, 360.0), 180.0, 180.0, "arccos(-1,360)");
-
- exception
- when Constraint_Error =>
- Report.Failed ("Constraint_Error raised in Exact_Result Test");
- when others =>
- Report.Failed ("Exception in Exact_Result Test");
- end Exact_Result_Test;
-
-
- procedure Arcsin_Taylor_Series_Test is
- -- the following range is chosen so that the Taylor series
- -- used will produce a result accurate to machine precision.
- --
- -- The following formula is used for the Taylor series:
- -- TS(x) = x { 1 + (xsq/2) [ (1/3) + (3/4)xsq { (1/5) +
- -- (5/6)xsq [ (1/7) + (7/8)xsq/9 ] } ] }
- -- where xsq = x * x
- --
- A : constant := -0.125;
- B : constant := 0.125;
- X : Real;
- Y, Y_Sq : Real;
- Actual, Sum, Xm : Real;
- -- terms in Taylor series
- K : constant Integer := Integer (
- Log (
- Real (Real'Machine_Radix) ** Real'Machine_Mantissa,
- 10.0)) + 1;
- begin
- Accuracy_Error_Reported := False; -- reset
- for I in 1..Max_Samples loop
- -- make sure there is no error in x-1, x, and x+1
- X := (B - A) * Real (I) / Real (Max_Samples) + A;
-
- Y := X;
- Y_Sq := Y * Y;
- Sum := 0.0;
- Xm := Real (K + K + 1);
- for M in 1 .. K loop
- Sum := Y_Sq * (Sum + 1.0/Xm);
- Xm := Xm - 2.0;
- Sum := Sum * (Xm /(Xm + 1.0));
- end loop;
- Sum := Sum * Y;
- Actual := Y + Sum;
- Sum := (Y - Actual) + Sum;
- if not Real'Machine_Rounds then
- Actual := Actual + (Sum + Sum);
- end if;
-
- Check (Actual, Arcsin (X),
- "Taylor Series test" & Integer'Image (I) & ": arcsin(" &
- Real'Image (X) & ") ",
- Minimum_Error);
-
- if Accuracy_Error_Reported then
- -- only report the first error in this test in order to keep
- -- lots of failures from producing a huge error log
- return;
- end if;
-
- end loop;
-
- exception
- when Constraint_Error =>
- Report.Failed
- ("Constraint_Error raised in Arcsin_Taylor_Series_Test" &
- " for X=" & Real'Image (X));
- when others =>
- Report.Failed ("exception in Arcsin_Taylor_Series_Test" &
- " for X=" & Real'Image (X));
- end Arcsin_Taylor_Series_Test;
-
-
-
- procedure Arccos_Taylor_Series_Test is
- -- the following range is chosen so that the Taylor series
- -- used will produce a result accurate to machine precision.
- --
- -- The following formula is used for the Taylor series:
- -- TS(x) = x { 1 + (xsq/2) [ (1/3) + (3/4)xsq { (1/5) +
- -- (5/6)xsq [ (1/7) + (7/8)xsq/9 ] } ] }
- -- arccos(x) = pi/2 - TS(x)
- A : constant := -0.125;
- B : constant := 0.125;
- C1, C2 : Real;
- X : Real;
- Y, Y_Sq : Real;
- Actual, Sum, Xm, S : Real;
- -- terms in Taylor series
- K : constant Integer := Integer (
- Log (
- Real (Real'Machine_Radix) ** Real'Machine_Mantissa,
- 10.0)) + 1;
- begin
- if Real'Digits > 23 then
- -- constants in this section only accurate to 23 digits
- Error_Low_Bound := 0.00000_00000_00000_00000_001;
- Report.Comment ("arctan accuracy checked to 23 digits");
- end if;
-
- -- C1 + C2 equals Pi/2 accurate to 23 digits
- if Real'Machine_Radix = 10 then
- C1 := 1.57;
- C2 := 7.9632679489661923132E-4;
- else
- C1 := 201.0 / 128.0;
- C2 := 4.8382679489661923132E-4;
- end if;
-
- Accuracy_Error_Reported := False; -- reset
- for I in 1..Max_Samples loop
- -- make sure there is no error in x-1, x, and x+1
- X := (B - A) * Real (I) / Real (Max_Samples) + A;
-
- Y := X;
- Y_Sq := Y * Y;
- Sum := 0.0;
- Xm := Real (K + K + 1);
- for M in 1 .. K loop
- Sum := Y_Sq * (Sum + 1.0/Xm);
- Xm := Xm - 2.0;
- Sum := Sum * (Xm /(Xm + 1.0));
- end loop;
- Sum := Sum * Y;
-
- -- at this point we have arcsin(x).
- -- We compute arccos(x) = pi/2 - arcsin(x).
- -- The following code segment is translated directly from
- -- the CELEFUNT FORTRAN implementation
-
- S := C1 + C2;
- Sum := ((C1 - S) + C2) - Sum;
- Actual := S + Sum;
- Sum := ((S - Actual) + Sum) - Y;
- S := Actual;
- Actual := S + Sum;
- Sum := (S - Actual) + Sum;
-
- if not Real'Machine_Rounds then
- Actual := Actual + (Sum + Sum);
- end if;
-
- Check (Actual, Arccos (X),
- "Taylor Series test" & Integer'Image (I) & ": arccos(" &
- Real'Image (X) & ") ",
- Minimum_Error);
-
- -- only report the first error in this test in order to keep
- -- lots of failures from producing a huge error log
- exit when Accuracy_Error_Reported;
- end loop;
- Error_Low_Bound := 0.0; -- reset
- exception
- when Constraint_Error =>
- Report.Failed
- ("Constraint_Error raised in Arccos_Taylor_Series_Test" &
- " for X=" & Real'Image (X));
- when others =>
- Report.Failed ("exception in Arccos_Taylor_Series_Test" &
- " for X=" & Real'Image (X));
- end Arccos_Taylor_Series_Test;
-
-
-
- procedure Identity_Test is
- -- test the identity arcsin(-x) = -arcsin(x)
- -- range chosen to be most of the valid range of the argument.
- A : constant := -0.999;
- B : constant := 0.999;
- X : Real;
- begin
- Accuracy_Error_Reported := False; -- reset
- for I in 1..Max_Samples loop
- -- make sure there is no error in x-1, x, and x+1
- X := (B - A) * Real (I) / Real (Max_Samples) + A;
-
- Check (Arcsin(-X), -Arcsin (X),
- "Identity test" & Integer'Image (I) & ": arcsin(" &
- Real'Image (X) & ") ",
- 8.0); -- 2 arcsin evaluations => twice the error bound
-
- if Accuracy_Error_Reported then
- -- only report the first error in this test in order to keep
- -- lots of failures from producing a huge error log
- return;
- end if;
- end loop;
- end Identity_Test;
-
-
- procedure Exception_Test is
- X1, X2 : Real := 0.0;
- begin
- begin
- X1 := Arcsin (1.1);
- Report.Failed ("no exception for Arcsin (1.1)");
- exception
- when Constraint_Error =>
- Report.Failed ("Constraint_Error instead of " &
- "Argument_Error for Arcsin (1.1)");
- when Ada.Numerics.Argument_Error =>
- null; -- expected result
- when others =>
- Report.Failed ("wrong exception for Arcsin(1.1)");
- end;
-
- begin
- X2 := Arccos (-1.1);
- Report.Failed ("no exception for Arccos (-1.1)");
- exception
- when Constraint_Error =>
- Report.Failed ("Constraint_Error instead of " &
- "Argument_Error for Arccos (-1.1)");
- when Ada.Numerics.Argument_Error =>
- null; -- expected result
- when others =>
- Report.Failed ("wrong exception for Arccos(-1.1)");
- end;
-
-
- -- optimizer thwarting
- if Report.Ident_Bool (False) then
- Report.Comment (Real'Image (X1 + X2));
- end if;
- end Exception_Test;
-
-
- procedure Do_Test is
- begin
- Special_Value_Test;
- Exact_Result_Test;
- Arcsin_Taylor_Series_Test;
- Arccos_Taylor_Series_Test;
- Identity_Test;
- Exception_Test;
- end Do_Test;
- end Generic_Check;
-
- -----------------------------------------------------------------------
- -----------------------------------------------------------------------
- -- These expressions must be truly static, which is why we have to do them
- -- outside of the generic, and we use the named numbers. Note that we know
- -- that PI is not a machine number (it is irrational), and it should be
- -- represented to more digits than supported by the target machine.
- Float_Half_PI_Low : constant := Float'Adjacent(PI/2.0, 0.0);
- Float_Half_PI_High : constant := Float'Adjacent(PI/2.0, 10.0);
- Float_PI_Low : constant := Float'Adjacent(PI, 0.0);
- Float_PI_High : constant := Float'Adjacent(PI, 10.0);
- package Float_Check is new Generic_Check (Float,
- Half_PI_Low => Float_Half_PI_Low,
- Half_PI_High => Float_Half_PI_High,
- PI_Low => Float_PI_Low,
- PI_High => Float_PI_High);
-
- -- check the floating point type with the most digits
- type A_Long_Float is digits System.Max_Digits;
- A_Long_Float_Half_PI_Low : constant := A_Long_Float'Adjacent(PI/2.0, 0.0);
- A_Long_Float_Half_PI_High : constant := A_Long_Float'Adjacent(PI/2.0, 10.0);
- A_Long_Float_PI_Low : constant := A_Long_Float'Adjacent(PI, 0.0);
- A_Long_Float_PI_High : constant := A_Long_Float'Adjacent(PI, 10.0);
- package A_Long_Float_Check is new Generic_Check (A_Long_Float,
- Half_PI_Low => A_Long_Float_Half_PI_Low,
- Half_PI_High => A_Long_Float_Half_PI_High,
- PI_Low => A_Long_Float_PI_Low,
- PI_High => A_Long_Float_PI_High);
-
- -----------------------------------------------------------------------
- -----------------------------------------------------------------------
-
-
-begin
- Report.Test ("CXG2015",
- "Check the accuracy of the ARCSIN and ARCCOS functions");
-
- if Verbose then
- Report.Comment ("checking Standard.Float");
- end if;
-
- Float_Check.Do_Test;
-
- if Verbose then
- Report.Comment ("checking a digits" &
- Integer'Image (System.Max_Digits) &
- " floating point type");
- end if;
-
- A_Long_Float_Check.Do_Test;
-
-
- Report.Result;
-end CXG2015;
diff --git a/gcc/testsuite/ada/acats/tests/cxg/cxg2016.a b/gcc/testsuite/ada/acats/tests/cxg/cxg2016.a
deleted file mode 100644
index 832b118224a..00000000000
--- a/gcc/testsuite/ada/acats/tests/cxg/cxg2016.a
+++ /dev/null
@@ -1,482 +0,0 @@
--- CXG2016.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that the ARCTAN function returns a
--- result that is within the error bound allowed.
---
--- TEST DESCRIPTION:
--- This test consists of a generic package that is
--- instantiated to check both Float and a long float type.
--- The test for each floating point type is divided into
--- several parts:
--- Special value checks where the result is a known constant.
--- Exception checks.
---
--- SPECIAL REQUIREMENTS
--- The Strict Mode for the numerical accuracy must be
--- selected. The method by which this mode is selected
--- is implementation dependent.
---
--- APPLICABILITY CRITERIA:
--- This test applies only to implementations supporting the
--- Numerics Annex.
--- This test only applies to the Strict Mode for numerical
--- accuracy.
---
---
--- CHANGE HISTORY:
--- 19 Mar 96 SAIC Initial release for 2.1
--- 30 APR 96 SAIC Fixed optimization issue
--- 17 AUG 96 SAIC Incorporated Reviewer's suggestions.
--- 12 OCT 96 SAIC Incorporated Reviewer's suggestions.
--- 02 DEC 97 EDS Remove procedure Identity_1_Test and calls to
--- procedure.
--- 29 JUN 98 EDS Replace -0.0 with call to ImpDef.Annex_G.Negative_Zero
--- 28 APR 99 RLB Replaced comma accidentally deleted in above change.
--- 15 DEC 99 RLB Added model range checking to "exact" results,
--- in order to avoid too strictly requiring a specific
--- result.
---!
-
---
--- References:
---
--- Software Manual for the Elementary Functions
--- William J. Cody, Jr. and William Waite
--- Prentice-Hall, 1980
---
--- CRC Standard Mathematical Tables
--- 23rd Edition
---
--- Implementation and Testing of Function Software
--- W. J. Cody
--- Problems and Methodologies in Mathematical Software Production
--- editors P. C. Messina and A. Murli
--- Lecture Notes in Computer Science Volume 142
--- Springer Verlag, 1982
---
-
-with System;
-with Report;
-with Ada.Numerics.Generic_Elementary_Functions;
-with Impdef.Annex_G;
-procedure CXG2016 is
- Verbose : constant Boolean := False;
- Max_Samples : constant := 1000;
-
- -- CRC Standard Mathematical Tables; 23rd Edition; pg 738
- Sqrt2 : constant :=
- 1.41421_35623_73095_04880_16887_24209_69807_85696_71875_37695;
- Sqrt3 : constant :=
- 1.73205_08075_68877_29352_74463_41505_87236_69428_05253_81039;
-
- Pi : constant := Ada.Numerics.Pi;
-
- generic
- type Real is digits <>;
- Half_PI_Low : in Real; -- The machine number closest to, but not greater
- -- than PI/2.0.
- Half_PI_High : in Real;-- The machine number closest to, but not less
- -- than PI/2.0.
- PI_Low : in Real; -- The machine number closest to, but not greater
- -- than PI.
- PI_High : in Real; -- The machine number closest to, but not less
- -- than PI.
- package Generic_Check is
- procedure Do_Test;
- end Generic_Check;
-
- package body Generic_Check is
- package Elementary_Functions is new
- Ada.Numerics.Generic_Elementary_Functions (Real);
-
- function Arctan (Y : Real;
- X : Real := 1.0) return Real renames
- Elementary_Functions.Arctan;
- function Arctan (Y : Real;
- X : Real := 1.0;
- Cycle : Real) return Real renames
- Elementary_Functions.Arctan;
-
- -- flag used to terminate some tests early
- Accuracy_Error_Reported : Boolean := False;
-
- -- The following value is a lower bound on the accuracy
- -- required. It is normally 0.0 so that the lower bound
- -- is computed from Model_Epsilon. However, for tests
- -- where the expected result is only known to a certain
- -- amount of precision this bound takes on a non-zero
- -- value to account for that level of precision.
- Error_Low_Bound : Real := 0.0;
-
- procedure Check (Actual, Expected : Real;
- Test_Name : String;
- MRE : Real) is
- Max_Error : Real;
- Rel_Error : Real;
- Abs_Error : Real;
- begin
- -- In the case where the expected result is very small or 0
- -- we compute the maximum error as a multiple of Model_Epsilon
- -- instead of Model_Epsilon and Expected.
- Rel_Error := MRE * abs Expected * Real'Model_Epsilon;
- Abs_Error := MRE * Real'Model_Epsilon;
- if Rel_Error > Abs_Error then
- Max_Error := Rel_Error;
- else
- Max_Error := Abs_Error;
- end if;
-
- -- take into account the low bound on the error
- if Max_Error < Error_Low_Bound then
- Max_Error := Error_Low_Bound;
- end if;
-
- if abs (Actual - Expected) > Max_Error then
- Accuracy_Error_Reported := True;
- Report.Failed (Test_Name &
- " actual: " & Real'Image (Actual) &
- " expected: " & Real'Image (Expected) &
- " difference: " & Real'Image (Actual - Expected) &
- " max err:" & Real'Image (Max_Error) );
- elsif Verbose then
- if Actual = Expected then
- Report.Comment (Test_Name & " exact result");
- else
- Report.Comment (Test_Name & " passed");
- end if;
- end if;
- end Check;
-
-
- procedure Special_Value_Test is
- -- If eta is very small, arctan(x + eta) ~= arctan(x) + eta/(1+x*x).
- --
- -- For tests 4 and 5, there is an error of 4.0ME for arctan + an
- -- additional error of 1.0ME because pi is not exact for a total of 5.0ME.
- --
- -- In test 3 there is the error for pi plus an additional error
- -- of (1.0ME)/4 since sqrt3 is not exact, for a total of 5.25ME.
- --
- -- In test 2 there is the error for pi plus an additional error
- -- of (3/4)(1.0ME) since sqrt3 is not exact, for a total of 5.75ME.
-
-
- type Data_Point is
- record
- Degrees,
- Radians,
- Tangent,
- Allowed_Error : Real;
- end record;
-
- type Test_Data_Type is array (Positive range <>) of Data_Point;
-
- -- the values in the following table only involve static
- -- expressions so no additional loss of precision occurs.
- Test_Data : constant Test_Data_Type := (
- -- degrees radians tangent error test #
- ( 0.0, 0.0, 0.0, 4.0 ), -- 1
- ( 30.0, Pi/6.0, Sqrt3/3.0, 5.75), -- 2
- ( 60.0, Pi/3.0, Sqrt3, 5.25), -- 3
- ( 45.0, Pi/4.0, 1.0, 5.0 ), -- 4
- (-45.0, -Pi/4.0, -1.0, 5.0 ) ); -- 5
-
- begin
- for I in Test_Data'Range loop
- Check (Arctan (Test_Data (I).Tangent),
- Test_Data (I).Radians,
- "special value test" & Integer'Image (I) &
- " arctan(" &
- Real'Image (Test_Data (I).Tangent) &
- ")",
- Test_Data (I).Allowed_Error);
- Check (Arctan (Test_Data (I).Tangent, Cycle => 360.0),
- Test_Data (I).Degrees,
- "special value test" & Integer'Image (I) &
- " arctan(" &
- Real'Image (Test_Data (I).Tangent) &
- ", cycle=>360)",
- Test_Data (I).Allowed_Error);
- end loop;
-
- exception
- when Constraint_Error =>
- Report.Failed ("Constraint_Error raised in special value test");
- when others =>
- Report.Failed ("exception in special value test");
- end Special_Value_Test;
-
-
-
- procedure Check_Exact (Actual, Expected_Low, Expected_High : Real;
- Test_Name : String) is
- -- If the expected result is not a model number, then Expected_Low is
- -- the first machine number less than the (exact) expected
- -- result, and Expected_High is the first machine number greater than
- -- the (exact) expected result. If the expected result is a model
- -- number, Expected_Low = Expected_High = the result.
- Model_Expected_Low : Real := Expected_Low;
- Model_Expected_High : Real := Expected_High;
- begin
- -- Calculate the first model number nearest to, but below (or equal)
- -- to the expected result:
- while Real'Model (Model_Expected_Low) /= Model_Expected_Low loop
- -- Try the next machine number lower:
- Model_Expected_Low := Real'Adjacent(Model_Expected_Low, 0.0);
- end loop;
- -- Calculate the first model number nearest to, but above (or equal)
- -- to the expected result:
- while Real'Model (Model_Expected_High) /= Model_Expected_High loop
- -- Try the next machine number higher:
- Model_Expected_High := Real'Adjacent(Model_Expected_High, 100.0);
- end loop;
-
- if Actual < Model_Expected_Low or Actual > Model_Expected_High then
- Accuracy_Error_Reported := True;
- if Actual < Model_Expected_Low then
- Report.Failed (Test_Name &
- " actual: " & Real'Image (Actual) &
- " expected low: " & Real'Image (Model_Expected_Low) &
- " expected high: " & Real'Image (Model_Expected_High) &
- " difference: " & Real'Image (Actual - Expected_Low));
- else
- Report.Failed (Test_Name &
- " actual: " & Real'Image (Actual) &
- " expected low: " & Real'Image (Model_Expected_Low) &
- " expected high: " & Real'Image (Model_Expected_High) &
- " difference: " & Real'Image (Expected_High - Actual));
- end if;
- elsif Verbose then
- Report.Comment (Test_Name & " passed");
- end if;
- end Check_Exact;
-
-
- procedure Exact_Result_Test is
- begin
- -- A.5.1(40);6.0
- Check_Exact (Arctan (0.0, 1.0), 0.0, 0.0, "arctan(0,1)");
- Check_Exact (Arctan (0.0, 1.0, 27.0), 0.0, 0.0, "arctan(0,1,27)");
-
- -- G.2.4(11-13);6.0
-
- Check_Exact (Arctan (1.0, 0.0), Half_PI_Low, Half_PI_High,
- "arctan(1,0)");
- Check_Exact (Arctan (1.0, 0.0, 360.0), 90.0, 90.0, "arctan(1,0,360)");
-
- Check_Exact (Arctan (-1.0, 0.0), -Half_PI_High, -Half_PI_Low,
- "arctan(-1,0)");
- Check_Exact (Arctan (-1.0, 0.0, 360.0), -90.0, -90.0,
- "arctan(-1,0,360)");
-
- if Real'Signed_Zeros then
- Check_Exact (Arctan (0.0, -1.0), PI_Low, PI_High, "arctan(+0,-1)");
- Check_Exact (Arctan (0.0, -1.0, 360.0), 180.0, 180.0,
- "arctan(+0,-1,360)");
- Check_Exact (Arctan ( Real ( ImpDef.Annex_G.Negative_Zero ), -1.0),
- -PI_High, -PI_Low, "arctan(-0,-1)");
- Check_Exact (Arctan ( Real ( ImpDef.Annex_G.Negative_Zero ), -1.0,
- 360.0), -180.0, -180.0, "arctan(-0,-1,360)");
- else
- Check_Exact (Arctan (0.0, -1.0), PI_Low, PI_High, "arctan(0,-1)");
- Check_Exact (Arctan (0.0, -1.0, 360.0), 180.0, 180.0,
- "arctan(0,-1,360)");
- end if;
- exception
- when Constraint_Error =>
- Report.Failed ("Constraint_Error raised in Exact_Result Test");
- when others =>
- Report.Failed ("Exception in Exact_Result Test");
- end Exact_Result_Test;
-
-
- procedure Taylor_Series_Test is
- -- This test checks the Arctan by using a taylor series expansion that
- -- will produce a result accurate to 19 decimal digits for
- -- the range under test.
- --
- -- The maximum relative error bound for this test is
- -- 4 for the arctan operation and 2 for the Taylor series
- -- for a total of 6 * Model_Epsilon
-
- A : constant := -1.0/16.0;
- B : constant := 1.0/16.0;
- X : Real;
- Actual, Expected : Real;
- Sum, Em, X_Squared : Real;
- begin
- if Real'Digits > 19 then
- -- Taylor series calculation produces result accurate to 19
- -- digits. If type being tested has more digits then set
- -- the error low bound to account for this.
- -- The error low bound is conservatively set to 6*10**-19
- Error_Low_Bound := 0.00000_00000_00000_0006;
- Report.Comment ("arctan accuracy checked to 19 digits");
- end if;
-
- Accuracy_Error_Reported := False; -- reset
- for I in 0..Max_Samples loop
- X := (B - A) * Real (I) / Real (Max_Samples) + A;
- X_Squared := X * X;
- Em := 17.0;
- Sum := X_Squared / Em;
-
- for II in 1 .. 7 loop
- Em := Em - 2.0;
- Sum := (1.0 / Em - Sum) * X_Squared;
- end loop;
- Sum := -X * Sum;
- Expected := X + Sum;
- Sum := (X - Expected) + Sum;
- if not Real'Machine_Rounds then
- Expected := Expected + (Sum + Sum);
- end if;
-
- Actual := Arctan (X);
-
- Check (Actual, Expected,
- "Taylor_Series_Test " & Integer'Image (I) & ": arctan(" &
- Real'Image (X) & ") ",
- 6.0);
-
- if Accuracy_Error_Reported then
- -- only report the first error in this test in order to keep
- -- lots of failures from producing a huge error log
- return;
- end if;
-
- end loop;
- Error_Low_Bound := 0.0; -- reset
- exception
- when Constraint_Error =>
- Report.Failed
- ("Constraint_Error raised in Taylor_Series_Test");
- when others =>
- Report.Failed ("exception in Taylor_Series_Test");
- end Taylor_Series_Test;
-
-
- procedure Exception_Test is
- X1, X2, X3 : Real := 0.0;
- begin
-
- begin -- A.5.1(20);6.0
- X1 := Arctan(0.0, Cycle => 0.0);
- Report.Failed ("no exception for cycle = 0.0");
- exception
- when Ada.Numerics.Argument_Error => null;
- when others =>
- Report.Failed ("wrong exception for cycle = 0.0");
- end;
-
- begin -- A.5.1(20);6.0
- X2 := Arctan (0.0, Cycle => -1.0);
- Report.Failed ("no exception for cycle < 0.0");
- exception
- when Ada.Numerics.Argument_Error => null;
- when others =>
- Report.Failed ("wrong exception for cycle < 0.0");
- end;
-
- begin -- A.5.1(25);6.0
- X3 := Arctan (0.0, 0.0);
- Report.Failed ("no exception for arctan(0,0)");
- exception
- when Ada.Numerics.Argument_Error => null;
- when others =>
- Report.Failed ("wrong exception for arctan(0,0)");
- end;
-
- -- optimizer thwarting
- if Report.Ident_Bool (False) then
- Report.Comment (Real'Image (X1 + X2 + X3));
- end if;
- end Exception_Test;
-
-
- procedure Do_Test is
- begin
- Special_Value_Test;
- Exact_Result_Test;
- Taylor_Series_Test;
- Exception_Test;
- end Do_Test;
- end Generic_Check;
-
- -----------------------------------------------------------------------
- -----------------------------------------------------------------------
- -- These expressions must be truly static, which is why we have to do them
- -- outside of the generic, and we use the named numbers. Note that we know
- -- that PI is not a machine number (it is irrational), and it should be
- -- represented to more digits than supported by the target machine.
- Float_Half_PI_Low : constant := Float'Adjacent(PI/2.0, 0.0);
- Float_Half_PI_High : constant := Float'Adjacent(PI/2.0, 10.0);
- Float_PI_Low : constant := Float'Adjacent(PI, 0.0);
- Float_PI_High : constant := Float'Adjacent(PI, 10.0);
- package Float_Check is new Generic_Check (Float,
- Half_PI_Low => Float_Half_PI_Low,
- Half_PI_High => Float_Half_PI_High,
- PI_Low => Float_PI_Low,
- PI_High => Float_PI_High);
-
- -- check the Floating point type with the most digits
- type A_Long_Float is digits System.Max_Digits;
- A_Long_Float_Half_PI_Low : constant := A_Long_Float'Adjacent(PI/2.0, 0.0);
- A_Long_Float_Half_PI_High : constant := A_Long_Float'Adjacent(PI/2.0, 10.0);
- A_Long_Float_PI_Low : constant := A_Long_Float'Adjacent(PI, 0.0);
- A_Long_Float_PI_High : constant := A_Long_Float'Adjacent(PI, 10.0);
- package A_Long_Float_Check is new Generic_Check (A_Long_Float,
- Half_PI_Low => A_Long_Float_Half_PI_Low,
- Half_PI_High => A_Long_Float_Half_PI_High,
- PI_Low => A_Long_Float_PI_Low,
- PI_High => A_Long_Float_PI_High);
-
- -----------------------------------------------------------------------
- -----------------------------------------------------------------------
-
-
-begin
- Report.Test ("CXG2016",
- "Check the accuracy of the ARCTAN function");
-
- if Verbose then
- Report.Comment ("checking Standard.Float");
- end if;
-
- Float_Check.Do_Test;
-
- if Verbose then
- Report.Comment ("checking a digits" &
- Integer'Image (System.Max_Digits) &
- " floating point type");
- end if;
-
- A_Long_Float_Check.Do_Test;
-
-
- Report.Result;
-end CXG2016;
diff --git a/gcc/testsuite/ada/acats/tests/cxg/cxg2017.a b/gcc/testsuite/ada/acats/tests/cxg/cxg2017.a
deleted file mode 100644
index 50add975f7f..00000000000
--- a/gcc/testsuite/ada/acats/tests/cxg/cxg2017.a
+++ /dev/null
@@ -1,296 +0,0 @@
--- CXG2017.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that the TANH function returns
--- a result that is within the error bound allowed.
---
--- TEST DESCRIPTION:
--- This test consists of a generic package that is
--- instantiated to check both Float and a long float type.
--- The test for each floating point type is divided into
--- several parts:
--- Special value checks where the result is a known constant.
--- Checks that use an identity for determining the result.
---
--- SPECIAL REQUIREMENTS
--- The Strict Mode for the numerical accuracy must be
--- selected. The method by which this mode is selected
--- is implementation dependent.
---
--- APPLICABILITY CRITERIA:
--- This test applies only to implementations supporting the
--- Numerics Annex.
--- This test only applies to the Strict Mode for numerical
--- accuracy.
---
---
--- CHANGE HISTORY:
--- 20 Mar 96 SAIC Initial release for 2.1
--- 17 Aug 96 SAIC Incorporated reviewer comments.
--- 03 Jun 98 EDS Add parens to remove the potential for overflow.
--- Remove the invocation of Identity_Test that checks
--- Tanh values that are too close to zero for the
--- test's error bounds.
---!
-
---
--- References:
---
--- Software Manual for the Elementary Functions
--- William J. Cody, Jr. and William Waite
--- Prentice-Hall, 1980
---
--- CRC Standard Mathematical Tables
--- 23rd Edition
---
--- Implementation and Testing of Function Software
--- W. J. Cody
--- Problems and Methodologies in Mathematical Software Production
--- editors P. C. Messina and A. Murli
--- Lecture Notes in Computer Science Volume 142
--- Springer Verlag, 1982
---
-
-with System;
-with Report;
-with Ada.Numerics.Generic_Elementary_Functions;
-procedure CXG2017 is
- Verbose : constant Boolean := False;
- Max_Samples : constant := 1000;
-
- E : constant := Ada.Numerics.E;
-
- generic
- type Real is digits <>;
- package Generic_Check is
- procedure Do_Test;
- end Generic_Check;
-
- package body Generic_Check is
- package Elementary_Functions is new
- Ada.Numerics.Generic_Elementary_Functions (Real);
-
- function Tanh (X : Real) return Real renames
- Elementary_Functions.Tanh;
-
- function Log (X : Real) return Real renames
- Elementary_Functions.Log;
-
- -- flag used to terminate some tests early
- Accuracy_Error_Reported : Boolean := False;
-
-
- -- The following value is a lower bound on the accuracy
- -- required. It is normally 0.0 so that the lower bound
- -- is computed from Model_Epsilon. However, for tests
- -- where the expected result is only known to a certain
- -- amount of precision this bound takes on a non-zero
- -- value to account for that level of precision.
- Error_Low_Bound : Real := 0.0;
-
- procedure Check (Actual, Expected : Real;
- Test_Name : String;
- MRE : Real) is
- Max_Error : Real;
- Rel_Error : Real;
- Abs_Error : Real;
- begin
- -- In the case where the expected result is very small or 0
- -- we compute the maximum error as a multiple of Model_Small instead
- -- of Model_Epsilon and Expected.
- Rel_Error := MRE * abs Expected * Real'Model_Epsilon;
- Abs_Error := MRE * Real'Model_Small;
- if Rel_Error > Abs_Error then
- Max_Error := Rel_Error;
- else
- Max_Error := Abs_Error;
- end if;
- -- take into account the low bound on the error
- if Max_Error < Error_Low_Bound then
- Max_Error := Error_Low_Bound;
- end if;
-
- if abs (Actual - Expected) > Max_Error then
- Accuracy_Error_Reported := True;
- Report.Failed (Test_Name &
- " actual: " & Real'Image (Actual) &
- " expected: " & Real'Image (Expected) &
- " difference: " & Real'Image (Actual - Expected) &
- " max err:" & Real'Image (Max_Error) );
- elsif Verbose then
- if Actual = Expected then
- Report.Comment (Test_Name & " exact result");
- else
- Report.Comment (Test_Name & " passed");
- end if;
- end if;
- end Check;
-
-
- procedure Special_Value_Test is
- -- In the following tests the expected result is accurate
- -- to the machine precision so the minimum guaranteed error
- -- bound can be used.
- Minimum_Error : constant := 8.0;
- E2 : constant := E * E;
- begin
- Check (Tanh (1.0),
- (E - 1.0 / E) / (E + 1.0 / E),
- "tanh(1)",
- Minimum_Error);
- Check (Tanh (2.0),
- (E2 - 1.0 / E2) / (E2 + 1.0 / E2),
- "tanh(2)",
- Minimum_Error);
- exception
- when Constraint_Error =>
- Report.Failed ("Constraint_Error raised in special value test");
- when others =>
- Report.Failed ("exception in special value test");
- end Special_Value_Test;
-
-
-
- procedure Exact_Result_Test is
- No_Error : constant := 0.0;
- begin
- -- A.5.1(38);6.0
- Check (Tanh (0.0), 0.0, "tanh(0)", No_Error);
- exception
- when Constraint_Error =>
- Report.Failed ("Constraint_Error raised in Exact_Result Test");
- when others =>
- Report.Failed ("exception in Exact_Result Test");
- end Exact_Result_Test;
-
-
- procedure Identity_Test (A, B : Real) is
- -- For this test we use the identity
- -- TANH(u+v) = [TANH(u) + TANH(v)] / [1 + TANH(u)*TANH(v)]
- -- which is transformed to
- -- TANH(x) = [TANH(y)+C] / [1 + TANH(y) * C]
- -- where C = TANH(1/8) and y = x - 1/8
- --
- -- see Cody pg 248-249 for details on the error analysis.
- -- The net result is a relative error bound of 16 * Model_Epsilon.
- --
- -- The second part of this test checks the identity
- -- TANH(-x) = -TANH(X)
-
- X, Y : Real;
- Actual1, Actual2 : Real;
- C : constant := 1.2435300177159620805e-1;
- begin
- if Real'Digits > 20 then
- -- constant C is accurate to 20 digits. Set the low bound
- -- on the error to 16*10**-20
- Error_Low_Bound := 0.00000_00000_00000_00016;
- Report.Comment ("tanh accuracy checked to 20 digits");
- end if;
-
- Accuracy_Error_Reported := False; -- reset
- for I in 1..Max_Samples loop
- X := (B - A) * (Real (I) / Real (Max_Samples)) + A;
- Actual1 := Tanh(X);
-
- -- TANH(x) = [TANH(y)+C] / [1 + TANH(y) * C]
- Y := X - (1.0 / 8.0);
- Actual2 := (Tanh (Y) + C) / (1.0 + Tanh(Y) * C);
-
- Check (Actual1, Actual2,
- "Identity_1_Test " & Integer'Image (I) & ": tanh(" &
- Real'Image (X) & ") ",
- 16.0);
-
- -- TANH(-x) = -TANH(X)
- Actual2 := Tanh(-X);
- Check (-Actual1, Actual2,
- "Identity_2_Test " & Integer'Image (I) & ": tanh(" &
- Real'Image (X) & ") ",
- 16.0);
-
- if Accuracy_Error_Reported then
- -- only report the first error in this test in order to keep
- -- lots of failures from producing a huge error log
- return;
- end if;
-
- end loop;
- Error_Low_Bound := 0.0; -- reset
- exception
- when Constraint_Error =>
- Report.Failed
- ("Constraint_Error raised in Identity_Test" &
- " for X=" & Real'Image (X));
- when others =>
- Report.Failed ("exception in Identity_Test" &
- " for X=" & Real'Image (X));
- end Identity_Test;
-
-
-
- procedure Do_Test is
- begin
- Special_Value_Test;
- Exact_Result_Test;
- -- cover a large range
- Identity_Test (1.0, Real'Safe_Last);
- end Do_Test;
- end Generic_Check;
-
- -----------------------------------------------------------------------
- -----------------------------------------------------------------------
- package Float_Check is new Generic_Check (Float);
-
- -- check the floating point type with the most digits
- type A_Long_Float is digits System.Max_Digits;
- package A_Long_Float_Check is new Generic_Check (A_Long_Float);
-
- -----------------------------------------------------------------------
- -----------------------------------------------------------------------
-
-
-begin
- Report.Test ("CXG2017",
- "Check the accuracy of the TANH function");
-
- if Verbose then
- Report.Comment ("checking Standard.Float");
- end if;
-
- Float_Check.Do_Test;
-
- if Verbose then
- Report.Comment ("checking a digits" &
- Integer'Image (System.Max_Digits) &
- " floating point type");
- end if;
-
- A_Long_Float_Check.Do_Test;
-
-
- Report.Result;
-end CXG2017;
diff --git a/gcc/testsuite/ada/acats/tests/cxg/cxg2018.a b/gcc/testsuite/ada/acats/tests/cxg/cxg2018.a
deleted file mode 100644
index be4f1a82faf..00000000000
--- a/gcc/testsuite/ada/acats/tests/cxg/cxg2018.a
+++ /dev/null
@@ -1,355 +0,0 @@
--- CXG2018.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that the complex EXP function returns
--- a result that is within the error bound allowed.
---
--- TEST DESCRIPTION:
--- This test consists of a generic package that is
--- instantiated to check complex numbers based upon
--- both Float and a long float type.
--- The test for each floating point type is divided into
--- several parts:
--- Special value checks where the result is a known constant.
--- Checks that use an identity for determining the result.
---
--- SPECIAL REQUIREMENTS
--- The Strict Mode for the numerical accuracy must be
--- selected. The method by which this mode is selected
--- is implementation dependent.
---
--- APPLICABILITY CRITERIA:
--- This test applies only to implementations supporting the
--- Numerics Annex.
--- This test only applies to the Strict Mode for numerical
--- accuracy.
---
---
--- CHANGE HISTORY:
--- 21 Mar 96 SAIC Initial release for 2.1
--- 17 Aug 96 SAIC Incorporated reviewer comments.
--- 27 Aug 99 RLB Repair on the error result of checks.
--- 02 Apr 03 RLB Added code to discard excess precision in the
--- construction of the test value for the
--- Identity_Test.
---
---!
-
---
--- References:
---
--- W. J. Cody
--- CELEFUNT: A Portable Test Package for Complex Elementary Functions
--- Algorithm 714, Collected Algorithms from ACM.
--- Published in Transactions On Mathematical Software,
--- Vol. 19, No. 1, March, 1993, pp. 1-21.
---
--- CRC Standard Mathematical Tables
--- 23rd Edition
---
-
-with System;
-with Report;
-with Ada.Numerics.Generic_Complex_Types;
-with Ada.Numerics.Generic_Complex_Elementary_Functions;
-procedure CXG2018 is
- Verbose : constant Boolean := False;
- -- Note that Max_Samples is the number of samples taken in
- -- both the real and imaginary directions. Thus, for Max_Samples
- -- of 100 the number of values checked is 10000.
- Max_Samples : constant := 100;
-
- E : constant := Ada.Numerics.E;
- Pi : constant := Ada.Numerics.Pi;
-
- generic
- type Real is digits <>;
- package Generic_Check is
- procedure Do_Test;
- end Generic_Check;
-
- package body Generic_Check is
- package Complex_Type is new
- Ada.Numerics.Generic_Complex_Types (Real);
- use Complex_Type;
-
- package CEF is new
- Ada.Numerics.Generic_Complex_Elementary_Functions (Complex_Type);
-
- function Exp (X : Complex) return Complex renames CEF.Exp;
- function Exp (X : Imaginary) return Complex renames CEF.Exp;
-
- -- flag used to terminate some tests early
- Accuracy_Error_Reported : Boolean := False;
-
-
- -- The following value is a lower bound on the accuracy
- -- required. It is normally 0.0 so that the lower bound
- -- is computed from Model_Epsilon. However, for tests
- -- where the expected result is only known to a certain
- -- amount of precision this bound takes on a non-zero
- -- value to account for that level of precision.
- Error_Low_Bound : Real := 0.0;
-
- procedure Check (Actual, Expected : Real;
- Test_Name : String;
- MRE : Real) is
- Max_Error : Real;
- Rel_Error : Real;
- Abs_Error : Real;
- begin
- -- In the case where the expected result is very small or 0
- -- we compute the maximum error as a multiple of Model_Small instead
- -- of Model_Epsilon and Expected.
- Rel_Error := MRE * abs Expected * Real'Model_Epsilon;
- Abs_Error := MRE * Real'Model_Small;
- if Rel_Error > Abs_Error then
- Max_Error := Rel_Error;
- else
- Max_Error := Abs_Error;
- end if;
-
- -- take into account the low bound on the error
- if Max_Error < Error_Low_Bound then
- Max_Error := Error_Low_Bound;
- end if;
-
- if abs (Actual - Expected) > Max_Error then
- Accuracy_Error_Reported := True;
- Report.Failed (Test_Name &
- " actual: " & Real'Image (Actual) &
- " expected: " & Real'Image (Expected) &
- " difference: " & Real'Image (Actual - Expected) &
- " max err:" & Real'Image (Max_Error) );
- elsif Verbose then
- if Actual = Expected then
- Report.Comment (Test_Name & " exact result");
- else
- Report.Comment (Test_Name & " passed");
- end if;
- end if;
- end Check;
-
-
- procedure Check (Actual, Expected : Complex;
- Test_Name : String;
- MRE : Real) is
- begin
- Check (Actual.Re, Expected.Re, Test_Name & " real part", MRE);
- Check (Actual.Im, Expected.Im, Test_Name & " imaginary part", MRE);
- end Check;
-
-
- procedure Special_Value_Test is
- -- In the following tests the expected result is accurate
- -- to the machine precision so the minimum guaranteed error
- -- bound can be used.
- --
- -- The error bounds given assumed z is exact. When using
- -- pi there is an extra error of 1.0ME.
- -- The pi inside the exp call requires that the complex
- -- component have an extra error allowance of 1.0*angle*ME.
- -- Thus for pi/2,the Minimum_Error_I is
- -- (2.0 + 1.0(pi/2))ME <= 3.6ME.
- -- For pi, it is (2.0 + 1.0*pi)ME <= 5.2ME,
- -- and for 2pi, it is (2.0 + 1.0(2pi))ME <= 8.3ME.
-
- -- The addition of 1 or i to a result is so that neither of
- -- the components of an expected result is 0. This is so
- -- that a reasonable relative error is allowed.
- Minimum_Error_C : constant := 7.0; -- for exp(Complex)
- Minimum_Error_I : constant := 2.0; -- for exp(Imaginary)
- begin
- Check (Exp (1.0 + 0.0*i) + i,
- E + i,
- "exp(1+0i)",
- Minimum_Error_C);
- Check (Exp ((Pi / 2.0) * i) + 1.0,
- 1.0 + 1.0*i,
- "exp(pi/2*i)",
- 3.6);
- Check (Exp (Pi * i) + i,
- -1.0 + 1.0*i,
- "exp(pi*i)",
- 5.2);
- Check (Exp (Pi * 2.0 * i) + i,
- 1.0 + i,
- "exp(2pi*i)",
- 8.3);
- exception
- when Constraint_Error =>
- Report.Failed ("Constraint_Error raised in special value test");
- when others =>
- Report.Failed ("exception in special value test");
- end Special_Value_Test;
-
-
-
- procedure Exact_Result_Test is
- No_Error : constant := 0.0;
- begin
- -- G.1.2(36);6.0
- Check (Exp(0.0 + 0.0*i), 1.0 + 0.0 * i, "exp(0+0i)", No_Error);
- Check (Exp( 0.0*i), 1.0 + 0.0 * i, "exp(0i)", No_Error);
- exception
- when Constraint_Error =>
- Report.Failed ("Constraint_Error raised in Exact_Result Test");
- when others =>
- Report.Failed ("exception in Exact_Result Test");
- end Exact_Result_Test;
-
-
- procedure Identity_Test (A, B : Real) is
- -- For this test we use the identity
- -- Exp(Z) = Exp(Z-W) * Exp (W)
- -- where W = (1+i)/16
- --
- -- The second part of this test checks the identity
- -- Exp(Z) * Exp(-Z) = 1
- --
-
- X, Y : Complex;
- Actual1, Actual2 : Complex;
- W : constant Complex := (0.0625, 0.0625);
- -- the following constant was taken from the CELEFUNC EXP test.
- -- This is the value EXP(W) - 1
- C : constant Complex := (6.2416044877018563681e-2,
- 6.6487597751003112768e-2);
- begin
- if Real'Digits > 20 then
- -- constant ExpW is accurate to 20 digits.
- -- The low bound is 19 * 10**-20
- Error_Low_Bound := 0.00000_00000_00019;
- Report.Comment ("complex exp accuracy checked to 20 digits");
- end if;
-
- Accuracy_Error_Reported := False; -- reset
- for II in 1..Max_Samples loop
- X.Re := Real'Machine ((B - A) * Real (II) / Real (Max_Samples)
- + A);
- for J in 1..Max_Samples loop
- X.Im := Real'Machine ((B - A) * Real (J) / Real (Max_Samples)
- + A);
-
- Actual1 := Exp(X);
-
- -- Exp(X) = Exp(X-W) * Exp (W)
- -- = Exp(X-W) * (1 - (1-Exp(W))
- -- = Exp(X-W) * (1 + (Exp(W) - 1))
- -- = Exp(X-W) * (1 + C)
- Y := X - W;
- Actual2 := Exp(Y);
- Actual2 := Actual2 + Actual2 * C;
-
- Check (Actual1, Actual2,
- "Identity_1_Test " & Integer'Image (II) &
- Integer'Image (J) & ": Exp((" &
- Real'Image (X.Re) & ", " &
- Real'Image (X.Im) & ")) ",
- 20.0); -- 2 exp and 1 multiply and 1 add = 2*7+1*5+1
- -- Note: The above is not strictly correct, as multiply
- -- has a box error, rather than a relative error.
- -- Supposedly, the interval is chosen to avoid the need
- -- to worry about this.
-
- -- Exp(X) * Exp(-X) + i = 1 + i
- -- The addition of i is to allow a reasonable relative
- -- error in the imaginary part
- Actual2 := (Actual1 * Exp(-X)) + i;
- Check (Actual2, (1.0, 1.0),
- "Identity_2_Test " & Integer'Image (II) &
- Integer'Image (J) & ": Exp((" &
- Real'Image (X.Re) & ", " &
- Real'Image (X.Im) & ")) ",
- 20.0); -- 2 exp and 1 multiply and one add = 2*7+1*5+1
-
- if Accuracy_Error_Reported then
- -- only report the first error in this test in order to keep
- -- lots of failures from producing a huge error log
- return;
- end if;
- end loop;
- end loop;
- Error_Low_Bound := 0.0;
- exception
- when Constraint_Error =>
- Report.Failed
- ("Constraint_Error raised in Identity_Test" &
- " for X=(" & Real'Image (X.Re) &
- ", " & Real'Image (X.Im) & ")");
- when others =>
- Report.Failed ("exception in Identity_Test" &
- " for X=(" & Real'Image (X.Re) &
- ", " & Real'Image (X.Im) & ")");
- end Identity_Test;
-
-
-
- procedure Do_Test is
- begin
- Special_Value_Test;
- Exact_Result_Test;
- -- test regions where we can avoid cancellation error problems
- -- See Cody page 10.
- Identity_Test (0.0625, 1.0);
- Identity_Test (15.0, 17.0);
- Identity_Test (1.625, 3.0);
- end Do_Test;
- end Generic_Check;
-
- -----------------------------------------------------------------------
- -----------------------------------------------------------------------
- package Float_Check is new Generic_Check (Float);
-
- -- check the floating point type with the most digits
- type A_Long_Float is digits System.Max_Digits;
- package A_Long_Float_Check is new Generic_Check (A_Long_Float);
-
- -----------------------------------------------------------------------
- -----------------------------------------------------------------------
-
-
-begin
- Report.Test ("CXG2018",
- "Check the accuracy of the complex EXP function");
-
- if Verbose then
- Report.Comment ("checking Standard.Float");
- end if;
-
- Float_Check.Do_Test;
-
- if Verbose then
- Report.Comment ("checking a digits" &
- Integer'Image (System.Max_Digits) &
- " floating point type");
- end if;
-
- A_Long_Float_Check.Do_Test;
-
-
- Report.Result;
-end CXG2018;
diff --git a/gcc/testsuite/ada/acats/tests/cxg/cxg2019.a b/gcc/testsuite/ada/acats/tests/cxg/cxg2019.a
deleted file mode 100644
index 0a4dddcc906..00000000000
--- a/gcc/testsuite/ada/acats/tests/cxg/cxg2019.a
+++ /dev/null
@@ -1,338 +0,0 @@
--- CXG2019.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that the complex LOG function returns
--- a result that is within the error bound allowed.
---
--- TEST DESCRIPTION:
--- This test consists of a generic package that is
--- instantiated to check complex numbers based upon
--- both Float and a long float type.
--- The test for each floating point type is divided into
--- several parts:
--- Special value checks where the result is a known constant.
--- Checks that use an identity for determining the result.
--- Exception conditions.
---
--- SPECIAL REQUIREMENTS
--- The Strict Mode for the numerical accuracy must be
--- selected. The method by which this mode is selected
--- is implementation dependent.
---
--- APPLICABILITY CRITERIA:
--- This test applies only to implementations supporting the
--- Numerics Annex.
--- This test only applies to the Strict Mode for numerical
--- accuracy.
---
---
--- CHANGE HISTORY:
--- 22 Mar 96 SAIC Initial release for 2.1
---
---!
-
---
--- References:
---
--- W. J. Cody
--- CELEFUNT: A Portable Test Package for Complex Elementary Functions
--- Algorithm 714, Collected Algorithms from ACM.
--- Published in Transactions On Mathematical Software,
--- Vol. 19, No. 1, March, 1993, pp. 1-21.
---
--- CRC Standard Mathematical Tables
--- 23rd Edition
---
-
-with System;
-with Report;
-with Ada.Numerics.Generic_Complex_Types;
-with Ada.Numerics.Generic_Complex_Elementary_Functions;
-procedure CXG2019 is
- Verbose : constant Boolean := False;
- -- Note that Max_Samples is the number of samples taken in
- -- both the real and imaginary directions. Thus, for Max_Samples
- -- of 100 the number of values checked is 10000.
- Max_Samples : constant := 100;
-
- E : constant := Ada.Numerics.E;
- Pi : constant := Ada.Numerics.Pi;
-
- generic
- type Real is digits <>;
- package Generic_Check is
- procedure Do_Test;
- end Generic_Check;
-
- package body Generic_Check is
- package Complex_Type is new
- Ada.Numerics.Generic_Complex_Types (Real);
- use Complex_Type;
-
- package CEF is new
- Ada.Numerics.Generic_Complex_Elementary_Functions (Complex_Type);
-
- function Log (X : Complex) return Complex renames CEF.Log;
-
- -- flag used to terminate some tests early
- Accuracy_Error_Reported : Boolean := False;
-
-
- procedure Check (Actual, Expected : Real;
- Test_Name : String;
- MRE : Real) is
- Max_Error : Real;
- Rel_Error : Real;
- Abs_Error : Real;
- begin
- -- In the case where the expected result is very small or 0
- -- we compute the maximum error as a multiple of Model_Small instead
- -- of Model_Epsilon and Expected.
- Rel_Error := MRE * abs Expected * Real'Model_Epsilon;
- Abs_Error := MRE * Real'Model_Epsilon;
- if Rel_Error > Abs_Error then
- Max_Error := Rel_Error;
- else
- Max_Error := Abs_Error;
- end if;
-
- if abs (Actual - Expected) > Max_Error then
- Accuracy_Error_Reported := True;
- Report.Failed (Test_Name &
- " actual: " & Real'Image (Actual) &
- " expected: " & Real'Image (Expected) &
- " difference: " & Real'Image (Actual - Expected) &
- " max err:" & Real'Image (Max_Error) );
- elsif Verbose then
- if Actual = Expected then
- Report.Comment (Test_Name & " exact result");
- else
- Report.Comment (Test_Name & " passed");
- end if;
- end if;
- end Check;
-
-
- procedure Check (Actual, Expected : Complex;
- Test_Name : String;
- MRE : Real) is
- begin
- Check (Actual.Re, Expected.Re, Test_Name & " real part", MRE);
- Check (Actual.Im, Expected.Im, Test_Name & " imaginary part", MRE);
- end Check;
-
-
- procedure Special_Value_Test is
- -- In the following tests the expected result is accurate
- -- to the machine precision so the minimum guaranteed error
- -- bound can be used if the argument is exact.
- --
- -- When using pi there is an extra error of 1.0ME.
- -- Although the real component has an error bound of 13.0,
- -- the complex component must take into account this error
- -- in the value for Pi.
- --
- -- One or i is added to the actual and expected results in
- -- order to prevent the expected result from having a
- -- real or imaginary part of 0. This is to allow a reasonable
- -- relative error for that component.
- Minimum_Error : constant := 13.0;
- begin
- Check (1.0 + Log (0.0 + i),
- 1.0 + Pi / 2.0 * i,
- "1+log(0+i)",
- Minimum_Error + 1.0);
- Check (1.0 + Log ((-1.0, 0.0)),
- 1.0 + (Pi * i),
- "log(-1+0i)+1 ",
- Minimum_Error + 1.0);
- exception
- when Constraint_Error =>
- Report.Failed ("Constraint_Error raised in special value test");
- when others =>
- Report.Failed ("exception in special value test");
- end Special_Value_Test;
-
-
-
- procedure Exact_Result_Test is
- No_Error : constant := 0.0;
- begin
- -- G.1.2(37);6.0
- Check (Log(1.0 + 0.0*i), 0.0 + 0.0 * i, "log(1+0i)", No_Error);
- exception
- when Constraint_Error =>
- Report.Failed ("Constraint_Error raised in Exact_Result Test");
- when others =>
- Report.Failed ("exception in Exact_Result Test");
- end Exact_Result_Test;
-
-
- procedure Identity_Test (RA, RB, IA, IB : Real) is
- -- Tests an identity over a range of values specified
- -- by the 4 parameters. RA and RB denote the range for the
- -- real part while IA and IB denote the range for the
- -- imaginary part.
- --
- -- For this test we use the identity
- -- Log(Z*Z) = 2 * Log(Z)
- --
-
- Scale : Real := Real (Real'Machine_Radix) ** (Real'Mantissa / 2 + 4);
- W, X, Y, Z : Real;
- CX, CY : Complex;
- Actual1, Actual2 : Complex;
- begin
- Accuracy_Error_Reported := False; -- reset
- for II in 1..Max_Samples loop
- X := (RB - RA) * Real (II) / Real (Max_Samples) + RA;
- for J in 1..Max_Samples loop
- Y := (IB - IA) * Real (J) / Real (Max_Samples) + IA;
-
- -- purify the arguments to minimize roundoff error.
- -- We construct the values so that the products X*X,
- -- Y*Y, and X*Y are all exact machine numbers.
- -- See Cody page 7 and CELEFUNT code.
- Z := X * Scale;
- W := Z + X;
- X := W - Z;
- Z := Y * Scale;
- W := Z + Y;
- Y := W - Z;
- CX := Compose_From_Cartesian(X,Y);
- Z := X*X - Y*Y;
- W := X*Y;
- CY := Compose_From_Cartesian(Z,W+W);
-
- -- The arguments are now ready so on with the
- -- identity computation.
- Actual1 := Log(CX);
-
- Actual2 := Log(CY) * 0.5;
-
- Check (Actual1, Actual2,
- "Identity_1_Test " & Integer'Image (II) &
- Integer'Image (J) & ": Log((" &
- Real'Image (CX.Re) & ", " &
- Real'Image (CX.Im) & ")) ",
- 26.0); -- 2 logs = 2*13. no error from this multiply
-
- if Accuracy_Error_Reported then
- -- only report the first error in this test in order to keep
- -- lots of failures from producing a huge error log
- return;
- end if;
- end loop;
- end loop;
-
- exception
- when Constraint_Error =>
- Report.Failed
- ("Constraint_Error raised in Identity_Test" &
- " for X=(" & Real'Image (X) &
- ", " & Real'Image (X) & ")");
- when others =>
- Report.Failed ("exception in Identity_Test" &
- " for X=(" & Real'Image (X) &
- ", " & Real'Image (X) & ")");
- end Identity_Test;
-
-
- procedure Exception_Test is
- -- Check that log((0,0)) causes constraint_error.
- -- G.1.2(29);
-
- X : Complex := (0.0, 0.0);
- begin
- if not Real'Machine_Overflows then
- -- not applicable: G.1.2(28);6.0
- return;
- end if;
-
- begin
- X := Log ((0.0, 0.0));
- Report.Failed ("exception not raised for log(0,0)");
- exception
- when Constraint_Error => null; -- ok
- when others =>
- Report.Failed ("wrong exception raised for log(0,0)");
- end;
-
- -- optimizer thwarting
- if Report.Ident_Bool(False) then
- Report.Comment (Real'Image (X.Re + X.Im));
- end if;
- end Exception_Test;
-
-
- procedure Do_Test is
- begin
- Special_Value_Test;
- Exact_Result_Test;
- -- test regions that do not include the unit circle so that
- -- the real part of LOG(Z) does not vanish
- -- See Cody page 9.
- Identity_Test ( 2.0, 10.0, 0.0, 10.0);
- Identity_Test (1000.0, 2000.0, -4000.0, -1000.0);
- Identity_Test (Real'Model_Epsilon, 0.25,
- -0.25, -Real'Model_Epsilon);
- Exception_Test;
- end Do_Test;
- end Generic_Check;
-
- -----------------------------------------------------------------------
- -----------------------------------------------------------------------
- package Float_Check is new Generic_Check (Float);
-
- -- check the floating point type with the most digits
- type A_Long_Float is digits System.Max_Digits;
- package A_Long_Float_Check is new Generic_Check (A_Long_Float);
-
- -----------------------------------------------------------------------
- -----------------------------------------------------------------------
-
-
-begin
- Report.Test ("CXG2019",
- "Check the accuracy of the complex LOG function");
-
- if Verbose then
- Report.Comment ("checking Standard.Float");
- end if;
-
- Float_Check.Do_Test;
-
- if Verbose then
- Report.Comment ("checking a digits" &
- Integer'Image (System.Max_Digits) &
- " floating point type");
- end if;
-
- A_Long_Float_Check.Do_Test;
-
-
- Report.Result;
-end CXG2019;
diff --git a/gcc/testsuite/ada/acats/tests/cxg/cxg2020.a b/gcc/testsuite/ada/acats/tests/cxg/cxg2020.a
deleted file mode 100644
index 1aed4ca5735..00000000000
--- a/gcc/testsuite/ada/acats/tests/cxg/cxg2020.a
+++ /dev/null
@@ -1,351 +0,0 @@
--- CXG2020.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that the complex SQRT function returns
--- a result that is within the error bound allowed.
---
--- TEST DESCRIPTION:
--- This test consists of a generic package that is
--- instantiated to check complex numbers based upon
--- both Float and a long float type.
--- The test for each floating point type is divided into
--- several parts:
--- Special value checks where the result is a known constant.
--- Checks that use an identity for determining the result.
---
--- SPECIAL REQUIREMENTS
--- The Strict Mode for the numerical accuracy must be
--- selected. The method by which this mode is selected
--- is implementation dependent.
---
--- APPLICABILITY CRITERIA:
--- This test applies only to implementations supporting the
--- Numerics Annex.
--- This test only applies to the Strict Mode for numerical
--- accuracy.
---
---
--- CHANGE HISTORY:
--- 24 Mar 96 SAIC Initial release for 2.1
--- 17 Aug 96 SAIC Incorporated reviewer comments.
--- 03 Jun 98 EDS Added parens to ensure that the expression is not
--- evaluated by multiplying its two large terms
--- together and overflowing.
---!
-
---
--- References:
---
--- W. J. Cody
--- CELEFUNT: A Portable Test Package for Complex Elementary Functions
--- Algorithm 714, Collected Algorithms from ACM.
--- Published in Transactions On Mathematical Software,
--- Vol. 19, No. 1, March, 1993, pp. 1-21.
---
--- CRC Standard Mathematical Tables
--- 23rd Edition
---
-
-with System;
-with Report;
-with Ada.Numerics.Generic_Complex_Types;
-with Ada.Numerics.Generic_Complex_Elementary_Functions;
-procedure CXG2020 is
- Verbose : constant Boolean := False;
- -- Note that Max_Samples is the number of samples taken in
- -- both the real and imaginary directions. Thus, for Max_Samples
- -- of 100 the number of values checked is 10000.
- Max_Samples : constant := 100;
-
- E : constant := Ada.Numerics.E;
- Pi : constant := Ada.Numerics.Pi;
-
- -- CRC Standard Mathematical Tables; 23rd Edition; pg 738
- Sqrt2 : constant :=
- 1.41421_35623_73095_04880_16887_24209_69807_85696_71875_37695;
- Sqrt3 : constant :=
- 1.73205_08075_68877_29352_74463_41505_87236_69428_05253_81039;
-
- generic
- type Real is digits <>;
- package Generic_Check is
- procedure Do_Test;
- end Generic_Check;
-
- package body Generic_Check is
- package Complex_Type is new
- Ada.Numerics.Generic_Complex_Types (Real);
- use Complex_Type;
-
- package CEF is new
- Ada.Numerics.Generic_Complex_Elementary_Functions (Complex_Type);
-
- function Sqrt (X : Complex) return Complex renames CEF.Sqrt;
-
- -- flag used to terminate some tests early
- Accuracy_Error_Reported : Boolean := False;
-
-
- procedure Check (Actual, Expected : Real;
- Test_Name : String;
- MRE : Real) is
- Max_Error : Real;
- Rel_Error : Real;
- Abs_Error : Real;
- begin
- -- In the case where the expected result is very small or 0
- -- we compute the maximum error as a multiple of Model_Epsilon
- -- instead of Model_Epsilon and Expected.
- Rel_Error := MRE * (abs Expected * Real'Model_Epsilon);
- Abs_Error := MRE * Real'Model_Epsilon;
- if Rel_Error > Abs_Error then
- Max_Error := Rel_Error;
- else
- Max_Error := Abs_Error;
- end if;
-
- if abs (Actual - Expected) > Max_Error then
- Accuracy_Error_Reported := True;
- Report.Failed (Test_Name &
- " actual: " & Real'Image (Actual) &
- " expected: " & Real'Image (Expected) &
- " difference: " & Real'Image (Actual - Expected) &
- " max err:" & Real'Image (Max_Error) );
- elsif Verbose then
- if Actual = Expected then
- Report.Comment (Test_Name & " exact result");
- else
- Report.Comment (Test_Name & " passed");
- end if;
- end if;
- end Check;
-
-
- procedure Check (Actual, Expected : Complex;
- Test_Name : String;
- MRE : Real) is
- begin
- Check (Actual.Re, Expected.Re, Test_Name & " real part", MRE);
- Check (Actual.Im, Expected.Im, Test_Name & " imaginary part", MRE);
- end Check;
-
-
- procedure Special_Value_Test is
- -- In the following tests the expected result is accurate
- -- to the machine precision so the minimum guaranteed error
- -- bound can be used if the argument is exact.
- --
- -- One or i is added to the actual and expected results in
- -- order to prevent the expected result from having a
- -- real or imaginary part of 0. This is to allow a reasonable
- -- relative error for that component.
- Minimum_Error : constant := 6.0;
- Z1, Z2 : Complex;
- begin
- Check (Sqrt(9.0+0.0*i) + i,
- 3.0+1.0*i,
- "sqrt(9+0i)+i",
- Minimum_Error);
- Check (Sqrt (-2.0 + 0.0 * i) + 1.0,
- 1.0 + Sqrt2 * i,
- "sqrt(-2)+1 ",
- Minimum_Error);
-
- -- make sure no exception occurs when taking the sqrt of
- -- very large and very small values.
-
- Z1 := (Real'Safe_Last * 0.9, Real'Safe_Last * 0.9);
- Z2 := Sqrt (Z1);
- begin
- Check (Z2 * Z2,
- Z1,
- "sqrt((big,big))",
- Minimum_Error + 5.0); -- +5 for multiply
- exception
- when others =>
- Report.Failed ("unexpected exception in sqrt((big,big))");
- end;
-
- Z1 := (Real'Model_Epsilon * 10.0, Real'Model_Epsilon * 10.0);
- Z2 := Sqrt (Z1);
- begin
- Check (Z2 * Z2,
- Z1,
- "sqrt((little,little))",
- Minimum_Error + 5.0); -- +5 for multiply
- exception
- when others =>
- Report.Failed ("unexpected exception in " &
- "sqrt((little,little))");
- end;
-
- exception
- when Constraint_Error =>
- Report.Failed ("Constraint_Error raised in special value test");
- when others =>
- Report.Failed ("exception in special value test");
- end Special_Value_Test;
-
-
-
- procedure Exact_Result_Test is
- No_Error : constant := 0.0;
- begin
- -- G.1.2(36);6.0
- Check (Sqrt(0.0 + 0.0*i), 0.0 + 0.0 * i, "sqrt(0+0i)", No_Error);
-
- -- G.1.2(37);6.0
- Check (Sqrt(1.0 + 0.0*i), 1.0 + 0.0 * i, "sqrt(1+0i)", No_Error);
-
- -- G.1.2(38-39);6.0
- Check (Sqrt(-1.0 + 0.0*i), 0.0 + 1.0 * i, "sqrt(-1+0i)", No_Error);
-
- -- G.1.2(40);6.0
- if Real'Signed_Zeros then
- Check (Sqrt(-1.0-0.0*i), 0.0 - 1.0 * i, "sqrt(-1-0i)", No_Error);
- end if;
- exception
- when Constraint_Error =>
- Report.Failed ("Constraint_Error raised in Exact_Result Test");
- when others =>
- Report.Failed ("exception in Exact_Result Test");
- end Exact_Result_Test;
-
-
- procedure Identity_Test (RA, RB, IA, IB : Real) is
- -- Tests an identity over a range of values specified
- -- by the 4 parameters. RA and RB denote the range for the
- -- real part while IA and IB denote the range for the
- -- imaginary part of the result.
- --
- -- For this test we use the identity
- -- Sqrt(Z*Z) = Z
- --
-
- Scale : Real := Real (Real'Machine_Radix) ** (Real'Mantissa / 2 + 4);
- W, X, Y, Z : Real;
- CX : Complex;
- Actual, Expected : Complex;
- begin
- Accuracy_Error_Reported := False; -- reset
- for II in 1..Max_Samples loop
- X := (RB - RA) * Real (II) / Real (Max_Samples) + RA;
- for J in 1..Max_Samples loop
- Y := (IB - IA) * Real (J) / Real (Max_Samples) + IA;
-
- -- purify the arguments to minimize roundoff error.
- -- We construct the values so that the products X*X,
- -- Y*Y, and X*Y are all exact machine numbers.
- -- See Cody page 7 and CELEFUNT code.
- Z := X * Scale;
- W := Z + X;
- X := W - Z;
- Z := Y * Scale;
- W := Z + Y;
- Y := W - Z;
- -- G.1.2(21);6.0 - real part of result is non-negative
- Expected := Compose_From_Cartesian( abs X,Y);
- Z := X*X - Y*Y;
- W := X*Y;
- CX := Compose_From_Cartesian(Z,W+W);
-
- -- The arguments are now ready so on with the
- -- identity computation.
- Actual := Sqrt(CX);
-
- Check (Actual, Expected,
- "Identity_1_Test " & Integer'Image (II) &
- Integer'Image (J) & ": Sqrt((" &
- Real'Image (CX.Re) & ", " &
- Real'Image (CX.Im) & ")) ",
- 8.5); -- 6.0 from sqrt, 2.5 from argument.
- -- See Cody pg 7-8 for analysis of additional error amount.
-
- if Accuracy_Error_Reported then
- -- only report the first error in this test in order to keep
- -- lots of failures from producing a huge error log
- return;
- end if;
- end loop;
- end loop;
-
- exception
- when Constraint_Error =>
- Report.Failed
- ("Constraint_Error raised in Identity_Test" &
- " for X=(" & Real'Image (X) &
- ", " & Real'Image (X) & ")");
- when others =>
- Report.Failed ("exception in Identity_Test" &
- " for X=(" & Real'Image (X) &
- ", " & Real'Image (X) & ")");
- end Identity_Test;
-
-
- procedure Do_Test is
- begin
- Special_Value_Test;
- Exact_Result_Test;
- -- ranges where the sign is the same and where it
- -- differs.
- Identity_Test ( 0.0, 10.0, 0.0, 10.0);
- Identity_Test ( 0.0, 100.0, -100.0, 0.0);
- end Do_Test;
- end Generic_Check;
-
- -----------------------------------------------------------------------
- -----------------------------------------------------------------------
- package Float_Check is new Generic_Check (Float);
-
- -- check the floating point type with the most digits
- type A_Long_Float is digits System.Max_Digits;
- package A_Long_Float_Check is new Generic_Check (A_Long_Float);
-
- -----------------------------------------------------------------------
- -----------------------------------------------------------------------
-
-
-begin
- Report.Test ("CXG2020",
- "Check the accuracy of the complex SQRT function");
-
- if Verbose then
- Report.Comment ("checking Standard.Float");
- end if;
-
- Float_Check.Do_Test;
-
- if Verbose then
- Report.Comment ("checking a digits" &
- Integer'Image (System.Max_Digits) &
- " floating point type");
- end if;
-
- A_Long_Float_Check.Do_Test;
-
-
- Report.Result;
-end CXG2020;
diff --git a/gcc/testsuite/ada/acats/tests/cxg/cxg2021.a b/gcc/testsuite/ada/acats/tests/cxg/cxg2021.a
deleted file mode 100644
index db49fc845f2..00000000000
--- a/gcc/testsuite/ada/acats/tests/cxg/cxg2021.a
+++ /dev/null
@@ -1,386 +0,0 @@
--- CXG2021.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that the complex SIN and COS functions return
--- a result that is within the error bound allowed.
---
--- TEST DESCRIPTION:
--- This test consists of a generic package that is
--- instantiated to check complex numbers based upon
--- both Float and a long float type.
--- The test for each floating point type is divided into
--- several parts:
--- Special value checks where the result is a known constant.
--- Checks that use an identity for determining the result.
---
--- SPECIAL REQUIREMENTS
--- The Strict Mode for the numerical accuracy must be
--- selected. The method by which this mode is selected
--- is implementation dependent.
---
--- APPLICABILITY CRITERIA:
--- This test applies only to implementations supporting the
--- Numerics Annex.
--- This test only applies to the Strict Mode for numerical
--- accuracy.
---
---
--- CHANGE HISTORY:
--- 27 Mar 96 SAIC Initial release for 2.1
--- 22 Aug 96 SAIC No longer skips test for systems with
--- more than 20 digits of precision.
---
---!
-
---
--- References:
---
--- W. J. Cody
--- CELEFUNT: A Portable Test Package for Complex Elementary Functions
--- Algorithm 714, Collected Algorithms from ACM.
--- Published in Transactions On Mathematical Software,
--- Vol. 19, No. 1, March, 1993, pp. 1-21.
---
--- CRC Standard Mathematical Tables
--- 23rd Edition
---
-
-with System;
-with Report;
-with Ada.Numerics.Generic_Complex_Types;
-with Ada.Numerics.Generic_Complex_Elementary_Functions;
-procedure CXG2021 is
- Verbose : constant Boolean := False;
- -- Note that Max_Samples is the number of samples taken in
- -- both the real and imaginary directions. Thus, for Max_Samples
- -- of 100 the number of values checked is 10000.
- Max_Samples : constant := 100;
-
- E : constant := Ada.Numerics.E;
- Pi : constant := Ada.Numerics.Pi;
-
- generic
- type Real is digits <>;
- package Generic_Check is
- procedure Do_Test;
- end Generic_Check;
-
- package body Generic_Check is
- package Complex_Type is new
- Ada.Numerics.Generic_Complex_Types (Real);
- use Complex_Type;
-
- package CEF is new
- Ada.Numerics.Generic_Complex_Elementary_Functions (Complex_Type);
-
- function Sin (X : Complex) return Complex renames CEF.Sin;
- function Cos (X : Complex) return Complex renames CEF.Cos;
-
- -- flag used to terminate some tests early
- Accuracy_Error_Reported : Boolean := False;
-
- -- The following value is a lower bound on the accuracy
- -- required. It is normally 0.0 so that the lower bound
- -- is computed from Model_Epsilon. However, for tests
- -- where the expected result is only known to a certain
- -- amount of precision this bound takes on a non-zero
- -- value to account for that level of precision.
- Error_Low_Bound : Real := 0.0;
-
- -- the E_Factor is an additional amount added to the Expected
- -- value prior to computing the maximum relative error.
- -- This is needed because the error analysis (Cody pg 17-20)
- -- requires this additional allowance.
- procedure Check (Actual, Expected : Real;
- Test_Name : String;
- MRE : Real;
- E_Factor : Real := 0.0) is
- Max_Error : Real;
- Rel_Error : Real;
- Abs_Error : Real;
- begin
- -- In the case where the expected result is very small or 0
- -- we compute the maximum error as a multiple of Model_Epsilon instead
- -- of Model_Epsilon and Expected.
- Rel_Error := MRE * Real'Model_Epsilon * (abs Expected + E_Factor);
- Abs_Error := MRE * Real'Model_Epsilon;
- if Rel_Error > Abs_Error then
- Max_Error := Rel_Error;
- else
- Max_Error := Abs_Error;
- end if;
-
- -- take into account the low bound on the error
- if Max_Error < Error_Low_Bound then
- Max_Error := Error_Low_Bound;
- end if;
-
- if abs (Actual - Expected) > Max_Error then
- Accuracy_Error_Reported := True;
- Report.Failed (Test_Name &
- " actual: " & Real'Image (Actual) &
- " expected: " & Real'Image (Expected) &
- " difference: " & Real'Image (Actual - Expected) &
- " max err:" & Real'Image (Max_Error) &
- " efactor:" & Real'Image (E_Factor) );
- elsif Verbose then
- if Actual = Expected then
- Report.Comment (Test_Name & " exact result");
- else
- Report.Comment (Test_Name & " passed" &
- " actual: " & Real'Image (Actual) &
- " expected: " & Real'Image (Expected) &
- " difference: " & Real'Image (Actual - Expected) &
- " max err:" & Real'Image (Max_Error) &
- " efactor:" & Real'Image (E_Factor) );
- end if;
- end if;
- end Check;
-
-
- procedure Check (Actual, Expected : Complex;
- Test_Name : String;
- MRE : Real;
- R_Factor, I_Factor : Real := 0.0) is
- begin
- Check (Actual.Re, Expected.Re, Test_Name & " real part",
- MRE, R_Factor);
- Check (Actual.Im, Expected.Im, Test_Name & " imaginary part",
- MRE, I_Factor);
- end Check;
-
-
- procedure Special_Value_Test is
- -- In the following tests the expected result is accurate
- -- to the machine precision so the minimum guaranteed error
- -- bound can be used if the argument is exact.
- -- Since the argument involves Pi, we must allow for this
- -- inexact argument.
- Minimum_Error : constant := 11.0;
- begin
- Check (Sin (Pi/2.0 + 0.0*i),
- 1.0 + 0.0*i,
- "sin(pi/2+0i)",
- Minimum_Error + 1.0);
- Check (Cos (Pi/2.0 + 0.0*i),
- 0.0 + 0.0*i,
- "cos(pi/2+0i)",
- Minimum_Error + 1.0);
- exception
- when Constraint_Error =>
- Report.Failed ("Constraint_Error raised in special value test");
- when others =>
- Report.Failed ("exception in special value test");
- end Special_Value_Test;
-
-
-
- procedure Exact_Result_Test is
- No_Error : constant := 0.0;
- begin
- -- G.1.2(36);6.0
- Check (Sin(0.0 + 0.0*i), 0.0 + 0.0 * i, "sin(0+0i)", No_Error);
- Check (Cos(0.0 + 0.0*i), 1.0 + 0.0 * i, "cos(0+0i)", No_Error);
- exception
- when Constraint_Error =>
- Report.Failed ("Constraint_Error raised in Exact_Result Test");
- when others =>
- Report.Failed ("exception in Exact_Result Test");
- end Exact_Result_Test;
-
-
- procedure Identity_Test (RA, RB, IA, IB : Real) is
- -- Tests an identity over a range of values specified
- -- by the 4 parameters. RA and RB denote the range for the
- -- real part while IA and IB denote the range for the
- -- imaginary part.
- --
- -- For this test we use the identity
- -- Sin(Z) = Sin(Z-W) * Cos(W) + Cos(Z-W) * Sin(W)
- -- and
- -- Cos(Z) = Cos(Z-W) * Cos(W) - Sin(Z-W) * Sin(W)
- --
-
- X, Y : Real;
- Z : Complex;
- W : constant Complex := Compose_From_Cartesian(0.0625, 0.0625);
- ZmW : Complex; -- Z - W
- Sin_ZmW,
- Cos_ZmW : Complex;
- Actual1, Actual2 : Complex;
- R_Factor : Real; -- additional real error factor
- I_Factor : Real; -- additional imaginary error factor
- Sin_W : constant Complex := (6.2581348413276935585E-2,
- 6.2418588008436587236E-2);
- -- numeric stability is enhanced by using Cos(W) - 1.0 instead of
- -- Cos(W) in the computation.
- Cos_W_m_1 : constant Complex := (-2.5431314180235545803E-6,
- -3.9062493377261771826E-3);
-
-
- begin
- if Real'Digits > 20 then
- -- constants used here accurate to 20 digits. Allow 1
- -- additional digit of error for computation.
- Error_Low_Bound := 0.00000_00000_00000_0001;
- Report.Comment ("accuracy checked to 19 digits");
- end if;
-
- Accuracy_Error_Reported := False; -- reset
- for II in 0..Max_Samples loop
- X := (RB - RA) * Real (II) / Real (Max_Samples) + RA;
- for J in 0..Max_Samples loop
- Y := (IB - IA) * Real (J) / Real (Max_Samples) + IA;
-
- Z := Compose_From_Cartesian(X,Y);
- ZmW := Z - W;
- Sin_ZmW := Sin (ZmW);
- Cos_ZmW := Cos (ZmW);
-
- -- now for the first identity
- -- Sin(Z) = Sin(Z-W) * Cos(W) + Cos(Z-W) * Sin(W)
- -- = Sin(Z-W) * (1+(Cos(W)-1)) + Cos(Z-W) * Sin(W)
- -- = Sin(Z-W) + Sin(Z-W)*(Cos(W)-1) + Cos(Z-W)*Sin(W)
-
-
- Actual1 := Sin (Z);
- Actual2 := Sin_ZmW + (Sin_ZmW * Cos_W_m_1 + Cos_ZmW * Sin_W);
-
- -- The computation of the additional error factors are taken
- -- from Cody pages 17-20.
-
- R_Factor := abs (Re (Sin_ZmW) * Re (1.0 - Cos_W_m_1)) +
- abs (Im (Sin_ZmW) * Im (1.0 - Cos_W_m_1)) +
- abs (Re (Cos_ZmW) * Re (Sin_W)) +
- abs (Re (Cos_ZmW) * Re (1.0 - Cos_W_m_1));
-
- I_Factor := abs (Re (Sin_ZmW) * Im (1.0 - Cos_W_m_1)) +
- abs (Im (Sin_ZmW) * Re (1.0 - Cos_W_m_1)) +
- abs (Re (Cos_ZmW) * Im (Sin_W)) +
- abs (Im (Cos_ZmW) * Re (1.0 - Cos_W_m_1));
-
- Check (Actual1, Actual2,
- "Identity_1_Test " & Integer'Image (II) &
- Integer'Image (J) & ": Sin((" &
- Real'Image (Z.Re) & ", " &
- Real'Image (Z.Im) & ")) ",
- 11.0, R_Factor, I_Factor);
-
- -- now for the second identity
- -- Cos(Z) = Cos(Z-W) * Cos(W) - Sin(Z-W) * Sin(W)
- -- = Cos(Z-W) * (1+(Cos(W)-1) - Sin(Z-W) * Sin(W)
- Actual1 := Cos (Z);
- Actual2 := Cos_ZmW + (Cos_ZmW * Cos_W_m_1 - Sin_ZmW * Sin_W);
-
- -- The computation of the additional error factors are taken
- -- from Cody pages 17-20.
-
- R_Factor := abs (Re (Sin_ZmW) * Re (Sin_W)) +
- abs (Im (Sin_ZmW) * Im (Sin_W)) +
- abs (Re (Cos_ZmW) * Re (1.0 - Cos_W_m_1)) +
- abs (Im (Cos_ZmW) * Im (1.0 - Cos_W_m_1));
-
- I_Factor := abs (Re (Sin_ZmW) * Im (Sin_W)) +
- abs (Im (Sin_ZmW) * Re (Sin_W)) +
- abs (Re (Cos_ZmW) * Im (1.0 - Cos_W_m_1)) +
- abs (Im (Cos_ZmW) * Re (1.0 - Cos_W_m_1));
-
- Check (Actual1, Actual2,
- "Identity_2_Test " & Integer'Image (II) &
- Integer'Image (J) & ": Cos((" &
- Real'Image (Z.Re) & ", " &
- Real'Image (Z.Im) & ")) ",
- 11.0, R_Factor, I_Factor);
-
- if Accuracy_Error_Reported then
- -- only report the first error in this test in order to keep
- -- lots of failures from producing a huge error log
- Error_Low_Bound := 0.0; -- reset
- return;
- end if;
- end loop;
- end loop;
-
- Error_Low_Bound := 0.0; -- reset
- exception
- when Constraint_Error =>
- Report.Failed
- ("Constraint_Error raised in Identity_Test" &
- " for Z=(" & Real'Image (X) &
- ", " & Real'Image (Y) & ")");
- when others =>
- Report.Failed ("exception in Identity_Test" &
- " for Z=(" & Real'Image (X) &
- ", " & Real'Image (Y) & ")");
- end Identity_Test;
-
-
- procedure Do_Test is
- begin
- Special_Value_Test;
- Exact_Result_Test;
- -- test regions where sin and cos have the same sign and
- -- about the same magnitude. This will minimize subtraction
- -- errors in the identities.
- -- See Cody page 17.
- Identity_Test (0.0625, 10.0, 0.0625, 10.0);
- Identity_Test ( 16.0, 17.0, 16.0, 17.0);
- end Do_Test;
- end Generic_Check;
-
- -----------------------------------------------------------------------
- -----------------------------------------------------------------------
- package Float_Check is new Generic_Check (Float);
-
- -- check the floating point type with the most digits
- type A_Long_Float is digits System.Max_Digits;
- package A_Long_Float_Check is new Generic_Check (A_Long_Float);
-
- -----------------------------------------------------------------------
- -----------------------------------------------------------------------
-
-
-begin
- Report.Test ("CXG2021",
- "Check the accuracy of the complex SIN and COS functions");
-
- if Verbose then
- Report.Comment ("checking Standard.Float");
- end if;
-
- Float_Check.Do_Test;
-
- if Verbose then
- Report.Comment ("checking a digits" &
- Integer'Image (System.Max_Digits) &
- " floating point type");
- end if;
-
- A_Long_Float_Check.Do_Test;
-
-
- Report.Result;
-end CXG2021;
diff --git a/gcc/testsuite/ada/acats/tests/cxg/cxg2022.a b/gcc/testsuite/ada/acats/tests/cxg/cxg2022.a
deleted file mode 100644
index f9e4d1cae33..00000000000
--- a/gcc/testsuite/ada/acats/tests/cxg/cxg2022.a
+++ /dev/null
@@ -1,309 +0,0 @@
--- CXG2022.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that multiplication and division of binary fixed point
--- numbers with compatible 'small values produce exact results.
---
--- TEST DESCRIPTION:
--- Signed, unsigned, and a mixture of signed and unsigned
--- binary fixed point values are multiplied and divided.
--- The result is checked against the expected "perfect result set"
---
--- SPECIAL REQUIREMENTS
--- The Strict Mode for the numerical accuracy must be
--- selected. The method by which this mode is selected
--- is implementation dependent.
---
--- APPLICABILITY CRITERIA:
--- This test applies only to implementations supporting the
--- Numerics Annex.
--- This test only applies to the Strict Mode for numerical
--- accuracy.
---
---
--- CHANGE HISTORY:
--- 1 Apr 96 SAIC Initial release for 2.1
--- 29 Jan 1998 EDS Repaired fixed point errors ("**" and
--- assumptions about 'Small)
---!
-
-with System;
-with Report;
-procedure CXG2022 is
- Verbose : constant Boolean := False;
-
-procedure Check_Signed is
- type Pairs is delta 2.0 range -2.0 ** (System.Max_Mantissa) ..
- 2.0 ** (System.Max_Mantissa) - 1.0;
- type Halves is delta 0.5 range -2.0 ** (System.Max_Mantissa-2) ..
- 2.0 ** (System.Max_Mantissa-2) - 1.0;
- P1, P2, P3, P4 : Pairs;
- H1, H2, H3, H4 : Halves;
-
- procedure Dont_Opt is
- -- keep optimizer from knowing the constant value of expressions
- begin
- if Report.Ident_Bool (False) then
- P1 := 2.0; P2 := 4.0; P3 := 6.0;
- H1 := -2.0; H2 := 9.0; H3 := 3.0;
- end if;
- end Dont_Opt;
-
-begin
- H1 := -0.5;
- H2 := Halves'First;
- H3 := 1.0;
- P1 := 12.0;
- P2 := Pairs'First;
- P3 := Pairs'Last;
- Dont_Opt;
-
- P4 := Pairs (P1 * H1); -- 12.0 * -0.5
- if P4 /= -6.0 then
- Report.Failed ("12.0 * -0.5 = " & Pairs'Image (P4));
- end if;
-
- H4 := Halves (P1 / H1); -- 12.0 / -0.5
- if H4 /= -24.0 then
- Report.Failed ("12.0 / -0.5 = " & Halves'Image (H4));
- end if;
-
- P4 := P3 * H3; -- Pairs'Last * 1.0
- if P4 /= Pairs'Last then
- Report.Failed ("Pairs'Last * 1.0 = " & Pairs'Image (P4));
- end if;
-
- P4 := P3 / H3; -- Pairs'Last / 1.0
- if P4 /= Pairs'Last then
- Report.Failed ("Pairs'Last / 1.0 = " & Pairs'Image (P4));
- end if;
-
- P4 := P2 * 0.25; -- Pairs'First * 0.25
- if P4 /= Pairs (-2.0 ** (System.Max_Mantissa - 2)) then
- Report.Failed ("Pairs'First * 0.25 = " & Pairs'Image (P4));
- end if;
-
- P4 := 100.5 / H1; -- 100.5 / -0.5
- if P4 = -201.0 then
- null; -- Perfect result
- elsif Pairs'Small = 2.0 and ( P4 = -200.0 or P4 = -202.0 ) then
- null; -- Allowed variation
- else
- Report.Failed ("Pairs'Small =" & Pairs'Image (Pairs'Small) &
- " and 100.5/-0.5 = " & Pairs'Image (P4) );
- end if;
-
- H4 := H1 * H2; -- -0.5 * Halves'First
- if H4 /= Halves (2.0 ** (System.Max_Mantissa-3)) then
- Report.Failed ("-0.5 * Halves'First =" & Halves'Image (H4) &
- " instead of " &
- Halves'Image( Halves(2.0 ** (System.Max_Mantissa-3))));
- end if;
-
-exception
- when others =>
- Report.Failed ("unexpected exception in Check_Signed");
-end Check_Signed;
-
-
-
-procedure Check_Unsigned is
- type Pairs is delta 2.0 range 0.0 .. 2.0 ** (System.Max_Mantissa+1) - 1.0;
- type Halves is delta 0.5 range 0.0 .. 2.0 ** (System.Max_Mantissa-1) - 1.0;
- P1, P2, P3, P4 : Pairs;
- H1, H2, H3, H4 : Halves;
-
- procedure Dont_Opt is
- -- keep optimizer from knowing the constant value of expressions
- begin
- if Report.Ident_Bool (False) then
- P1 := 2.0; P2 := 4.0; P3 := 6.0;
- H1 := 2.0; H2 := 9.0; H3 := 3.0;
- end if;
- end Dont_Opt;
-
-begin
- H1 := 10.5;
- H2 := Halves(2.0 ** (System.Max_Mantissa - 6));
- H3 := 1.0;
- P1 := 12.0;
- P2 := Pairs'Last / 2;
- P3 := Pairs'Last;
- Dont_Opt;
-
- P4 := Pairs (P1 * H1); -- 12.0 * 10.5
- if P4 /= 126.0 then
- Report.Failed ("12.0 * 10.5 = " & Pairs'Image (P4));
- end if;
-
- H4 := Halves (P1 / H1); -- 12.0 / 10.5
- if H4 /= 1.0 and H4 /= 1.5 then
- Report.Failed ("12.0 / 10.5 = " & Halves'Image (H4));
- end if;
-
- P4 := P3 * H3; -- Pairs'Last * 1.0
- if P4 /= Pairs'Last then
- Report.Failed ("Pairs'Last * 1.0 = " & Pairs'Image (P4));
- end if;
-
- P4 := P3 / H3; -- Pairs'Last / 1.0
- if P4 /= Pairs'Last then
- Report.Failed ("Pairs'Last / 1.0 = " & Pairs'Image (P4));
- end if;
-
- P4 := P1 * 0.25; -- 12.0 * 0.25
- if P4 /= 2.0 and P4 /= 4.0 then
- Report.Failed ("12.0 * 0.25 = " & Pairs'Image (P4));
- end if;
-
- P4 := 100.5 / H1; -- 100.5 / 10.5 = 9.571...
- if P4 /= 8.0 and P4 /= 10.0 then
- Report.Failed ("100.5/10.5 = " & Pairs'Image (P4));
- end if;
-
- H4 := H2 * 2; -- 2**(max_mantissa-6) * 2
- if H4 /= Halves(2.0 ** (System.Max_Mantissa-5)) then
- Report.Failed ("2**(System.Max_Mantissa-6) * 2=" & Halves'Image (H4) &
- " instead of " &
- Halves'Image( Halves(2.0 ** (System.Max_Mantissa-5))));
- end if;
-
-exception
- when others =>
- Report.Failed ("unexpected exception in Check_Unsigned");
-end Check_Unsigned;
-
-
-
-procedure Check_Mixed is
- type Pairs is delta 2.0 range -2.0 ** (System.Max_Mantissa) ..
- 2.0 ** (System.Max_Mantissa) - 1.0;
- type Halves is delta 0.5 range 0.0 .. 2.0 ** (System.Max_Mantissa-1) - 1.0;
- P1, P2, P3, P4 : Pairs;
- H1, H2, H3, H4 : Halves;
-
- procedure Dont_Opt is
- -- keep optimizer from knowing the constant value of expressions
- begin
- if Report.Ident_Bool (False) then
- P1 := 2.0; P2 := 4.0; P3 := 6.0;
- H1 := 2.0; H2 := 9.0; H3 := 3.0;
- end if;
- end Dont_Opt;
-
-begin
- H1 := 10.5;
- H2 := Halves(2.0 ** (System.Max_Mantissa - 6));
- H3 := 1.0;
- P1 := 12.0;
- P2 := -4.0;
- P3 := Pairs'Last;
- Dont_Opt;
-
- P4 := Pairs (P1 * H1); -- 12.0 * 10.5
- if P4 /= 126.0 then
- Report.Failed ("12.0 * 10.5 = " & Pairs'Image (P4));
- end if;
-
- H4 := Halves (P1 / H1); -- 12.0 / 10.5
- if H4 /= 1.0 and H4 /= 1.5 then
- Report.Failed ("12.0 / 10.5 = " & Halves'Image (H4));
- end if;
-
- P4 := P3 * H3; -- Pairs'Last * 1.0
- if P4 /= Pairs'Last then
- Report.Failed ("Pairs'Last * 1.0 = " & Pairs'Image (P4));
- end if;
-
- P4 := P3 / H3; -- Pairs'Last / 1.0
- if P4 /= Pairs'Last then
- Report.Failed ("Pairs'Last / 1.0 = " & Pairs'Image (P4));
- end if;
-
- P4 := P1 * 0.25; -- 12.0 * 0.25
- if P4 = 3.0 then
- null; -- Perfect result
- elsif Pairs'Small = 2.0 and then ( P4 = 2.0 or P4 = 4.0 ) then
- null; -- Allowed deviation
- else
- Report.Failed ("Pairs'Small =" & Pairs'Image (Pairs'Small) &
- "and 12.0 * 0.25 = " & Pairs'Image (P4) );
- end if;
-
- P4 := 100.5 / H1; -- 100.5 / 10.5 = 9.571...
- if P4 = 9.0 then
- null; -- Perfect result
- elsif Pairs'Small = 2.0 and then ( P4 = 8.0 or P4 = 10.0 ) then
- null; -- Allowed values
- else
- Report.Failed ("Pairs'Small =" & Pairs'Image (Pairs'Small) &
- "and 100.5/10.5 = " & Pairs'Image (P4) );
- end if;
-
- H4 := H2 * 2; -- 2**(max_mantissa-6) * 2
- if H4 /= Halves(2.0 ** (System.Max_Mantissa-5)) then
- Report.Failed ("2**(System.Max_Mantissa-6) * 2=" & Halves'Image (H4) &
- " instead of " &
- Halves'Image( Halves(2.0 ** (System.Max_Mantissa-5))));
- end if;
-
- P4 := Pairs(P1 * 6) / P2; -- 12 * 6 / -4
- if (P4 /= -18.0) then
- Report.Failed ("12*6/-4 = " & Pairs'Image(P4));
- end if;
-
- P4 := Halves(P1 * 6.0) / P2; -- 12 * 6 / -4
- if (P4 /= -18.0) then
- Report.Failed ("Halves(12*6)/-4 = " & Pairs'Image(P4));
- end if;
-
-exception
- when others =>
- Report.Failed ("unexpected exception in Check_Mixed");
-end Check_Mixed;
-
-
-begin -- main
- Report.Test ("CXG2022",
- "Check the accuracy of multiplication and division" &
- " of binary fixed point numbers");
- if Verbose then
- Report.Comment ("starting signed test");
- end if;
- Check_Signed;
-
- if Verbose then
- Report.Comment ("starting unsigned test");
- end if;
- Check_Unsigned;
-
- if Verbose then
- Report.Comment ("starting mixed sign test");
- end if;
- Check_Mixed;
-
- Report.Result;
-end CXG2022;
diff --git a/gcc/testsuite/ada/acats/tests/cxg/cxg2023.a b/gcc/testsuite/ada/acats/tests/cxg/cxg2023.a
deleted file mode 100644
index 0cdd5574e09..00000000000
--- a/gcc/testsuite/ada/acats/tests/cxg/cxg2023.a
+++ /dev/null
@@ -1,351 +0,0 @@
--- CXG2023.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that multiplication and division of decimal fixed point
--- numbers produce exact results.
---
--- TEST DESCRIPTION:
--- Check that multiplication and division of decimal fixed point
--- numbers produce exact results.
---
--- SPECIAL REQUIREMENTS
--- The Strict Mode for the numerical accuracy must be
--- selected. The method by which this mode is selected
--- is implementation dependent.
---
--- APPLICABILITY CRITERIA:
--- This test applies only to implementations supporting the
--- Numerics Annex.
--- This test only applies to the Strict Mode for numerical
--- accuracy.
--- This test applies only to implementations supporting
--- decimal fixed point types of at least 9 digits.
---
---
--- CHANGE HISTORY:
--- 3 Apr 96 SAIC Initial release for 2.1
---
---!
-
-with System;
-with Report;
-procedure CXG2023 is
- Verbose : constant Boolean := False;
-
-procedure Check_1 is
- Num_Digits : constant := 6;
- type Pennies is delta 0.01 digits Num_Digits;
- type Franklins is delta 100.0 digits Num_Digits;
- type Dollars is delta 1.0 digits Num_Digits;
-
- P1 : Pennies;
- F1 : Franklins;
- D1 : Dollars;
-
- -- optimization thwarting functions
-
- function P (X : Pennies) return Pennies is
- begin
- if Report.Ident_Bool (True) then
- return X;
- else
- return 3.21; -- never executed
- end if;
- end P;
-
-
- function F (X : Franklins) return Franklins is
- begin
- if Report.Ident_Bool (True) then
- return X;
- else
- return 32100.0; -- never executed
- end if;
- end F;
-
-
- function D (X : Dollars) return Dollars is
- begin
- if Report.Ident_Bool (True) then
- return X;
- else
- return 321.0; -- never executed
- end if;
- end D;
-
-
-begin
- -- multiplication where one operand is universal real
-
- P1 := P(0.05) * 200.0;
- if P1 /= 10.00 then
- Report.Failed ("1 - expected 10.00 got " & Pennies'Image (P1));
- end if;
-
- D1 := P(0.05) * 100.0;
- if D1 /= 5.00 then
- Report.Failed ("2 - expected 5.00 got " & Dollars'Image (D1));
- end if;
-
- F1 := P(0.05) * 50_000.0;
- if F1 /= 2500.00 then
- Report.Failed ("3 - expected 2500.0 got " & Franklins'Image (F1));
- end if;
-
- -- multiplication where both operands are decimal fixed
-
- P1 := P(0.05) * D(-200.0);
- if P1 /= -10.00 then
- Report.Failed ("4 - expected -10.00 got " & Pennies'Image (P1));
- end if;
-
- D1 := P(0.05) * P(-100.0);
- if D1 /= -5.00 then
- Report.Failed ("5 - expected -5.00 got " & Dollars'Image (D1));
- end if;
-
- F1 := P(-0.05) * F(50_000.0);
- if F1 /= -2500.00 then
- Report.Failed ("6 - expected -2500.0 got " & Franklins'Image (F1));
- end if;
-
- -- division where one operand is universal real
-
- P1 := P(0.05) / 0.001;
- if P1 /= 50.00 then
- Report.Failed ("7 - expected 50.00 got " & Pennies'Image (P1));
- end if;
-
- D1 := D(1000.0) / 3.0;
- if D1 /= 333.00 then
- Report.Failed ("8 - expected 333.00 got " & Dollars'Image (D1));
- end if;
-
- F1 := P(1234.56) / 0.0001;
- if F1 /= 12345600.00 then
- Report.Failed ("9 - expected 12345600.0 got " & Franklins'Image (F1));
- end if;
-
-
- -- division where both operands are decimal fixed
-
- P1 := P(0.05) / D(1.0);
- if P1 /= 0.05 then
- Report.Failed ("10 - expected 0.05 got " & Pennies'Image (P1));
- end if;
-
- -- check for truncation toward 0
- D1 := P(-101.00) / P(2.0);
- if D1 /= -50.00 then
- Report.Failed ("11 - expected -50.00 got " & Dollars'Image (D1));
- end if;
-
- P1 := P(-102.03) / P(-0.5);
- if P1 /= 204.06 then
- Report.Failed ("12 - expected 204.06 got " & Pennies'Image (P1));
- end if;
-
- F1 := P(876.54) / P(0.03);
- if F1 /= 29200.00 then
- Report.Failed ("13 - expected 29200.0 got " & Franklins'Image (F1));
- end if;
-
-exception
- when others =>
- Report.Failed ("unexpected exception in Check_1");
-end Check_1;
-
-generic
- type Pennies is delta<> digits<>;
- type Dollars is delta<> digits<>;
- type Franklins is delta<> digits<>;
-procedure Generic_Check;
-procedure Generic_Check is
-
- -- the following code is copied directly from the
- -- above procedure Check_1
-
- P1 : Pennies;
- F1 : Franklins;
- D1 : Dollars;
-
- -- optimization thwarting functions
-
- function P (X : Pennies) return Pennies is
- begin
- if Report.Ident_Bool (True) then
- return X;
- else
- return 3.21; -- never executed
- end if;
- end P;
-
-
- function F (X : Franklins) return Franklins is
- begin
- if Report.Ident_Bool (True) then
- return X;
- else
- return 32100.0; -- never executed
- end if;
- end F;
-
-
- function D (X : Dollars) return Dollars is
- begin
- if Report.Ident_Bool (True) then
- return X;
- else
- return 321.0; -- never executed
- end if;
- end D;
-
-
-begin
- -- multiplication where one operand is universal real
-
- P1 := P(0.05) * 200.0;
- if P1 /= 10.00 then
- Report.Failed ("1 - expected 10.00 got " & Pennies'Image (P1));
- end if;
-
- D1 := P(0.05) * 100.0;
- if D1 /= 5.00 then
- Report.Failed ("2 - expected 5.00 got " & Dollars'Image (D1));
- end if;
-
- F1 := P(0.05) * 50_000.0;
- if F1 /= 2500.00 then
- Report.Failed ("3 - expected 2500.0 got " & Franklins'Image (F1));
- end if;
-
- -- multiplication where both operands are decimal fixed
-
- P1 := P(0.05) * D(-200.0);
- if P1 /= -10.00 then
- Report.Failed ("4 - expected -10.00 got " & Pennies'Image (P1));
- end if;
-
- D1 := P(0.05) * P(-100.0);
- if D1 /= -5.00 then
- Report.Failed ("5 - expected -5.00 got " & Dollars'Image (D1));
- end if;
-
- F1 := P(-0.05) * F(50_000.0);
- if F1 /= -2500.00 then
- Report.Failed ("6 - expected -2500.0 got " & Franklins'Image (F1));
- end if;
-
- -- division where one operand is universal real
-
- P1 := P(0.05) / 0.001;
- if P1 /= 50.00 then
- Report.Failed ("7 - expected 50.00 got " & Pennies'Image (P1));
- end if;
-
- D1 := D(1000.0) / 3.0;
- if D1 /= 333.00 then
- Report.Failed ("8 - expected 333.00 got " & Dollars'Image (D1));
- end if;
-
- F1 := P(1234.56) / 0.0001;
- if F1 /= 12345600.00 then
- Report.Failed ("9 - expected 12345600.0 got " & Franklins'Image (F1));
- end if;
-
-
- -- division where both operands are decimal fixed
-
- P1 := P(0.05) / D(1.0);
- if P1 /= 0.05 then
- Report.Failed ("10 - expected 0.05 got " & Pennies'Image (P1));
- end if;
-
- -- check for truncation toward 0
- D1 := P(-101.00) / P(2.0);
- if D1 /= -50.00 then
- Report.Failed ("11 - expected -50.00 got " & Dollars'Image (D1));
- end if;
-
- P1 := P(-102.03) / P(-0.5);
- if P1 /= 204.06 then
- Report.Failed ("12 - expected 204.06 got " & Pennies'Image (P1));
- end if;
-
- F1 := P(876.54) / P(0.03);
- if F1 /= 29200.00 then
- Report.Failed ("13 - expected 29200.0 got " & Franklins'Image (F1));
- end if;
-
-end Generic_Check;
-
-
-procedure Check_G6 is
- Num_Digits : constant := 6;
- type Pennies is delta 0.01 digits Num_Digits;
- type Franklins is delta 100.0 digits Num_Digits;
- type Dollars is delta 1.0 digits Num_Digits;
-
- procedure G is new Generic_Check (Pennies, Dollars, Franklins);
-begin
- G;
-end Check_G6;
-
-
-procedure Check_G9 is
- Num_Digits : constant := 9;
- type Pennies is delta 0.01 digits Num_Digits;
- type Franklins is delta 100.0 digits Num_Digits;
- type Dollars is delta 1.0 digits Num_Digits;
-
- procedure G is new Generic_Check (Pennies, Dollars, Franklins);
-begin
- G;
-end Check_G9;
-
-
-begin -- main
- Report.Test ("CXG2023",
- "Check the accuracy of multiplication and division" &
- " of decimal fixed point numbers");
-
- if Verbose then
- Report.Comment ("starting Check_1");
- end if;
- Check_1;
-
- if Verbose then
- Report.Comment ("starting Check_G6");
- end if;
- Check_G6;
-
- if Verbose then
- Report.Comment ("starting Check_G9");
- end if;
- Check_G9;
-
- Report.Result;
-end CXG2023;
diff --git a/gcc/testsuite/ada/acats/tests/cxg/cxg2024.a b/gcc/testsuite/ada/acats/tests/cxg/cxg2024.a
deleted file mode 100644
index 55648283eba..00000000000
--- a/gcc/testsuite/ada/acats/tests/cxg/cxg2024.a
+++ /dev/null
@@ -1,191 +0,0 @@
--- CXG2024.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- Check that multiplication and division of decimal
--- and binary fixed point numbers that result in a
--- decimal fixed point type produce acceptable results.
---
--- TEST DESCRIPTION:
--- Multiplication and division of mixed binary and decimal
--- values are performed. Identity functions are used so
--- that the operands of the expressions will not be seen
--- as static by the compiler.
---
--- SPECIAL REQUIREMENTS
--- The Strict Mode for the numerical accuracy must be
--- selected. The method by which this mode is selected
--- is implementation dependent.
---
--- APPLICABILITY CRITERIA:
--- This test applies only to implementations supporting the
--- Numerics Annex.
--- This test only applies to the Strict Mode for numerical
--- accuracy.
--- This test applies only to implementations supporting
--- decimal fixed point types of at least 9 digits.
---
---
--- CHANGE HISTORY:
--- 4 Apr 96 SAIC Initial release for 2.1
--- 17 Aug 96 SAIC Removed checks for close results
---
---!
-
-with System;
-with Report;
-procedure CXG2024 is
-
-procedure Do_Check is
- Num_Digits : constant := 9;
- type Pennies is delta 0.01 digits Num_Digits;
- type Dollars is delta 1.0 digits Num_Digits;
-
- type Signed_Sixteenths is delta 0.0625
- range -2.0 ** (System.Max_Mantissa-5) ..
- 2.0 ** (System.Max_Mantissa-5) - 1.0;
- type Unsigned_Sixteenths is delta 0.0625
- range 0.0 .. 2.0 ** (System.Max_Mantissa-4) - 1.0;
-
- P1 : Pennies;
- D1 : Dollars;
-
- -- optimization thwarting functions
-
- function P (X : Pennies) return Pennies is
- begin
- if Report.Ident_Bool (True) then
- return X;
- else
- return 3.21; -- never executed
- end if;
- end P;
-
-
- function D (X : Dollars) return Dollars is
- begin
- if Report.Ident_Bool (True) then
- return X;
- else
- return 321.0; -- never executed
- end if;
- end D;
-
-
- function US (X : Unsigned_Sixteenths) return Unsigned_Sixteenths is
- begin
- if Report.Ident_Bool (True) then
- return X;
- else
- return 321.0; -- never executed
- end if;
- end US;
-
-
- function SS (X : Signed_Sixteenths) return Signed_Sixteenths is
- begin
- if Report.Ident_Bool (True) then
- return X;
- else
- return 321.0; -- never executed
- end if;
- end SS;
-
-
-begin
-
- P1 := P(0.05) * SS(-200.0);
- if P1 /= -10.00 then
- Report.Failed ("1 - expected -10.00 got " & Pennies'Image (P1));
- end if;
-
- D1 := P(0.05) * SS(-100.0);
- if D1 /= -5.00 then
- Report.Failed ("2 - expected -5.00 got " & Dollars'Image (D1));
- end if;
-
- P1 := P(0.05) * US(200.0);
- if P1 /= 10.00 then
- Report.Failed ("3 - expected 10.00 got " & Pennies'Image (P1));
- end if;
-
- D1 := P(-0.05) * US(100.0);
- if D1 /= -5.00 then
- Report.Failed ("4 - expected -5.00 got " & Dollars'Image (D1));
- end if;
-
-
-
- P1 := P(0.05) / US(1.0);
- if P1 /= 0.05 then
- Report.Failed ("6 - expected 0.05 got " & Pennies'Image (P1));
- end if;
-
-
- -- check rounding
-
- D1 := Dollars'Round (Pennies (P(-101.00) / US(2.0)));
- if D1 /= -51.00 then
- Report.Failed ("11 - expected -51.00 got " & Dollars'Image (D1));
- end if;
-
- D1 := Dollars'Round (Pennies (P(101.00) / US(2.0)));
- if D1 /= 51.00 then
- Report.Failed ("12 - expected 51.00 got " & Dollars'Image (D1));
- end if;
-
- D1 := Dollars'Round (Pennies (SS(-101.00) / P(2.0)));
- if D1 /= -51.00 then
- Report.Failed ("13 - expected -51.00 got " & Dollars'Image (D1));
- end if;
-
- D1 := Dollars'Round (Pennies (US(101.00) / P(2.0)));
- if D1 /= 51.00 then
- Report.Failed ("14 - expected 51.00 got " & Dollars'Image (D1));
- end if;
-
-
-
- P1 := P(-102.03) / SS(-0.5);
- if P1 /= 204.06 then
- Report.Failed ("15 - expected 204.06 got " & Pennies'Image (P1));
- end if;
-
-
-exception
- when others =>
- Report.Failed ("unexpected exception in Do_Check");
-end Do_Check;
-
-
-begin -- main
- Report.Test ("CXG2024",
- "Check the accuracy of multiplication and division" &
- " of mixed decimal and binary fixed point numbers");
-
- Do_Check;
-
- Report.Result;
-end CXG2024;
diff --git a/gcc/testsuite/ada/acats/tests/cxh/cxh1001.a b/gcc/testsuite/ada/acats/tests/cxh/cxh1001.a
deleted file mode 100644
index 12379a1a551..00000000000
--- a/gcc/testsuite/ada/acats/tests/cxh/cxh1001.a
+++ /dev/null
@@ -1,349 +0,0 @@
--- 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
deleted file mode 100644
index 4ed41b4d06f..00000000000
--- a/gcc/testsuite/ada/acats/tests/cxh/cxh3001.a
+++ /dev/null
@@ -1,243 +0,0 @@
--- CXH3001.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE
--- Check pragma Reviewable.
--- Check that pragma Reviewable is accepted as a configuration pragma.
---
--- TEST DESCRIPTION
--- The test requires that the configuration pragma Reviewable
--- be processed. The following package contains a simple "one of each
--- construct in the language" to check that the configuration pragma has
--- not disallowed some feature of the language. This test should generate
--- no errors.
---
--- APPLICABILITY CRITERIA:
--- This test is only applicable for a compiler attempting validation
--- for the Safety and Security Annex.
---
--- PASS/FAIL CRITERIA:
--- This test passes if it correctly compiles, executes, and reports PASS.
--- It fails if the pragma is rejected. The effect of the pragma should
--- be to produce a listing with information, including warnings, as
--- required in H.3.1. Specific form and contents of this listing are not
--- required by this test and are not part of the PASS/FAIL criteria.
---
--- SPECIAL REQUIREMENTS
--- The implementation must process a configuration pragma which is not
--- part of any Compilation Unit; the method employed is implementation
--- defined.
---
--- Pragma Reviewable requires that the implementation provide the
--- following information for the compilation units in this test:
---
--- o Where compiler-generated run-time checks remain (6)
---
--- o Identification of any construct with a language-defined check
--- that is recognized prior to runtime as certain to fail if
--- executed (7)
---
--- o For each reference to a scalar object, an identification of
--- the reference as either "known to be initialized,"
--- or "possibly uninitialized" (8)
---
--- o Where run-time support routines are implicitly invoked (9)
---
--- o An object code listing including: (10)
---
--- o Machine instructions with relative offsets (11)
---
--- o Where each data object is stored during its lifetime (12)
---
--- o Correspondence with the source program (13)
---
--- o Identification of each construct for which the implementation
--- detects the possibility of erroneous execution (14)
---
--- o For each subprogram, block, task or other construct implemented by
--- reserving and subsequently freezing an area of the run-time stack,
--- an identification of the length of the fixed-size portion of
--- the area and an indication of whether the non-fixed size portion
--- is reserved on the stack or in a dynamically managed storage
--- region (15)
---
---
--- CHANGE HISTORY:
--- 26 OCT 95 SAIC Initial version
--- 12 NOV 96 SAIC Revised for 2.1
--- 27 AUG 99 RLB Removed result dependence on uninitialized object.
--- 30 AUG 99 RLB Repaired the above.
---
---!
-
----------------------------- CONFIGURATION PRAGMAS -----------------------
-
-pragma Reviewable; -- OK
- -- configuration pragma
-
------------------------- END OF CONFIGURATION PRAGMAS --------------------
-
-
------------------------------------------------------------------ CXH3001_0
-
-package CXH3001_0 is
-
- type Enum is (Item,Stuff,Things);
-
- type Int is range 0..256;
-
- type Unt is mod 256;
-
- type Flt is digits 5;
-
- type Fix is delta 0.5 range -1.0..1.0;
-
- type Root(Disc: Enum) is tagged record
- I: Int; U:Unt;
- end record;
-
- type List is array(Unt) of Root(Stuff);
-
- type A_List is access List;
- type A_Proc is access procedure(R:Root);
-
- procedure P(R:Root);
-
- function F return A_Proc;
-
- protected PT is
- entry Set(Switch: Boolean);
- function Enquire return Boolean;
- private
- Toggle : Boolean;
- end PT;
-
- task TT is
- entry Release;
- end TT;
-
- Global_Variable : Boolean := False;
-
-end CXH3001_0;
-
--- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
-
-with Report;
-package body CXH3001_0 is
-
- procedure P(R:Root) is
- Warnable : Positive := 0; -- (7) -- OPTIONAL WARNING
- -- this would raise Constraint_Error if P were ever called, however
- -- this test never calls P.
- begin
- case R.Disc is
- when Item => Report.Comment("Got Item");
- when Stuff => Report.Comment("Got Stuff");
- when Things => Report.Comment("Got Things");
- end case;
- if Report.Ident_Int( Warnable ) = 0 then
- Global_Variable := not Global_Variable; -- (8) known to be initialized
- end if;
- end P;
-
- function F return A_Proc is
- begin
- return P'Access;
- end F;
-
- protected body PT is
-
- entry Set(Switch: Boolean) when True is
- begin
- Toggle := Switch;
- end Set;
-
- function Enquire return Boolean is
- begin
- return Toggle;
- end Enquire;
-
- end PT;
-
- task body TT is
- begin
- loop
- accept Release;
- exit when Global_Variable;
- end loop;
- end TT;
-
- -- (9) TT activation
-end CXH3001_0;
-
-------------------------------------------------------------------- CXH3001
-
-with Report;
-with CXH3001_0;
-procedure CXH3001 is
-begin
- Report.Test("CXH3001", "Check pragma Reviewable as a configuration pragma");
-
- Block: declare
- A_Truth : Boolean;
- Message : String := Report.Ident_Str( "Bad value encountered" );
- begin
- begin
- A_Truth := Report.Ident_Bool( True ) or A_Truth; -- (8) not initialized
- if not A_Truth then
- Report.Comment ("True or Uninit = False");
- A_Truth := Report.Ident_Bool (True);
- else
- A_Truth := Report.Ident_Bool (True);
- -- We do this separately on each branch in order to insure that a
- -- clever optimizer can find out little about this value. Ident_Bool
- -- is supposed to be opaque to any optimizer.
- end if;
- exception
- when Constraint_Error | Program_Error =>
- -- Possible results of accessing an uninitialized object.
- A_Truth := Report.Ident_Bool (True);
- end;
-
- CXH3001_0.PT.Set( A_Truth );
-
- CXH3001_0.Global_Variable := A_Truth;
-
- CXH3001_0.TT.Release; -- (9) rendezvous with TT
-
- while CXH3001_0.TT'Callable loop
- delay 1.0; -- wait for TT to become non-callable
- end loop;
-
- if not CXH3001_0.PT.Enquire
- or not CXH3001_0.Global_Variable
- or CXH3001_0.TT'Callable then
- Report.Failed(Message);
- end if;
-
- end Block;
-
- Report.Result;
-end CXH3001;
diff --git a/gcc/testsuite/ada/acats/tests/cxh/cxh3002.a b/gcc/testsuite/ada/acats/tests/cxh/cxh3002.a
deleted file mode 100644
index 5e9f7b9cc9e..00000000000
--- a/gcc/testsuite/ada/acats/tests/cxh/cxh3002.a
+++ /dev/null
@@ -1,343 +0,0 @@
--- CXH3002.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE
--- Check that pragma Inspection_Point is allowed whereever a declarative
--- item or statement is allowed. Check that pragma Inspection_Point may
--- have zero or more arguments. Check that the execution of pragma
--- Inspection_Point has no effect.
---
--- TEST DESCRIPTION
--- Check pragma Inspection_Point applied to:
--- A no objects,
--- B one object,
--- C multiple objects.
--- Check pragma Inspection_Point applied to:
--- D Enumeration type objects,
--- E Integer type objects (signed and unsigned),
--- F access type objects,
--- G Floating Point type objects,
--- H Fixed point type objects,
--- I array type objects,
--- J record type objects,
--- K tagged type objects,
--- L protected type objects,
--- M controlled type objects,
--- N task type objects.
--- Check pragma Inspection_Point applied in:
--- O declarations (package, procedure)
--- P statements (incl package elaboration)
--- Q subprogram (procedure, function, finalization)
--- R package
--- S specification
--- T body (PO entry, task body, loop body, accept body, select body)
--- U task
--- V protected object
---
---
--- APPLICABILITY CRITERIA:
--- This test is only applicable for a compiler attempting validation
--- for the Safety and Security Annex.
---
---
--- CHANGE HISTORY:
--- 26 OCT 95 SAIC Initial version
--- 12 NOV 96 SAIC Revised for 2.1
---
---!
-
------------------------------------------------------------------ CXH3002_0
-
-package CXH3002_0 is
-
- type Enum is (Item,Stuff,Things);
-
- type Int is range 0..256;
-
- type Unt is mod 256;
-
- type Flt is digits 5;
-
- type Fix is delta 0.5 range -1.0..1.0;
-
- type Root(Disc: Enum) is record
- I: Int;
- U: Unt;
- end record;
-
- type List is array(Unt) of Root(Stuff);
-
- type A_List is access all List;
- type A_Proc is access procedure(R:Root);
-
- procedure Proc(R:Root);
- function Func return A_Proc;
-
- protected type PT is
- entry Prot_Entry(Switch: Boolean);
- private
- Toggle : Boolean := False;
- end PT;
-
- task type TT is
- entry Task_Entry(Items: in A_List);
- end TT;
-
- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- ---====
- pragma Inspection_Point; -- AORS
- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- ---====
-
-end CXH3002_0;
-
------------------------------------------------------------------ CXH3002_1
-
-with Ada.Finalization;
-package CXH3002_0.CXH3002_1 is
-
- type Final is new Ada.Finalization.Controlled with
- record
- Value : Natural;
- end record;
-
- procedure Initialize( F: in out Final );
- procedure Adjust( F: in out Final );
- procedure Finalize( F: in out Final );
-
-end CXH3002_0.CXH3002_1;
-
--- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- CXH3002_0
-
-package body CXH3002_0 is
-
- Global_Variable : Character := 'A';
-
- procedure Proc(R:Root) is
- begin
- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- ---=====
- pragma Inspection_Point( Global_Variable ); -- BDPQT
- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- ---=====
- case R.Disc is
- when Item => Global_Variable := 'I';
- when Stuff => Global_Variable := 'S';
- when Things => Global_Variable := 'T';
- end case;
- end Proc;
-
- function Func return A_Proc is
- begin
- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- ---====
- pragma Inspection_Point; -- APQT
- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- ---====
- return Proc'Access;
- end Func;
-
- protected body PT is
- entry Prot_Entry(Switch: Boolean) when True is
- begin
- Toggle := Switch;
- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- ---====
- pragma Inspection_Point; -- APVT
- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- ---====
- end Prot_Entry;
- end PT;
-
- task body TT is
- List_Copy : A_List;
- begin
- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- ---====
- pragma Inspection_Point; -- APUT
- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- ---====
- loop
- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- ---====
- pragma Inspection_Point; -- APUT
- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- ---====
- select
- accept Task_Entry(Items: in A_List) do
- List_Copy := Items;
- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- ---=====
- pragma Inspection_Point( List_Copy ); -- BFPUT
- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- ---=====
- end Task_Entry;
- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- ---====
- pragma Inspection_Point; -- APUT
- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- ---====
- or terminate;
- end select;
- end loop;
- end TT;
-
- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- ---=====
- pragma Inspection_Point; -- ARTO
- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- ---=====
-
-end CXH3002_0;
-
--- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- CXH3002_1
-
-with Report;
-package body CXH3002_0.CXH3002_1 is
-
- Embedded_Final_Object : Final
- := (Ada.Finalization.Controlled with Value => 1);
- -- attempt to call Initialize here would P_E!
-
- procedure Initialize( F: in out Final ) is
- begin
- F.Value := 1;
- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- ---=====
- pragma Inspection_Point( Embedded_Final_Object ); -- BKQP
- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- ---=====
- end Initialize;
-
- procedure Adjust( F: in out Final ) is
- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- ---=====
- pragma Inspection_Point; -- AQO
- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- ---=====
- begin
- F.Value := 2;
- end Adjust;
-
- procedure Finalize( F: in out Final ) is
- begin
- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- ---====
- pragma Inspection_Point; -- AQP
- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- ---====
- if F.Value not in 1..10 then
- Report.Failed("Bad value in controlled object at finalization");
- end if;
- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- ---====
- pragma Inspection_Point; -- AQP
- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- ---====
- end Finalize;
-
-begin
- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- ---======
- pragma Inspection_Point( Embedded_Final_Object ); -- BKRTP
- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- ---======
- null;
-end CXH3002_0.CXH3002_1;
-
-------------------------------------------------------------------- CXH3002
-
-with Report;
-with CXH3002_0.CXH3002_1;
-procedure CXH3002 is
-
- use type CXH3002_0.Enum, CXH3002_0.Int, CXH3002_0.Unt, CXH3002_0.Flt,
- CXH3002_0.Fix, CXH3002_0.Root;
-
- Main_Enum : CXH3002_0.Enum := CXH3002_0.Item;
- Main_Int : CXH3002_0.Int;
- Main_Unt : CXH3002_0.Unt;
- Main_Flt : CXH3002_0.Flt;
- Main_Fix : CXH3002_0.Fix;
- Main_Rec : CXH3002_0.Root(CXH3002_0.Stuff)
- := (CXH3002_0.Stuff, I => 1, U => 2);
-
- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- ---=====
- pragma Inspection_Point( Main_Rec ); -- BJQO
- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- ---=====
-
- Main_List : CXH3002_0.List := ( others => Main_Rec );
-
- Main_A_List : CXH3002_0.A_List := new CXH3002_0.List'( others => Main_Rec );
- Main_A_Proc : CXH3002_0.A_Proc := CXH3002_0.Func;
- -- CXH3002_0.Proc'Access
- Main_PT : CXH3002_0.PT;
- Main_TT : CXH3002_0.TT;
-
- type Test_Range is (First, Second);
-
- procedure Assert( Truth : Boolean; Message : String ) is
- begin
- if not Truth then
- Report.Failed( "Unexpected value found in " & Message );
- end if;
- end Assert;
-
-begin -- Main test procedure.
-
- Report.Test ("CXH3002", "Check pragma Inspection_Point" );
-
- Enclosure:declare
- Main_Final : CXH3002_0.CXH3002_1.Final;
- Xtra_Final : CXH3002_0.CXH3002_1.Final;
- begin
- for Test_Case in Test_Range loop
-
-
- case Test_Case is
- when First =>
- Main_Final.Value := 5;
- Xtra_Final := Main_Final; -- call Adjust
- Main_Enum := CXH3002_0.Things;
- Main_Int := CXH3002_0.Int'First;
- Main_Unt := CXH3002_0.Unt'Last;
- Main_Flt := 3.14;
- Main_Fix := 0.5;
- Main_Rec := (CXH3002_0.Stuff, I => 3, U => 4);
- Main_List(Main_Unt) := Main_Rec;
- Main_A_List(CXH3002_0.Unt'First) := (CXH3002_0.Stuff, I => 5, U => 6);
- Main_A_Proc( Main_A_List(2) );
- Main_PT.Prot_Entry(True);
- Main_TT.Task_Entry( null );
-
- when Second =>
- Assert( Main_Final.Value = 5, "Main_Final" );
- Assert( Xtra_Final.Value = 2, "Xtra_Final" );
- Assert( Main_Enum = CXH3002_0.Things, "Main_Enum" );
- Assert( Main_Int = CXH3002_0.Int'First, "Main_Int" );
- Assert( Main_Unt = CXH3002_0.Unt'Last, "Main_Unt" );
- Assert( Main_Flt in 3.0..3.5, "Main_Flt" );
- Assert( Main_Fix = 0.5, "Main_Fix" );
- Assert( Main_Rec = (CXH3002_0.Stuff, I => 3, U => 4), "Main_Rec" );
- Assert( Main_List(Main_Unt) = Main_Rec, "Main_List" );
- Assert( Main_A_List(CXH3002_0.Unt'First)
- = (CXH3002_0.Stuff, I => 5, U => 6), "Main_A_List" );
-
- end case;
-
- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- ---==
- pragma Inspection_Point( -- CQP
- Main_Final, -- M
- Main_Enum, -- D
- Main_Int, -- E
- Main_Unt, -- E
- Main_Flt, -- G
- Main_Fix, -- H
- Main_Rec, -- J
- Main_List, -- I
- Main_A_List, -- F
- Main_A_Proc, -- F
- Main_PT, -- L
- Main_TT ); -- N
- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- ---==
-
- end loop;
- end Enclosure;
-
- Report.Result;
-
-end CXH3002;
diff --git a/gcc/testsuite/ada/acats/tests/cxh/cxh30030.a b/gcc/testsuite/ada/acats/tests/cxh/cxh30030.a
deleted file mode 100644
index 1b1399c598d..00000000000
--- a/gcc/testsuite/ada/acats/tests/cxh/cxh30030.a
+++ /dev/null
@@ -1,54 +0,0 @@
--- CXH30030.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE
--- See CHX30031.AM
---
--- TEST DESCRIPTION
--- See CHX30031.AM
---
--- TEST FILES:
--- The following files comprise this test:
---
--- => CXH30030.A
--- CXH30031.AM
---
--- APPLICABILITY CRITERIA:
--- See CHX30031.AM
---
--- SPECIAL REQUIREMENTS
--- See CHX30031.AM
---
--- CHANGE HISTORY:
--- 26 OCT 95 SAIC Initial version for 2.1
--- 07 JUN 96 SAIC Revised by reviewer request, split to multifile
---
---!
-
- pragma Reviewable;
-
--- This test requires that this configuration pragma be applied to all
--- following compilation units in the environment; specifically the ones
--- in file CXH30031.AM
diff --git a/gcc/testsuite/ada/acats/tests/l/la140010.a b/gcc/testsuite/ada/acats/tests/l/la140010.a
deleted file mode 100644
index 58ba661958e..00000000000
--- a/gcc/testsuite/ada/acats/tests/l/la140010.a
+++ /dev/null
@@ -1,51 +0,0 @@
--- LA140010.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- See LA140011.AM.
---
--- TEST DESCRIPTION:
--- See LA140011.AM.
---
--- SPECIAL REQUIREMENTS:
--- See LA140011.AM.
---
--- TEST FILES:
--- This test consists of the following files:
--- -> LA140010.A
--- LA140011.AM
--- LA140012.A
---
--- PASS/FAIL CRITERIA:
--- See LA140011.AM.
---
--- CHANGE HISTORY:
--- 07 DEC 96 SAIC ACVC 2.1: Initial version.
---
---!
-
-package LA140010_0 is
- TC_Var : integer := 100;
-end LA140010_0;
diff --git a/gcc/testsuite/ada/acats/tests/l/la140012.a b/gcc/testsuite/ada/acats/tests/l/la140012.a
deleted file mode 100644
index 1dc8a7c9273..00000000000
--- a/gcc/testsuite/ada/acats/tests/l/la140012.a
+++ /dev/null
@@ -1,55 +0,0 @@
--- LA140012.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- See LA140011.AM.
---
--- TEST DESCRIPTION:
--- See LA140011.AM.
---
--- SPECIAL REQUIREMENTS:
--- See LA140011.AM.
---
--- TEST FILES:
--- This test consists of the following files:
--- LA140010.A
--- LA140011.AM
--- -> LA140012.A
---
--- PASS/FAIL CRITERIA:
--- See LA140011.AM.
---
--- CHANGE HISTORY:
--- 01 MAY 95 ACVC 1.12 LA5007I baseline version
--- 08 MAY 95 SAIC Initial version
--- 16 NOV 96 SAIC Modified prologue to conform to standards.
--- 07 DEC 96 SAIC Modified prologue to reflect new test
--- file organization.
---
---!
-
-package LA140010_0 is
- TC_Var : integer := -10;
-end LA140010_0;
diff --git a/gcc/testsuite/ada/acats/tests/l/la140020.a b/gcc/testsuite/ada/acats/tests/l/la140020.a
deleted file mode 100644
index 6b49ca2d11e..00000000000
--- a/gcc/testsuite/ada/acats/tests/l/la140020.a
+++ /dev/null
@@ -1,60 +0,0 @@
--- LA140020.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- See LA140021.AM.
---
--- TEST DESCRIPTION:
--- See LA140021.AM.
---
--- SPECIAL REQUIREMENTS:
--- See LA140021.AM.
---
--- TEST FILES:
--- This test consists of the following files:
--- -> LA140020.A
--- LA140021.AM
--- LA140022.A
---
--- PASS/FAIL CRITERIA:
--- See LA140021.AM.
---
--- CHANGE HISTORY:
--- 07 DEC 96 SAIC ACVC 2.1: Initial version.
---
---!
-
-package LA140020_0 is
- procedure P (TC_change : out integer);
-
- TC_Var : integer := 100;
-end LA140020_0;
-
-package body LA140020_0 is
- procedure P (TC_change : out integer) is
- begin
- TC_change := TC_Var;
- end P;
-end LA140020_0;
diff --git a/gcc/testsuite/ada/acats/tests/l/la140022.a b/gcc/testsuite/ada/acats/tests/l/la140022.a
deleted file mode 100644
index 75a4c4483e6..00000000000
--- a/gcc/testsuite/ada/acats/tests/l/la140022.a
+++ /dev/null
@@ -1,66 +0,0 @@
--- LA140022.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- See LA140021.AM.
---
--- TEST DESCRIPTION:
--- See LA140021.AM.
---
--- SPECIAL REQUIREMENTS:
--- See LA140021.AM.
---
--- TEST FILES:
--- This test consists of the following files:
--- LA140020.A
--- LA140021.AM
--- -> LA140022.A
---
--- PASS/FAIL CRITERIA:
--- See LA140021.AM.
---
--- CHANGE HISTORY:
--- 01 MAY 95 ACVC 1.12 LA5007J baseline version
--- 08 MAY 95 SAIC Initial version
--- 16 NOV 96 SAIC Modified prologue to conform to coding
--- conventions.
--- 07 DEC 96 SAIC Modified prologue to reflect new test
--- file organization. Added body for unit to
--- allow automatic recompilation.
---
---!
-
-package LA140020_0 is
- procedure P (TC_change : out integer);
-
- TC_Var : integer := -10;
-end LA140020_0;
-
-package body LA140020_0 is
- procedure P (TC_change : out integer) is
- begin
- TC_change := TC_Var;
- end P;
-end LA140020_0;
diff --git a/gcc/testsuite/ada/acats/tests/l/la140030.a b/gcc/testsuite/ada/acats/tests/l/la140030.a
deleted file mode 100644
index 82d97e787ff..00000000000
--- a/gcc/testsuite/ada/acats/tests/l/la140030.a
+++ /dev/null
@@ -1,57 +0,0 @@
--- LA140030.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- See LA140032.AM.
---
--- TEST DESCRIPTION:
--- See LA140032.AM.
---
--- SPECIAL REQUIREMENTS:
--- See LA140032.AM.
---
--- TEST FILES:
--- This test consists of the following files:
--- => LA140030.A
--- LA140031.A
--- LA140032.AM
--- LA140033.A
---
--- PASS/FAIL CRITERIA:
--- See LA140032.AM.
---
---
--- CHANGE HISTORY:
--- 01 MAY 95 ACVC 1.12 LA5007K baseline version
--- 09 MAY 95 SAIC Initial version
--- 16 NOV 96 SAIC Modified prologue to conform to coding
--- conventions.
---
---!
-
-package LA140030 is
- TC_named_number : constant := 100;
- TC_Var : integer := 100;
-end LA140030;
diff --git a/gcc/testsuite/ada/acats/tests/l/la140031.a b/gcc/testsuite/ada/acats/tests/l/la140031.a
deleted file mode 100644
index 250162b28f1..00000000000
--- a/gcc/testsuite/ada/acats/tests/l/la140031.a
+++ /dev/null
@@ -1,66 +0,0 @@
--- LA140031.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- See LA140032.AM.
---
--- TEST DESCRIPTION:
--- See LA140032.AM.
---
--- SPECIAL REQUIREMENTS:
--- See LA140032.AM.
---
--- TEST FILES:
--- This test consists of the following files:
--- LA140030.A
--- => LA140031.A
--- LA140032.AM
--- LA140033.A
---
--- PASS/FAIL CRITERIA:
--- See LA140032.AM.
---
---
--- CHANGE HISTORY:
--- 01 MAY 95 ACVC 1.12 LA5007K baseline version
--- 09 MAY 95 SAIC Initial version
--- 16 NOV 96 SAIC Modified prologue to conform to coding
--- conventions.
---
---!
-
-package LA140031 is
- procedure P (TC_Change : out integer);
-end LA140031;
-
-with LA140030; -- when LA140030 is revised and recompiled,
- -- this semantic dependency has to be handled
-
-package body LA140031 is
- procedure P (TC_Change : out integer) is
- begin
- TC_Change := LA140030.TC_Var;
- end P;
-end LA140031;
diff --git a/gcc/testsuite/ada/acats/tests/l/la140033.a b/gcc/testsuite/ada/acats/tests/l/la140033.a
deleted file mode 100644
index 9d7f13366c5..00000000000
--- a/gcc/testsuite/ada/acats/tests/l/la140033.a
+++ /dev/null
@@ -1,56 +0,0 @@
--- LA140033.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- See LA140032.AM.
---
--- TEST DESCRIPTION:
--- See LA140032.AM.
---
--- SPECIAL REQUIREMENTS:
--- See LA140032.AM.
---
--- TEST FILES:
--- This test consists of the following files:
--- LA140030.A
--- LA140031.A
--- LA140032.AM
--- => LA140033.A
---
--- PASS/FAIL CRITERIA:
--- See LA140032.AM.
---
---
--- CHANGE HISTORY:
--- 01 MAY 95 ACVC 1.12 LA5007K baseline version
--- 09 MAY 95 SAIC Initial version
--- 16 NOV 96 SAIC Modified prologue to conform to coding
--- conventions.
---
---!
-
-package LA140030 is
- TC_Var : integer := -10;
-end LA140030;
diff --git a/gcc/testsuite/ada/acats/tests/l/la140040.a b/gcc/testsuite/ada/acats/tests/l/la140040.a
deleted file mode 100644
index eef6d987457..00000000000
--- a/gcc/testsuite/ada/acats/tests/l/la140040.a
+++ /dev/null
@@ -1,52 +0,0 @@
--- LA140040.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- See LA140041.AM.
---
--- TEST DESCRIPTION:
--- See LA140041.AM.
---
--- SPECIAL REQUIREMENTS:
--- See LA140041.AM.
---
--- TEST FILES:
--- This test consists of the following files:
--- -> LA140040.A
--- LA140041.AM
--- LA140042.A
---
--- PASS/FAIL CRITERIA:
--- See LA140041.AM.
---
--- CHANGE HISTORY:
--- 09 MAY 95 SAIC Initial version
--- 10 DEC 96 SAIC Reorganized to permit automatic recompilation.
---
---!
-
-package LA14004_0 is
- TC_Var : integer := 100;
-end LA14004_0;
diff --git a/gcc/testsuite/ada/acats/tests/l/la140042.a b/gcc/testsuite/ada/acats/tests/l/la140042.a
deleted file mode 100644
index bb4ba6c09b3..00000000000
--- a/gcc/testsuite/ada/acats/tests/l/la140042.a
+++ /dev/null
@@ -1,53 +0,0 @@
--- LA140042.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- See LA140041.AM.
---
--- TEST DESCRIPTION:
--- See LA140041.AM.
---
--- SPECIAL REQUIREMENTS:
--- See LA140041.AM.
---
--- TEST FILES:
--- This test consists of the following files:
--- LA140040.A
--- LA140041.AM
--- -> LA140042.A
---
--- PASS/FAIL CRITERIA:
--- See LA140041.AM.
---
--- CHANGE HISTORY:
--- 09 MAY 95 SAIC Initial version
--- 10 DEC 96 SAIC Reorganized to permit automatic recompilation.
---
---!
-
-package LA14004_0 is
- Small_array : array (1..15) of integer;
- TC_Var : integer := -10;
-end LA14004_0;
diff --git a/gcc/testsuite/ada/acats/tests/l/la140050.a b/gcc/testsuite/ada/acats/tests/l/la140050.a
deleted file mode 100644
index 542c1ffddbe..00000000000
--- a/gcc/testsuite/ada/acats/tests/l/la140050.a
+++ /dev/null
@@ -1,60 +0,0 @@
--- LA140050.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- See LA140052.AM.
---
--- TEST DESCRIPTION:
--- See LA140052.AM.
---
--- SPECIAL REQUIREMENTS:
--- See LA140052.AM.
---
--- TEST FILES:
--- This test consists of the following files:
--- -> LA140050.A
--- LA140051.A
--- LA140052.AM
--- LA140053.A
---
--- PASS/FAIL CRITERIA:
--- See LA140052.AM.
---
--- CHANGE HISTORY:
--- 07 DEC 96 SAIC ACVC 2.1: Initial version.
---
---!
-
-generic
- hi : integer;
- lo : integer;
- type flt is digits <>;
-package LA14005_0 is
- TC_var : flt := flt(lo);
- type gen_flt is new flt range flt(lo)..flt(hi);
- max : integer := hi;
- min : integer := lo;
- avg : integer := (hi + lo)/ (integer(2.0));
-end LA14005_0;
diff --git a/gcc/testsuite/ada/acats/tests/l/la140051.a b/gcc/testsuite/ada/acats/tests/l/la140051.a
deleted file mode 100644
index 6af550a3a3e..00000000000
--- a/gcc/testsuite/ada/acats/tests/l/la140051.a
+++ /dev/null
@@ -1,56 +0,0 @@
--- LA140051.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- See LA140052.AM.
---
--- TEST DESCRIPTION:
--- See LA140052.AM.
---
--- SPECIAL REQUIREMENTS:
--- See LA140052.AM.
---
--- TEST FILES:
--- This test consists of the following files:
--- LA140050.A
--- -> LA140051.A
--- LA140052.AM
--- LA140053.A
---
--- PASS/FAIL CRITERIA:
--- See LA140052.AM.
---
--- CHANGE HISTORY:
--- 07 DEC 96 SAIC ACVC 2.1: Initial version.
---
---!
-
-with LA14005_0;
-generic
- with package types is new LA14005_0 (<>);
-package LA14005_1 is
- TC_constant_flt : constant types.gen_flt := types.gen_flt(types.avg);
- function return_flt return types.gen_flt;
-end LA14005_1;
diff --git a/gcc/testsuite/ada/acats/tests/l/la140053.a b/gcc/testsuite/ada/acats/tests/l/la140053.a
deleted file mode 100644
index 406b3abb082..00000000000
--- a/gcc/testsuite/ada/acats/tests/l/la140053.a
+++ /dev/null
@@ -1,60 +0,0 @@
--- LA140053.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- See LA140052.AM.
---
--- TEST DESCRIPTION:
--- See LA140052.AM.
---
--- SPECIAL REQUIREMENTS:
--- See LA140052.AM.
---
--- TEST FILES:
--- This test consists of the following files:
--- LA140050.A
--- LA140051.A
--- LA140052.AM
--- -> LA140053.A
---
--- PASS/FAIL CRITERIA:
--- See LA140052.AM.
---
--- CHANGE HISTORY:
--- 01 MAY 95 ACVC 1.12 LA5008I baseline version
--- 09 MAY 95 SAIC Initial version
--- 07 DEC 96 SAIC Modified prologue to reflect new test
--- file organization.
---
---!
-
-with LA14005_0;
-generic
- with package types is new LA14005_0 (<>);
-package LA14005_1 is
- TC_constant_flt : constant
- types.gen_flt := types.gen_flt(types.min); --changed line
- function return_flt return types.gen_flt;
-end LA14005_1;
diff --git a/gcc/testsuite/ada/acats/tests/l/la140060.a b/gcc/testsuite/ada/acats/tests/l/la140060.a
deleted file mode 100644
index 4f54da1e630..00000000000
--- a/gcc/testsuite/ada/acats/tests/l/la140060.a
+++ /dev/null
@@ -1,54 +0,0 @@
--- LA140060.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- See LA140062.AM.
---
--- TEST DESCRIPTION:
--- See LA140062.AM.
---
--- SPECIAL REQUIREMENTS:
--- See LA140062.AM.
---
--- TEST FILES:
--- This test consists of the following files:
--- -> LA140060.A
--- LA140061.A
--- LA140062.AM
--- LA140063.A
---
--- PASS/FAIL CRITERIA:
--- See LA140062.AM.
---
--- CHANGE HISTORY:
--- 07 DEC 96 SAIC ACVC 2.1: Initial version.
---
---!
-
-package LA14006_types is
- type t_type is tagged record
- f : integer := 87;
- end record;
-end LA14006_types;
diff --git a/gcc/testsuite/ada/acats/tests/l/la140061.a b/gcc/testsuite/ada/acats/tests/l/la140061.a
deleted file mode 100644
index 40ff151cb0d..00000000000
--- a/gcc/testsuite/ada/acats/tests/l/la140061.a
+++ /dev/null
@@ -1,66 +0,0 @@
--- LA140061.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- See LA140062.AM.
---
--- TEST DESCRIPTION:
--- See LA140062.AM.
---
--- SPECIAL REQUIREMENTS:
--- See LA140062.AM.
---
--- TEST FILES:
--- This test consists of the following files:
--- LA140060.A
--- -> LA140061.A
--- LA140062.AM
--- LA140063.A
---
--- PASS/FAIL CRITERIA:
--- See LA140062.AM.
---
--- CHANGE HISTORY:
--- 07 DEC 96 SAIC ACVC 2.1: Initial version.
---
---!
-
-with LA14006_types;
-use LA14006_types;
-generic
- type t is new t_type with private;
-package LA14006_0 is
-
- type T2 is new t with record
- g : integer := 100;
- end record;
-
- TC_var : T2;
-
-private
- type type_t is new t with record
- g2 : integer := 99;
- end record;
-end LA14006_0;
diff --git a/gcc/testsuite/ada/acats/tests/l/la140063.a b/gcc/testsuite/ada/acats/tests/l/la140063.a
deleted file mode 100644
index e4e6457d0e3..00000000000
--- a/gcc/testsuite/ada/acats/tests/l/la140063.a
+++ /dev/null
@@ -1,70 +0,0 @@
--- LA140063.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- See LA140062.AM.
---
--- TEST DESCRIPTION:
--- See LA140062.AM.
---
--- SPECIAL REQUIREMENTS:
--- See LA140062.AM.
---
--- TEST FILES:
--- This test consists of the following files:
--- LA140060.A
--- LA140061.A
--- LA140062.AM
--- -> LA140063.A
---
--- PASS/FAIL CRITERIA:
--- See LA140062.AM.
---
--- CHANGE HISTORY:
--- 09 MAY 95 SAIC Initial version
--- 17 NOV 96 SAIC Modified unit names and prologue to conform
--- to coding conventions.
--- 07 DEC 96 SAIC Modified prologue to reflect new test
--- file organization.
---
---!
-
-with LA14006_types;
-use LA14006_types;
-generic
- type t is new t_type with private;
-package LA14006_0 is
- type T2 is new t with record
- g : integer := -10;
- end record;
-
- TC_var : T2;
- Other_var : integer := 12;
-
- private
- type type_t is new t with record
- g2 : integer := 88;
- end record;
-end LA14006_0;
diff --git a/gcc/testsuite/ada/acats/tests/l/la140070.a b/gcc/testsuite/ada/acats/tests/l/la140070.a
deleted file mode 100644
index e3c864ac467..00000000000
--- a/gcc/testsuite/ada/acats/tests/l/la140070.a
+++ /dev/null
@@ -1,62 +0,0 @@
--- LA140070.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- See LA140072.AM.
---
--- TEST DESCRIPTION:
--- See LA140072.AM.
---
--- SPECIAL REQUIREMENTS:
--- See LA140072.AM.
---
--- TEST FILES:
--- This test consists of the following files:
--- -> LA140070.A
--- LA140071.A
--- LA140072.AM
--- LA140073.A
---
--- PASS/FAIL CRITERIA:
--- See LA140072.AM.
---
--- CHANGE HISTORY:
--- 01 MAY 95 ACVC 1.12 LA5007L baseline version
--- 12 MAY 95 SAIC Initial version
--- 17 NOV 96 SAIC Modified prologue to conform
--- to coding conventions.
---
---!
-
-package LA14007_0 is -- this will be modified and recompiled
- type mod_16 is new integer;
- type rec is tagged record
- f: mod_16 := 12;
- end record;
- type t_rec is new rec with record
- g : mod_16 := -2;
- end record;
- TC_Var : t_rec;
-end LA14007_0;
diff --git a/gcc/testsuite/ada/acats/tests/l/la140071.a b/gcc/testsuite/ada/acats/tests/l/la140071.a
deleted file mode 100644
index e895b874479..00000000000
--- a/gcc/testsuite/ada/acats/tests/l/la140071.a
+++ /dev/null
@@ -1,72 +0,0 @@
--- LA140071.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- See LA140072.AM.
---
--- TEST DESCRIPTION:
--- See LA140072.AM.
---
--- SPECIAL REQUIREMENTS:
--- See LA140072.AM.
---
--- TEST FILES:
--- This test consists of the following files:
--- LA140070.A
--- -> LA140071.A
--- LA140072.AM
--- LA140073.A
---
--- PASS/FAIL CRITERIA:
--- See LA140072.AM.
---
--- CHANGE HISTORY:
--- 01 MAY 95 ACVC 1.12 LA5007L baseline version
--- 12 MAY 95 SAIC Initial version
--- 17 NOV 96 SAIC Modified prologue to conform to coding
--- conventions. Deleted extraneous procedure
--- specification.
---
---!
-
-procedure LA14007_1 (TC_Parent : in out integer);
-
- --================================================================--
-
-procedure LA14007_1 (TC_Parent : in out integer) is
- procedure LA14007_2 (TC_Local : in out integer) is separate;
-begin
- LA14007_2 (TC_Parent);
-end LA14007_1;
-
- --================================================================--
-
-with LA14007_0;
-
-separate (LA14007_1)
-procedure LA14007_2 (TC_Local : in out integer) is
-begin
- TC_Local := integer (LA14007_0.TC_Var.f);
-end LA14007_2;
diff --git a/gcc/testsuite/ada/acats/tests/l/la140073.a b/gcc/testsuite/ada/acats/tests/l/la140073.a
deleted file mode 100644
index 01e07151938..00000000000
--- a/gcc/testsuite/ada/acats/tests/l/la140073.a
+++ /dev/null
@@ -1,63 +0,0 @@
--- LA140073.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- See LA140072.AM.
---
--- TEST DESCRIPTION:
--- See LA140072.AM.
---
--- SPECIAL REQUIREMENTS:
--- See LA140072.AM.
---
--- TEST FILES:
--- This test consists of the following files:
--- LA140070.A
--- LA140071.A
--- LA140072.AM
--- -> LA140073.A
---
--- PASS/FAIL CRITERIA:
--- See LA140072.AM.
---
--- CHANGE HISTORY:
--- 01 MAY 95 ACVC 1.12 LA5007L baseline version
--- 12 MAY 95 SAIC Initial version
--- 17 NOV 96 SAIC Modified prologue to conform
--- to coding conventions.
---
---!
-
-package LA14007_0 is -- this is the corrected version
- extra_integer : integer;
- type mod_16 is new integer;
- type rec is tagged record
- f: mod_16 := 3;
- end record;
- type t_rec is new rec with record
- null;
- end record;
- TC_Var : t_rec;
-end LA14007_0;
diff --git a/gcc/testsuite/ada/acats/tests/l/la140080.a b/gcc/testsuite/ada/acats/tests/l/la140080.a
deleted file mode 100644
index 506c182512c..00000000000
--- a/gcc/testsuite/ada/acats/tests/l/la140080.a
+++ /dev/null
@@ -1,52 +0,0 @@
--- LA140080.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- See LA140082.AM.
---
--- TEST DESCRIPTION:
--- See LA140082.AM.
---
--- SPECIAL REQUIREMENTS:
--- See LA140082.AM.
---
--- TEST FILES:
--- This test consists of the following files:
--- -> LA140080.A
--- LA140081.A
--- LA140082.AM
--- LA140083.A
---
--- PASS/FAIL CRITERIA:
--- See LA140082.AM.
---
--- CHANGE HISTORY:
--- 01 MAY 95 ACVC 1.12 LA5007M baseline version
--- 25 MAY 95 SAIC Initial version
--- 10 DEC 96 SAIC Reorganized to permit automatic recompilation.
---
---!
-
-function LA14008_0 return integer;
diff --git a/gcc/testsuite/ada/acats/tests/l/la140081.a b/gcc/testsuite/ada/acats/tests/l/la140081.a
deleted file mode 100644
index b800da79916..00000000000
--- a/gcc/testsuite/ada/acats/tests/l/la140081.a
+++ /dev/null
@@ -1,63 +0,0 @@
--- LA140081.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- See LA140082.AM.
---
--- TEST DESCRIPTION:
--- See LA140082.AM.
---
--- SPECIAL REQUIREMENTS:
--- See LA140082.AM.
---
--- TEST FILES:
--- This test consists of the following files:
--- LA140080.A
--- -> LA140081.A
--- LA140082.AM
--- LA140083.A
---
--- PASS/FAIL CRITERIA:
--- See LA140082.AM.
---
--- CHANGE HISTORY:
--- 01 MAY 95 ACVC 1.12 LA5007M baseline version
--- 25 MAY 95 SAIC Initial version
--- 10 DEC 96 SAIC Reorganized to permit automatic recompilation.
---
---!
-
-function LA14008_0 return integer is
- TC_local : integer := 0;
- TC_var : integer := 100;
-
- function LA14008_1 return integer is separate;
- -- when LA14008_0 is revised and recompiled,
- -- this semantic dependency has to be
- -- handled
-begin
- TC_local := LA14008_1;
- return TC_local;
-end LA14008_0;
diff --git a/gcc/testsuite/ada/acats/tests/l/la140083.a b/gcc/testsuite/ada/acats/tests/l/la140083.a
deleted file mode 100644
index cad1cf311d5..00000000000
--- a/gcc/testsuite/ada/acats/tests/l/la140083.a
+++ /dev/null
@@ -1,61 +0,0 @@
--- LA140083.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- See LA140082.AM.
---
--- TEST DESCRIPTION:
--- See LA140082.AM.
---
--- SPECIAL REQUIREMENTS:
--- See LA140082.AM.
---
--- TEST FILES:
--- This test consists of the following files:
--- LA140080.A
--- LA140081.A
--- LA140082.AM
--- -> LA140083.A
---
--- PASS/FAIL CRITERIA:
--- See LA140082.AM.
---
--- CHANGE HISTORY:
--- 01 MAY 95 ACVC 1.12 LA5007M baseline version
--- 25 MAY 95 SAIC Initial version
--- 10 DEC 96 SAIC Reorganized to permit automatic recompilation.
---
-
-function LA14008_0 return integer is
- Another_var : integer := 1000;
- TC_local : integer := 0;
- TC_var : integer := -10;
-
- function LA14008_1 return integer is separate;
-
-begin
- TC_local := LA14008_1;
- return TC_local;
-end LA14008_0;
diff --git a/gcc/testsuite/ada/acats/tests/l/la140090.a b/gcc/testsuite/ada/acats/tests/l/la140090.a
deleted file mode 100644
index d2e02c71484..00000000000
--- a/gcc/testsuite/ada/acats/tests/l/la140090.a
+++ /dev/null
@@ -1,60 +0,0 @@
--- LA140090.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- See LA140092.AM.
---
--- TEST DESCRIPTION:
--- See LA140092.AM.
---
--- SPECIAL REQUIREMENTS:
--- See LA140092.AM.
---
--- TEST FILES:
--- This test consists of the following files:
--- -> LA140090.A
--- LA140091.A
--- LA140092.AM
--- LA140093.A
---
--- PASS/FAIL CRITERIA:
--- See LA140092.AM.
---
--- CHANGE HISTORY:
--- 01 MAY 95 ACVC 1.12 LA5007N baseline version
--- 25 MAY 95 SAIC Initial version
--- 12 DEC 96 SAIC Reorganized to permit automatic recompilation.
---
---!
-
-package LA14009_0 is
-
- package LA14009_1 is
-
- procedure P (TC_local : in out integer);
-
- end LA14009_1;
-
-end LA14009_0;
diff --git a/gcc/testsuite/ada/acats/tests/l/la140091.a b/gcc/testsuite/ada/acats/tests/l/la140091.a
deleted file mode 100644
index 550b908fbb4..00000000000
--- a/gcc/testsuite/ada/acats/tests/l/la140091.a
+++ /dev/null
@@ -1,60 +0,0 @@
--- LA140091.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- See LA140092.AM.
---
--- TEST DESCRIPTION:
--- See LA140092.AM.
---
--- SPECIAL REQUIREMENTS:
--- See LA140092.AM.
---
--- TEST FILES:
--- This test consists of the following files:
--- LA140090.A
--- -> LA140091.A
--- LA140092.AM
--- LA140093.A
---
--- PASS/FAIL CRITERIA:
--- See LA140092.AM.
---
--- CHANGE HISTORY:
--- 01 MAY 95 ACVC 1.12 LA5007N baseline version
--- 25 MAY 95 SAIC Initial version
--- 12 DEC 96 SAIC Reorganized to permit automatic recompilation.
---
---!
-
-package body LA14009_0 is
- TC_var : integer := 100;
-
- package body LA14009_1 is separate;
- -- when LA14009_0 is revised and recompiled,
- -- this semantic dependency has to be
- -- handled
-
-end LA14009_0;
diff --git a/gcc/testsuite/ada/acats/tests/l/la140093.a b/gcc/testsuite/ada/acats/tests/l/la140093.a
deleted file mode 100644
index 375570675ff..00000000000
--- a/gcc/testsuite/ada/acats/tests/l/la140093.a
+++ /dev/null
@@ -1,59 +0,0 @@
--- LA140093.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- See LA140092.AM.
---
--- TEST DESCRIPTION:
--- See LA140092.AM.
---
--- SPECIAL REQUIREMENTS:
--- See LA140092.AM.
---
--- TEST FILES:
--- This test consists of the following files:
--- LA140090.A
--- LA140091.A
--- LA140092.AM
--- -> LA140093.A
---
--- PASS/FAIL CRITERIA:
--- See LA140092.AM.
---
--- CHANGE HISTORY:
--- 01 MAY 95 ACVC 1.12 LA5007N baseline version
--- 25 MAY 95 SAIC Initial version
--- 12 DEC 96 SAIC Reorganized to permit automatic recompilation.
---
---!
-
-package body LA14009_0 is
- New_TC_var : integer := 50;
- Dummy_array : array (1..100) of boolean := (others => False);
- TC_var : constant integer := -10;
-
- package body LA14009_1 is separate;
-
-end LA14009_0;
diff --git a/gcc/testsuite/ada/acats/tests/l/la140100.a b/gcc/testsuite/ada/acats/tests/l/la140100.a
deleted file mode 100644
index dfa78696628..00000000000
--- a/gcc/testsuite/ada/acats/tests/l/la140100.a
+++ /dev/null
@@ -1,56 +0,0 @@
--- LA140100.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- See LA140102.AM.
---
--- TEST DESCRIPTION:
--- See LA140102.AM.
---
--- SPECIAL REQUIREMENTS:
--- See LA140102.AM.
---
--- TEST FILES:
--- This test consists of the following files:
--- -> LA140100.A
--- LA140101.A
--- LA140102.AM
--- LA140103.A
---
--- PASS/FAIL CRITERIA:
--- See LA140102.AM.
---
--- CHANGE HISTORY:
--- 01 MAY 95 ACVC 1.12 LA5008O baseline version
--- 29 JUN 95 SAIC Initial version
--- 29 FEB 96 SAIC First revision after review
--- 17 NOV 96 SAIC Modified prologue to conform
--- to coding conventions.
---
---!
-
-package LA14010_0 is
- delta_v : integer := 1;
-end LA14010_0;
diff --git a/gcc/testsuite/ada/acats/tests/l/la140101.a b/gcc/testsuite/ada/acats/tests/l/la140101.a
deleted file mode 100644
index 332f5ff20b5..00000000000
--- a/gcc/testsuite/ada/acats/tests/l/la140101.a
+++ /dev/null
@@ -1,89 +0,0 @@
--- LA140101.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- See LA140102.AM.
---
--- TEST DESCRIPTION:
--- See LA140102.AM.
---
--- SPECIAL REQUIREMENTS:
--- See LA140102.AM.
---
--- TEST FILES:
--- This test consists of the following files:
--- LA140100.A
--- -> LA140101.A
--- LA140102.AM
--- LA140103.A
---
--- PASS/FAIL CRITERIA:
--- See LA140102.AM.
---
--- CHANGE HISTORY:
--- 01 MAY 95 ACVC 1.12 LA5008O baseline version
--- 29 JUN 95 SAIC Initial version
--- 29 FEB 96 SAIC First revision after review
--- 17 NOV 96 SAIC Modified prologue to conform to coding
--- conventions. Changed task to task type.
---
---!
-
-generic
- type scalar is range <>;
-package LA14010_1 is
- procedure inc (param : in out scalar);
-end LA14010_1;
-
-with LA14010_0;
-use LA14010_0;
-
-package body LA14010_1 is
- procedure inc (param : in out scalar) is
- begin
- for i in 1..delta_v loop
- param := param + 1;
- end loop;
- end inc;
-
- task type inc_task is
- entry increment (param : in out scalar);
- end inc_task;
-
- task body inc_task is separate;
-end LA14010_1;
-
-
-separate (LA14010_1)
-
-task body inc_task is
- static_zero : integer := 0;
-begin
- accept increment (param : in out scalar) do
- static_zero := LA14010_0.delta_v + static_zero;
- static_zero := static_zero - LA14010_0.delta_v;
- inc (param);
- end increment;
-end inc_task;
diff --git a/gcc/testsuite/ada/acats/tests/l/la140103.a b/gcc/testsuite/ada/acats/tests/l/la140103.a
deleted file mode 100644
index a16d7debfff..00000000000
--- a/gcc/testsuite/ada/acats/tests/l/la140103.a
+++ /dev/null
@@ -1,58 +0,0 @@
--- LA140103.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- See LA140102.AM.
---
--- TEST DESCRIPTION:
--- See LA140102.AM.
---
--- SPECIAL REQUIREMENTS:
--- See LA140102.AM.
---
--- TEST FILES:
--- This test consists of the following files:
--- LA140100.A
--- LA140101.A
--- LA140102.AM
--- -> LA140103.A
---
--- PASS/FAIL CRITERIA:
--- See LA140102.AM.
---
--- CHANGE HISTORY:
--- 01 MAY 95 ACVC 1.12 LA5008O baseline version
--- 29 JUN 95 SAIC Initial version
--- 29 FEB 96 SAIC First revision after review
--- 17 NOV 96 SAIC Modified prologue to conform
--- to coding conventions.
---
---!
-
-package LA14010_0 is
- New_var : integer := 100;
- Local_array : array (1..51) of integer;
- delta_v : constant integer := 10;
-end LA14010_0;
diff --git a/gcc/testsuite/ada/acats/tests/l/la140110.a b/gcc/testsuite/ada/acats/tests/l/la140110.a
deleted file mode 100644
index 3f69c92a9ec..00000000000
--- a/gcc/testsuite/ada/acats/tests/l/la140110.a
+++ /dev/null
@@ -1,64 +0,0 @@
--- LA140110.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- See LA140112.AM.
---
--- TEST DESCRIPTION:
--- See LA140112.AM.
---
--- SPECIAL REQUIREMENTS:
--- See LA140112.AM.
---
--- TEST FILES:
--- This test consists of the following files:
--- -> LA140110.A
--- LA140111.A
--- LA140112.AM
--- LA140113.A
---
--- PASS/FAIL CRITERIA:
--- See LA140112.AM.
---
--- CHANGE HISTORY:
--- 01 MAY 95 ACVC 1.12 LA5007P baseline version
--- 25 MAY 95 SAIC Initial version
--- 17 NOV 96 SAIC Modified prologue to conform
--- to coding conventions.
---
---!
-
-
-procedure LA14011_0 (Change_this : in out integer);
-
-
-procedure LA14011_0 (Change_this : in out integer) is
-begin
- if Change_this = 10 then
- Change_this := 100;
- else
- Change_this := 50;
- end if;
-end LA14011_0;
diff --git a/gcc/testsuite/ada/acats/tests/l/la140111.a b/gcc/testsuite/ada/acats/tests/l/la140111.a
deleted file mode 100644
index c3a1cf1a18f..00000000000
--- a/gcc/testsuite/ada/acats/tests/l/la140111.a
+++ /dev/null
@@ -1,62 +0,0 @@
--- LA140111.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- See LA140112.AM.
---
--- TEST DESCRIPTION:
--- See LA140112.AM.
---
--- SPECIAL REQUIREMENTS:
--- See LA140112.AM.
---
--- TEST FILES:
--- This test consists of the following files:
--- LA140110.A
--- -> LA140111.A
--- LA140112.AM
--- LA140113.A
---
--- PASS/FAIL CRITERIA:
--- See LA140112.AM.
---
--- CHANGE HISTORY:
--- 01 MAY 95 ACVC 1.12 LA5007P baseline version
--- 25 MAY 95 SAIC Initial version
--- 17 NOV 96 SAIC Modified prologue to conform
--- to coding conventions.
---
---!
-
-
-with LA14011_0;
-
-procedure LA14011_1 (Change_this1 : in out integer);
-
-
-procedure LA14011_1 (Change_this1 : in out integer) is
-begin
- LA14011_0(Change_this1);
-end LA14011_1;
diff --git a/gcc/testsuite/ada/acats/tests/l/la140113.a b/gcc/testsuite/ada/acats/tests/l/la140113.a
deleted file mode 100644
index 8dd9683e353..00000000000
--- a/gcc/testsuite/ada/acats/tests/l/la140113.a
+++ /dev/null
@@ -1,59 +0,0 @@
--- LA140113.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- See LA140112.AM.
---
--- TEST DESCRIPTION:
--- See LA140112.AM.
---
--- SPECIAL REQUIREMENTS:
--- See LA140112.AM.
---
--- TEST FILES:
--- This test consists of the following files:
--- LA140110.A
--- LA140111.A
--- LA140112.AM
--- -> LA140113.A
---
--- PASS/FAIL CRITERIA:
--- See LA140112.AM.
---
--- CHANGE HISTORY:
--- 01 MAY 95 ACVC 1.12 LA5007P baseline version
--- 25 MAY 95 SAIC Initial version
--- 17 NOV 96 SAIC Modified prologue to conform
--- to coding conventions.
---
---!
-
-procedure LA14011_0 (Change_this : in out integer);
-
-
-procedure LA14011_0 (Change_this : in out integer) is
-begin
- Change_this := -Change_this;
-end LA14011_0;
diff --git a/gcc/testsuite/ada/acats/tests/l/la140120.a b/gcc/testsuite/ada/acats/tests/l/la140120.a
deleted file mode 100644
index d21525ed470..00000000000
--- a/gcc/testsuite/ada/acats/tests/l/la140120.a
+++ /dev/null
@@ -1,63 +0,0 @@
--- LA140120.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- See LA140122.AM.
---
--- TEST DESCRIPTION:
--- See LA140122.AM.
---
--- SPECIAL REQUIREMENTS:
--- See LA140122.AM.
---
--- TEST FILES:
--- This test consists of the following files:
--- -> LA140120.A
--- LA140121.A
--- LA140122.AM
--- LA140123.A
---
--- PASS/FAIL CRITERIA:
--- See LA140122.AM.
---
--- CHANGE HISTORY:
--- 01 MAY 95 ACVC 1.12 LA5007Q baseline version
--- 25 MAY 95 SAIC Initial version
--- 17 NOV 96 SAIC Modified prologue to conform
--- to coding conventions.
---
---!
-
-function LA14012_0 (Parm_1 : integer) return integer;
-
-
-function LA14012_0 (Parm_1 : integer) return integer is
-begin
- if Parm_1 >= 0 then
- return 100;
- else
- return 200;
- end if;
-end LA14012_0;
diff --git a/gcc/testsuite/ada/acats/tests/l/la140121.a b/gcc/testsuite/ada/acats/tests/l/la140121.a
deleted file mode 100644
index e4ea3ed9a55..00000000000
--- a/gcc/testsuite/ada/acats/tests/l/la140121.a
+++ /dev/null
@@ -1,64 +0,0 @@
--- LA140121.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- See LA140122.AM.
---
--- TEST DESCRIPTION:
--- See LA140122.AM.
---
--- SPECIAL REQUIREMENTS:
--- See LA140122.AM.
---
--- TEST FILES:
--- This test consists of the following files:
--- LA140120.A
--- -> LA140121.A
--- LA140122.AM
--- LA140123.A
---
--- PASS/FAIL CRITERIA:
--- See LA140122.AM.
---
--- CHANGE HISTORY:
--- 01 MAY 95 ACVC 1.12 LA5007Q baseline version
--- 25 MAY 95 SAIC Initial version
--- 17 NOV 96 SAIC Modified prologue to conform
--- to coding conventions.
---
---!
-
-
-with LA14012_0;
-
-function LA14012_1 return integer;
-
-
-function LA14012_1 return integer is
- Local_val : integer := 5;
-begin
- Local_val := LA14012_0 (Parm_1 => Local_val);
- return Local_val;
-end LA14012_1;
diff --git a/gcc/testsuite/ada/acats/tests/l/la140123.a b/gcc/testsuite/ada/acats/tests/l/la140123.a
deleted file mode 100644
index cacbf64e45b..00000000000
--- a/gcc/testsuite/ada/acats/tests/l/la140123.a
+++ /dev/null
@@ -1,59 +0,0 @@
--- LA140123.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- See LA140122.AM.
---
--- TEST DESCRIPTION:
--- See LA140122.AM.
---
--- SPECIAL REQUIREMENTS:
--- See LA140122.AM.
---
--- TEST FILES:
--- This test consists of the following files:
--- LA140120.A
--- LA140121.A
--- LA140122.AM
--- -> LA140123.A
---
--- PASS/FAIL CRITERIA:
--- See LA140122.AM.
---
--- CHANGE HISTORY:
--- 01 MAY 95 ACVC 1.12 LA5007Q baseline version
--- 25 MAY 95 SAIC Initial version
--- 17 NOV 96 SAIC Modified prologue to conform
--- to coding conventions.
---
---!
-
-function LA14012_0 (Parm_1 : integer) return integer;
-
-
-function LA14012_0 (Parm_1 : integer) return integer is
-begin
- return -(2 * Parm_1);
-end LA14012_0;
diff --git a/gcc/testsuite/ada/acats/tests/l/la140130.a b/gcc/testsuite/ada/acats/tests/l/la140130.a
deleted file mode 100644
index a65ce80013d..00000000000
--- a/gcc/testsuite/ada/acats/tests/l/la140130.a
+++ /dev/null
@@ -1,57 +0,0 @@
--- LA140130.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- See LA140132.AM.
---
--- TEST DESCRIPTION:
--- See LA140132.AM.
---
--- SPECIAL REQUIREMENTS:
--- See LA140132.AM.
---
--- TEST FILES:
--- This test consists of the following files:
--- -> LA140130.A
--- LA140131.A
--- LA140132.AM
--- LA140133.A
---
--- PASS/FAIL CRITERIA:
--- See LA140132.AM.
---
---
--- CHANGE HISTORY:
--- 01 MAY 95 ACVC 1.12 LA5007R baseline version
--- 26 MAY 95 SAIC Initial version
--- 17 NOV 96 SAIC Modified prologue to conform
--- to coding conventions.
---
---!
-
-package LA140130 is
- subtype TC_type is integer range 0..100;
- TC_var : TC_type := TC_type'last;
-end LA140130;
diff --git a/gcc/testsuite/ada/acats/tests/l/la140131.a b/gcc/testsuite/ada/acats/tests/l/la140131.a
deleted file mode 100644
index fe03f670568..00000000000
--- a/gcc/testsuite/ada/acats/tests/l/la140131.a
+++ /dev/null
@@ -1,58 +0,0 @@
--- LA140131.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- See LA140132.AM.
---
--- TEST DESCRIPTION:
--- See LA140132.AM.
---
--- SPECIAL REQUIREMENTS:
--- See LA140132.AM.
---
--- TEST FILES:
--- This test consists of the following files:
--- LA140130.A
--- -> LA140131.A
--- LA140132.AM
--- LA140133.A
---
--- PASS/FAIL CRITERIA:
--- See LA140132.AM.
---
---
--- CHANGE HISTORY:
--- 01 MAY 95 ACVC 1.12 LA5007R baseline version
--- 26 MAY 95 SAIC Initial version
--- 17 NOV 96 SAIC Modified prologue to conform
--- to coding conventions.
---
---!
-
-with LA140130;
-
-package LA140131 is
- TC_local : LA140130.TC_type := LA140130.TC_var;
-end LA140131;
diff --git a/gcc/testsuite/ada/acats/tests/l/la140133.a b/gcc/testsuite/ada/acats/tests/l/la140133.a
deleted file mode 100644
index 4d1451e4e53..00000000000
--- a/gcc/testsuite/ada/acats/tests/l/la140133.a
+++ /dev/null
@@ -1,58 +0,0 @@
--- LA140133.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- See LA140132.AM.
---
--- TEST DESCRIPTION:
--- See LA140132.AM.
---
--- SPECIAL REQUIREMENTS:
--- See LA140132.AM.
---
--- TEST FILES:
--- This test consists of the following files:
--- LA140130.A
--- LA140131.A
--- LA140132.AM
--- -> LA140133.A
---
--- PASS/FAIL CRITERIA:
--- See LA140132.AM.
---
---
--- CHANGE HISTORY:
--- 01 MAY 95 ACVC 1.12 LA5007R baseline version
--- 26 MAY 95 SAIC Initial version
--- 17 NOV 96 SAIC Modified prologue to conform
--- to coding conventions.
---
---!
-
-package LA140130 is
- subtype TC_type is integer range -49..50;
- TC_const : constant TC_type := TC_type'first;
- TC_var : TC_type := TC_const;
-end LA140130;
diff --git a/gcc/testsuite/ada/acats/tests/l/la140140.a b/gcc/testsuite/ada/acats/tests/l/la140140.a
deleted file mode 100644
index 21168913c3e..00000000000
--- a/gcc/testsuite/ada/acats/tests/l/la140140.a
+++ /dev/null
@@ -1,55 +0,0 @@
--- LA140140.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- See LA140142.AM.
---
--- TEST DESCRIPTION:
--- See LA140142.AM.
---
--- SPECIAL REQUIREMENTS:
--- See LA140142.AM.
---
--- TEST FILES:
--- This test consists of the following files:
--- -> LA140140.A
--- LA140141.A
--- LA140142.AM
--- LA140143.A
---
--- PASS/FAIL CRITERIA:
--- See LA140142.AM.
---
--- CHANGE HISTORY:
--- 01 MAY 95 ACVC 1.12 LA5007S baseline version
--- 26 MAY 95 SAIC Initial version
--- 12 DEC 96 SAIC Reorganized to permit automatic recompilation.
---
---!
-
-procedure LA14014_0 (Change_one : in out integer) is
-begin
- Change_one := Change_one * 5;
-end LA14014_0;
diff --git a/gcc/testsuite/ada/acats/tests/l/la140141.a b/gcc/testsuite/ada/acats/tests/l/la140141.a
deleted file mode 100644
index d0406e6e581..00000000000
--- a/gcc/testsuite/ada/acats/tests/l/la140141.a
+++ /dev/null
@@ -1,57 +0,0 @@
--- LA140141.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- See LA140142.AM.
---
--- TEST DESCRIPTION:
--- See LA140142.AM.
---
--- SPECIAL REQUIREMENTS:
--- See LA140142.AM.
---
--- TEST FILES:
--- This test consists of the following files:
--- LA140140.A
--- -> LA140141.A
--- LA140142.AM
--- LA140143.A
---
--- PASS/FAIL CRITERIA:
--- See LA140142.AM.
---
--- CHANGE HISTORY:
--- 01 MAY 95 ACVC 1.12 LA5007S baseline version
--- 26 MAY 95 SAIC Initial version
--- 12 DEC 96 SAIC Reorganized to permit automatic recompilation.
---
---!
-
-with LA14014_0;
-procedure LA14014_1 (Change_this : out integer) is
-begin
- Change_this := 10;
- LA14014_0(Change_one => Change_this);
-end LA14014_1;
diff --git a/gcc/testsuite/ada/acats/tests/l/la140143.a b/gcc/testsuite/ada/acats/tests/l/la140143.a
deleted file mode 100644
index 2c21b1bef95..00000000000
--- a/gcc/testsuite/ada/acats/tests/l/la140143.a
+++ /dev/null
@@ -1,64 +0,0 @@
--- LA140143.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- See LA140142.AM.
---
--- TEST DESCRIPTION:
--- See LA140142.AM.
---
--- SPECIAL REQUIREMENTS:
--- See LA140142.AM.
---
--- TEST FILES:
--- This test consists of the following files:
--- LA140140.A
--- LA140141.A
--- LA140142.AM
--- -> LA140143.A
---
--- PASS/FAIL CRITERIA:
--- See LA140142.AM.
---
--- CHANGE HISTORY:
--- 01 MAY 95 ACVC 1.12 LA5007S baseline version
--- 26 MAY 95 SAIC Initial version
--- 12 DEC 96 SAIC Reorganized to permit automatic recompilation.
---
---!
-
-procedure LA14014_0 (Change_two : in integer := 0;
- Change_one : out integer) is
-begin
-
- if Change_two = 10 then
- Change_one := 70;
- elsif Change_two = 0 then
- Change_one := -10;
- else
- Change_one := 30;
- end if;
-
-end LA14014_0;
diff --git a/gcc/testsuite/ada/acats/tests/l/la140150.a b/gcc/testsuite/ada/acats/tests/l/la140150.a
deleted file mode 100644
index 77a5a21a854..00000000000
--- a/gcc/testsuite/ada/acats/tests/l/la140150.a
+++ /dev/null
@@ -1,56 +0,0 @@
--- LA140150.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- See LA140152.AM.
---
--- TEST DESCRIPTION:
--- See LA140152.AM.
---
--- SPECIAL REQUIREMENTS:
--- See LA140152.AM.
---
--- TEST FILES:
--- This test consists of the following files:
--- -> LA140150.A
--- LA140151.A
--- LA140152.AM
--- LA140153.A
---
--- PASS/FAIL CRITERIA:
--- See LA140152.AM.
---
--- CHANGE HISTORY:
--- 01 MAY 95 ACVC 1.12 LA5007T baseline version
--- 06 JUN 95 SAIC Initial version
--- 17 NOV 96 SAIC Modified prologue to conform
--- to coding conventions.
---
---!
-
-function LA14015_0 (Param_1 : integer) return boolean is
-begin
- return Param_1 = 5;
-end LA14015_0;
diff --git a/gcc/testsuite/ada/acats/tests/l/la140151.a b/gcc/testsuite/ada/acats/tests/l/la140151.a
deleted file mode 100644
index 6cd0d1a6410..00000000000
--- a/gcc/testsuite/ada/acats/tests/l/la140151.a
+++ /dev/null
@@ -1,65 +0,0 @@
--- LA140151.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- See LA140152.AM.
---
--- TEST DESCRIPTION:
--- See LA140152.AM.
---
--- SPECIAL REQUIREMENTS:
--- See LA140152.AM.
---
--- TEST FILES:
--- This test consists of the following files:
--- LA140150.A
--- -> LA140151.A
--- LA140152.AM
--- LA140153.A
---
--- PASS/FAIL CRITERIA:
--- See LA140152.AM.
---
--- CHANGE HISTORY:
--- 01 MAY 95 ACVC 1.12 LA5007T baseline version
--- 06 JUN 95 SAIC Initial version
--- 17 NOV 96 SAIC Modified prologue to conform
--- to coding conventions.
---
---!
-
-with LA14015_0; -- when LA140150 is revised and recompiled,
- -- this semantic dependency has to be
- -- handled
-
-
-function LA14015_1 (P : integer) return integer is
-begin
- if LA14015_0 (Param_1 => P) then
- return 100;
- else
- return -10;
- end if;
-end LA14015_1;
diff --git a/gcc/testsuite/ada/acats/tests/l/la140153.a b/gcc/testsuite/ada/acats/tests/l/la140153.a
deleted file mode 100644
index 812644595e4..00000000000
--- a/gcc/testsuite/ada/acats/tests/l/la140153.a
+++ /dev/null
@@ -1,61 +0,0 @@
--- LA140153.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- See LA140152.AM.
---
--- TEST DESCRIPTION:
--- See LA140152.AM.
---
--- SPECIAL REQUIREMENTS:
--- See LA140152.AM.
---
--- TEST FILES:
--- This test consists of the following files:
--- LA140150.A
--- LA140151.A
--- LA140152.AM
--- -> LA140153.A
---
--- PASS/FAIL CRITERIA:
--- See LA140152.AM.
---
--- CHANGE HISTORY:
--- 01 MAY 95 ACVC 1.12 LA5007T baseline version
--- 06 JUN 95 SAIC Initial version
--- 17 NOV 96 SAIC Modified prologue to conform
--- to coding conventions.
---
---!
-
-function LA14015_0 (Param_2 : boolean := false;
- Param_1 : integer := 10) return boolean is
-begin
- if Param_2 then
- return true;
- else
- return Param_1 = 10;
- end if;
-end LA14015_0;
diff --git a/gcc/testsuite/ada/acats/tests/l/la140160.a b/gcc/testsuite/ada/acats/tests/l/la140160.a
deleted file mode 100644
index 38c396d9622..00000000000
--- a/gcc/testsuite/ada/acats/tests/l/la140160.a
+++ /dev/null
@@ -1,54 +0,0 @@
--- LA140160.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- See LA140162.AM.
---
--- TEST DESCRIPTION:
--- See LA140162.AM.
---
--- SPECIAL REQUIREMENTS:
--- See LA140162.AM.
---
--- TEST FILES:
--- This test consists of the following files:
--- -> LA140160.A
--- LA140161.A
--- LA140162.AM
--- LA140163.A
---
--- PASS/FAIL CRITERIA:
--- See LA140162.AM.
---
--- CHANGE HISTORY:
--- 07 DEC 96 SAIC ACVC 2.1: Initial version.
---
---!
-
-package LA14016_0 is
- subtype status_code is integer range 0..10;
- type tagged_type is abstract tagged null record;
- function status (param : tagged_type) return status_code is abstract;
-end LA14016_0;
diff --git a/gcc/testsuite/ada/acats/tests/l/la140161.a b/gcc/testsuite/ada/acats/tests/l/la140161.a
deleted file mode 100644
index 4be9f1dfd8c..00000000000
--- a/gcc/testsuite/ada/acats/tests/l/la140161.a
+++ /dev/null
@@ -1,63 +0,0 @@
--- LA140161.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- See LA140162.AM.
---
--- TEST DESCRIPTION:
--- See LA140162.AM.
---
--- SPECIAL REQUIREMENTS:
--- See LA140162.AM.
---
--- TEST FILES:
--- This test consists of the following files:
--- LA140160.A
--- -> LA140161.A
--- LA140162.AM
--- LA140162.A
---
--- PASS/FAIL CRITERIA:
--- See LA140162.AM.
---
--- CHANGE HISTORY:
--- 07 DEC 96 SAIC ACVC 2.1: Initial version.
---
---!
-
-with LA14016_0;
-generic
- type T is new LA14016_0.tagged_type with private;
- type count_type is range <>;
-package LA14016_1 is
- default_status : constant LA14016_0.status_code := 0;
- type new_t is new T with
- record
- count : count_type;
- end record;
- function status (param : new_t) return LA14016_0.status_code;
-
- procedure inc (param : in out new_t);
-end LA14016_1;
diff --git a/gcc/testsuite/ada/acats/tests/l/la140163.a b/gcc/testsuite/ada/acats/tests/l/la140163.a
deleted file mode 100644
index d91923a6c63..00000000000
--- a/gcc/testsuite/ada/acats/tests/l/la140163.a
+++ /dev/null
@@ -1,67 +0,0 @@
--- LA140163.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- See LA140162.AM.
---
--- TEST DESCRIPTION:
--- See LA140162.AM.
---
--- SPECIAL REQUIREMENTS:
--- See LA140162.AM.
---
--- TEST FILES:
--- This test consists of the following files:
--- LA140160.A
--- LA140161.A
--- LA140162.AM
--- -> LA140163.A
---
--- PASS/FAIL CRITERIA:
--- See LA140162.AM.
---
--- CHANGE HISTORY:
--- 01 MAY 95 ACVC 1.12 LA5008L baseline version
--- 16 JUN 95 SAIC Initial version
--- 07 DEC 96 SAIC Modified unit names and prologue to conform
--- to coding conventions and to reflect new
--- test file organization.
---
---!
-
-with LA14016_0;
-generic
- type T is new LA14016_0.tagged_type with private;
- type count_type is range <>;
-package LA14016_1 is
- default_status : constant LA14016_0.status_code := 5;
- type new_t is new T with
- record
- count : count_type;
- end record;
- function status (param : new_t) return LA14016_0.status_code;
-
- procedure inc (param : in out new_t);
-end LA14016_1;
diff --git a/gcc/testsuite/ada/acats/tests/l/la140170.a b/gcc/testsuite/ada/acats/tests/l/la140170.a
deleted file mode 100644
index 0c041d00a26..00000000000
--- a/gcc/testsuite/ada/acats/tests/l/la140170.a
+++ /dev/null
@@ -1,64 +0,0 @@
--- LA140170.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- See LA140172.AM.
---
--- TEST DESCRIPTION:
--- See LA140172.AM.
---
--- SPECIAL REQUIREMENTS:
--- See LA140172.AM.
---
--- TEST FILES:
--- This test consists of the following files:
--- -> LA140170.A
--- LA140171.A
--- LA140172.AM
--- LA140173.A
---
--- PASS/FAIL CRITERIA:
--- See LA140172.AM.
---
--- CHANGE HISTORY:
--- 07 DEC 96 SAIC ACVC 2.1: Initial version.
---
---!
-
-package LA14017_0 is
- type swap_type_ptr is record
- p_all : integer;
- end record;
- subtype count_type is integer;
-end LA14017_0;
-
------------------------------------------------------
-
-with LA14017_0;
-use LA14017_0;
-generic
- type swap_type is private;
-function LA14017_1 (P1, P2 : swap_type_ptr;
- count : count_type) return count_type;
diff --git a/gcc/testsuite/ada/acats/tests/l/la140171.a b/gcc/testsuite/ada/acats/tests/l/la140171.a
deleted file mode 100644
index d7f37663c9a..00000000000
--- a/gcc/testsuite/ada/acats/tests/l/la140171.a
+++ /dev/null
@@ -1,69 +0,0 @@
--- LA140171.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- See LA140172.AM.
---
--- TEST DESCRIPTION:
--- See LA140172.AM.
---
--- SPECIAL REQUIREMENTS:
--- See LA140172.AM.
---
--- TEST FILES:
--- This test consists of the following files:
--- LA140170.A
--- -> LA140171.A
--- LA140172.AM
--- LA140173.A
---
--- PASS/FAIL CRITERIA:
--- See LA140172.AM.
---
--- CHANGE HISTORY:
--- 07 DEC 96 SAIC ACVC 2.1: Initial version.
---
---!
-
-function LA14017_1 (P1, P2 : swap_type_ptr;
- count : count_type) return count_type is
- temp : integer := 0;
- count_factor : count_type := 10;
-
- function Inc (Param : integer) return integer;
-
- function Inc (Param : integer) return integer is separate;
-
- procedure Swap_Ptrs (P1, P2 : in out swap_type_ptr) is
- temp : integer := 0;
- begin
- temp := P1.p_all;
- P1.p_all := P2.p_all;
- P2.p_all := temp;
- end Swap_Ptrs;
-
-begin
- return count_type (Inc (integer(count)));
-end LA14017_1;
diff --git a/gcc/testsuite/ada/acats/tests/l/la140173.a b/gcc/testsuite/ada/acats/tests/l/la140173.a
deleted file mode 100644
index 73f382e72aa..00000000000
--- a/gcc/testsuite/ada/acats/tests/l/la140173.a
+++ /dev/null
@@ -1,75 +0,0 @@
--- LA140173.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- See LA140172.AM.
---
--- TEST DESCRIPTION:
--- See LA140172.AM.
---
--- SPECIAL REQUIREMENTS:
--- See LA140172.AM.
---
--- TEST FILES:
--- This test consists of the following files:
--- LA140170.A
--- LA140171.A
--- LA140172.AM
--- -> LA140173.A
---
--- PASS/FAIL CRITERIA:
--- See LA140172.AM.
---
--- CHANGE HISTORY:
--- 01 MAY 95 ACVC 1.12 LA5008M baseline version
--- 16 JUN 95 SAIC Initial version
--- 03 MAR 96 SAIC First revision after review
--- 17 NOV 96 SAIC Modified unit names and prologue to conform
--- to coding conventions.
--- 07 DEC 96 SAIC Modified prologue to reflect new test
--- file organization.
---
---!
-
-function LA14017_1 (P1, P2 : swap_type_ptr;
- count : count_type) return count_type is
- count_factor : count_type := -10;
-
- procedure Swap_Ptrs (P1, P2 : in out swap_type_ptr) is
- temp : integer := 0;
- begin
- temp := P1.p_all;
- P1.p_all := P2.p_all;
- P2.p_all := temp;
- end Swap_Ptrs;
-
- function Inc (Param : integer) return integer;
-
- function Inc (Param : integer) return integer is separate;
-
- temp : integer := 0;
-begin
- return count_type (Inc (integer(count)));
-end LA14017_1;
diff --git a/gcc/testsuite/ada/acats/tests/l/la140180.a b/gcc/testsuite/ada/acats/tests/l/la140180.a
deleted file mode 100644
index 185ca21f438..00000000000
--- a/gcc/testsuite/ada/acats/tests/l/la140180.a
+++ /dev/null
@@ -1,65 +0,0 @@
--- LA140180.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- See LA140182.AM.
---
--- TEST DESCRIPTION:
--- See LA140182.AM.
---
--- SPECIAL REQUIREMENTS:
--- See LA140182.AM.
---
--- TEST FILES:
--- This test consists of the following files:
--- -> LA140180.A
--- LA140181.A
--- LA140182.AM
--- LA140183.A
---
--- PASS/FAIL CRITERIA:
--- See LA140182.AM.
---
--- CHANGE HISTORY:
--- 07 DEC 96 SAIC ACVC 2.1: Initial version.
---
---!
-
-generic
- type unsigned is mod <>;
- mod_value : unsigned := 1;
-package LA14018_0 is
- --types declared locally
-
- generic
- type discrete is (<>);
- package utils_18 is
- procedure Dec (Param : in out unsigned);
-
- -- other utilities
- end utils_18;
-
- --routines that make this generic useful
-end LA14018_0;
diff --git a/gcc/testsuite/ada/acats/tests/l/la140181.a b/gcc/testsuite/ada/acats/tests/l/la140181.a
deleted file mode 100644
index 3d9847a98ae..00000000000
--- a/gcc/testsuite/ada/acats/tests/l/la140181.a
+++ /dev/null
@@ -1,54 +0,0 @@
--- LA140181.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- See LA140182.AM.
---
--- TEST DESCRIPTION:
--- See LA140182.AM.
---
--- SPECIAL REQUIREMENTS:
--- See LA140182.AM.
---
--- TEST FILES:
--- This test consists of the following files:
--- LA140180.A
--- -> LA140181.A
--- LA140182.AM
--- LA140183.A
---
--- PASS/FAIL CRITERIA:
--- See LA140182.AM.
---
--- CHANGE HISTORY:
--- 07 DEC 96 SAIC ACVC 2.1: Initial version.
---
---!
-
-package body LA14018_0 is
- offset : constant unsigned := mod_value;
-
- package body utils_18 is separate;
-end LA14018_0;
diff --git a/gcc/testsuite/ada/acats/tests/l/la140183.a b/gcc/testsuite/ada/acats/tests/l/la140183.a
deleted file mode 100644
index f50ae15ba18..00000000000
--- a/gcc/testsuite/ada/acats/tests/l/la140183.a
+++ /dev/null
@@ -1,60 +0,0 @@
--- LA140183.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- See LA140182.AM.
---
--- TEST DESCRIPTION:
--- See LA140182.AM.
---
--- SPECIAL REQUIREMENTS:
--- See LA140182.AM.
---
--- TEST FILES:
--- This test consists of the following files:
--- LA140180.A
--- LA140181.A
--- LA140182.AM
--- -> LA140183.A
---
--- PASS/FAIL CRITERIA:
--- See LA140182.AM.
---
--- CHANGE HISTORY:
--- 01 MAY 95 ACVC 1.12 LA5008N baseline version
--- 16 JUN 95 SAIC Initial version
--- 07 DEC 96 SAIC Modified unit names and prologue to conform
--- to coding conventions, and to reflect new test
--- file organization.
---
---!
-
-package body LA14018_0 is
- New_TC_var : integer := 101;
- New_array : array (1..101) of integer := (others => 0);
- offset : constant unsigned := mod_value + 2;
-
- package body utils_18 is separate;
-end LA14018_0;
diff --git a/gcc/testsuite/ada/acats/tests/l/la140190.a b/gcc/testsuite/ada/acats/tests/l/la140190.a
deleted file mode 100644
index 0c4c3a9d656..00000000000
--- a/gcc/testsuite/ada/acats/tests/l/la140190.a
+++ /dev/null
@@ -1,61 +0,0 @@
--- LA140190.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- See LA140192.AM.
---
--- TEST DESCRIPTION:
--- See LA140192.AM.
---
--- SPECIAL REQUIREMENTS:
--- See LA140192.AM.
---
--- TEST FILES:
--- This test consists of the following files:
--- -> LA140190.A
--- LA140191.A
--- LA140192.AM
--- LA140193.A
---
--- PASS/FAIL CRITERIA:
--- See LA140192.AM.
---
--- CHANGE HISTORY:
--- 01 MAY 95 ACVC 1.12 LA5008P baseline version
--- 23 JUN 95 SAIC Initial version
--- 29 JAN 96 SAIC First revision after review
--- 17 NOV 96 SAIC Modified unit names and prologue to conform
--- to coding conventions.
---
---!
-
-procedure LA14019_0 (Param : in out integer);
-
-
-procedure LA14019_0 (Param : in out integer) is
- TC_offset : constant integer := 1;
-begin
- Param := Param + TC_offset;
-end LA14019_0;
diff --git a/gcc/testsuite/ada/acats/tests/l/la140191.a b/gcc/testsuite/ada/acats/tests/l/la140191.a
deleted file mode 100644
index 8b7af2e7c90..00000000000
--- a/gcc/testsuite/ada/acats/tests/l/la140191.a
+++ /dev/null
@@ -1,74 +0,0 @@
--- LA140191.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- See LA140192.AM.
---
--- TEST DESCRIPTION:
--- See LA140192.AM.
---
--- SPECIAL REQUIREMENTS:
--- See LA140192.AM.
---
--- TEST FILES:
--- This test consists of the following files:
--- LA140190.A
--- -> LA140191.A
--- LA140192.AM
--- LA140193.A
---
--- PASS/FAIL CRITERIA:
--- See LA140192.AM.
---
--- CHANGE HISTORY:
--- 01 MAY 95 ACVC 1.12 LA5008P baseline version
--- 23 JUN 95 SAIC Initial version
--- 29 JAN 96 SAIC First revision after review
--- 17 NOV 96 SAIC Modified unit names and prologue to conform
--- to coding conventions.
---
---!
-
-generic
- type integer_type is range <>;
-procedure LA14019_1 (Test_val : in out integer);
-
-with LA14019_0;
-procedure LA14019_1 (Test_val : in out integer) is
- arr : array (1..5) of integer;
- sum : integer := 0;
- temp_val : integer := 0;
-begin
- arr(1) := Test_val;
- for i in 2..arr'last loop
- temp_val := arr(i-1);
- LA14019_0 (temp_val);
- arr(i) := temp_val;
- end loop;
- for i in 1..arr'last loop
- sum := sum + arr(i);
- end loop;
- Test_val := sum;
-end LA14019_1;
diff --git a/gcc/testsuite/ada/acats/tests/l/la140193.a b/gcc/testsuite/ada/acats/tests/l/la140193.a
deleted file mode 100644
index 717cc633ba7..00000000000
--- a/gcc/testsuite/ada/acats/tests/l/la140193.a
+++ /dev/null
@@ -1,64 +0,0 @@
--- LA140193.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- See LA140192.AM.
---
--- TEST DESCRIPTION:
--- See LA140192.AM.
---
--- SPECIAL REQUIREMENTS:
--- See LA140192.AM.
---
--- TEST FILES:
--- This test consists of the following files:
--- LA140190.A
--- LA140191.A
--- LA140192.AM
--- -> LA140193.A
---
--- PASS/FAIL CRITERIA:
--- See LA140192.AM.
---
--- CHANGE HISTORY:
--- 01 MAY 95 ACVC 1.12 LA5008P baseline version
--- 23 JUN 95 SAIC Initial version
--- 29 JAN 96 SAIC First revision after review
--- 17 NOV 96 SAIC Modified unit names and prologue to conform
--- to coding conventions.
---
---!
-
-procedure LA14019_0 (Param : in out integer);
-
-
-procedure LA14019_0 (Param : in out integer) is
- Local_array : array (1..10) of float := (others => 0.0);
- Local_var : integer := 0;
- TC_var : constant integer := -9;
-
-begin
- Param := (1 + Param) * 2;
-end LA14019_0;
diff --git a/gcc/testsuite/ada/acats/tests/l/la140200.a b/gcc/testsuite/ada/acats/tests/l/la140200.a
deleted file mode 100644
index 9adf75e67bf..00000000000
--- a/gcc/testsuite/ada/acats/tests/l/la140200.a
+++ /dev/null
@@ -1,76 +0,0 @@
--- LA140200.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- See LA140202.AM.
---
--- TEST DESCRIPTION:
--- See LA140202.AM.
---
--- SPECIAL REQUIREMENTS:
--- See LA140202.AM.
---
--- TEST FILES:
--- This test consists of the following files:
--- -> LA140200.A
--- LA140201.A
--- LA140202.AM
--- LA140203.A
---
--- PASS/FAIL CRITERIA:
--- See LA140202.AM.
---
--- CHANGE HISTORY:
--- 01 MAY 95 ACVC 1.12 LA5008Q baseline version
--- 23 JUN 95 SAIC Initial version
--- 29 FEB 96 SAIC First revision after review
--- 12 DEC 96 SAIC Reorganized to permit automatic recompilation.
--- Reworded objective. Moved instance to
--- library-level and redesigned to use generic
--- formal function. Fixed arithmetic errors.
---
---!
-
-package LA14020_0 is
-
- subtype apples is integer range 0..100;
- subtype oranges is integer range 0..200;
-
- type Fruit_Basket is tagged record
- App : apples;
- Ora : oranges;
- end record;
-
-end LA14020_0;
-
- --==================================================================--
-
-package LA14020_0.LA14020_1 is
-
- type Bigger_Basket is new Fruit_Basket with record
- Total : integer;
- end record;
-
-end LA14020_0.LA14020_1;
diff --git a/gcc/testsuite/ada/acats/tests/l/la140201.a b/gcc/testsuite/ada/acats/tests/l/la140201.a
deleted file mode 100644
index 66822553207..00000000000
--- a/gcc/testsuite/ada/acats/tests/l/la140201.a
+++ /dev/null
@@ -1,71 +0,0 @@
--- LA140201.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- See LA140202.AM.
---
--- TEST DESCRIPTION:
--- See LA140202.AM.
---
--- SPECIAL REQUIREMENTS:
--- See LA140202.AM.
---
--- TEST FILES:
--- This test consists of the following files:
--- LA140200.A
--- -> LA140201.A
--- LA140202.AM
--- LA140203.A
---
--- PASS/FAIL CRITERIA:
--- See LA140202.AM.
---
--- CHANGE HISTORY:
--- 01 MAY 95 ACVC 1.12 LA5008Q baseline version
--- 23 JUN 95 SAIC Initial version
--- 29 FEB 96 SAIC First revision after review
--- 12 DEC 96 SAIC Reorganized to permit automatic recompilation.
--- Reworded objective. Moved instance to
--- library-level and redesigned to use generic
--- formal function. Fixed arithmetic errors.
---
---!
-
-with LA14020_0;
-generic
- type Basket is new LA14020_0.Fruit_Basket with private;
-function LA14020_2 (Left, Right : Basket) return Basket;
-
- --==================================================================--
-
-function LA14020_2 (Left, Right : Basket) return Basket is
- Result : Basket;
-begin
- Result.App := Left.App + Left.App;
- Result.Ora := Right.Ora + Right.Ora;
- -- wrong algorithm, to be corrected later
-
- return Result;
-end LA14020_2;
diff --git a/gcc/testsuite/ada/acats/tests/l/la140203.a b/gcc/testsuite/ada/acats/tests/l/la140203.a
deleted file mode 100644
index f2965b407c4..00000000000
--- a/gcc/testsuite/ada/acats/tests/l/la140203.a
+++ /dev/null
@@ -1,71 +0,0 @@
--- LA140203.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- See LA140202.AM.
---
--- TEST DESCRIPTION:
--- See LA140202.AM.
---
--- SPECIAL REQUIREMENTS:
--- See LA140202.AM.
---
--- TEST FILES:
--- This test consists of the following files:
--- LA140200.A
--- LA140201.A
--- LA140202.AM
--- -> LA140203.A
---
--- PASS/FAIL CRITERIA:
--- See LA140202.AM.
---
--- CHANGE HISTORY:
--- 01 MAY 95 ACVC 1.12 LA5008Q baseline version
--- 23 JUN 95 SAIC Initial version
--- 29 FEB 96 SAIC First revision after review
--- 12 DEC 96 SAIC Reorganized to permit automatic recompilation.
--- Reworded objective. Moved instance to
--- library-level and redesigned to use generic
--- formal function. Fixed arithmetic errors.
---
---!
-
-with LA14020_0;
-generic
- type Basket is new LA14020_0.Fruit_Basket with private;
-function LA14020_2 (Left, Right : Basket) return Basket;
-
- --==================================================================--
-
-function LA14020_2 (Left, Right : Basket) return Basket is
- Result : Basket;
-begin
- Result.App := Left.App + Right.App;
- Result.Ora := Left.Ora + Right.Ora;
- -- correct algorithm
-
- return Result;
-end LA14020_2;
diff --git a/gcc/testsuite/ada/acats/tests/l/la140210.a b/gcc/testsuite/ada/acats/tests/l/la140210.a
deleted file mode 100644
index ab3ad5f776a..00000000000
--- a/gcc/testsuite/ada/acats/tests/l/la140210.a
+++ /dev/null
@@ -1,69 +0,0 @@
--- LA140210.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- See LA140211.AM.
---
--- TEST DESCRIPTION:
--- See LA140211.AM.
---
--- SPECIAL REQUIREMENTS:
--- See LA140211.AM.
---
--- TEST FILES:
--- This test consists of the following files:
--- -> LA140210.A
--- LA140211.AM
--- LA140212.A
---
--- PASS/FAIL CRITERIA:
--- See LA140211.AM.
---
--- CHANGE HISTORY:
--- 07 DEC 96 SAIC ACVC 2.1: Initial version.
---
---!
-
-generic
- type swap_type is private;
- type int_type is range <>;
- times : int_type :=1;
-package LA14021_0 is
- procedure swap (this, for_that : in out swap_type);
-end LA14021_0;
-
----------------------------------------------------------
-
-package body LA14021_0 is
- procedure swap (this, for_that : in out swap_type) is
- temp : swap_type;
- begin
- for i in int_type'first..times loop
- temp := this;
- this := for_that;
- for_that := temp;
- end loop;
- end swap;
-end LA14021_0;
diff --git a/gcc/testsuite/ada/acats/tests/l/la140212.a b/gcc/testsuite/ada/acats/tests/l/la140212.a
deleted file mode 100644
index 0c689b9996a..00000000000
--- a/gcc/testsuite/ada/acats/tests/l/la140212.a
+++ /dev/null
@@ -1,74 +0,0 @@
--- LA140212.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- See LA140211.AM.
---
--- TEST DESCRIPTION:
--- See LA140211.AM.
---
--- SPECIAL REQUIREMENTS:
--- See LA140211.AM.
---
--- TEST FILES:
--- This test consists of the following files:
--- LA140210.A
--- LA140211.AM
--- -> LA140212.A
---
--- PASS/FAIL CRITERIA:
--- See LA140211.AM.
---
--- CHANGE HISTORY:
--- 01 MAY 95 ACVC 1.12 LA5008R baseline version
--- 23 JUN 95 SAIC Initial version
--- 18 NOV 96 SAIC Modified prologue to conform
--- to coding conventions.
--- 07 DEC 96 SAIC Modified prologue to reflect new test
--- file organization.
---
---!
-
-generic
- type swap_type is private;
- type int_type is range <>;
- times : int_type :=2; --this line contains the change
-package LA14021_0 is
- procedure swap (this, for_that : in out swap_type);
-end LA14021_0;
-
----------------------------------------------------------
-
-package body LA14021_0 is
- procedure swap (this, for_that : in out swap_type) is
- temp : swap_type;
- begin
- for i in int_type'first..times loop
- temp := this;
- this := for_that;
- for_that := temp;
- end loop;
- end swap;
-end LA14021_0;
diff --git a/gcc/testsuite/ada/acats/tests/l/la140220.a b/gcc/testsuite/ada/acats/tests/l/la140220.a
deleted file mode 100644
index c5e4c6575e2..00000000000
--- a/gcc/testsuite/ada/acats/tests/l/la140220.a
+++ /dev/null
@@ -1,64 +0,0 @@
--- LA140220.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- See LA140221.AM.
---
--- TEST DESCRIPTION:
--- See LA140221.AM.
---
--- SPECIAL REQUIREMENTS:
--- See LA140221.AM.
---
--- TEST FILES:
--- This test consists of the following files:
--- -> LA140220.A
--- LA140221.AM
--- LA140222.A
---
--- PASS/FAIL CRITERIA:
--- See LA140221.AM.
---
--- CHANGE HISTORY:
--- 07 DEC 96 SAIC ACVC 2.1: Initial version.
---
---!
-
-generic
- type stuff is private;
- type ptr is access stuff;
- type return_result is range <>;
- delta_val : return_result := 1;
-procedure LA14022_0 (pointer : in out ptr;
- result : in out return_result);
-
--------------------------------------------------------
-
-procedure LA14022_0 (pointer : in out ptr;
- result : in out return_result) is
-begin
- pointer := new stuff;
- result := result + delta_val;
-end LA14022_0;
diff --git a/gcc/testsuite/ada/acats/tests/l/la140222.a b/gcc/testsuite/ada/acats/tests/l/la140222.a
deleted file mode 100644
index 424236b3efc..00000000000
--- a/gcc/testsuite/ada/acats/tests/l/la140222.a
+++ /dev/null
@@ -1,69 +0,0 @@
--- LA140222.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- See LA140221.AM.
---
--- TEST DESCRIPTION:
--- See LA140221.AM.
---
--- SPECIAL REQUIREMENTS:
--- See LA140221.AM.
---
--- TEST FILES:
--- This test consists of the following files:
--- LA140220.A
--- LA140221.AM
--- -> LA140222.A
---
--- PASS/FAIL CRITERIA:
--- See LA140221.AM.
---
--- CHANGE HISTORY:
--- 01 MAY 95 ACVC 1.12 LA5008S baseline version
--- 23 JUN 95 SAIC Initial version
--- 18 NOV 96 SAIC Modified prologue to conform
--- to coding conventions.
--- 07 DEC 96 SAIC Modified prologue to reflect new test
--- file organization.
---
---!
-
-generic
- type stuff is private;
- type ptr is access stuff;
- type return_result is range <>;
- delta_val : return_result := 1;
-procedure LA14022_0 (pointer : in out ptr;
- result : in out return_result);
-
--------------------------------------------------------
-
-procedure LA14022_0 (pointer : in out ptr;
- result : in out return_result) is
-begin
- pointer := null;
- result := result + return_result'first;
-end LA14022_0;
diff --git a/gcc/testsuite/ada/acats/tests/l/la140240.a b/gcc/testsuite/ada/acats/tests/l/la140240.a
deleted file mode 100644
index e5541006ec1..00000000000
--- a/gcc/testsuite/ada/acats/tests/l/la140240.a
+++ /dev/null
@@ -1,61 +0,0 @@
--- LA140240.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- See LA140242.AM.
---
--- TEST DESCRIPTION:
--- See LA140242.AM.
---
--- SPECIAL REQUIREMENTS:
--- See LA140242.AM.
---
--- TEST FILES:
--- This test consists of the following files:
--- -> LA140240.A
--- LA140241.A
--- LA140242.AM
--- LA140243.A
---
--- PASS/FAIL CRITERIA:
--- See LA140242.AM.
---
--- CHANGE HISTORY:
--- 01 MAY 95 ACVC 1.12 LA5008U baseline version
--- 29 JUN 95 SAIC Initial version
--- 18 NOV 96 SAIC Modified prologue to conform
--- to coding conventions.
---
---!
-
-generic
- Local_max : positive;
- type Thing is private;
-package LA14024_0 is
- type Goodies is tagged
- record
- X, Y : integer := 100;
- end record;
-end LA14024_0;
diff --git a/gcc/testsuite/ada/acats/tests/l/la140241.a b/gcc/testsuite/ada/acats/tests/l/la140241.a
deleted file mode 100644
index dde3b3db520..00000000000
--- a/gcc/testsuite/ada/acats/tests/l/la140241.a
+++ /dev/null
@@ -1,55 +0,0 @@
--- LA140241.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- See LA140242.AM.
---
--- TEST DESCRIPTION:
--- See LA140242.AM.
---
--- SPECIAL REQUIREMENTS:
--- See LA140242.AM.
---
--- TEST FILES:
--- This test consists of the following files:
--- LA140240.A
--- -> LA140241.A
--- LA140242.AM
--- LA140243.A
---
--- PASS/FAIL CRITERIA:
--- See LA140242.AM.
---
--- CHANGE HISTORY:
--- 01 MAY 95 ACVC 1.12 LA5008U baseline version
--- 29 JUN 95 SAIC Initial version
--- 18 NOV 96 SAIC Modified prologue to conform
--- to coding conventions.
---
---!
-
-with LA14024_0;
-
-package LA14024_1 is new LA14024_0 (100, integer);
diff --git a/gcc/testsuite/ada/acats/tests/l/la140243.a b/gcc/testsuite/ada/acats/tests/l/la140243.a
deleted file mode 100644
index 98b03438bc4..00000000000
--- a/gcc/testsuite/ada/acats/tests/l/la140243.a
+++ /dev/null
@@ -1,61 +0,0 @@
--- LA140243.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- See LA140242.AM.
---
--- TEST DESCRIPTION:
--- See LA140242.AM.
---
--- SPECIAL REQUIREMENTS:
--- See LA140242.AM.
---
--- TEST FILES:
--- This test consists of the following files:
--- LA140240.A
--- LA140241.A
--- LA140242.AM
--- -> LA140243.A
---
--- PASS/FAIL CRITERIA:
--- See LA140242.AM.
---
--- CHANGE HISTORY:
--- 01 MAY 95 ACVC 1.12 LA5008U baseline version
--- 29 JUN 95 SAIC Initial version
--- 18 NOV 96 SAIC Modified prologue to conform
--- to coding conventions.
---
---!
-
-generic
- Local_max : positive;
- type Thing is private;
-package LA14024_0 is
- type Goodies is tagged
- record
- Y, X : integer := -10;
- end record;
-end LA14024_0;
diff --git a/gcc/testsuite/ada/acats/tests/l/la140250.a b/gcc/testsuite/ada/acats/tests/l/la140250.a
deleted file mode 100644
index 44477df4d70..00000000000
--- a/gcc/testsuite/ada/acats/tests/l/la140250.a
+++ /dev/null
@@ -1,56 +0,0 @@
--- LA140250.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- See LA140251.AM.
---
--- TEST DESCRIPTION:
--- See LA140251.AM.
---
--- SPECIAL REQUIREMENTS:
--- See LA140251.AM.
---
--- TEST FILES:
--- This test consists of the following files:
--- -> LA140050.A
--- LA140051.AM
--- LA140052.A
---
--- PASS/FAIL CRITERIA:
--- See LA140251.AM.
---
--- CHANGE HISTORY:
--- 07 DEC 96 SAIC ACVC 2.1: Initial version.
---
---!
-
-package LA14025_0 is
- subtype byte is integer range 0..511;
- byte_val : constant byte := 128;
- type Data_rec is tagged record
- Id : integer := 1;
- Val: byte := byte_val;
- end record;
-end LA14025_0;
diff --git a/gcc/testsuite/ada/acats/tests/l/la140252.a b/gcc/testsuite/ada/acats/tests/l/la140252.a
deleted file mode 100644
index 2fce76cea6f..00000000000
--- a/gcc/testsuite/ada/acats/tests/l/la140252.a
+++ /dev/null
@@ -1,59 +0,0 @@
--- LA140252.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- See LA140251.AM.
---
--- TEST DESCRIPTION:
--- See LA140251.AM.
---
--- SPECIAL REQUIREMENTS:
--- See LA140251.AM.
---
--- TEST FILES:
--- This test consists of the following files:
--- LA140050.A
--- LA140051.AM
--- -> LA140052.A
---
--- PASS/FAIL CRITERIA:
--- See LA140251.AM.
---
--- CHANGE HISTORY:
--- 01 MAY 95 ACVC 1.12 LA5008V baseline version
--- 06 JUL 95 SAIC Initial version
--- 07 DEC 96 SAIC Modified prologue to reflect new test
--- file organization.
---
---!
-
-package LA14025_0 is
- subtype byte is integer range 0..511;
- byte_val : constant byte := 64;
- type Data_rec is tagged record
- Id : integer := 1;
- Val: byte := byte_val;
- end record;
-end LA14025_0;
diff --git a/gcc/testsuite/ada/acats/tests/l/la140260.a b/gcc/testsuite/ada/acats/tests/l/la140260.a
deleted file mode 100644
index fae1736673b..00000000000
--- a/gcc/testsuite/ada/acats/tests/l/la140260.a
+++ /dev/null
@@ -1,98 +0,0 @@
--- LA140260.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- See LA140262.AM.
---
--- TEST DESCRIPTION:
--- See LA140262.AM.
---
--- SPECIAL REQUIREMENTS:
--- See LA140262.AM.
---
--- TEST FILES:
--- This test consists of the following files:
--- -> LA140260.A
--- LA140261.A
--- LA140262.AM
--- LA140263.A
---
--- PASS/FAIL CRITERIA:
--- See LA140262.AM.
---
--- CHANGE HISTORY:
--- 07 DEC 96 SAIC ACVC 2.1: Initial version.
---
---!
-
-package LA14026_0 is
- type basic_rec is tagged
- record
- null;
- end record;
-end LA14026_0;
-
----------------------------------------------------------
-
-with LA14026_0;
-generic
- type data_type is private;
- type serial_type is range <>;
- serial_init : serial_type;
-package LA14026_1 is
-
- pragma Elaborate_Body;
-
- function get_serial_num return serial_type;
-
- type node_type is new LA14026_0.basic_rec with
- record
- data_field : data_type;
- serial_no : serial_type := get_serial_num;
- end record;
-end LA14026_1;
-
----------------------------------------------------------
-
-package body LA14026_1 is
- serial : serial_type := serial_init;
- function get_serial_num return serial_type is
- begin
- serial := serial + 1;
- return serial;
- end;
-end LA14026_1;
-
----------------------------------------------------------
-
-package LA14026_2 is
- subtype serial_type is integer range 0..5;
- subtype data_type is integer range 0..100;
-
- type data_rec is record
- F1 : data_type := data_type'first;
- F2 : data_type := data_type'last;
- end record;
-end LA14026_2;
diff --git a/gcc/testsuite/ada/acats/tests/l/la140261.a b/gcc/testsuite/ada/acats/tests/l/la140261.a
deleted file mode 100644
index 73cd334ed42..00000000000
--- a/gcc/testsuite/ada/acats/tests/l/la140261.a
+++ /dev/null
@@ -1,52 +0,0 @@
--- LA140261.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- See LA140262.AM.
---
--- TEST DESCRIPTION:
--- See LA140262.AM.
---
--- SPECIAL REQUIREMENTS:
--- See LA140262.AM.
---
--- TEST FILES:
--- This test consists of the following files:
--- LA140260.A
--- -> LA140261.A
--- LA140262.AM
--- LA140263.A
---
--- PASS/FAIL CRITERIA:
--- See LA140262.AM.
---
--- CHANGE HISTORY:
--- 07 DEC 96 SAIC ACVC 2.1: Initial version.
---
---!
-
-with LA14026_2, LA14026_1;
-package LA14026_3 is new LA14026_1 (LA14026_2.data_rec,
- LA14026_2.serial_type, 0);
diff --git a/gcc/testsuite/ada/acats/tests/l/la140263.a b/gcc/testsuite/ada/acats/tests/l/la140263.a
deleted file mode 100644
index c0224894d2d..00000000000
--- a/gcc/testsuite/ada/acats/tests/l/la140263.a
+++ /dev/null
@@ -1,57 +0,0 @@
--- LA140263.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- See LA140262.AM.
---
--- TEST DESCRIPTION:
--- See LA140262.AM.
---
--- SPECIAL REQUIREMENTS:
--- See LA140262.AM.
---
--- TEST FILES:
--- This test consists of the following files:
--- LA140260.A
--- LA140261.A
--- LA140262.AM
--- -> LA140263.A
---
--- PASS/FAIL CRITERIA:
--- See LA140262.AM.
---
--- CHANGE HISTORY:
--- 01 MAY 95 ACVC 1.12 LA5008W baseline version
--- 06 JUL 95 SAIC Initial version
--- 18 NOV 96 SAIC Modified unit names and prologue to conform
--- to coding conventions.
--- 07 DEC 96 SAIC Modified prologue to reflect new test
--- file organization.
---
---!
-
-with LA14026_2, LA14026_1;
-package LA14026_3 is new LA14026_1 (LA14026_2.data_rec,
- LA14026_2.serial_type, 3);
diff --git a/gcc/testsuite/ada/acats/tests/l/la140270.a b/gcc/testsuite/ada/acats/tests/l/la140270.a
deleted file mode 100644
index dab574cd682..00000000000
--- a/gcc/testsuite/ada/acats/tests/l/la140270.a
+++ /dev/null
@@ -1,56 +0,0 @@
--- LA140270.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- See LA140272.AM.
---
--- TEST DESCRIPTION:
--- See LA140272.AM.
---
--- SPECIAL REQUIREMENTS:
--- See LA140272.AM.
---
--- TEST FILES:
--- This test consists of the following files:
--- -> LA140270.A
--- LA140271.A
--- LA140272.AM
--- LA140273.A
---
--- PASS/FAIL CRITERIA:
--- See LA140272.AM.
---
--- CHANGE HISTORY:
--- 01 MAY 95 ACVC 1.12 LA5007O baseline version
--- 28 JUL 95 SAIC Initial version
--- 29 JAN 96 SAIC First revision after review
--- 18 NOV 96 SAIC Modified prologue to conform
--- to coding conventions.
---
---!
-
-package LA14027_0 is
- Sample_value : integer := 100;
-end LA14027_0;
diff --git a/gcc/testsuite/ada/acats/tests/l/la140271.a b/gcc/testsuite/ada/acats/tests/l/la140271.a
deleted file mode 100644
index 703b1b8aee1..00000000000
--- a/gcc/testsuite/ada/acats/tests/l/la140271.a
+++ /dev/null
@@ -1,93 +0,0 @@
--- LA140271.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- See LA140272.AM.
---
--- TEST DESCRIPTION:
--- See LA140272.AM.
---
--- SPECIAL REQUIREMENTS:
--- See LA140272.AM.
---
--- TEST FILES:
--- This test consists of the following files:
--- LA140270.A
--- -> LA140271.A
--- LA140272.AM
--- LA140273.A
---
--- PASS/FAIL CRITERIA:
--- See LA140272.AM.
---
--- CHANGE HISTORY:
--- 01 MAY 95 ACVC 1.12 LA5007O baseline version
--- 28 JUL 95 SAIC Initial version
--- 29 JAN 96 SAIC First revision after review
--- 18 NOV 96 SAIC Modified unit names and prologue to conform
--- to coding conventions. Removed loop from
--- task body to prevent hang.
---
---!
-
-package LA14027_1 is
- procedure Random (Number : out integer);
-end LA14027_1;
-
- --------------------------------------------
-
-package body LA14027_1 is
- task LA14027_2 is
- entry Get (Value : out integer);
- end LA14027_2;
-
- task body LA14027_2 is separate;
-
- procedure Random (Number : out integer) is
- begin
- -- get a random number from sampling task
- LA14027_2.Get (Number);
- -- massage it
- Number := Number + 10;
- -- and return it
- end;
-end LA14027_1;
-
- --------------------------------------------
-
-with LA14027_0; -- must resolve this
-
-separate (LA14027_1)
-
-task body LA14027_2 is
- begin
- select
- accept Get (Value : out integer) do
- -- sample some random physical process
- Value := LA14027_0.Sample_value;
- -- and return it
- end Get;
- end select;
-end LA14027_2;
diff --git a/gcc/testsuite/ada/acats/tests/l/la140273.a b/gcc/testsuite/ada/acats/tests/l/la140273.a
deleted file mode 100644
index 0e535f10c62..00000000000
--- a/gcc/testsuite/ada/acats/tests/l/la140273.a
+++ /dev/null
@@ -1,58 +0,0 @@
--- LA140273.A
---
--- Grant of Unlimited Rights
---
--- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--- unlimited rights in the software and documentation contained herein.
--- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
--- this public release, the Government intends to confer upon all
--- recipients unlimited rights equal to those held by the Government.
--- These rights include rights to use, duplicate, release or disclose the
--- released technical data and computer software in whole or in part, in
--- any manner and for any purpose whatsoever, and to have or permit others
--- to do so.
---
--- DISCLAIMER
---
--- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--- PARTICULAR PURPOSE OF SAID MATERIAL.
---*
---
--- OBJECTIVE:
--- See LA140272.AM.
---
--- TEST DESCRIPTION:
--- See LA140272.AM.
---
--- SPECIAL REQUIREMENTS:
--- See LA140272.AM.
---
--- TEST FILES:
--- This test consists of the following files:
--- LA140270.A
--- LA140271.A
--- LA140272.AM
--- -> LA140273.A
---
--- PASS/FAIL CRITERIA:
--- See LA140272.AM.
---
--- CHANGE HISTORY:
--- 01 MAY 95 ACVC 1.12 LA5007O baseline version
--- 28 JUL 95 SAIC Initial version
--- 29 JAN 96 SAIC First revision after review
--- 18 NOV 96 SAIC Modified prologue to conform
--- to coding conventions.
---
---!
-
-package LA14027_0 is
- New_var : integer := 100;
- Local_array : array (1..51) of integer;
- Sample_value : constant integer := -10;
-end LA14027_0;
diff --git a/gcc/testsuite/g++.dg/abi/layout2.C b/gcc/testsuite/g++.dg/abi/layout2.C
index fb4e1e5d9ff..d9ccda8a074 100644
--- a/gcc/testsuite/g++.dg/abi/layout2.C
+++ b/gcc/testsuite/g++.dg/abi/layout2.C
@@ -1,5 +1,7 @@
// Red Hat bugzilla 65210
// { dg-do run }
+// APPLE LOCAL Apple has specific long double warning message then FSF
+// { dg-options "-Wno-long-double" { target *-apple-darwin* } }
struct A {
int a;
diff --git a/gcc/testsuite/g++.dg/align-test-1.C b/gcc/testsuite/g++.dg/align-test-1.C
new file mode 100644
index 00000000000..e3df21d6d3b
--- /dev/null
+++ b/gcc/testsuite/g++.dg/align-test-1.C
@@ -0,0 +1,347 @@
+/* APPLE LOCAL file Macintosh alignment */
+
+/* { dg-do run } */
+/* { dg-options "-Wno-long-long" } */
+
+/*
+ * Macintosh compiler alignment test for C++.
+ * Fred Forsman
+ * Apple Computer, Inc.
+ * (C) 2000-2001.
+ * Last modified 2002-5-24.
+ */
+
+ /* Check whether we are testing GCC 3 or later. If so, it has a
+ different scheme for laying out classes: members of a derived
+ class can be laid out starting in the padding at the end of the
+ base class. */
+#ifdef __GNUC__
+#if __GNUC__ >= 3
+ #define GCC3 1
+#endif
+#endif
+
+#include <stdio.h>
+#include <stddef.h>
+#include <string.h>
+
+extern "C" void abort (void);
+
+#define Q(x) #x, x
+
+typedef unsigned char UINT8;
+typedef unsigned short UINT16;
+typedef unsigned long UINT32;
+
+static int bad_option = 0;
+static int flag_verbose = 0;
+static int nbr_failures = 0;
+
+/* === classes === */
+
+class C1 {
+ static const int f1 = 1;
+ UINT8 f2;
+};
+
+class C2 {
+ static int f1;
+ UINT8 f2;
+};
+
+class C3 {
+ public:
+ enum E1 {
+ f1 = 1
+ };
+ protected:
+ UINT8 f2;
+};
+
+class C4 {
+ UINT8 f1;
+ static const int f2 = 1;
+};
+
+class C5 {
+ UINT8 f2;
+ static int f1;
+};
+
+class C6 {
+ UINT8 f1;
+ enum E1 {
+ f2 = 1
+ };
+};
+
+class C7 {
+ /* empty base class */
+};
+
+#pragma options align=mac68k
+
+class C8 {
+ /* empty base class */
+};
+
+class C9: public C8 {
+ public:
+ UINT8 f1;
+};
+
+#pragma options align=reset
+
+/* What is offset of first field after an empty base class? */
+class C10: public C7 {
+ public:
+ UINT8 f1;
+};
+
+/* GCC3 starts layout of derived class in padding at end of base class. */
+class C11 {
+ public:
+ UINT32 f1;
+ UINT8 f2;
+};
+
+class C12: public C11 {
+ public:
+ UINT8 f3;
+};
+
+/* Check whether compiler will reorder members to take advantage of
+ padding. If the compiler did this (which it does not appear to
+ do), f3 and f4 in C14 would be reordered to take advantage of the
+ padding at the end of the base class. */
+class C13 {
+ public:
+ UINT32 f1;
+ UINT16 f2;
+};
+
+class C14: public C13 {
+ public:
+ UINT32 f3;
+ UINT16 f4;
+};
+
+/* Tests for double aligned base class */
+
+class C15 {
+ public:
+ double f1;
+ long f2;
+};
+
+class C16: public C15 {
+};
+
+class C17: public C15 {
+ public:
+ long f3;
+};
+
+class C18: public C16 {
+ public:
+ char f3;
+};
+
+class C19: public C17 {
+ public:
+ char f4;
+};
+
+/* Tests for alignment in class with v-table pointer */
+
+class C20 {
+ public:
+ double f1;
+ virtual void func1(void);
+};
+
+/* === vectors === */
+
+#ifdef __VEC__
+class VC1 {
+ public:
+ vector signed short f1;
+ UINT8 f2;
+};
+
+typedef struct VS1 {
+ VC1 f1;
+ UINT8 f2;
+} VS1;
+
+class VC2: public VC1 {
+ public:
+ UINT8 f1;
+};
+
+typedef struct VS2 {
+ UINT8 f1;
+ VC2 f2;
+ UINT8 f3;
+} VS2;
+
+class VC3 {
+ public:
+ vector signed short f1;
+ virtual void func1(void);
+};
+
+#endif
+
+/* === bools === */
+
+typedef struct B1 {
+ bool f1;
+ UINT8 f2;
+} B1;
+
+typedef struct B2 {
+ UINT8 f1;
+ bool f2;
+} B2;
+
+
+static void check(char * rec_name, int actual, int expected, char * comment)
+{
+ if (flag_verbose || (actual != expected)) {
+ printf("%-20s = %2d (%2d) ", rec_name, actual, expected);
+ if (actual != expected) {
+ printf("*** FAIL");
+ nbr_failures++;
+ } else
+ printf(" PASS");
+ printf(": %s\n", comment);
+ }
+}
+
+static void check_option(char *option)
+{
+ if (*option == '-') {
+ if (strcmp(option, "-v") == 0)
+ flag_verbose = 1;
+ else {
+ fprintf(stderr, "*** unrecognized option '%s'.\n", option);
+ bad_option = 1;
+ }
+ } else {
+ fprintf(stderr, "*** unrecognized option '%s'.\n", option);
+ bad_option = 1;
+ }
+}
+
+int main(int argc, char *argv[])
+{
+ int i;
+
+ for (i = 1; i < argc; i++)
+ check_option(argv[i]);
+
+ if (bad_option)
+ return 1;
+
+ check(Q(sizeof(C1)), 1, "const as 1st field");
+ check(Q(sizeof(C2)), 1, "static as 1st field");
+ check(Q(sizeof(C3)), 1, "enum as 1st field");
+ check(Q(sizeof(C4)), 1, "const as 2nd field");
+ check(Q(sizeof(C5)), 1, "static as 2nd field");
+ check(Q(sizeof(C6)), 1, "enum as 2nd field");
+ check(Q(sizeof(C7)), 1, "empty class, power mode");
+ check(Q(sizeof(C8)), 2, "empty class, mac68k mode");
+ check(Q(sizeof(C9)), 2, "class with empty base class and one char, mac68k");
+ check(Q(offsetof(C9, f1)), 0, "offset of 1st field after empty base class"); /* { dg-warning "invalid access" "" } */
+ /* { dg-warning "macro was used incorrectly" "" { target *-*-* } 256 } */
+ check(Q(sizeof(C10)), 1, "class based on an empty class, power mode");
+ check(Q(sizeof(C11)), 8, "class with long, char");
+#ifdef GCC3
+ check(Q(sizeof(C12)), 8, "class with base class with long, char and its own char");
+#else
+ check(Q(sizeof(C12)), 12, "class with base class with long, char and its own char");
+#endif
+#ifdef GCC3
+ check(Q(offsetof(C12, f3)), 5, "offset of 1st field in class with a base class with a long, char"); /* { dg-warning "invalid access" "" } */
+ /* { dg-warning "macro was used incorrectly" "" { target *-*-* } 266 } */
+#else
+ check(Q(offsetof(C12, f3)), 8, "offset of 1st field in class with a base class with a long, char");
+#endif
+ check(Q(sizeof(C13)), 8, "class with long, short");
+ check(Q(sizeof(C14)), 16, "derived class with short, long");
+ check(Q(offsetof(C14, f3)), 8, "offset of 1st field after base class with padding"); /* { dg-warning "invalid access" "" } */
+ /* { dg-warning "macro was used incorrectly" "" { target *-*-* } 273 } */
+ check(Q(offsetof(C14, f4)), 12, "offset of 2nd field after base class with padding"); /* { dg-warning "invalid access" "" } */
+ /* { dg-warning "macro was used incorrectly" "" { target *-*-* } 275 } */
+
+ check(Q(sizeof(C15)), 16, "base class with double, long");
+ check(Q(sizeof(C16)), 16, "empty derived class with base with double, long");
+#ifdef GCC3
+ check(Q(sizeof(C17)), 16, "derived class with base with double, long and its own long");
+#else
+ check(Q(sizeof(C17)), 24, "derived class with base with double, long and its own long");
+#endif
+#ifdef GCC3
+ check(Q(sizeof(C18)), 16, "derived class based on empty derived class with base with double, long");
+#else
+ check(Q(sizeof(C18)), 24, "derived class based on empty derived class with base with double, long");
+#endif
+#ifdef GCC3
+ check(Q(sizeof(C19)), 24, "derived class based on derived class with base with double, long and its own long");
+#else
+ check(Q(sizeof(C19)), 32, "derived class based on derived class with base with double, long and its own long");
+#endif
+#ifdef GCC3
+ check(Q(sizeof(C20)), 16, "class with double and v-table ptr");
+ check(Q(offsetof(C20, f1)), 8, "offset of double 1st field in class with v-table ptr"); /* { dg-warning "invalid access" "" } */
+ /* { dg-warning "macro was used incorrectly" "" { target *-*-* } 297 } */
+#else
+ check(Q(sizeof(C20)), 16, "class with double and v-table ptr");
+ check(Q(offsetof(C20, f1)), 0, "offset of 1st field in class with v-table ptr");
+#endif
+
+ /* Vector tests */
+#ifdef __VEC__
+ check(Q(sizeof(VC1)), 32, "class with vector as 1st field");
+ check(Q(sizeof(VS1)), 48, "struct with a class with a vector as 1st field");
+#ifdef GCC3
+ check(Q(sizeof(VC2)), 32, "class with base class containing a vector");
+#else
+ check(Q(sizeof(VC2)), 48, "class with base class containing a vector");
+#endif
+#ifdef GCC3
+ check(Q(offsetof(VC2, f1)), 17, "offset of 1st field after base class with vector, char, and padding");
+#else
+ check(Q(offsetof(VC2, f1)), 32, "offset of 1st field after base class with vector, char, and padding");
+#endif
+#ifdef GCC3
+ check(Q(sizeof(VS2)), 64, "struct with a char, class with a vector, char");
+#else
+ check(Q(sizeof(VS2)), 80, "struct with a char, class with a vector, char");
+#endif
+ check(Q(offsetof(VS2, f2)), 16, "offset of class with a vector in a struct with char, class...");
+#ifdef GCC3
+ check(Q(offsetof(VS2, f3)), 48, "offset of 2nd char in a struct with char, class, char");
+#else
+ check(Q(offsetof(VS2, f3)), 64, "offset of 2nd char in a struct with char, class, char");
+#endif
+#ifdef GCC3
+ check(Q(sizeof(VC3)), 32, "class with a vector and v-table ptr");
+ check(Q(offsetof(VC3, f1)), 16, "offset vector in class with a vector and v-table ptr");
+#else
+ check(Q(sizeof(VC3)), 32, "class with a vector and v-table ptr");
+ check(Q(offsetof(VC3, f1)), 0, "offset vector in class with a vector and v-table ptr");
+#endif
+#endif
+
+ /* bool tests */
+ check(Q(sizeof(bool)), 4, "bool data type");
+ check(Q(sizeof(B1)), 8, "struct with bool, char");
+ check(Q(sizeof(B2)), 8, "struct with char, bool");
+
+ if (nbr_failures > 0)
+ return 1;
+ else
+ return 0;
+}
diff --git a/gcc/testsuite/g++.dg/altivec-1.C b/gcc/testsuite/g++.dg/altivec-1.C
new file mode 100644
index 00000000000..6bda7094db0
--- /dev/null
+++ b/gcc/testsuite/g++.dg/altivec-1.C
@@ -0,0 +1,12 @@
+/* APPLE LOCAL file AltiVec */
+/* Test for static_cast<...> among AltiVec types. */
+/* { dg-do compile { target powerpc*-*-* } } */
+/* { dg-options "-faltivec" } */
+
+struct Foo2 {
+ vector unsigned int vui;
+ vector signed int As_vsi() {
+ return static_cast<vector signed int>(vui); /* { dg-bogus "invalid static_cast" } */
+ }
+};
+
diff --git a/gcc/testsuite/g++.dg/altivec-2.C b/gcc/testsuite/g++.dg/altivec-2.C
new file mode 100644
index 00000000000..0b2f3751a24
--- /dev/null
+++ b/gcc/testsuite/g++.dg/altivec-2.C
@@ -0,0 +1,15 @@
+/* APPLE LOCAL file AltiVec */
+/* Test for distinguishing 'vector bool ...' from 'vector unsigned ...'
+ types by the front-end. */
+/* { dg-do compile { target powerpc*-*-* } } */
+/* { dg-options "-faltivec" } */
+
+struct Foo1 {
+ void foo(vector unsigned char) { }
+ void foo(vector bool char) { } /* { dg-bogus "has already been declared" } */
+ void bar(vector unsigned short) { }
+ void bar(vector bool short) { } /* { dg-bogus "has already been declared" } */
+ void baz(vector unsigned int) { }
+ void baz(vector bool int) { } /* { dg-bogus "has already been declared" } */
+};
+
diff --git a/gcc/testsuite/g++.dg/altivec-3.C b/gcc/testsuite/g++.dg/altivec-3.C
new file mode 100644
index 00000000000..77084a1d824
--- /dev/null
+++ b/gcc/testsuite/g++.dg/altivec-3.C
@@ -0,0 +1,21 @@
+/* APPLE LOCAL file AltiVec */
+/* { dg-do run { target powerpc*-*-* } } */
+/* { dg-options "-faltivec -Wall" } */
+
+/* This test checks if AltiVec builtins accept const-qualified
+ arguments. */
+
+int main (int argc, const char * argv[])
+{
+ int i;
+ const float cf = 1.0;
+ vector float v;
+ const vector float cv = (vector float)(1.0, 2.0, 3.0, 4.0);
+
+ vec_dst(&cv, i, 0);
+ v = vec_ld(0, &cv);
+ v = vec_lde(0, &cf);
+ vec_lvsl(0, &cf);
+
+ return 0;
+}
diff --git a/gcc/testsuite/g++.dg/altivec-4.C b/gcc/testsuite/g++.dg/altivec-4.C
new file mode 100644
index 00000000000..1b33365408b
--- /dev/null
+++ b/gcc/testsuite/g++.dg/altivec-4.C
@@ -0,0 +1,129 @@
+/* APPLE LOCAL file AltiVec */
+/* { dg-do run { target powerpc*-*-* } } */
+/* { dg-options "-faltivec -Wno-long-double" } */
+
+/* Test for correct handling of AltiVec constants passed
+ through '...' (va_arg). */
+
+#include <stdarg.h>
+#include <stdio.h>
+#include <stdlib.h>
+
+#define CHECK_INVARIANT(expr) \
+ if (!(expr)) { \
+ printf ("ASSERT FAILED: %d: %s\n", __LINE__, #expr); \
+ abort (); \
+ }
+
+struct foo { int x; int y; };
+struct vfoo { int x; __vector signed int v; int y; };
+union u { __vector signed int v; signed int i[4]; };
+
+struct foo x_g = { 3, 4};
+struct vfoo vx_g = { 10, (vector signed int)(11, 12, 13, 14), 15 };
+__vector signed int v_g = (vector signed int) (22, 23, 24, 25);
+struct vfoo vx2_g = { 30, (vector signed int)(31, 32, 33, 34), 35 };
+__vector signed int v2_g = (vector signed int)(40, 41, 42, 43);
+int i_1 = 99, i_2 = 33;
+double d_2 = 1.5, d_3 = 1.75;
+long double ld_1 = 1.25;
+
+void bar (int i, ... )
+{
+ struct foo xi;
+ double d;
+ long double ld;
+ float f;
+ char c;
+ short s;
+ va_list ap;
+ va_start(ap, i);
+ xi = va_arg(ap, struct foo);
+ s = (short)va_arg(ap, int);
+ f = (float)va_arg(ap, double);
+ ld = va_arg(ap, long double);
+ c = (char)va_arg(ap, int);
+ d = va_arg(ap, double);
+ va_end(ap);
+
+ CHECK_INVARIANT (xi.x == x_g.x && xi.y == x_g.y);
+ CHECK_INVARIANT (s == (short)i_2);
+ CHECK_INVARIANT (f == (float)d_2);
+ CHECK_INVARIANT (ld == ld_1);
+ CHECK_INVARIANT (c == (char)i_1);
+ CHECK_INVARIANT (d == d_3);
+}
+
+void baz (int i, ... )
+{
+ struct vfoo vx, vx2;
+ __vector signed int v_i, v2_i;
+ int j, k, l;
+ va_list ap;
+ va_start(ap, i);
+ v_i = va_arg(ap, __vector signed int); /* { dg-bogus "non-POD type" } */
+ j = va_arg(ap, int);
+ vx = va_arg(ap, struct vfoo); /* { dg-bogus "non-POD type" } */
+ k = va_arg(ap, int);
+ v2_i = va_arg(ap, __vector signed int); /* { dg-bogus "non-POD type" } */
+ l = va_arg(ap, int);
+ vx2 = va_arg(ap, struct vfoo); /* { dg-bogus "non-POD type" } */
+ va_end(ap);
+
+ CHECK_INVARIANT (vec_all_eq (v_i, v_g));
+ CHECK_INVARIANT (j == i_1);
+ CHECK_INVARIANT (vx.x == vx_g.x && vec_all_eq(vx.v, vx_g.v) && vx.y == vx_g.y);
+ CHECK_INVARIANT (k == i_1);
+ CHECK_INVARIANT (vec_all_eq (v2_i, v2_g));
+ CHECK_INVARIANT (l == i_1);
+ CHECK_INVARIANT (vx2.x == vx2_g.x && vec_all_eq(vx2.v, vx2_g.v) && vx2.y == vx2_g.y);
+}
+
+void quux (int i, ... )
+{
+ __vector signed int v_i, v2_i;
+ union u vi, v2i;
+ va_list ap;
+ va_start(ap, i);
+ v_i = va_arg(ap, __vector signed int);
+ v2_i = va_arg(ap, __vector signed int);
+ va_end(ap);
+ vi.v = v_i;
+ v2i.v = v2_i;
+
+ CHECK_INVARIANT (vec_all_eq (v_i, v_g));
+ CHECK_INVARIANT (vec_all_eq (v2_i, v_g));
+ CHECK_INVARIANT (vec_all_eq (vi.v, v_g));
+ CHECK_INVARIANT (vec_all_eq (v2i.v, v_g));
+}
+
+void baz2 (int i, ... )
+{
+ struct vfoo vx;
+ union u vxi;
+ va_list ap;
+ va_start(ap, i);
+ vx = va_arg(ap, struct vfoo);
+ va_end(ap);
+ vxi.v = vx.v;
+
+ CHECK_INVARIANT (vx.x == vx_g.x && vec_all_eq(vx.v, vx_g.v) && vx.y == vx_g.y);
+ CHECK_INVARIANT (vec_all_eq (vxi.v, vx_g.v));
+}
+
+int main(void)
+{
+ CHECK_INVARIANT (sizeof(struct foo) == 8 && sizeof(struct vfoo) == 48);
+
+ bar(i_1, x_g, (short)i_2, (float)d_2, ld_1, (char)i_1, d_3);
+ baz(i_1, v_g, /* { dg-bogus "non-POD type" "" { target *-*-* } 122 } */
+ i_1, vx_g, /* { dg-bogus "non-POD type" "" { target *-*-* } 122 } */
+ i_1, v2_g, /* { dg-bogus "non-POD type" "" { target *-*-* } 122 } */
+ i_1, vx2_g); /* { dg-bogus "non-POD type" } */
+ quux(i_1, v_g, /* { dg-bogus "non-POD type" "" { target *-*-* } 124 } */
+ v_g); /* { dg-bogus "non-POD type" } */
+ baz2(i_1, vx_g); /* { dg-bogus "non-POD type" } */
+
+ return 0;
+}
+
diff --git a/gcc/testsuite/g++.dg/altivec-5.C b/gcc/testsuite/g++.dg/altivec-5.C
new file mode 100644
index 00000000000..4c5a21ad46f
--- /dev/null
+++ b/gcc/testsuite/g++.dg/altivec-5.C
@@ -0,0 +1,19 @@
+/* APPLE LOCAL file AltiVec */
+/* Test for AltiVec type overloading. */
+/* { dg-do compile { target powerpc*-*-* } } */
+/* { dg-options "-faltivec" } */
+ void foo(vector unsigned char) { }
+ void foo(vector signed char) { }
+ void foo(vector bool char) { }
+ void foo(vector unsigned short) { }
+ void foo(vector signed short) { }
+ void foo(vector bool short) { }
+ void foo(vector unsigned long) { }
+ void foo(vector signed long) { }
+ void foo(vector bool long) { }
+ void foo(vector float) { }
+ void foo(vector pixel) { }
+ void foo(int) { }
+ void foo(unsigned int) { }
+ void foo(float) { }
+ void foo(bool) { }
diff --git a/gcc/testsuite/g++.dg/apple-altivec-1.C b/gcc/testsuite/g++.dg/apple-altivec-1.C
new file mode 100644
index 00000000000..c070de43f6c
--- /dev/null
+++ b/gcc/testsuite/g++.dg/apple-altivec-1.C
@@ -0,0 +1,9 @@
+/* APPLE LOCAL file AltiVec */
+/* { dg-do compile { target powerpc*-*-* } } */
+/* { dg-options "-faltivec" } */
+
+void foo() {
+ vector bool int boolVector = (vector bool int) vec_splat_u32(3);
+ boolVector = vec_sld( boolVector, boolVector,
+ 1 ); /* { dg-bogus "no instance of overloaded" } */
+}
diff --git a/gcc/testsuite/g++.dg/charset/asm1.c b/gcc/testsuite/g++.dg/charset/asm1.c
deleted file mode 100644
index 9c0ff2866b0..00000000000
--- a/gcc/testsuite/g++.dg/charset/asm1.c
+++ /dev/null
@@ -1,14 +0,0 @@
-/* { dg-do compile { target *-*-* } }
- { dg-require-iconv "IBM-1047" }
- { dg-final { scan-assembler ".ascii bar" } }
- { dg-final { scan-assembler ".ascii foo" } }
- */
-extern int x, y;
-
-asm (".ascii bar");
-
-int foo (void)
-{
- __asm__ (".ascii foo");
- return 0;
-}
diff --git a/gcc/testsuite/g++.dg/charset/asm2.c b/gcc/testsuite/g++.dg/charset/asm2.c
deleted file mode 100644
index 8d8dbbb524d..00000000000
--- a/gcc/testsuite/g++.dg/charset/asm2.c
+++ /dev/null
@@ -1,33 +0,0 @@
-/* Test for complex asm statements. Make sure it compiles
- then test for some of the asm statements not being translated. */
-/* { dg-do compile { target i?86-*-* } }
- { dg-require-iconv "IBM-1047" }
- { dg-final { scan-assembler "std" } }
- { dg-final { scan-assembler "cld" } }
- { dg-final { scan-assembler "rep" } }
- { dg-final { scan-assembler "movsb" } } */
-#define size_t int
-void *
-memmove (void *__dest, __const void *__src, size_t __n)
-{
- register unsigned long int __d0, __d1, __d2;
- if (__dest < __src)
- __asm__ __volatile__
- ("cld\n\t"
- "rep\n\t"
- "movsb"
- : "=&c" (__d0), "=&S" (__d1), "=&D" (__d2)
- : "0" (__n), "1" (__src), "2" (__dest)
- : "memory");
- else
- __asm__ __volatile__
- ("std\n\t"
- "rep\n\t"
- "movsb\n\t"
- "cld"
- : "=&c" (__d0), "=&S" (__d1), "=&D" (__d2)
- : "0" (__n), "1" (__n - 1 + (const char *) __src),
- "2" (__n - 1 + (char *) __dest)
- : "memory");
- return __dest;
-}
diff --git a/gcc/testsuite/g++.dg/charset/asm3.c b/gcc/testsuite/g++.dg/charset/asm3.c
deleted file mode 100644
index cd850c3e81f..00000000000
--- a/gcc/testsuite/g++.dg/charset/asm3.c
+++ /dev/null
@@ -1,10 +0,0 @@
-/* Simple asm test. */
-/* { dg-do compile }
- { dg-require-iconv "IBM-1047" }
- { dg-final { scan-assembler "foo" } } */
-extern int bar;
-
-int main (void)
-{
- asm ("foo %0" : "=r" (bar));
-}
diff --git a/gcc/testsuite/g++.dg/charset/asm4.c b/gcc/testsuite/g++.dg/charset/asm4.c
deleted file mode 100644
index fa93f40fdaf..00000000000
--- a/gcc/testsuite/g++.dg/charset/asm4.c
+++ /dev/null
@@ -1,8 +0,0 @@
-/* Test for string translation. */
-/* { dg-do compile }
- { dg-require-iconv "IBM-1047" }
- { dg-final { scan-assembler-not "translate" } } */
-void foo (void)
-{
- asm ("xx" : : "r"("translate") : "cc");
-}
diff --git a/gcc/testsuite/g++.dg/charset/attribute1.c b/gcc/testsuite/g++.dg/charset/attribute1.c
deleted file mode 100644
index 993c7934c80..00000000000
--- a/gcc/testsuite/g++.dg/charset/attribute1.c
+++ /dev/null
@@ -1,10 +0,0 @@
-/* Test for attribute non-translation. */
-/* { dg-do compile }
- { dg-require-iconv "IBM-1047" }
- { dg-final { scan-assembler "foo" } } */
-int walrus __attribute__ ((section (".foo")));
-
-int main (void)
-{
- return 0;
-}
diff --git a/gcc/testsuite/g++.dg/charset/attribute2.c b/gcc/testsuite/g++.dg/charset/attribute2.c
deleted file mode 100644
index 3cb766aa63a..00000000000
--- a/gcc/testsuite/g++.dg/charset/attribute2.c
+++ /dev/null
@@ -1,8 +0,0 @@
-/* Test to make sure that invalid attributes aren't translated.
- If error recovery is ever testable then "foobar" should be
- translated. */
-/* { dg-do compile }
- { dg-require-iconv "IBM-1047" }
-*/
-int foo __attribute__ ((walrus)); /* { dg-error "walrus" "ignored" } */
-char x[] = "foobar";
diff --git a/gcc/testsuite/g++.dg/charset/extern1.cc b/gcc/testsuite/g++.dg/charset/extern1.cc
deleted file mode 100644
index 2a68ab7cf78..00000000000
--- a/gcc/testsuite/g++.dg/charset/extern1.cc
+++ /dev/null
@@ -1,15 +0,0 @@
-/* Test extern statments not being translated. */
-/* { dg-do compile }
- { dg-require-iconv "IBM-1047" }
-*/
-
-extern "C" {
-
-
-int testbug (void) {
-
- return 0;
-
-}
-
-} //extern block
diff --git a/gcc/testsuite/g++.dg/charset/extern2.cc b/gcc/testsuite/g++.dg/charset/extern2.cc
deleted file mode 100644
index 82157a6fea4..00000000000
--- a/gcc/testsuite/g++.dg/charset/extern2.cc
+++ /dev/null
@@ -1,5 +0,0 @@
-/* Check that we push the declaration and then continue translation. */
-/* { dg-do compile }
- { dg-require-iconv "IBM-1047" }
- { dg-final { scan-assembler-not "foobar" } } */
-extern "C" { char *foo = "foobar"; }
diff --git a/gcc/testsuite/g++.dg/charset/string.c b/gcc/testsuite/g++.dg/charset/string.c
deleted file mode 100644
index 375e28a2ed6..00000000000
--- a/gcc/testsuite/g++.dg/charset/string.c
+++ /dev/null
@@ -1,5 +0,0 @@
-/* Simple character translation test. */
-/* { dg-do compile }
- { dg-require-iconv "IBM-1047" }
- { dg-final { scan-assembler-not "string foobar" } } */
-char *foo = "string foobar";
diff --git a/gcc/testsuite/g++.dg/const-cfstring-1.C b/gcc/testsuite/g++.dg/const-cfstring-1.C
new file mode 100644
index 00000000000..ff1e2665540
--- /dev/null
+++ b/gcc/testsuite/g++.dg/const-cfstring-1.C
@@ -0,0 +1,26 @@
+/* APPLE LOCAL file constant cfstrings */
+/* Test whether the __builtin__CFStringMakeConstantString
+ "function" fails gracefully when handed a non-constant
+ argument. This will only work on MacOS X 10.1.2 and later. */
+/* Developed by Ziemowit Laski <zlaski@apple.com>. */
+
+/* { dg-do compile { target powerpc-apple-darwin* } } */
+/* { dg-options "-fconstant-cfstrings" } */
+
+#import <CoreFoundation/CFString.h>
+
+#ifdef __CONSTANT_CFSTRINGS__
+#undef CFSTR
+#define CFSTR(STR) ((CFStringRef) __builtin___CFStringMakeConstantString (STR))
+#endif
+
+extern int cond;
+extern const char *func(void);
+
+int main(void) {
+ CFStringRef s1 = CFSTR("Str1");
+ CFStringRef s2 = CFSTR(cond? "Str2": "Str3"); /* { dg-error "CFString literal expression not constant" } */
+ CFStringRef s3 = CFSTR(func()); /* { dg-error "CFString literal expression not constant" } */
+
+ return 0;
+}
diff --git a/gcc/testsuite/g++.dg/debug/debug8.C b/gcc/testsuite/g++.dg/debug/debug8.C
index 1f8a18ac8ac..4a4b55a190d 100644
--- a/gcc/testsuite/g++.dg/debug/debug8.C
+++ b/gcc/testsuite/g++.dg/debug/debug8.C
@@ -1,2 +1,27 @@
-struct t{};
-struct g : public t{};
+// Check -gstabs
+// Contributed by Devang Patel dpatel@apple.com
+// { dg-do compile }
+class LcBase
+{
+public:
+ virtual ~LcBase();
+protected:
+ LcBase();
+};
+
+class LcDerive : public LcBase
+{
+public:
+ LcDerive();
+ ~LcDerive();
+};
+
+LcDerive::LcDerive()
+: LcBase()
+{
+}
+
+LcDerive::~LcDerive()
+{
+}
+
diff --git a/gcc/testsuite/g++.dg/eh/spec7.C b/gcc/testsuite/g++.dg/eh/spec7.C
deleted file mode 100644
index 08586a2af75..00000000000
--- a/gcc/testsuite/g++.dg/eh/spec7.C
+++ /dev/null
@@ -1,35 +0,0 @@
-// PR 14535
-// { dg-do run }
-// { dg-options "-O -finline" }
-//
-// Original test case failure required that Raiser constructor be inlined.
-
-extern "C" void abort();
-bool destructor_called = false;
-
-struct B {
- virtual void Run(){};
-};
-
-struct D : public B {
- virtual void Run()
- {
- struct O {
- ~O() { destructor_called = true; };
- } o;
-
- struct Raiser {
- Raiser() throw( int ) {throw 1;};
- } raiser;
- };
-};
-
-int main() {
- try {
- D d;
- static_cast<B&>(d).Run();
- } catch (...) {}
-
- if (!destructor_called)
- abort ();
-}
diff --git a/gcc/testsuite/g++.dg/expr/align68k-1.C b/gcc/testsuite/g++.dg/expr/align68k-1.C
new file mode 100644
index 00000000000..80ce93039f2
--- /dev/null
+++ b/gcc/testsuite/g++.dg/expr/align68k-1.C
@@ -0,0 +1,46 @@
+// APPLE LOCAL file test of -mdynamic-no-pic combined with 68k alignment
+// Radar 3242139: Positive C++ test case
+// Origin: Matt Austern <austern@apple.com>
+// { dg-do run }
+// { dg-options "-mdynamic-no-pic" }
+
+const long val1 = 0xa0b0;
+const long val2 = 0x1234;
+
+#pragma options align=mac68k
+struct X {
+ long x1;
+ long x2;
+};
+
+#pragma options align=reset
+
+void setX(X* x) {
+ x->x1 = val1;
+ x->x2 = val2;
+}
+
+struct Y
+{
+ X field;
+ void set_vals();
+};
+
+void Y::set_vals()
+{
+ ::setX(&field);
+}
+
+int main()
+{
+ Y y;
+ bool ok = true;
+
+ y.field.x1 = y.field.x2 = 0;
+ ok = ok && y.field.x1 == 0 && y.field.x2 == 0;
+
+ y.set_vals();
+ ok = ok && y.field.x1 == val1 && y.field.x2 == val2;
+
+ return !ok;
+}
diff --git a/gcc/testsuite/g++.dg/expr/align68k-2.C b/gcc/testsuite/g++.dg/expr/align68k-2.C
new file mode 100644
index 00000000000..4070bcdc0ff
--- /dev/null
+++ b/gcc/testsuite/g++.dg/expr/align68k-2.C
@@ -0,0 +1,38 @@
+// APPLE LOCAL file test 68k alignment
+// Radar 3313261: Positive C++ test case
+// Origin: Matt Austern <austern@apple.com>
+// { dg-do run }
+
+#pragma options align=mac68k
+
+typedef struct PMR {
+ double x;
+ double y;
+}PMR;
+
+#pragma options align=reset
+
+static void GetDouble(double *doubleP)
+{
+ *doubleP = 1.;
+}
+
+static void GetPMR(PMR *p)
+{
+ GetDouble(&p->x);
+ GetDouble(&p->y);
+}
+
+int main(void)
+{
+ PMR tmp;
+ bool ok = true;
+
+ tmp.x = tmp.y = 0;
+ ok = ok && tmp.x == 0.0 && tmp.y == 0.0;
+
+ GetPMR(&tmp);
+ ok = ok && tmp.x == 1.0 && tmp.y == 1.0;
+
+ return !ok;
+}
diff --git a/gcc/testsuite/g++.dg/expr/cast-ptr-1.C b/gcc/testsuite/g++.dg/expr/cast-ptr-1.C
new file mode 100644
index 00000000000..cb42d13ac48
--- /dev/null
+++ b/gcc/testsuite/g++.dg/expr/cast-ptr-1.C
@@ -0,0 +1,15 @@
+/* APPLE LOCAL file pointer casts */
+/* Test that casts of pointer to unsigned long long aren't sign extended */
+/* Author: Matt Austern <austern@apple.com> */
+/* { dg-do run } */
+/* { dg-options "-Wno-error -w" } */
+
+int main () {
+ /* Note: test assumes sizeof(long long) >= sizeof(void*) */
+
+ unsigned long x1 = 0x80000000ul;
+ void* p = (void*) x1;
+ unsigned long long x2 = (unsigned long long) p;
+
+ return !(x1 == x2);
+}
diff --git a/gcc/testsuite/g++.dg/expr/fieldref1.C b/gcc/testsuite/g++.dg/expr/fieldref1.C
new file mode 100644
index 00000000000..b04ed137548
--- /dev/null
+++ b/gcc/testsuite/g++.dg/expr/fieldref1.C
@@ -0,0 +1,23 @@
+// APPLE LOCAL file - test of access to 8-byte struct field
+// Radar 3309305: positive C++ test case
+// Origin: Matt Austern <austern@apple.com>
+// { dg-do run }
+
+struct X {
+ char array[8];
+};
+
+char* get_array(X* p) {
+ char* p2 = p->array;
+ return p2;
+}
+
+int main()
+{
+ X t;
+ X* p = &t;
+ char* p2 = get_array(p);
+
+ bool ok = (void*)p == (void*)p2;
+ return !ok;
+}
diff --git a/gcc/testsuite/g++.dg/ext/anon-struct4.C b/gcc/testsuite/g++.dg/ext/anon-struct4.C
deleted file mode 100644
index f0b3b57f70d..00000000000
--- a/gcc/testsuite/g++.dg/ext/anon-struct4.C
+++ /dev/null
@@ -1,3 +0,0 @@
-// PR c++/14401
-
-struct { struct { int& i ; } bar ; } foo ; // { dg-error "" }
diff --git a/gcc/testsuite/g++.dg/ext/attrib14.C b/gcc/testsuite/g++.dg/ext/attrib14.C
deleted file mode 100644
index 3a819e01d82..00000000000
--- a/gcc/testsuite/g++.dg/ext/attrib14.C
+++ /dev/null
@@ -1,13 +0,0 @@
-// PR c++/13170
-// The bogus attribute is ignored, but was in TYPE_ATTRIBUTES during
-// parsing of the class, causing some variants to have it and some not.
-
-struct __attribute__((bogus)) A
-{
- virtual ~A();
- void foo(const A&);
- void bar(const A&);
-}; // { dg-warning "ignored" "" }
-
-void A::foo(const A&) {}
-void A::bar(const A& a) { foo(a); }
diff --git a/gcc/testsuite/g++.dg/init/ctor3.C b/gcc/testsuite/g++.dg/init/ctor3.C
deleted file mode 100644
index 1678aaf2c4d..00000000000
--- a/gcc/testsuite/g++.dg/init/ctor3.C
+++ /dev/null
@@ -1,6 +0,0 @@
-// PR c++/14401
-
-struct S {
- S() {} // { dg-error "" }
- const int i;
-};
diff --git a/gcc/testsuite/g++.dg/init/ref11.C b/gcc/testsuite/g++.dg/init/ref11.C
deleted file mode 100644
index b283e3a69be..00000000000
--- a/gcc/testsuite/g++.dg/init/ref11.C
+++ /dev/null
@@ -1,13 +0,0 @@
-// PR c++/14230
-
-struct A {
- A ();
- A (const A&);
- A& operator= (const A&);
-};
-
-struct D {
- A a;
-};
-
-const A& z = D().a;
diff --git a/gcc/testsuite/g++.dg/init/union1.C b/gcc/testsuite/g++.dg/init/union1.C
deleted file mode 100644
index 0049f442916..00000000000
--- a/gcc/testsuite/g++.dg/init/union1.C
+++ /dev/null
@@ -1,5 +0,0 @@
-// PR c++/14401
-
-union U {
- int& i; // { dg-error "" }
-};
diff --git a/gcc/testsuite/g++.dg/kext1.C b/gcc/testsuite/g++.dg/kext1.C
new file mode 100644
index 00000000000..174ec027259
--- /dev/null
+++ b/gcc/testsuite/g++.dg/kext1.C
@@ -0,0 +1,11 @@
+/* APPLE LOCAL file -findirect-virtual-calls 15 Oct 2002 */
+/* Radar 3008388: Positive C++ test case. */
+/* Origin: Matt Austern <austern@apple.com> */
+/* { dg-do compile } */
+/* { dg-options "-fapple-kext" } */
+
+struct B1 { }; /* ok */
+struct B2 { }; /* ok */
+struct D1 : B1 { }; /* ok */
+struct D2 : B1, B2 { }; /* ok */
+struct D3 : virtual B1 { }; /* ok */
diff --git a/gcc/testsuite/g++.dg/kext2.C b/gcc/testsuite/g++.dg/kext2.C
new file mode 100644
index 00000000000..f2f2a9514bd
--- /dev/null
+++ b/gcc/testsuite/g++.dg/kext2.C
@@ -0,0 +1,13 @@
+/* APPLE LOCAL file -findirect-virtual-calls 15 Oct 2002 */
+/* Radar 3008388: Positive C++ test case. */
+/* Origin: Matt Austern <austern@apple.com> */
+/* { dg-do compile } */
+/* { dg-options "-fapple-kext" } */
+
+struct B1 { virtual ~B1(); virtual void f(); }; /* ok */
+struct D1 : B1 { }; /* ok */
+struct X1 : D1 { virtual void f(); }; /* ok */
+
+void X1::f() { D1::f(); } /* ok */
+
+
diff --git a/gcc/testsuite/g++.dg/kext3.C b/gcc/testsuite/g++.dg/kext3.C
new file mode 100644
index 00000000000..7d9efbd8cf1
--- /dev/null
+++ b/gcc/testsuite/g++.dg/kext3.C
@@ -0,0 +1,18 @@
+/* APPLE LOCAL file -findirect-virtual-calls 15 Oct 2002 */
+/* Radar 3008388: Negative C++ test case. */
+/* Origin: Matt Austern <austern@apple.com> */
+/* { dg-do compile } */
+/* { dg-options "-fapple-kext" } */
+
+struct B1 { virtual ~B1(); virtual void f(); }; /* ok */
+struct D1 : B1 { }; /* ok */
+struct D2 { }; /* ok */
+
+struct X1 : D1, D2 { }; /* ok */
+struct X2 : virtual D1 { }; /* ok */
+
+struct Y1 : X1 { virtual void f(); }; /* ok */
+struct Y2 : X2 { virtual void f(); }; /* ok */
+
+void Y1::f() { X1::f(); } /* { dg-error "indirect virtual" } */
+void Y2::f() { X2::f(); } /* { dg-error "indirect virtual" } */
diff --git a/gcc/testsuite/g++.dg/lookup/enum1.C b/gcc/testsuite/g++.dg/lookup/enum1.C
deleted file mode 100644
index 9422814e271..00000000000
--- a/gcc/testsuite/g++.dg/lookup/enum1.C
+++ /dev/null
@@ -1,5 +0,0 @@
-// PR c++/14476
-
-struct tree_common {
- enum tree_code code : 8; // { dg-error "" }
-};
diff --git a/gcc/testsuite/g++.dg/lookup/struct2.C b/gcc/testsuite/g++.dg/lookup/struct2.C
deleted file mode 100644
index a66f403c291..00000000000
--- a/gcc/testsuite/g++.dg/lookup/struct2.C
+++ /dev/null
@@ -1,7 +0,0 @@
-// PR c++/14510
-
-struct c {};
-namespace A {
- int c(struct c*req);
-}
-int A::c(struct c*req) {}
diff --git a/gcc/testsuite/g++.dg/opt/eh1.C b/gcc/testsuite/g++.dg/opt/eh1.C
deleted file mode 100644
index 63a4d2ef35f..00000000000
--- a/gcc/testsuite/g++.dg/opt/eh1.C
+++ /dev/null
@@ -1,21 +0,0 @@
-// PR middle-end/14477
-// { dg-do compile }
-// { dg-options "-O2 -fno-default-inline" }
-
-struct A
-{
- A();
-};
-
-struct B
-{
- B(const A*);
-};
-
-struct C
-{
- B b;
- C(int) : b(new A) {}
-};
-
-C c(0);
diff --git a/gcc/testsuite/g++.dg/overload/ref1.C b/gcc/testsuite/g++.dg/overload/ref1.C
deleted file mode 100644
index e239d88a438..00000000000
--- a/gcc/testsuite/g++.dg/overload/ref1.C
+++ /dev/null
@@ -1,21 +0,0 @@
-// Copyright (C) 2004 Free Software Foundation, Inc.
-// Contributed by Nathan Sidwell 5 Mar 2004 <nathan@codesourcery.com>
-
-// Origin: schmid@snake.iap.physik.tu-darmstadt.de
-// Bug 14397: Bogus access error.
-
-struct S {
- S (int);
- S(S const&);
- private:
- S(S&);
-};
-
-S foo()
-{
- int result = 0;
-
- S s ((0,S (result)));
-
- return S (result);
-}
diff --git a/gcc/testsuite/g++.dg/parse/builtin2.C b/gcc/testsuite/g++.dg/parse/builtin2.C
deleted file mode 100644
index c524ea68416..00000000000
--- a/gcc/testsuite/g++.dg/parse/builtin2.C
+++ /dev/null
@@ -1,5 +0,0 @@
-// PR c++/14432
-// { dg-options "" }
-
-struct Y {};
-Y y1;
diff --git a/gcc/testsuite/g++.dg/parse/crash14.C b/gcc/testsuite/g++.dg/parse/crash14.C
deleted file mode 100644
index b4cf49a9921..00000000000
--- a/gcc/testsuite/g++.dg/parse/crash14.C
+++ /dev/null
@@ -1,20 +0,0 @@
-// { dg-do compile }
-// Contributed by: Giovanni Bajo <giovannibajo at libero dot it>
-// PR c++/14448: Fold constant initializers in templates
-
-template <int> struct A
-{
- A();
-};
-
-
-template<typename T> void foo(T)
-{
- static const int n=1+1;
- A<n+1> a;
-}
-
-void bar()
-{
- foo(0);
-}
diff --git a/gcc/testsuite/g++.dg/parse/non-dependent3.C b/gcc/testsuite/g++.dg/parse/non-dependent3.C
deleted file mode 100644
index 9dfb99636a8..00000000000
--- a/gcc/testsuite/g++.dg/parse/non-dependent3.C
+++ /dev/null
@@ -1,17 +0,0 @@
-// PR c++/14586
-
-enum E { e };
-
-E & operator |= (E &f1, const E &f2);
-
-E operator | (const E &f1, const E &f2) {
- E result = f1;
- result |= f2;
- return result;
-}
-
-template <typename> void foo () {
- const E flags = e | e;
-}
-
-template void foo<double> ();
diff --git a/gcc/testsuite/g++.dg/parse/template14.C b/gcc/testsuite/g++.dg/parse/template14.C
deleted file mode 100644
index ada87524352..00000000000
--- a/gcc/testsuite/g++.dg/parse/template14.C
+++ /dev/null
@@ -1,17 +0,0 @@
-// PR c++/14550
-
-struct A {
- A();
-};
-
-template <int> void foo()
-{
- A *p = new A;
-}
-
-void bar()
-{
- foo<0>();
-}
-
-
diff --git a/gcc/testsuite/g++.dg/pascal-strings-1.C b/gcc/testsuite/g++.dg/pascal-strings-1.C
new file mode 100644
index 00000000000..ca95ee9c10b
--- /dev/null
+++ b/gcc/testsuite/g++.dg/pascal-strings-1.C
@@ -0,0 +1,44 @@
+/* APPLE LOCAL file Pascal strings 2001-07-05 zll */
+/* Positive C++ test cases. */
+/* Origin: Ziemowit Laski <zlaski@apple.com> */
+/* { dg-do run } */
+/* { dg-options "-fpascal-strings" } */
+
+typedef __SIZE_TYPE__ size_t;
+extern "C" void abort (void);
+extern "C" size_t strlen (const char *s);
+
+const unsigned char *pascalStr1 = "\pHello, World!";
+const unsigned char *concat1 = "\pConcatenated" "string" "\pliteral";
+
+const unsigned char msg1[] = "\pHello"; /* ok */
+const unsigned char *msg2 = "\pHello"; /* ok */
+const signed char msg3[] = "\pHello"; /* ok */
+const char msg4[] = "\pHello"; /* ok */
+unsigned char msg5[] = "\pHello"; /* ok */
+signed char msg7[] = "\pHello"; /* ok */
+char msg8[] = "\pHello"; /* ok */
+
+int
+main (void)
+{
+ const unsigned char *pascalStr2 = "\pGood-bye!";
+
+ if (strlen ((const char *)pascalStr1) != 14)
+ abort ();
+ if (*pascalStr1 != 13)
+ abort (); /* the length byte does not include trailing null */
+
+ if (strlen ((const char *)pascalStr2) != 10)
+ abort ();
+ if (*pascalStr2 != 9)
+ abort ();
+
+ if (strlen ((const char *)concat1) != 26)
+ abort ();
+ if (*concat1 != 25)
+ abort ();
+
+ return 0;
+}
+
diff --git a/gcc/testsuite/g++.dg/pascal-strings-2.C b/gcc/testsuite/g++.dg/pascal-strings-2.C
new file mode 100644
index 00000000000..619e112c184
--- /dev/null
+++ b/gcc/testsuite/g++.dg/pascal-strings-2.C
@@ -0,0 +1,43 @@
+/* APPLE LOCAL file Pascal strings 2001-07-05 zll */
+/* Negative C++ test cases. */
+/* Origin: Ziemowit Laski <zlaski@apple.com> */
+/* { dg-do compile } */
+/* { dg-options "-fpascal-strings" } */
+
+const wchar_t *pascalStr1 = L"\pHi!"; /* { dg-error "not allowed in wide" } */
+const wchar_t *pascalStr2 = L"Bye\p!"; /* { dg-error "not allowed in wide" } */
+
+const wchar_t *initErr0 = "\pHi"; /* { dg-error "cannot convert" } */
+const wchar_t initErr0a[] = "\pHi"; /* { dg-error "initialized from non-wide string" } */
+const wchar_t *initErr1 = "Bye"; /* { dg-error "cannot convert" } */
+const wchar_t initErr1a[] = "Bye"; /* { dg-error "initialized from non-wide string" } */
+
+const char *initErr2 = L"Hi"; /* { dg-error "cannot convert" } */
+const char initErr2a[] = L"Hi"; /* { dg-error "initialized from wide string" } */
+const signed char *initErr3 = L"Hi"; /* { dg-error "cannot convert" } */
+const signed char initErr3a[] = L"Hi"; /* { dg-error "initialized from wide string" } */
+const unsigned char *initErr4 = L"Hi"; /* { dg-error "cannot convert" } */
+const unsigned char initErr4a[] = L"Hi"; /* { dg-error "initialized from wide string" } */
+
+const char *pascalStr3 = "Hello\p, World!"; /* { dg-error "must be at beginning" } */
+
+const char *concat2 = "Hi" "\pthere"; /* { dg-error "not allowed in concatenation" } */
+const char *concat3 = "Hi" "there\p"; /* { dg-error "must be at beginning" } */
+
+const char *s2 = "\pGoodbye!"; /* { dg-error "cannot convert" } */
+unsigned char *s3 = "\pHi!"; /* { dg-error "cannot convert" } */
+char *s4 = "\pHi"; /* { dg-error "cannot convert" } */
+signed char *s5 = "\pHi"; /* { dg-error "cannot convert" } */
+const signed char *s6 = "\pHi"; /* { dg-error "cannot convert" } */
+
+/* the maximum length of a Pascal literal is 255. */
+const unsigned char *almostTooLong =
+ "\p12345678901234567890123456789012345678901234567890123456789012345678901234567890"
+ "12345678901234567890123456789012345678901234567890123456789012345678901234567890"
+ "12345678901234567890123456789012345678901234567890123456789012345678901234567890"
+ "123456789012345"; /* ok */
+const unsigned char *definitelyTooLong =
+ "\p12345678901234567890123456789012345678901234567890123456789012345678901234567890"
+ "12345678901234567890123456789012345678901234567890123456789012345678901234567890"
+ "12345678901234567890123456789012345678901234567890123456789012345678901234567890"
+ "1234567890123456"; /* { dg-error "too long" } */
diff --git a/gcc/testsuite/g++.dg/preserve-PPC-CR.C b/gcc/testsuite/g++.dg/preserve-PPC-CR.C
new file mode 100644
index 00000000000..55409ba0111
--- /dev/null
+++ b/gcc/testsuite/g++.dg/preserve-PPC-CR.C
@@ -0,0 +1,41 @@
+// APPLE LOCAL preserve CR2 for save_world prologues
+// This testcase failed at -O2 due to a missing EH note describing the PowerPC Condition Register.
+// Thanks to Dale Johannesen.
+
+// { dg-do run }
+// { dg-options "-fpascal-strings" }
+#include <stdlib.h>
+#include <stdio.h>
+int tick = 1;
+int caught_x = 1;
+int h() { return 2; }
+void f()
+{ throw(3); }
+extern int h();
+void ff() {
+ bool xx = h() == 0;
+ if ( !xx ) {
+ try {
+ f();
+ } catch (float f) {
+ if (!xx) printf("%f\n", f);
+ }
+ }
+}
+int g(int y)
+{
+ bool x = h() != 0;
+ if ( x) {
+ try {
+ ff();
+ } catch (int ex) {
+ // if (x) printf("%d\n", ex);
+ if (x) { tick++; caught_x = ex; }
+ }}
+}
+main()
+{
+ g(3);
+ if (tick != 2 || caught_x != 3)
+ abort();
+}
diff --git a/gcc/testsuite/g++.dg/template/spec12.C b/gcc/testsuite/g++.dg/template/spec12.C
deleted file mode 100644
index 7cf2e2f0aa2..00000000000
--- a/gcc/testsuite/g++.dg/template/spec12.C
+++ /dev/null
@@ -1,18 +0,0 @@
-// { dg-do compile }
-// Contributed by: Wolfgang Bangerth <bangerth at dealii dot org>
-// PR c++/14409: Accepts invalid function signature for explicit instantiation
-
-struct X
-{
- template <typename U>
- void foo (U) {}
-
- template <typename U>
- void foo_const (U) const {}
-};
-
-template void X::foo (int);
-template void X::foo_const (int) const;
-
-template void X::foo (int) const; // { dg-error "" }
-template void X::foo_const (int); // { dg-error "" }
diff --git a/gcc/testsuite/g++.dg/warn/Wunused-7.C b/gcc/testsuite/g++.dg/warn/Wunused-7.C
deleted file mode 100644
index 4281bc81569..00000000000
--- a/gcc/testsuite/g++.dg/warn/Wunused-7.C
+++ /dev/null
@@ -1,12 +0,0 @@
-// PR c++/14481
-// { dg-options "-Wunused" }
-
-void func()
-{
- struct mybitfields {
- unsigned int s_field:8;
- };
- struct mybitfields s;
- s.s_field = 255;
-};
-
diff --git a/gcc/testsuite/g++.old-deja/g++.pt/static3.C b/gcc/testsuite/g++.old-deja/g++.pt/static3.C
index 6688d23cda5..650b7c02cf1 100644
--- a/gcc/testsuite/g++.old-deja/g++.pt/static3.C
+++ b/gcc/testsuite/g++.old-deja/g++.pt/static3.C
@@ -1,4 +1,4 @@
-// { dg-do run { xfail *-*-aout *-*-coff *-*-hpux* *-*-hms } }
+// { dg-do run { xfail *-*-aout *-*-coff *-*-hpux* *-*-hms *-*-darwin* } }
// On targets that don't support weak symbols, we require an explicit
// instantiation of arr.
diff --git a/gcc/testsuite/gcc.apple/Wextra-tokens.c b/gcc/testsuite/gcc.apple/Wextra-tokens.c
new file mode 100644
index 00000000000..08b3cb7745c
--- /dev/null
+++ b/gcc/testsuite/gcc.apple/Wextra-tokens.c
@@ -0,0 +1,21 @@
+/* APPLE LOCAL file -Wextra-tokens */
+/* Lifted from gcc.dg/cpp/extratokens2.c. */
+/* Copyright (C) 2002 Free Software Foundation, Inc. */
+
+/* { dg-do preprocess } */
+/* { dg-options "-fno-show-column -Wextra-tokens" } */
+
+/* Tests that -Wextra-tokens correctly enables the checks
+ that are disabled by default. */
+
+#if 1
+#if 0
+#else foo /* { dg-warning "extra tokens" "bad warning" } */
+#endif / /* { dg-warning "extra tokens" "bad warning" } */
+#endif
+
+# 36 "file.c" 3
+
+/* ... but in a system header, it's acceptable. */
+#ifdef KERNEL
+#endif KERNEL /* { dg-bogus "extra tokens" "bad warning" } */
diff --git a/gcc/testsuite/gcc.apple/Wfour-char-constants-1.c b/gcc/testsuite/gcc.apple/Wfour-char-constants-1.c
new file mode 100644
index 00000000000..536396454b7
--- /dev/null
+++ b/gcc/testsuite/gcc.apple/Wfour-char-constants-1.c
@@ -0,0 +1,12 @@
+/* APPLE LOCAL file -Wfour-char-constants */
+/* We warn by default on Darwin, so no specific option needed. */
+
+/* { dg-do compile { target "*-*-darwin*" } } */
+/* { dg-options "" } */
+
+int glob1 = 'a';
+int glob2 = 'ab'; /* { dg-warning "multi-character character constant" } */
+int glob3 = 'abc'; /* { dg-warning "multi-character character constant" } */
+int glob4 = 'abcd'; /* say nothing */
+int glob5 = 'abcde'; /* { dg-warning "character constant too long" } */
+
diff --git a/gcc/testsuite/gcc.apple/Wfour-char-constants-2.c b/gcc/testsuite/gcc.apple/Wfour-char-constants-2.c
new file mode 100644
index 00000000000..14115ba6fea
--- /dev/null
+++ b/gcc/testsuite/gcc.apple/Wfour-char-constants-2.c
@@ -0,0 +1,12 @@
+/* APPLE LOCAL file -Wfour-char-constants */
+/* Explicitly enable the warning. */
+
+/* { dg-do compile } */
+/* { dg-options "-Wfour-char-constants" } */
+
+int glob1 = 'a';
+int glob2 = 'ab'; /* { dg-warning "multi-character character constant" } */
+int glob3 = 'abc'; /* { dg-warning "multi-character character constant" } */
+int glob4 = 'abcd'; /* { dg-warning "multi-character character constant" } */
+int glob5 = 'abcde'; /* { dg-warning "character constant too long" } */
+
diff --git a/gcc/testsuite/gcc.apple/Wlong-double.c b/gcc/testsuite/gcc.apple/Wlong-double.c
new file mode 100644
index 00000000000..2a42912b660
--- /dev/null
+++ b/gcc/testsuite/gcc.apple/Wlong-double.c
@@ -0,0 +1,11 @@
+/* APPLE LOCAL file -Wlong-double */
+
+/* We warn by default, so no specific option needed. */
+
+/* { dg-do compile { target "*-*-darwin*" } } */
+/* { dg-options "" } */
+
+long double ld; /* { dg-warning "use of `long double' type" } */
+/* { dg-warning "is reported only once" "" { target *-*-* } 8 } */
+/* { dg-warning "disable this warning" "" { target *-*-* } 8 } */
+
diff --git a/gcc/testsuite/gcc.apple/Wmost.c b/gcc/testsuite/gcc.apple/Wmost.c
new file mode 100644
index 00000000000..6e1d3342539
--- /dev/null
+++ b/gcc/testsuite/gcc.apple/Wmost.c
@@ -0,0 +1,19 @@
+/* APPLE LOCAL file -Wmost */
+
+/* { dg-do compile } */
+/* { dg-options "-Wmost" } */
+
+int baz (void);
+
+int
+foo ()
+{
+ int loc;
+
+ bar (); /* { dg-warning "implicit declaration" } */
+
+ if (loc = baz ()) /* be quiet about this */
+ return 1;
+ return 0;
+}
+
diff --git a/gcc/testsuite/gcc.apple/align-test-1.c b/gcc/testsuite/gcc.apple/align-test-1.c
new file mode 100644
index 00000000000..f9bdb7b2c21
--- /dev/null
+++ b/gcc/testsuite/gcc.apple/align-test-1.c
@@ -0,0 +1,605 @@
+/* APPLE LOCAL file Macintosh alignment */
+
+/* { dg-do run } */
+/* { dg-options "-Wno-long-long" } */
+
+/*
+ * Macintosh compiler alignment test for C.
+ * Fred Forsman
+ * Apple Computer, Inc.
+ * (C) 2000-2002.
+ * Last modified 2002-4-29
+ */
+
+#include <stdio.h>
+#include <stddef.h>
+#include <string.h>
+
+#define Q(x) #x, x
+
+typedef unsigned char UINT8;
+
+static int bad_option = 0;
+static int flag_verbose = 0;
+static int nbr_failures = 0;
+
+/* === basic types === */
+
+typedef struct B1 {
+ char f1;
+ UINT8 f2;
+} B1;
+
+typedef struct B2 {
+ short f1;
+ UINT8 f2;
+} B2;
+
+typedef struct B3 {
+ long f1;
+ UINT8 f2;
+} B3;
+
+typedef struct B4 {
+ int f1;
+ UINT8 f2;
+} B4;
+
+typedef struct B5 {
+ float f1;
+ UINT8 f2;
+} B5;
+
+/* doubles, long longs, and vectors are treated separately below. */
+
+/* === enums === */
+
+typedef enum E1 {
+ e1_b = 0,
+ e1_e = 255
+} E1;
+
+typedef enum E2 {
+ e2_b = -256,
+ e2_e = 255
+} E2;
+
+typedef enum E3 {
+ e3_b = 0,
+ e3_e = 32767
+} E3;
+
+typedef enum E4 {
+ e4_b = 0,
+ e4_e = 65536
+} E4;
+
+/* === pointers === */
+
+typedef struct P1 {
+ char * f1;
+ UINT8 f2;
+} P1;
+
+typedef struct P2 {
+ long * f1;
+ UINT8 f2;
+} P2;
+
+typedef struct P3 {
+ double * f1;
+ UINT8 f2;
+} P3;
+
+typedef struct P4 {
+ long long * f1;
+ UINT8 f2;
+} P4;
+
+typedef struct P5 {
+ void (* f1) (void);
+ UINT8 f2;
+} P5;
+
+#ifdef __VEC__
+typedef struct P61 {
+ vector signed short * f1;
+ UINT8 f2;
+} P6;
+#endif
+
+/* === vectors === */
+
+#ifdef __VEC__
+typedef struct V1 {
+ vector signed short f1;
+ UINT8 f2;
+} V1;
+
+typedef struct V2 {
+ V1 f1;
+ UINT8 f2;
+} V2;
+
+typedef struct V3 {
+ UINT8 f1;
+ vector signed short f2;
+} V3;
+
+typedef struct V4 {
+ V3 f1;
+ UINT8 f2;
+} V4;
+#endif
+
+/* === doubles === */
+
+typedef struct D1 {
+ double f1;
+ UINT8 f2;
+} D1;
+
+typedef struct D2 {
+ D1 f1;
+ UINT8 f2;
+} D2;
+
+typedef struct D3 {
+ UINT8 f1;
+ double f2;
+} D3;
+
+typedef struct D4 {
+ D3 f1;
+ UINT8 f2;
+} D4;
+
+typedef struct D5 {
+ UINT8 f1;
+ D3 f2;
+} D5;
+
+typedef struct D6 {
+ double f1;
+ UINT8 f2;
+ double f3;
+} D6;
+
+typedef struct D7 {
+ UINT8 f1;
+ D1 f2;
+} D7;
+
+/* === long longs === */
+
+typedef struct LL1 {
+ long long f1;
+ UINT8 f2;
+} LL1;
+
+typedef struct LL2 {
+ LL1 f1;
+ UINT8 f2;
+} LL2;
+
+typedef struct LL3 {
+ UINT8 f1;
+ long long f2;
+} LL3;
+
+typedef struct LL4 {
+ LL3 f1;
+ UINT8 f2;
+} LL4;
+
+typedef struct LL5 {
+ UINT8 f1;
+ LL3 f2;
+} LL5;
+
+/* === arrays === */
+
+typedef struct A1 {
+ short f1[4];
+ UINT8 f2;
+} A1;
+
+typedef struct A2 {
+ A1 f1;
+ UINT8 f2;
+} A2;
+
+typedef struct A3 {
+ double f1[4];
+ UINT8 f2;
+} A3;
+
+typedef struct A4 {
+ A3 f1;
+ UINT8 f2;
+} A4;
+
+typedef struct A5 {
+ long long f1[4];
+ UINT8 f2;
+} A5;
+
+typedef struct A6 {
+ A5 f1;
+ UINT8 f2;
+} A6;
+
+#ifdef __VEC__
+typedef struct A7 {
+ vector signed short f1[4];
+ UINT8 f2;
+} A7;
+
+typedef struct A8 {
+ A7 f1;
+ UINT8 f2;
+} A8;
+#endif
+
+typedef struct A9 {
+ D1 f1[4];
+ UINT8 f2;
+} A9;
+
+typedef struct A10 {
+ A9 f1;
+ UINT8 f2;
+} A10;
+
+/* === unions === */
+
+typedef union U1 {
+ UINT8 f1;
+ double f2;
+} U1;
+
+typedef struct U2 {
+ U1 f1;
+ UINT8 f2;
+} U2;
+
+typedef union U3 {
+ UINT8 f1;
+ long long f2;
+} U3;
+
+typedef struct U4 {
+ U3 f1;
+ UINT8 f2;
+} U4;
+
+#ifdef __VEC__
+typedef union U5 {
+ UINT8 f1;
+ vector signed short f2;
+} U5;
+
+typedef struct U6 {
+ U5 f1;
+ UINT8 f2;
+} U6;
+#endif
+
+typedef union U7 {
+ UINT8 f1;
+ short f2[4];
+} U7;
+
+typedef struct U8 {
+ U7 f1;
+ UINT8 f2;
+} U8;
+
+/* === misc === */
+
+typedef struct { /* unnamed struct */
+ long long f1;
+ UINT8 f2;
+} M0;
+
+typedef struct M1 {
+ UINT8 f1[8];
+} M1;
+
+typedef struct M2 {
+ M1 f1;
+ UINT8 f2;
+} M2;
+
+typedef struct M3 {
+ UINT8 f1;
+ M1 f2;
+} M3;
+
+typedef struct M4 { /* M4 & M5: see corresponding mac68k tests (M68K11 & M68K12) */
+ UINT8 f1[9];
+} M4;
+
+typedef struct M5 {
+ UINT8 f1;
+ M4 f2;
+} M5;
+
+/* === mac68k === */
+
+#pragma options align=mac68k
+
+typedef struct M68K0 {
+ long f1;
+ UINT8 f2;
+} M68K0;
+
+typedef struct M68K1 {
+ double f1;
+ UINT8 f2;
+} M68K1;
+
+#pragma options align=reset
+
+typedef struct M68K2 {
+ M68K1 f1;
+ UINT8 f2;
+} M68K2;
+
+#ifdef __VEC__
+#pragma options align=mac68k
+
+typedef struct M68K3 {
+ vector signed short f1;
+ UINT8 f2;
+} M68K3;
+
+typedef struct M68K4 {
+ M68K3 f1;
+ UINT8 f2;
+} M68K4;
+
+#pragma options align=reset
+
+typedef struct M68K5 {
+ M68K3 f1;
+ UINT8 f2;
+} M68K5;
+
+#pragma options align=mac68k
+
+typedef struct M68K6 {
+ UINT8 f1;
+ vector signed short f2;
+} M68K6;
+
+#pragma options align=reset
+#endif
+
+#pragma options align=mac68k
+
+typedef struct M68K7 {
+ UINT8 f1;
+} M68K7;
+
+typedef union M68K8 {
+ UINT8 f1;
+} M68K8;
+
+typedef struct M68K9 {
+ UINT8 f1;
+ int f2;
+ UINT8 f3;
+} M68K9;
+
+#pragma options align=reset
+
+typedef struct M68K10 {
+ UINT8 f1;
+ M68K9 f2;
+} M68K10;
+
+#pragma options align=mac68k
+
+typedef struct M68K11 { /* M68K11 & M68K12: see corresponding power tests (M4 & M5) */
+ UINT8 f1[9];
+} M68K11;
+
+typedef struct M68K12 {
+ UINT8 f1;
+ M68K11 f2;
+} M68K12;
+
+typedef struct M68K13 {
+ UINT8 f1;
+ UINT8 f2[5];
+} M68K13;
+
+#pragma options align=reset
+
+
+static void check(char * rec_name, int actual, int expected, char * comment)
+{
+ if (flag_verbose || (actual != expected)) {
+ printf("%-20s = %2d (%2d) ", rec_name, actual, expected);
+ if (actual != expected) {
+ printf("*** FAIL");
+ nbr_failures++;
+ } else
+ printf(" PASS");
+ printf(": %s\n", comment);
+ }
+}
+
+static void check_option(char *option)
+{
+ if (*option == '-') {
+ if (strcmp(option, "-v") == 0)
+ flag_verbose = 1;
+ else {
+ fprintf(stderr, "*** unrecognized option '%s'.\n", option);
+ bad_option = 1;
+ }
+ } else {
+ fprintf(stderr, "*** unrecognized option '%s'.\n", option);
+ bad_option = 1;
+ }
+}
+
+int main(int argc, char *argv[])
+{
+ int i;
+
+ for (i = 1; i < argc; i++)
+ check_option(argv[i]);
+
+ if (bad_option)
+ return 1;
+
+ /* === basic data types === */
+
+ check(Q(sizeof(char)), 1, "char data type");
+ check(Q(sizeof(signed char)), 1, "signed char data type");
+ check(Q(sizeof(unsigned char)), 1, "unsigned char data type");
+ check(Q(sizeof(short)), 2, "short data type");
+ check(Q(sizeof(signed short)), 2, "signed short data type");
+ check(Q(sizeof(unsigned short)), 2, "unsigned short data type");
+ check(Q(sizeof(long)), 4, "short long type");
+ check(Q(sizeof(signed long)), 4, "signed long data type");
+ check(Q(sizeof(unsigned long)), 4, "unsigned long data type");
+ check(Q(sizeof(int)), 4, "short int type");
+ check(Q(sizeof(signed int)), 4, "signed int data type");
+ check(Q(sizeof(unsigned int)), 4, "unsigned int data type");
+ check(Q(sizeof(float)), 4, "float type");
+ check(Q(sizeof(double)), 8, "double data type");
+ check(Q(sizeof(long long)), 8, "long long data type");
+ check(Q(sizeof(signed long long)), 8, "signed long long data type");
+ check(Q(sizeof(unsigned long long)), 8, "unsigned long long data type");
+
+ check(Q(sizeof(B1)), 2, "char as 1st field");
+ check(Q(sizeof(B2)), 4, "short as 1st field");
+ check(Q(sizeof(B3)), 8, "long as 1st field");
+ check(Q(sizeof(B4)), 8, "int as 1st field");
+ check(Q(sizeof(B5)), 8, "float as 1st field");
+
+ /* === enums === */
+
+ check(Q(sizeof(E1)), 4, "enum with range 0..255");
+ check(Q(sizeof(E2)), 4, "enum with range -256..255");
+ check(Q(sizeof(E3)), 4, "enum with range 0..32767");
+ check(Q(sizeof(E4)), 4, "enum with range 0..65536");
+
+ /* === pointers === */
+
+ check(Q(sizeof(P1)), 8, "char * as 1st field");
+ check(Q(sizeof(P2)), 8, "long * as 1st field");
+ check(Q(sizeof(P3)), 8, "double * as 1st field");
+ check(Q(sizeof(P4)), 8, "long long * as 1st field");
+ check(Q(sizeof(P5)), 8, "function * as 1st field");
+
+#ifdef __VEC__
+ check(Q(sizeof(P6)), 8, "vector signed short * as 1st field");
+#endif
+
+#ifdef __VEC__
+ /* === vectors === */
+
+ /* ??? Do we want to test all the possible vector data types? ??? */
+ check(Q(sizeof(vector signed short)), 16, "vector signed short data type");
+
+ check(Q(sizeof(V1)), 32, "vector as 1st field");
+ check(Q(sizeof(V2)), 48, "embedding struct with vector as 1st field");
+ check(Q(sizeof(V3)), 32, "vector as 2nd field");
+ check(Q(offsetof(V3, f2)), 16, "offset of vector as 2nd field");
+ check(Q(sizeof(V4)), 48, "embedding struct with vector as 2nd field");
+#endif
+
+ /* === doubles === */
+
+ check(Q(sizeof(D1)), 16, "double as 1st field");
+ check(Q(sizeof(D2)), 24, "embedding struct with double as 1st field");
+ check(Q(sizeof(D3)), 12, "double as 2nd field");
+ check(Q(offsetof(D3, f2)), 4, "offset of double as 2nd field");
+ check(Q(sizeof(D4)), 16, "embedding struct with double as 2nd field");
+ check(Q(sizeof(D5)), 16, "struct with double as 2nd field");
+ check(Q(offsetof(D5, f2)), 4, "offset of struct with double as 2nd field");
+ check(Q(sizeof(D6)), 24, "struct with double, char, double");
+ check(Q(offsetof(D6, f3)), 12, "offset of 2nd double in struct with double, char, double");
+ check(Q(sizeof(D7)), 20, "struct with double as 2nd field of another struct");
+ check(Q(offsetof(D7, f2)), 4, "offset of struct with double as 2nd field of another struct");
+
+ /* === long longs === */
+
+ check(Q(sizeof(LL1)), 16, "long long as 1st field");
+ check(Q(sizeof(LL2)), 24, "embedding struct with long long as 1st field");
+ check(Q(sizeof(LL3)), 12, "long long as 2nd field");
+ check(Q(offsetof(LL3, f2)), 4, "offset of long long as 2nd field");
+ check(Q(sizeof(LL4)), 16, "embedding struct with long long as 2nd field");
+ check(Q(sizeof(LL5)), 16, "struct with long long as 2nd field");
+ check(Q(offsetof(LL5, f2)), 4, "offset of struct with long long as 2nd field");
+
+ /* === arrays === */
+
+ check(Q(sizeof(A1)), 10, "array of shorts as 1st field");
+ check(Q(sizeof(A2)), 12, "embedding struct with array of shorts as 1st field");
+ check(Q(sizeof(A3)), 40, "array of doubles as 1st field");
+ check(Q(sizeof(A4)), 48, "embedding struct with array of doubles as 1st field");
+ check(Q(sizeof(A5)), 40, "array of long longs as 1st field");
+ check(Q(sizeof(A6)), 48, "embedding struct with array of long longs as 1st field");
+#ifdef __VEC__
+ check(Q(sizeof(A7)), 80, "array of vectors as 1st field");
+ check(Q(sizeof(A8)), 96, "embedding struct with array of vectors as 1st field");
+#endif
+ check(Q(sizeof(A9)), 72, "array of structs as 1st field");
+ check(Q(sizeof(A10)), 80, "embedding struct with array of structs as 1st field");
+
+ /* === unions === */
+
+ check(Q(sizeof(U1)), 8, "union with double");
+ check(Q(sizeof(U2)), 16, "embedding union with double");
+ check(Q(sizeof(U3)), 8, "union with long long");
+ check(Q(sizeof(U4)), 16, "embedding union with long long");
+#if __VEC__
+ check(Q(sizeof(U5)), 16, "union with vector");
+ check(Q(sizeof(U6)), 32, "embedding union with vector");
+#endif
+ check(Q(sizeof(U7)), 8, "union with array of shorts");
+ check(Q(sizeof(U8)), 10, "embedding union with array of shorts");
+
+ /* === misc === */
+
+ check(Q(sizeof(M0)), 16, "untagged struct with long long as 1st field");
+ check(Q(sizeof(M1)), 8, "array[8] of char");
+ check(Q(sizeof(M2)), 9, "embedding struct with array[8] of char as 1st field");
+ check(Q(sizeof(M3)), 9, "embedding struct with array[8] of char as 2nd field");
+ check(Q(offsetof(M3, f2)), 1, "offset of struct with array[8] of char as 2nd field");
+ check(Q(sizeof(M4)), 9, "odd size struct: array[9] of char");
+ check(Q(sizeof(M5)), 10, "embedding odd size struct");
+
+ /* === mac68k mode === */
+
+ check(Q(sizeof(M68K0)), 6, "mac68k struct with long");
+ check(Q(sizeof(M68K1)), 10, "mac68k struct with double as 1st field");
+ check(Q(sizeof(M68K2)), 12, "embedding mac68k struct with double as 1st field");
+#ifdef __VEC__
+ check(Q(sizeof(M68K3)), 32, "mac68k struct with vector as 1st field");
+ check(Q(sizeof(M68K4)), 48, "embedding mac68k struct with vector as 1st field in a mac68k struct");
+ check(Q(sizeof(M68K5)), 48, "embedding mac68k struct with vector as 1st field in a power struct");
+ check(Q(offsetof(M68K6, f2)), 16, "offset of vector as 2nd field in a mac68k struct");
+#endif
+ check(Q(sizeof(M68K7)), 2, "padding of mac68k struct with one char");
+ check(Q(sizeof(M68K8)), 2, "padding of mac68k union with one char");
+ check(Q(sizeof(M68K9)), 8, "padding of mac68k struct");
+ check(Q(offsetof(M68K9, f2)), 2, "offset of int as 2nd field in a mac68k struct");
+ check(Q(sizeof(M68K10)), 10, "power struct with embedded mac68k struct");
+ check(Q(offsetof(M68K10, f2)), 2, "offset of mac68k struct as 2nd field in a power struct");
+ check(Q(sizeof(M68K11)), 10, "odd size struct (before padding): array[9] of char");
+ check(Q(sizeof(M68K12)), 12, "embedding odd size struct (before padding)");
+ check(Q(sizeof(M68K13)), 6, "array of char at odd addr in mac68k struct");
+ check(Q(offsetof(M68K13, f2)), 1, "offset of array of char at odd addr in mac68k struct");
+
+ if (nbr_failures > 0)
+ return 1;
+ else
+ return 0;
+}
diff --git a/gcc/testsuite/gcc.apple/align-test-2.c b/gcc/testsuite/gcc.apple/align-test-2.c
new file mode 100644
index 00000000000..1e0ecc819c1
--- /dev/null
+++ b/gcc/testsuite/gcc.apple/align-test-2.c
@@ -0,0 +1,152 @@
+/* APPLE LOCAL file Macintosh alignment */
+
+/* { dg-do run } */
+/* { dg-options "-Wno-long-long" } */
+
+/*
+ * Macintosh compiler alignment test for alignment extensions in GCC 3.
+ * Fred Forsman
+ * Apple Computer, Inc.
+ * (C) 2000-2002.
+ * Last modified 2002-1-22.
+ */
+
+ /* Check whether we are testing GCC 3 or later. */
+#ifdef __GNUC__
+#if __GNUC__ >= 3
+ #define GCC3 1
+#endif
+#endif
+
+#include <stdio.h>
+#include <stddef.h>
+#include <string.h>
+
+#define Q(x) #x, x
+
+typedef unsigned char UINT8;
+typedef unsigned long UINT32;
+
+static int bad_option = 0;
+static int flag_verbose = 0;
+static int nbr_failures = 0;
+
+/* === alignment modes === */
+
+typedef struct S1 {
+ UINT8 f1;
+} S1;
+
+#pragma options align=mac68k
+
+typedef struct S2 {
+ UINT8 f1;
+} S2;
+
+#pragma options align=native
+
+typedef struct S3 {
+ UINT8 f1;
+} S3;
+
+#pragma options align=reset
+/* Should be mac68k mode here. */
+
+#pragma options align=reset
+/* Should be power mode here. */
+
+typedef struct S4 {
+ UINT8 f1;
+ double f2;
+} S4;
+
+#pragma options align=natural
+
+typedef struct S5 {
+ UINT8 f1;
+ double f2;
+} S5;
+
+typedef struct S6 {
+ UINT8 f1;
+ double f2;
+ UINT8 f3;
+} S6;
+
+#pragma options align=reset
+/* Should be power mode here. */
+
+#pragma options align=packed
+
+typedef struct S7 {
+ UINT8 f1;
+ UINT32 f2;
+} S7;
+
+#pragma options align=reset
+/* Should be power mode here. */
+
+typedef struct S8 {
+ UINT8 f1;
+ UINT32 f2;
+} S8;
+
+static void check(char * rec_name, int actual, int expected, char * comment)
+{
+ if (flag_verbose || (actual != expected)) {
+ printf("%-20s = %2d (%2d) ", rec_name, actual, expected);
+ if (actual != expected) {
+ printf("*** FAIL");
+ nbr_failures++;
+ } else
+ printf(" PASS");
+ printf(": %s\n", comment);
+ }
+}
+
+static void check_option(char *option)
+{
+ if (*option == '-') {
+ if (strcmp(option, "-v") == 0)
+ flag_verbose = 1;
+ else {
+ fprintf(stderr, "*** unrecognized option '%s'.\n", option);
+ bad_option = 1;
+ }
+ } else {
+ fprintf(stderr, "*** unrecognized option '%s'.\n", option);
+ bad_option = 1;
+ }
+}
+
+int main(int argc, char *argv[])
+{
+ int i;
+
+ for (i = 1; i < argc; i++)
+ check_option(argv[i]);
+
+ if (bad_option)
+ return 1;
+
+#ifndef GCC3
+ printf("This test requires GCC 3");
+ return 1;
+#endif
+
+ check(Q(sizeof(S1)), 1, "struct with 1 char; power mode");
+ check(Q(sizeof(S2)), 2, "struct with 1 char; mac68k mode");
+ check(Q(sizeof(S3)), 1, "struct with 1 char; native mode");
+ check(Q(sizeof(S4)), 12, "struct with char, double; power mode");
+ check(Q(offsetof(S4, f2)), 4, "offset of double in a struct with char, double; power mode");
+ check(Q(sizeof(S5)), 16, "struct with char, double; natural mode");
+ check(Q(offsetof(S5, f2)), 8, "offset of double in a struct with char, double; natural mode");
+ check(Q(sizeof(S6)), 24, "struct with char, double, char; natural mode");
+ check(Q(sizeof(S7)), 5, "struct with char, long; packed mode");
+ check(Q(sizeof(S8)), 8, "struct with char, long; power mode");
+
+ if (nbr_failures > 0)
+ return 1;
+ else
+ return 0;
+}
diff --git a/gcc/testsuite/gcc.apple/align-test-3.c b/gcc/testsuite/gcc.apple/align-test-3.c
new file mode 100644
index 00000000000..1351031bec3
--- /dev/null
+++ b/gcc/testsuite/gcc.apple/align-test-3.c
@@ -0,0 +1,123 @@
+/* APPLE LOCAL file Macintosh alignment */
+
+/* { dg-do run } */
+/* { dg-options "-Wno-long-long" } */
+
+/*
+ * GCC alignment test for alignment problems due to interactions
+ * between FSF and Macintosh alignment modes.
+ * Fred Forsman
+ * Apple Computer, Inc.
+ * (C) 2000-2002.
+ * Last modified 2002-1-22.
+ */
+
+ /* Check whether we are testing GCC 3 or later. */
+#ifdef __GNUC__
+#if __GNUC__ >= 3
+#define GCC3 1
+#else
+#define GCC3 0
+#endif
+#endif
+
+#include <stdio.h>
+#include <stddef.h>
+#include <string.h>
+
+#define Q(x) #x, x
+
+typedef unsigned char UINT8;
+typedef unsigned long UINT32;
+
+static int bad_option = 0;
+static int flag_verbose = 0;
+static int nbr_failures = 0;
+
+/* === alignment modes === */
+
+#pragma options align=power
+#pragma options align=mac68k
+#pragma pack(1)
+
+typedef struct S0 {
+ UINT32 f1;
+ UINT8 f2;
+} S0;
+
+#pragma options align=reset
+
+/* We should be back in mac68k alignment, if #pragma option align=reset
+ can rest a #pragma pack(n). So check for mac68k alignment. */
+
+typedef struct S1 {
+ UINT32 f1;
+ UINT8 f2;
+} S1;
+
+#if GCC3
+#pragma options align=power
+#pragma options align=mac68k
+//#pragma pack(push, 1)
+//#pragma pack(pop)
+#pragma pack(1)
+#pragma pack()
+
+/* We should be back in mac68k alignment, if #pragma pack()
+ can reset a #pragma pack(n). So check for mac68k alignment. */
+
+typedef struct S2 {
+ UINT32 f1;
+ UINT8 f2;
+} S2;
+#endif /* GCC3 */
+
+static void check(char * rec_name, int actual, int expected, char * comment)
+{
+ if (flag_verbose || (actual != expected)) {
+ printf("%-20s = %2d (%2d) ", rec_name, actual, expected);
+ if (actual != expected) {
+ printf("*** FAIL");
+ nbr_failures++;
+ } else
+ printf(" PASS");
+ printf(": %s\n", comment);
+ }
+}
+
+static void check_option(char *option)
+{
+ if (*option == '-') {
+ if (strcmp(option, "-v") == 0)
+ flag_verbose = 1;
+ else {
+ fprintf(stderr, "*** unrecognized option '%s'.\n", option);
+ bad_option = 1;
+ }
+ } else {
+ fprintf(stderr, "*** unrecognized option '%s'.\n", option);
+ bad_option = 1;
+ }
+}
+
+int main(int argc, char *argv[])
+{
+ int i;
+
+ for (i = 1; i < argc; i++)
+ check_option(argv[i]);
+
+ if (bad_option)
+ return 1;
+
+ check(Q(sizeof(S0)), 5, "struct with 1 long, 1 char; pack(1) mode");
+ check(Q(sizeof(S1)), 6, "struct with 1 long, 1 char; should be mac68k mode");
+#if GCC3
+ check(Q(sizeof(S2)), 6, "struct with 1 long, 1 char; should be mac68k mode");
+#endif
+
+ if (nbr_failures > 0)
+ return 1;
+ else
+ return 0;
+}
diff --git a/gcc/testsuite/gcc.apple/align-test-4.c b/gcc/testsuite/gcc.apple/align-test-4.c
new file mode 100644
index 00000000000..f07a10911f9
--- /dev/null
+++ b/gcc/testsuite/gcc.apple/align-test-4.c
@@ -0,0 +1,224 @@
+/* APPLE LOCAL file Macintosh alignment */
+
+/* { dg-do run } */
+/* { dg-options "-Wno-long-long" } */
+
+/*
+ * GCC alignment test for bit-fields.
+ * This came up initially as an alignment problem in the kernel.
+ * Fred Forsman
+ * Apple Computer, Inc.
+ * (C) 2000-2002.
+ * Last modified 2002-2-18.
+ */
+
+ /* Check whether we are testing GCC 3 or later. */
+#ifdef __GNUC__
+#if __GNUC__ >= 3
+#define GCC3 1
+#else
+#define GCC3 0
+#endif
+#endif
+
+#include <stdio.h>
+#include <stddef.h>
+#include <string.h>
+
+/*
+ * The following defined determines whether we should compare against
+ * the values produced by GCC 2.95 or against the values I expect given
+ * my understanding of the alignment rules.
+ */
+#define USE_GCC2_VALUES 1
+
+#define NAME2(name,mode) mode##_##name
+#define NAME(name,mode) NAME2(name,mode)
+
+#define STR(s) #s
+#define SIZEOF3(name) STR(sizeof(name)), sizeof(name)
+#define SIZEOF2(name,mode) SIZEOF3(mode##_##name)
+#define SIZEOF(name,mode) SIZEOF2(name,mode)
+
+#define OFFSETOF3(name,field) STR(offsetof(name,field)), offsetof(name,field)
+#define OFFSETOF2(name,mode,field) OFFSETOF3(mode##_##name,field)
+#define OFFSETOF(name,mode,field) OFFSETOF2(name,mode,field)
+
+typedef unsigned char UINT8;
+typedef unsigned long UINT32;
+
+static int bad_option = 0;
+static int flag_verbose = 0;
+static int nbr_failures = 0;
+
+/* === mac68k alignment problem in kernel === */
+
+typedef unsigned PEF_UBits32, ByteCount;
+typedef short SInt16;
+
+/* === power === */
+#pragma options align=power
+#define MODE power
+#include "align-test-4.h"
+
+/* === mac68k === */
+#pragma options align=mac68k
+#undef MODE
+#define MODE mac68k
+#include "align-test-4.h"
+
+/* === pack(2) === */
+#pragma pack(2)
+#undef MODE
+#define MODE pack2
+#include "align-test-4.h"
+
+
+static void check(char * rec_name, int actual, int expected, char * comment)
+{
+ if (flag_verbose || (actual != expected)) {
+ printf("%-30s = %2d (%2d) ", rec_name, actual, expected);
+ if (actual != expected) {
+ printf("*** FAIL");
+ nbr_failures++;
+ } else
+ printf(" PASS");
+ printf(": %s\n", comment);
+ }
+}
+
+static void check_option(char *option)
+{
+ if (*option == '-') {
+ if (strcmp(option, "-v") == 0)
+ flag_verbose = 1;
+ else {
+ fprintf(stderr, "*** unrecognized option '%s'.\n", option);
+ bad_option = 1;
+ }
+ } else {
+ fprintf(stderr, "*** unrecognized option '%s'.\n", option);
+ bad_option = 1;
+ }
+}
+
+int main(int argc, char *argv[])
+{
+ int i;
+
+ for (i = 1; i < argc; i++)
+ check_option(argv[i]);
+
+ if (bad_option)
+ return 1;
+
+#undef MODE
+#define MODE power
+
+#if USE_GCC2_VALUES
+ check(SIZEOF(LoaderExport, MODE), 12, "kernel struct");
+ check(OFFSETOF(LoaderExport, MODE, offset), 4, "offset of offset");
+ check(OFFSETOF(LoaderExport, MODE, sectionNumber), 8, "offset of sectionNumber");
+ check(SIZEOF(S1, MODE), 8, "bitfields & char");
+ check(SIZEOF(S2, MODE), 8, "int & char");
+ check(SIZEOF(S3, MODE), 12, "char, bitfields(32), char");
+ check(OFFSETOF(S3, MODE, f3), 8, "offset of 2nd char");
+ check(SIZEOF(S4, MODE), 8, "char, bitfields(32), char");
+ check(OFFSETOF(S4, MODE, f3), 7, "offset of 2nd char");
+ check(SIZEOF(S5, MODE), 4, "char, bitfields(16), char");
+ check(OFFSETOF(S5, MODE, f3), 3, "offset of 2nd char");
+ check(SIZEOF(S6, MODE), 4, "char, bitfields(8), char");
+ check(OFFSETOF(S6, MODE, f3), 2, "offset of 2nd char");
+#else
+ check(SIZEOF(LoaderExport, MODE), 12, "kernel struct");
+ check(OFFSETOF(LoaderExport, MODE, offset), 4, "offset of offset");
+ check(OFFSETOF(LoaderExport, MODE, sectionNumber), 8, "offset of sectionNumber");
+ check(SIZEOF(S1, MODE), 8, "bitfields & char");
+ check(SIZEOF(S2, MODE), 8, "int & char");
+ check(SIZEOF(S3, MODE), 12, "char, bitfields(32), char");
+ check(OFFSETOF(S3, MODE, f3), 8, "offset of 2nd char");
+ check(SIZEOF(S4, MODE), 12, "char, bitfields(32), char");
+ check(OFFSETOF(S4, MODE, f3), 8, "offset of 2nd char");
+ check(SIZEOF(S5, MODE), 12, "char, bitfields(16), char");
+ check(OFFSETOF(S5, MODE, f3), 8, "offset of 2nd char");
+ check(SIZEOF(S6, MODE), 12, "char, bitfields(8), char");
+ check(OFFSETOF(S6, MODE, f3), 8, "offset of 2nd char");
+#endif
+
+#undef MODE
+#define MODE mac68k
+
+#if USE_GCC2_VALUES
+ check(SIZEOF(LoaderExport, MODE), 10, "kernel struct");
+ check(OFFSETOF(LoaderExport, MODE, offset), 4, "offset of offset");
+ check(OFFSETOF(LoaderExport, MODE, sectionNumber), 8, "offset of sectionNumber");
+#if 1
+ // GCC 2 is wrong on the following.
+ check(SIZEOF(S1, MODE), 6, "bitfields & char");
+#else
+ check(SIZEOF(S1, MODE), 8, "bitfields & char");
+#endif
+ check(SIZEOF(S2, MODE), 6, "int & char");
+ check(SIZEOF(S3, MODE), 6, "char, bitfields(32), char");
+ check(OFFSETOF(S3, MODE, f3), 5, "offset of 2nd char");
+ check(SIZEOF(S4, MODE), 6, "char, bitfields(32), char");
+ check(OFFSETOF(S4, MODE, f3), 5, "offset of 2nd char");
+ check(SIZEOF(S5, MODE), 4, "char, bitfields(16), char");
+ check(OFFSETOF(S5, MODE, f3), 3, "offset of 2nd char");
+ check(SIZEOF(S6, MODE), 4, "char, bitfields(8), char");
+ check(OFFSETOF(S6, MODE, f3), 2, "offset of 2nd char");
+#else
+ check(SIZEOF(LoaderExport, MODE), 10, "kernel struct");
+ check(OFFSETOF(LoaderExport, MODE, offset), 4, "offset of offset");
+ check(OFFSETOF(LoaderExport, MODE, sectionNumber), 8, "offset of sectionNumber");
+ check(SIZEOF(S1, MODE), 6, "bitfields & char");
+ check(SIZEOF(S2, MODE), 6, "int & char");
+ check(SIZEOF(S3, MODE), 8, "char, bitfields(32), char");
+ check(OFFSETOF(S3, MODE, f3), 6, "offset of 2nd char");
+ check(SIZEOF(S4, MODE), 8, "char, bitfields(32), char");
+ check(OFFSETOF(S4, MODE, f3), 6, "offset of 2nd char");
+ check(SIZEOF(S5, MODE), 6, "char, bitfields(16), char");
+ check(OFFSETOF(S5, MODE, f3), 4, "offset of 2nd char");
+ check(SIZEOF(S6, MODE), 4, "char, bitfields(8), char");
+ check(OFFSETOF(S6, MODE, f3), 2, "offset of 2nd char");
+#endif
+
+#undef MODE
+#define MODE pack2
+
+#if USE_GCC2_VALUES
+ check(SIZEOF(LoaderExport, MODE), 10, "kernel struct");
+ check(OFFSETOF(LoaderExport, MODE, offset), 4, "offset of offset");
+ check(OFFSETOF(LoaderExport, MODE, sectionNumber), 8, "offset of sectionNumber");
+ /* GCC2 used to have this as '8', but it should really be 6. */
+ check(SIZEOF(S1, MODE), 6, "bitfields & char");
+ check(SIZEOF(S2, MODE), 6, "int & char");
+ check(SIZEOF(S3, MODE), 6, "char, bitfields(32), char");
+ check(OFFSETOF(S3, MODE, f3), 5, "offset of 2nd char");
+ check(SIZEOF(S4, MODE), 6, "char, bitfields(32), char");
+ check(OFFSETOF(S4, MODE, f3), 5, "offset of 2nd char");
+ check(SIZEOF(S5, MODE), 4, "char, bitfields(16), char");
+ check(OFFSETOF(S5, MODE, f3), 3, "offset of 2nd char");
+ check(SIZEOF(S6, MODE), 4, "char, bitfields(8), char");
+ check(OFFSETOF(S6, MODE, f3), 2, "offset of 2nd char");
+#else
+ check(SIZEOF(LoaderExport, MODE), 10, "kernel struct");
+ check(OFFSETOF(LoaderExport, MODE, offset), 4, "offset of offset");
+ check(OFFSETOF(LoaderExport, MODE, sectionNumber), 8, "offset of sectionNumber");
+ check(SIZEOF(S1, MODE), 6, "bitfields & char");
+ check(SIZEOF(S2, MODE), 6, "int & char");
+ check(SIZEOF(S3, MODE), 8, "char, bitfields(32), char");
+ check(OFFSETOF(S3, MODE, f3), 6, "offset of 2nd char");
+ check(SIZEOF(S4, MODE), 8, "char, bitfields(32), char");
+ check(OFFSETOF(S4, MODE, f3), 6, "offset of 2nd char");
+ check(SIZEOF(S5, MODE), 6, "char, bitfields(16), char");
+ check(OFFSETOF(S5, MODE, f3), 4, "offset of 2nd char");
+ check(SIZEOF(S6, MODE), 4, "char, bitfields(8), char");
+ check(OFFSETOF(S6, MODE, f3), 2, "offset of 2nd char");
+#endif
+
+ if (nbr_failures > 0)
+ return 1;
+ else
+ return 0;
+}
diff --git a/gcc/testsuite/gcc.apple/align-test-4.h b/gcc/testsuite/gcc.apple/align-test-4.h
new file mode 100644
index 00000000000..f7c18727fee
--- /dev/null
+++ b/gcc/testsuite/gcc.apple/align-test-4.h
@@ -0,0 +1,43 @@
+/* APPLE LOCAL file Macintosh alignment */
+
+typedef struct {
+ PEF_UBits32 symClass : 8;
+ PEF_UBits32 nameOffset : 24;
+ ByteCount offset;
+ SInt16 sectionNumber;
+} NAME(LoaderExport, MODE);
+
+typedef struct {
+ unsigned f1 : 32;
+ char f2;
+} NAME(S1, MODE);
+
+typedef struct {
+ unsigned f1;
+ char f2;
+} NAME(S2, MODE);
+
+typedef struct {
+ char f1;
+ unsigned f2 : 32;
+ char f3;
+} NAME(S3, MODE);
+
+typedef struct {
+ char f1;
+ unsigned f2_1 : 8;
+ unsigned f2_2 : 24;
+ char f3;
+} NAME(S4, MODE);
+
+typedef struct {
+ char f1;
+ unsigned f2 : 16;
+ char f3;
+} NAME(S5, MODE);
+
+typedef struct {
+ char f1;
+ unsigned f2 : 8;
+ char f3;
+} NAME(S6, MODE);
diff --git a/gcc/testsuite/gcc.apple/align-test-5a.c b/gcc/testsuite/gcc.apple/align-test-5a.c
new file mode 100644
index 00000000000..6833535fcec
--- /dev/null
+++ b/gcc/testsuite/gcc.apple/align-test-5a.c
@@ -0,0 +1,87 @@
+/* APPLE LOCAL file Macintosh alignment */
+/* align-test-5*.c are all the same code but with different options. */
+
+/* { dg-do run } */
+/* { dg-options "-malign-natural -DSIZE=16" } */
+
+/*
+ * GCC alignment test for command line options for setting alignment modes.
+ * Fred Forsman
+ * Apple Computer, Inc.
+ * (C) 2000-2002.
+ * Last modified 2002-2-18.
+ *
+ */
+
+ /* Check whether we are testing GCC 3 or later. */
+#ifdef __GNUC__
+#if __GNUC__ >= 3
+#define GCC3 1
+#else
+#define GCC3 0
+#endif
+#endif
+
+#include <stdio.h>
+#include <stddef.h>
+#include <string.h>
+
+#define Q(x) #x, x
+
+typedef unsigned char UINT8;
+typedef unsigned long UINT32;
+
+static int bad_option = 0;
+static int flag_verbose = 0;
+static int nbr_failures = 0;
+
+typedef struct S0 {
+ UINT8 f1;
+ double f2;
+} S0;
+
+static void check(char * rec_name, int actual, int expected, char * comment)
+{
+ if (flag_verbose || (actual != expected)) {
+ printf("%-20s = %2d (%2d) ", rec_name, actual, expected);
+ if (actual != expected) {
+ printf("*** FAIL");
+ nbr_failures++;
+ } else
+ printf(" PASS");
+ printf(": %s\n", comment);
+ }
+}
+
+static void check_option(char *option)
+{
+ if (*option == '-') {
+ if (strcmp(option, "-v") == 0)
+ flag_verbose = 1;
+ else {
+ fprintf(stderr, "*** unrecognized option '%s'.\n", option);
+ bad_option = 1;
+ }
+ } else {
+ fprintf(stderr, "*** unrecognized option '%s'.\n", option);
+ bad_option = 1;
+ }
+}
+
+int main(int argc, char *argv[])
+{
+ int i;
+
+ for (i = 1; i < argc; i++)
+ check_option(argv[i]);
+
+ if (bad_option)
+ return 1;
+
+ check(Q(sizeof(S0)), SIZE, "struct with 1 char, 1 double");
+
+ if (nbr_failures > 0)
+ return 1;
+ else
+ return 0;
+}
diff --git a/gcc/testsuite/gcc.apple/align-test-5b.c b/gcc/testsuite/gcc.apple/align-test-5b.c
new file mode 100644
index 00000000000..6845bd34766
--- /dev/null
+++ b/gcc/testsuite/gcc.apple/align-test-5b.c
@@ -0,0 +1,87 @@
+/* APPLE LOCAL file Macintosh alignment */
+/* align-test-5*.c are all the same code but with different options. */
+
+/* { dg-do run } */
+/* { dg-options "-malign-power -DSIZE=12" } */
+
+/*
+ * GCC alignment test for command line options for setting alignment modes.
+ * Fred Forsman
+ * Apple Computer, Inc.
+ * (C) 2000-2002.
+ * Last modified 2002-2-18.
+ *
+ */
+
+ /* Check whether we are testing GCC 3 or later. */
+#ifdef __GNUC__
+#if __GNUC__ >= 3
+#define GCC3 1
+#else
+#define GCC3 0
+#endif
+#endif
+
+#include <stdio.h>
+#include <stddef.h>
+#include <string.h>
+
+#define Q(x) #x, x
+
+typedef unsigned char UINT8;
+typedef unsigned long UINT32;
+
+static int bad_option = 0;
+static int flag_verbose = 0;
+static int nbr_failures = 0;
+
+typedef struct S0 {
+ UINT8 f1;
+ double f2;
+} S0;
+
+static void check(char * rec_name, int actual, int expected, char * comment)
+{
+ if (flag_verbose || (actual != expected)) {
+ printf("%-20s = %2d (%2d) ", rec_name, actual, expected);
+ if (actual != expected) {
+ printf("*** FAIL");
+ nbr_failures++;
+ } else
+ printf(" PASS");
+ printf(": %s\n", comment);
+ }
+}
+
+static void check_option(char *option)
+{
+ if (*option == '-') {
+ if (strcmp(option, "-v") == 0)
+ flag_verbose = 1;
+ else {
+ fprintf(stderr, "*** unrecognized option '%s'.\n", option);
+ bad_option = 1;
+ }
+ } else {
+ fprintf(stderr, "*** unrecognized option '%s'.\n", option);
+ bad_option = 1;
+ }
+}
+
+int main(int argc, char *argv[])
+{
+ int i;
+
+ for (i = 1; i < argc; i++)
+ check_option(argv[i]);
+
+ if (bad_option)
+ return 1;
+
+ check(Q(sizeof(S0)), SIZE, "struct with 1 char, 1 double");
+
+ if (nbr_failures > 0)
+ return 1;
+ else
+ return 0;
+}
diff --git a/gcc/testsuite/gcc.apple/align-test-5c.c b/gcc/testsuite/gcc.apple/align-test-5c.c
new file mode 100644
index 00000000000..fd9bd5cca4c
--- /dev/null
+++ b/gcc/testsuite/gcc.apple/align-test-5c.c
@@ -0,0 +1,87 @@
+/* APPLE LOCAL file Macintosh alignment */
+/* align-test-5*.c are all the same code but with different options. */
+
+/* { dg-do run } */
+/* { dg-options "-malign-mac68k -DSIZE=10" } */
+
+/*
+ * GCC alignment test for command line options for setting alignment modes.
+ * Fred Forsman
+ * Apple Computer, Inc.
+ * (C) 2000-2002.
+ * Last modified 2002-2-18.
+ *
+ */
+
+ /* Check whether we are testing GCC 3 or later. */
+#ifdef __GNUC__
+#if __GNUC__ >= 3
+#define GCC3 1
+#else
+#define GCC3 0
+#endif
+#endif
+
+#include <stdio.h>
+#include <stddef.h>
+#include <string.h>
+
+#define Q(x) #x, x
+
+typedef unsigned char UINT8;
+typedef unsigned long UINT32;
+
+static int bad_option = 0;
+static int flag_verbose = 0;
+static int nbr_failures = 0;
+
+typedef struct S0 {
+ UINT8 f1;
+ double f2;
+} S0;
+
+static void check(char * rec_name, int actual, int expected, char * comment)
+{
+ if (flag_verbose || (actual != expected)) {
+ printf("%-20s = %2d (%2d) ", rec_name, actual, expected);
+ if (actual != expected) {
+ printf("*** FAIL");
+ nbr_failures++;
+ } else
+ printf(" PASS");
+ printf(": %s\n", comment);
+ }
+}
+
+static void check_option(char *option)
+{
+ if (*option == '-') {
+ if (strcmp(option, "-v") == 0)
+ flag_verbose = 1;
+ else {
+ fprintf(stderr, "*** unrecognized option '%s'.\n", option);
+ bad_option = 1;
+ }
+ } else {
+ fprintf(stderr, "*** unrecognized option '%s'.\n", option);
+ bad_option = 1;
+ }
+}
+
+int main(int argc, char *argv[])
+{
+ int i;
+
+ for (i = 1; i < argc; i++)
+ check_option(argv[i]);
+
+ if (bad_option)
+ return 1;
+
+ check(Q(sizeof(S0)), SIZE, "struct with 1 char, 1 double");
+
+ if (nbr_failures > 0)
+ return 1;
+ else
+ return 0;
+}
diff --git a/gcc/testsuite/gcc.apple/altivec-1.c b/gcc/testsuite/gcc.apple/altivec-1.c
new file mode 100644
index 00000000000..d2040d96bbc
--- /dev/null
+++ b/gcc/testsuite/gcc.apple/altivec-1.c
@@ -0,0 +1,124 @@
+/* APPLE LOCAL file AltiVec */
+/* { dg-do run { target powerpc*-*-* } } */
+/* { dg-options "-faltivec -Wno-long-double" } */
+
+/* Test for correct handling of AltiVec constants passed
+ through '...' (va_arg). */
+
+#include <stdarg.h>
+#include <stdio.h>
+#include <stdlib.h>
+
+#define CHECK_INVARIANT(expr) \
+ if (!(expr)) { \
+ printf ("ASSERT FAILED: %d: %s\n", __LINE__, #expr); \
+ abort (); \
+ }
+
+struct foo { int x; int y; };
+struct vfoo { int x; __vector signed int v; int y; };
+union u { __vector signed int v; signed int i[4]; };
+
+struct foo x_g = { 3, 4};
+struct vfoo vx_g = { 10, (vector signed int)(11, 12, 13, 14), 15 };
+__vector signed int v_g = (vector signed int) (22, 23, 24, 25);
+struct vfoo vx2_g = { 30, (vector signed int)(31, 32, 33, 34), 35 };
+__vector signed int v2_g = (vector signed int)(40, 41, 42, 43);
+int i_1 = 99, i_2 = 33;
+double d_2 = 1.5, d_3 = 1.75;
+long double ld_1 = 1.25;
+
+void bar (int i, ... )
+{
+ struct foo xi;
+ double d;
+ long double ld;
+ float f;
+ char c;
+ short s;
+ va_list ap;
+ va_start(ap, i);
+ xi = va_arg(ap, struct foo);
+ s = (short)va_arg(ap, int);
+ f = (float)va_arg(ap, double);
+ ld = va_arg(ap, long double);
+ c = (char)va_arg(ap, int);
+ d = va_arg(ap, double);
+ va_end(ap);
+
+ CHECK_INVARIANT (xi.x == x_g.x && xi.y == x_g.y);
+ CHECK_INVARIANT (s == (short)i_2);
+ CHECK_INVARIANT (f == (float)d_2);
+ CHECK_INVARIANT (ld == ld_1);
+ CHECK_INVARIANT (c == (char)i_1);
+ CHECK_INVARIANT (d == d_3);
+}
+
+void baz (int i, ... )
+{
+ struct vfoo vx, vx2;
+ __vector signed int v_i, v2_i;
+ int j, k, l;
+ va_list ap;
+ va_start(ap, i);
+ v_i = va_arg(ap, __vector signed int);
+ j = va_arg(ap, int);
+ vx = va_arg(ap, struct vfoo);
+ k = va_arg(ap, int);
+ v2_i = va_arg(ap, __vector signed int);
+ l = va_arg(ap, int);
+ vx2 = va_arg(ap, struct vfoo);
+ va_end(ap);
+
+ CHECK_INVARIANT (vec_all_eq (v_i, v_g));
+ CHECK_INVARIANT (j == i_1);
+ CHECK_INVARIANT (vx.x == vx_g.x && vec_all_eq(vx.v, vx_g.v) && vx.y == vx_g.y);
+ CHECK_INVARIANT (k == i_1);
+ CHECK_INVARIANT (vec_all_eq (v2_i, v2_g));
+ CHECK_INVARIANT (l == i_1);
+ CHECK_INVARIANT (vx2.x == vx2_g.x && vec_all_eq(vx2.v, vx2_g.v) && vx2.y == vx2_g.y);
+}
+
+void quux (int i, ... )
+{
+ __vector signed int v_i, v2_i;
+ union u vi, v2i;
+ va_list ap;
+ va_start(ap, i);
+ v_i = va_arg(ap, __vector signed int);
+ v2_i = va_arg(ap, __vector signed int);
+ va_end(ap);
+ vi.v = v_i;
+ v2i.v = v2_i;
+
+ CHECK_INVARIANT (vec_all_eq (v_i, v_g));
+ CHECK_INVARIANT (vec_all_eq (v2_i, v_g));
+ CHECK_INVARIANT (vec_all_eq (vi.v, v_g));
+ CHECK_INVARIANT (vec_all_eq (v2i.v, v_g));
+}
+
+void baz2 (int i, ... )
+{
+ struct vfoo vx;
+ union u vxi;
+ va_list ap;
+ va_start(ap, i);
+ vx = va_arg(ap, struct vfoo);
+ va_end(ap);
+ vxi.v = vx.v;
+
+ CHECK_INVARIANT (vx.x == vx_g.x && vec_all_eq(vx.v, vx_g.v) && vx.y == vx_g.y);
+ CHECK_INVARIANT (vec_all_eq (vxi.v, vx_g.v));
+}
+
+int main(void)
+{
+ CHECK_INVARIANT (sizeof(struct foo) == 8 && sizeof(struct vfoo) == 48);
+
+ bar(i_1, x_g, (short)i_2, (float)d_2, ld_1, (char)i_1, d_3);
+ baz(i_1, v_g, i_1, vx_g, i_1, v2_g, i_1, vx2_g);
+ quux(i_1, v_g, v_g);
+ baz2(i_1, vx_g);
+
+ return 0;
+}
diff --git a/gcc/testsuite/gcc.apple/altivec-2.c b/gcc/testsuite/gcc.apple/altivec-2.c
new file mode 100644
index 00000000000..c070de43f6c
--- /dev/null
+++ b/gcc/testsuite/gcc.apple/altivec-2.c
@@ -0,0 +1,9 @@
+/* APPLE LOCAL file AltiVec */
+/* { dg-do compile { target powerpc*-*-* } } */
+/* { dg-options "-faltivec" } */
+
+void foo() {
+ vector bool int boolVector = (vector bool int) vec_splat_u32(3);
+ boolVector = vec_sld( boolVector, boolVector,
+ 1 ); /* { dg-bogus "no instance of overloaded" } */
+}
diff --git a/gcc/testsuite/gcc.apple/applecc.c b/gcc/testsuite/gcc.apple/applecc.c
new file mode 100644
index 00000000000..757ad573272
--- /dev/null
+++ b/gcc/testsuite/gcc.apple/applecc.c
@@ -0,0 +1,14 @@
+/* APPLE LOCAL file Apple version */
+/* { dg-do compile } */
+
+#if __APPLE_CC__ < 1000
+#error build number too small
+#endif
+#if __APPLE_CC__ > 32768
+#error build number too big
+#endif
+#if ! ( __APPLE_CC__ > 1000)
+#error build number not really a number
+#endif
+
+int x = __APPLE_CC__;
diff --git a/gcc/testsuite/gcc.apple/const-cfstring-1.c b/gcc/testsuite/gcc.apple/const-cfstring-1.c
new file mode 100644
index 00000000000..ff1e2665540
--- /dev/null
+++ b/gcc/testsuite/gcc.apple/const-cfstring-1.c
@@ -0,0 +1,26 @@
+/* APPLE LOCAL file constant cfstrings */
+/* Test whether the __builtin__CFStringMakeConstantString
+ "function" fails gracefully when handed a non-constant
+ argument. This will only work on MacOS X 10.1.2 and later. */
+/* Developed by Ziemowit Laski <zlaski@apple.com>. */
+
+/* { dg-do compile { target powerpc-apple-darwin* } } */
+/* { dg-options "-fconstant-cfstrings" } */
+
+#import <CoreFoundation/CFString.h>
+
+#ifdef __CONSTANT_CFSTRINGS__
+#undef CFSTR
+#define CFSTR(STR) ((CFStringRef) __builtin___CFStringMakeConstantString (STR))
+#endif
+
+extern int cond;
+extern const char *func(void);
+
+int main(void) {
+ CFStringRef s1 = CFSTR("Str1");
+ CFStringRef s2 = CFSTR(cond? "Str2": "Str3"); /* { dg-error "CFString literal expression not constant" } */
+ CFStringRef s3 = CFSTR(func()); /* { dg-error "CFString literal expression not constant" } */
+
+ return 0;
+}
diff --git a/gcc/testsuite/gcc.apple/const-cfstring-2.c b/gcc/testsuite/gcc.apple/const-cfstring-2.c
new file mode 100644
index 00000000000..90475112453
--- /dev/null
+++ b/gcc/testsuite/gcc.apple/const-cfstring-2.c
@@ -0,0 +1,13 @@
+/* APPLE LOCAL file constant cfstrings */
+/* Test whether the __builtin__CFStringMakeConstantString
+ "function" fails gracefully when used without the
+ -fconstant-cfstrings flag. */
+/* Developed by Ziemowit Laski <zlaski@apple.com>. */
+
+/* { dg-options "-fno-constant-cfstrings" } */
+/* { dg-do compile { target *-*-darwin* } } */
+
+#include <CoreFoundation/CFBase.h>
+
+const CFStringRef S = ((CFStringRef)__builtin___CFStringMakeConstantString("Testing"));
+/* { dg-error "built-in" "built-in function .* requires .* flag" { target *-*-* } 12 } */
diff --git a/gcc/testsuite/gcc.dg/debug/dwarf2/dwarf2.exp b/gcc/testsuite/gcc.apple/dg.exp
index 6e3621db3ce..42fcefba10e 100644
--- a/gcc/testsuite/gcc.dg/debug/dwarf2/dwarf2.exp
+++ b/gcc/testsuite/gcc.apple/dg.exp
@@ -1,4 +1,5 @@
-# Copyright (C) 2002 Free Software Foundation, Inc.
+# APPLE LOCAL file testsuite
+# Copyright (C) 1997 Free Software Foundation, Inc.
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
@@ -14,7 +15,9 @@
# along with this program; if not, write to the Free Software
# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
-# GCC testsuite that uses the `dg.exp' driver.
+# Apple-specific GCC testsuite driver.
+# Note that this is basically a clone of gcc.dg/dg.exp, updated
+# whenever the original file changes (which is not very often).
# Load support procs.
load_lib gcc-dg.exp
@@ -22,21 +25,16 @@ load_lib gcc-dg.exp
# If a testcase doesn't have special options, use these.
global DEFAULT_CFLAGS
if ![info exists DEFAULT_CFLAGS] then {
- set DEFAULT_CFLAGS " -ansi -pedantic-errors -gdwarf-2"
+ set DEFAULT_CFLAGS " -ansi -pedantic-errors -Wno-long-double"
}
# Initialize `dg'.
dg-init
# Main loop.
-set comp_output [gcc_target_compile \
- "$srcdir/$subdir/../trivial.c" "trivial.S" assembly \
- "additional_flags=-gdwarf-2"]
-if { ! [string match "*: target system does not support the * debug format*" \
- $comp_output] } {
- dg-runtest [lsort [glob -nocomplain $srcdir/$subdir/*.\[cS\]]] \
- "" $DEFAULT_CFLAGS
-}
+# APPLE LOCAL preprocess .s files
+dg-runtest [lsort [glob -nocomplain $srcdir/$subdir/*.\[cSs\]]] \
+ "" $DEFAULT_CFLAGS
# All done.
dg-finish
diff --git a/gcc/testsuite/gcc.apple/execute/bitfield-1.c b/gcc/testsuite/gcc.apple/execute/bitfield-1.c
new file mode 100644
index 00000000000..f013853f48e
--- /dev/null
+++ b/gcc/testsuite/gcc.apple/execute/bitfield-1.c
@@ -0,0 +1,52 @@
+/* { dg-do run { target *-*-darwin* } } */
+/* { dg-options "-O2 -fss-const-prop" } */
+/* APPLE LOCAL */
+/* <rdar://problem/3366203>:Setup Assistant crashes in SetModificationDateToPasteboard */
+/* <rdar://problem/3379022>:GCC compiler error in bitfield handling */
+
+
+typedef struct
+{
+ unsigned int b01 : 1;
+ unsigned int b02 : 2;
+ unsigned int b03 : 1;
+ unsigned int b04 : 1;
+ unsigned int b05 : 1;
+ unsigned int b06 : 1;
+ unsigned int b07 : 3;
+ unsigned int b08 : 3;
+ unsigned int b09 : 3;
+ unsigned int b10 : 3;
+ unsigned int b11 : 8;
+ unsigned int b12 : 1;
+ unsigned int b13 : 4;
+} test_struct;
+
+void func( test_struct* s, int t )
+{
+ s->b12 = 0;
+ s->b02 = 0;
+}
+
+main()
+{
+ test_struct r = { 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1 };
+
+ func (&r, 42);
+
+ if (r.b01 != 1
+ || r.b03 != 1
+ || r.b04 != 1
+ || r.b05 != 1
+ || r.b06 != 1
+ || r.b07 != 1
+ || r.b08 != 1
+ || r.b09 != 1
+ || r.b10 != 1
+ || r.b11 != 1
+ || r.b13 != 1)
+ {
+ abort();
+ }
+ exit (0);
+}
diff --git a/gcc/testsuite/gcc.apple/execute/execute.exp b/gcc/testsuite/gcc.apple/execute/execute.exp
new file mode 100644
index 00000000000..f7b1f5b5eeb
--- /dev/null
+++ b/gcc/testsuite/gcc.apple/execute/execute.exp
@@ -0,0 +1,43 @@
+# Copyright (C) 1991, 1992, 1993, 1995, 1997 Free Software Foundation, Inc.
+
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program; if not, write to the Free Software
+# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
+
+# This file was written by Rob Savoye. (rob@cygnus.com)
+# Modified and maintained by Jeffrey Wheat (cassidy@cygnus.com)
+
+#
+# These tests come from Torbjorn Granlund (tege@cygnus.com)
+# C torture test suite.
+#
+
+if $tracelevel then {
+ strace $tracelevel
+}
+
+# load support procs
+load_lib c-torture.exp
+
+#
+# main test loop
+#
+
+foreach src [lsort [glob -nocomplain $srcdir/$subdir/*.c]] {
+ # If we're only testing specific files and this isn't one of them, skip it.
+ if ![runtest_file_p $runtests $src] then {
+ continue
+ }
+
+ c-torture-execute $src
+}
diff --git a/gcc/testsuite/gcc.apple/framework1.c b/gcc/testsuite/gcc.apple/framework1.c
new file mode 100644
index 00000000000..bd0203669c2
--- /dev/null
+++ b/gcc/testsuite/gcc.apple/framework1.c
@@ -0,0 +1,12 @@
+/* Copyright (C) 2003 Free Software Foundation, Inc. */
+
+/* { dg-do preprocess } */
+/* { dg-options "-nostdinc -c -F${srcdir}/gcc.apple" } */
+
+/* Contributed by Devang Patel <dpatel@apple.com> */
+
+#include <one/one.h>
+int main()
+{
+ return 0;
+}
diff --git a/gcc/testsuite/gcc.apple/import.c b/gcc/testsuite/gcc.apple/import.c
new file mode 100644
index 00000000000..110a2d249ed
--- /dev/null
+++ b/gcc/testsuite/gcc.apple/import.c
@@ -0,0 +1,9 @@
+/* APPLE LOCAL file #import not deprecated */
+/* { dg-do compile } */
+/* { dg-options "" } */
+
+#import "importee.h"
+
+#import "importee.h"
+
+void foo (bar x) {}
diff --git a/gcc/testsuite/gcc.apple/importee.h b/gcc/testsuite/gcc.apple/importee.h
new file mode 100644
index 00000000000..86fbd11da4d
--- /dev/null
+++ b/gcc/testsuite/gcc.apple/importee.h
@@ -0,0 +1,3 @@
+/* APPLE LOCAL file #import not deprecated */
+
+typedef int bar;
diff --git a/gcc/testsuite/gcc.apple/inttypes-1.c b/gcc/testsuite/gcc.apple/inttypes-1.c
new file mode 100644
index 00000000000..40404e2995b
--- /dev/null
+++ b/gcc/testsuite/gcc.apple/inttypes-1.c
@@ -0,0 +1,21 @@
+/* APPLE LOCAL file test of inttypes.h formatter macros */
+
+/* { dg-do compile } */
+/* { dg-options "-Wall -W" } */
+
+#include <stdio.h>
+#include <inttypes.h>
+#include <stdint.h>
+
+int main ()
+{
+ uint32_t x = 12;
+ int32_t y = 15;
+ printf("x = %" PRIo32 "\n", x);
+ printf("x = %" PRIu32 "\n", x);
+ printf("x = %" PRIx32 "\n", x);
+ printf("x = %" PRIX32 "\n", x);
+ printf("y = %" PRId32 "\n", y);
+ printf("y = %" PRIi32 "\n", y);
+ return 0;
+}
diff --git a/gcc/testsuite/gcc.apple/no-warning.c b/gcc/testsuite/gcc.apple/no-warning.c
new file mode 100644
index 00000000000..9b71d722239
--- /dev/null
+++ b/gcc/testsuite/gcc.apple/no-warning.c
@@ -0,0 +1,8 @@
+/* APPLE LOCAL file -Wno-#warnings */
+
+/* { dg-do compile } */
+/* { dg-options "-Wno-#warnings" } */
+
+#warning "suppress this warning"
+
+int a;
diff --git a/gcc/testsuite/gcc.apple/one.framework/Headers/one.h b/gcc/testsuite/gcc.apple/one.framework/Headers/one.h
new file mode 100644
index 00000000000..50c24d3e6c5
--- /dev/null
+++ b/gcc/testsuite/gcc.apple/one.framework/Headers/one.h
@@ -0,0 +1,3 @@
+/* Contributed by Devang Patel <dpatel@apple.com> */
+
+/* Empty header */
diff --git a/gcc/testsuite/gcc.apple/pascal-strings-1.c b/gcc/testsuite/gcc.apple/pascal-strings-1.c
new file mode 100644
index 00000000000..04eb870903e
--- /dev/null
+++ b/gcc/testsuite/gcc.apple/pascal-strings-1.c
@@ -0,0 +1,46 @@
+/* APPLE LOCAL file Pascal strings 2001-07-05 zll */
+/* Positive C test cases. */
+/* Origin: Ziemowit Laski <zlaski@apple.com> */
+/* { dg-do run } */
+/* { dg-options "-std=iso9899:1999 -fpascal-strings" } */
+
+typedef __WCHAR_TYPE__ wchar_t;
+typedef __SIZE_TYPE__ size_t;
+
+extern void abort (void);
+extern size_t strlen (const char *s);
+
+const unsigned char *pascalStr1 = "\pHello, World!";
+const unsigned char *concat1 = "\pConcatenated" "string" "\pliteral";
+
+const unsigned char msg1[] = "\pHello"; /* ok */
+const unsigned char *msg2 = "\pHello"; /* ok */
+const signed char msg3[] = "\pHello"; /* ok */
+const char msg4[] = "\pHello"; /* ok */
+unsigned char msg5[] = "\pHello"; /* ok */
+signed char msg7[] = "\pHello"; /* ok */
+char msg8[] = "\pHello"; /* ok */
+
+int
+main (void)
+{
+ const unsigned char *pascalStr2 = "\pGood-bye!";
+
+ if (strlen ((const char *)pascalStr1) != 14)
+ abort ();
+ if (*pascalStr1 != 13)
+ abort (); /* the length byte does not include trailing null */
+
+ if (strlen ((const char *)pascalStr2) != 10)
+ abort ();
+ if (*pascalStr2 != 9)
+ abort ();
+
+ if (strlen ((const char *)concat1) != 26)
+ abort ();
+ if (*concat1 != 25)
+ abort ();
+
+ return 0;
+}
+
diff --git a/gcc/testsuite/gcc.apple/pascal-strings-2.c b/gcc/testsuite/gcc.apple/pascal-strings-2.c
new file mode 100644
index 00000000000..0ccbee44a96
--- /dev/null
+++ b/gcc/testsuite/gcc.apple/pascal-strings-2.c
@@ -0,0 +1,45 @@
+/* APPLE LOCAL file Pascal strings 2001-07-05 zll */
+/* Negative C test cases. */
+/* Origin: Ziemowit Laski <zlaski@apple.com> */
+/* { dg-do compile } */
+/* { dg-options "-std=iso9899:1999 -Wwrite-strings -fpascal-strings" } */
+
+typedef __WCHAR_TYPE__ wchar_t;
+
+const wchar_t *pascalStr1 = L"\pHi!"; /* { dg-error "not allowed in wide" } */
+const wchar_t *pascalStr2 = L"Bye\p!"; /* { dg-error "not allowed in wide" } */
+
+const wchar_t *initErr0 = "\pHi"; /* { dg-warning "incompatible pointer type" } */
+const wchar_t initErr0a[] = "\pHi"; /* { dg-error "initialized from non-wide string" } */
+const wchar_t *initErr1 = "Bye"; /* { dg-warning "incompatible pointer type" } */
+const wchar_t initErr1a[] = "Bye"; /* { dg-error "initialized from non-wide string" } */
+
+const char *initErr2 = L"Hi"; /* { dg-warning "incompatible pointer type" } */
+const char initErr2a[] = L"Hi"; /* { dg-error "initialized from wide string" } */
+const signed char *initErr3 = L"Hi"; /* { dg-warning "incompatible pointer type" } */
+const signed char initErr3a[] = L"Hi"; /* { dg-error "initialized from wide string" } */
+const unsigned char *initErr4 = L"Hi"; /* { dg-warning "incompatible pointer type" } */
+const unsigned char initErr4a[] = L"Hi"; /* { dg-error "initialized from wide string" } */
+
+const char *pascalStr3 = "Hello\p, World!"; /* { dg-error "must be at beginning" } */
+
+const char *concat2 = "Hi" "\pthere"; /* { dg-error "not allowed in concatenation" } */
+const char *concat3 = "Hi" "there\p"; /* { dg-error "must be at beginning" } */
+
+const char *s2 = "\pGoodbye!"; /* ok */
+unsigned char *s3 = "\pHi!"; /* { dg-warning "initialization discards qualifiers" } */
+char *s4 = "\pHi"; /* { dg-warning "initialization discards qualifiers" } */
+signed char *s5 = "\pHi"; /* { dg-warning "initialization discards qualifiers" } */
+const signed char *s6 = "\pHi"; /* ok */
+
+/* the maximum length of a Pascal literal is 255. */
+const unsigned char *almostTooLong =
+ "\p12345678901234567890123456789012345678901234567890123456789012345678901234567890"
+ "12345678901234567890123456789012345678901234567890123456789012345678901234567890"
+ "12345678901234567890123456789012345678901234567890123456789012345678901234567890"
+ "123456789012345"; /* ok */
+const unsigned char *definitelyTooLong =
+ "\p12345678901234567890123456789012345678901234567890123456789012345678901234567890"
+ "12345678901234567890123456789012345678901234567890123456789012345678901234567890"
+ "12345678901234567890123456789012345678901234567890123456789012345678901234567890"
+ "1234567890123456"; /* { dg-error "too long" } */
diff --git a/gcc/testsuite/gcc.apple/preprocess.s b/gcc/testsuite/gcc.apple/preprocess.s
new file mode 100644
index 00000000000..897f2a7d6b1
--- /dev/null
+++ b/gcc/testsuite/gcc.apple/preprocess.s
@@ -0,0 +1,16 @@
+/* APPLE LOCAL file preprocess .s files */
+
+/* Regression test - in assembly language, # may have some significance
+ other than 'stringize macro argument' and therefore must be preserved
+ in the output, and should not be warned about. */
+
+/* { dg-do preprocess } */
+
+#define foo() mov r0, #5 /* { dg-bogus "not followed" "spurious warning" } */
+
+entry:
+ foo()
+
+/* Check we don't EOF on an unknown directive. */
+#unknown directive
+#error a later diagnostic /* { dg-error "diagnostic" } */
diff --git a/gcc/testsuite/gcc.apple/special/liblongcall.c b/gcc/testsuite/gcc.apple/special/liblongcall.c
new file mode 100644
index 00000000000..297e473927a
--- /dev/null
+++ b/gcc/testsuite/gcc.apple/special/liblongcall.c
@@ -0,0 +1,9 @@
+/* { dg-do compile } */
+/* { dg-options "-mlongcall" } */
+
+int
+dy_foo (char *str, int i)
+{
+ printf ("dy_foo (\"%s\", %d)\n", str, i);
+ return i + 1;
+}
diff --git a/gcc/testsuite/gcc.apple/special/longcall-prog.c b/gcc/testsuite/gcc.apple/special/longcall-prog.c
new file mode 100644
index 00000000000..59448507350
--- /dev/null
+++ b/gcc/testsuite/gcc.apple/special/longcall-prog.c
@@ -0,0 +1,17 @@
+#include <stdio.h>
+
+/* declare all externally visible functions in libweak.c */
+int dy_foo (char *, int);
+
+main ()
+{
+ int answer, x=41;
+ char *str = "foostr";
+ printf ("%s begins:\n", __FILE__);
+ answer = dy_foo (str, x);
+ printf ("dy_foo (\"%s\", %d) = %d", str, x, answer);
+ if (answer != 42)
+ printf (" (error!)");
+ printf ("\n%s done.\n", __FILE__);
+ exit (answer != 42);
+}
diff --git a/gcc/testsuite/gcc.apple/special/longcall.exp b/gcc/testsuite/gcc.apple/special/longcall.exp
new file mode 100644
index 00000000000..d9ebd1270ea
--- /dev/null
+++ b/gcc/testsuite/gcc.apple/special/longcall.exp
@@ -0,0 +1,69 @@
+# APPLE LOCAL file testsuite
+# Copyright (C) 2002 Free Software Foundation, Inc.
+
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program; if not, write to the Free Software
+# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
+
+
+# Load support procs.
+load_lib gcc-dg.exp
+
+# Initialize `dg'.
+dg-init
+
+set timeout 30
+
+set prms_id 0
+set bug_id 0
+
+set testfile "longcall-prog"
+set binfile ${objdir}/${subdir}/${testfile}
+set srcfile ${srcdir}/${subdir}/${testfile}.c
+
+set libfilestem "longcall"
+set libfile "lib${libfilestem}"
+set libbinfile ${objdir}/${subdir}/${libfile}.dylib
+set libsrcfile ${srcdir}/${subdir}/${libfile}.c
+
+file mkdir ${objdir}/${subdir}
+
+set test "longcall/dylib"
+
+proc note_result {success diagnostic} {
+ set verb [expr {($success) ? "pass" : "fail"}]
+ eval {$verb $diagnostic}
+}
+
+set whine "building $test library"
+set additional_flags "additional_flags=-dynamiclib -mlongcall"
+set result [expr {[gcc_target_compile "${libsrcfile}" "${libbinfile}" executable [list debug $additional_flags]] == ""}]
+note_result $result $whine
+
+set whine "building $test test program"
+set additional_flags "additional_flags=-L${objdir}/${subdir} -l${libfilestem}"
+set result [expr {[gcc_target_compile "${srcfile}" "${binfile}" executable [list debug $additional_flags]] == ""}]
+note_result $result $whine
+
+set result [gcc_load "$binfile" "" ""]
+set status [lindex $result 0]
+set output [lindex $result 1];
+if {$status == "pass" } {
+ pass $test
+ file delete $libbinfile $binfile
+} else {
+ fail $test
+}
+
+# All done.
+dg-finish
diff --git a/gcc/testsuite/gcc.apple/special/special.exp b/gcc/testsuite/gcc.apple/special/special.exp
new file mode 100644
index 00000000000..5344a4817b7
--- /dev/null
+++ b/gcc/testsuite/gcc.apple/special/special.exp
@@ -0,0 +1,42 @@
+# APPLE LOCAL file testsuite
+# Copyright (C) 2002 Free Software Foundation, Inc.
+
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program; if not, write to the Free Software
+# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
+
+
+# Load support procs.
+load_lib gcc-dg.exp
+
+# Initialize `dg'.
+dg-init
+
+# Test the zerofill support by seeing if a file with a large array
+# compiled -fno-common has a small size on disk.
+
+gcc_target_compile "$srcdir/$subdir/zerofill.c" "zerofill.o" object \
+ "additional_flags=-fno-common"
+
+set size [ exec wc -c < zerofill.o ]
+
+if { $size < 100000 } {
+ pass "zerofill"
+} else {
+ fail "zerofill"
+}
+
+file delete zerofill.o
+
+# All done.
+dg-finish
diff --git a/gcc/testsuite/gcc.apple/special/zerofill.c b/gcc/testsuite/gcc.apple/special/zerofill.c
new file mode 100644
index 00000000000..e4bd84c816f
--- /dev/null
+++ b/gcc/testsuite/gcc.apple/special/zerofill.c
@@ -0,0 +1,5 @@
+/* APPLE LOCAL file zerofill */
+
+int arr[40000];
+
+foo() {}
diff --git a/gcc/testsuite/gcc.c-torture/compile/simd-4.x b/gcc/testsuite/gcc.c-torture/compile/simd-4.x
new file mode 100644
index 00000000000..6bb99bad79f
--- /dev/null
+++ b/gcc/testsuite/gcc.c-torture/compile/simd-4.x
@@ -0,0 +1,4 @@
+# APPLE LOCAL vector instructions are not supported except with -faltivec
+
+if { [istarget "*-apple-darwin*"] } { set options "-faltivec" }
+return 0
diff --git a/gcc/testsuite/gcc.c-torture/execute/20040308-1.c b/gcc/testsuite/gcc.c-torture/execute/20040308-1.c
deleted file mode 100644
index 4c63535e7f7..00000000000
--- a/gcc/testsuite/gcc.c-torture/execute/20040308-1.c
+++ /dev/null
@@ -1,21 +0,0 @@
-/* This used to fail on SPARC with an unaligned memory access. */
-
-void foo(int n)
-{
- struct S {
- int i[n];
- unsigned int b:1;
- int i2;
- } __attribute__ ((packed)) __attribute__ ((aligned (4)));
-
- struct S s;
-
- s.i2 = 0;
-}
-
-int main(void)
-{
- foo(4);
-
- return 0;
-}
diff --git a/gcc/testsuite/gcc.c-torture/execute/20040309-1.c b/gcc/testsuite/gcc.c-torture/execute/20040309-1.c
deleted file mode 100644
index 49fa79560c6..00000000000
--- a/gcc/testsuite/gcc.c-torture/execute/20040309-1.c
+++ /dev/null
@@ -1,24 +0,0 @@
-extern void abort ();
-
-int foo(unsigned short x)
-{
- unsigned short y;
- y = x > 32767 ? x - 32768 : 0;
- return y;
-}
-
-int main()
-{
- if (foo (0) != 0)
- abort ();
- if (foo (32767) != 0)
- abort ();
- if (foo (32768) != 0)
- abort ();
- if (foo (32769) != 1)
- abort ();
- if (foo (65535) != 32767)
- abort ();
- return 0;
-}
-
diff --git a/gcc/testsuite/gcc.c-torture/execute/20040311-1.c b/gcc/testsuite/gcc.c-torture/execute/20040311-1.c
deleted file mode 100644
index 013d869abf4..00000000000
--- a/gcc/testsuite/gcc.c-torture/execute/20040311-1.c
+++ /dev/null
@@ -1,68 +0,0 @@
-/* Copyright (C) 2004 Free Software Foundation.
-
- Check that constant folding and RTL simplification of -(x >> y) doesn't
- break anything and produces the expected results.
-
- Written by Roger Sayle, 11th March 2004. */
-
-extern void abort (void);
-
-#define INT_BITS (sizeof(int)*8)
-
-int test1(int x)
-{
- return -(x >> (INT_BITS-1));
-}
-
-int test2(unsigned int x)
-{
- return -((int)(x >> (INT_BITS-1)));
-}
-
-int test3(int x)
-{
- int y;
- y = INT_BITS-1;
- return -(x >> y);
-}
-
-int test4(unsigned int x)
-{
- int y;
- y = INT_BITS-1;
- return -((int)(x >> y));
-}
-
-int main()
-{
- if (test1(0) != 0)
- abort ();
- if (test1(1) != 0)
- abort ();
- if (test1(-1) != 1)
- abort ();
-
- if (test2(0) != 0)
- abort ();
- if (test2(1) != 0)
- abort ();
- if (test2((unsigned int)-1) != -1)
- abort ();
-
- if (test3(0) != 0)
- abort ();
- if (test3(1) != 0)
- abort ();
- if (test3(-1) != 1)
- abort ();
-
- if (test4(0) != 0)
- abort ();
- if (test4(1) != 0)
- abort ();
- if (test4((unsigned int)-1) != -1)
- abort ();
-
- return 0;
-}
-
diff --git a/gcc/testsuite/gcc.c-torture/execute/20040313-1.c b/gcc/testsuite/gcc.c-torture/execute/20040313-1.c
deleted file mode 100644
index c05fe730f0c..00000000000
--- a/gcc/testsuite/gcc.c-torture/execute/20040313-1.c
+++ /dev/null
@@ -1,17 +0,0 @@
-/* PR middle-end/14470 */
-/* Origin: Lodewijk Voge <lvoge@cs.vu.nl> */
-
-extern void abort(void);
-
-int main()
-{
- int t[1025] = { 1024 }, d;
-
- d = 0;
- d = t[d]++;
- if (t[0] != 1025)
- abort();
- if (d != 1024)
- abort();
- return 0;
-}
diff --git a/gcc/testsuite/gcc.c-torture/execute/simd-1.x b/gcc/testsuite/gcc.c-torture/execute/simd-1.x
new file mode 100644
index 00000000000..db203f3d590
--- /dev/null
+++ b/gcc/testsuite/gcc.c-torture/execute/simd-1.x
@@ -0,0 +1,7 @@
+# APPLE LOCAL vector instructions are not supported except with -faltivec. xfailed it.
+
+if { [istarget "*-apple-darwin*"] } {
+ set torture_compile_xfail "*-apple-darwin*"
+}
+
+return 0
diff --git a/gcc/testsuite/gcc.c-torture/execute/simd-2.x b/gcc/testsuite/gcc.c-torture/execute/simd-2.x
new file mode 100644
index 00000000000..db203f3d590
--- /dev/null
+++ b/gcc/testsuite/gcc.c-torture/execute/simd-2.x
@@ -0,0 +1,7 @@
+# APPLE LOCAL vector instructions are not supported except with -faltivec. xfailed it.
+
+if { [istarget "*-apple-darwin*"] } {
+ set torture_compile_xfail "*-apple-darwin*"
+}
+
+return 0
diff --git a/gcc/testsuite/gcc.dg/20020416-1.c b/gcc/testsuite/gcc.dg/20020416-1.c
index db1a2617fcd..44916ef1b83 100644
--- a/gcc/testsuite/gcc.dg/20020416-1.c
+++ b/gcc/testsuite/gcc.dg/20020416-1.c
@@ -1,6 +1,7 @@
/* PR bootstrap/6315 */
/* { dg-do compile } */
-/* { dg-options "-O2" } */
+/* APPLE LOCAL -Wlong-double */
+/* { dg-options "-O2 -Wno-long-double" } */
/* { dg-options "-O2 -mhard-quad-float" { target sparc*-*-* } } */
/* { dg-options "-O2" { target sparclet*-*-* sparclite*-*-* sparc86x-*-* } } */
diff --git a/gcc/testsuite/gcc.dg/20040305-2.c b/gcc/testsuite/gcc.dg/20040305-2.c
deleted file mode 100644
index b0423a25495..00000000000
--- a/gcc/testsuite/gcc.dg/20040305-2.c
+++ /dev/null
@@ -1,47 +0,0 @@
-/* PR target/14262 */
-/* { dg-do run } */
-
-typedef char ACS;
-typedef char LSM;
-typedef char PANEL;
-typedef char DRIVE;
-typedef struct {
- ACS acs;
- LSM lsm;
-} LSMID;
-typedef struct {
- LSMID lsm_id;
- PANEL panel;
-} PANELID;
-typedef struct {
- PANELID panel_id;
- DRIVE drive;
-} DRIVEID;
-
-void sub (DRIVEID driveid)
-{
- if (driveid.drive != 1)
- abort ();
- if (driveid.panel_id.panel != 2)
- abort ();
- if (driveid.panel_id.lsm_id.lsm != 3)
- abort ();
- if (driveid.panel_id.lsm_id.acs != 4)
- abort ();
-}
-
-int main(void)
-{
- DRIVEID driveid;
-
- driveid.drive = 1;
- driveid.panel_id.panel = 2;
- driveid.panel_id.lsm_id.lsm = 3;
- driveid.panel_id.lsm_id.acs = 4;
-
- sub(driveid);
-
- return 0;
-}
-
-
diff --git a/gcc/testsuite/gcc.dg/20040309-1.c b/gcc/testsuite/gcc.dg/20040309-1.c
deleted file mode 100644
index 736150731c7..00000000000
--- a/gcc/testsuite/gcc.dg/20040309-1.c
+++ /dev/null
@@ -1,17 +0,0 @@
-/* Test integer mod on ia64. There was a bug in the inline integer
- division code. */
-
-/* { dg-do run } */
-/* { dg-options "-minline-int-divide-max-throughput" { target ia64-*-* } } */
-
-extern void abort (void);
-
-volatile int i = 10;
-volatile int j = 10;
-
-int main()
-{
- int k = i % j;
- if (k != 0) abort();
- return 0;
-}
diff --git a/gcc/testsuite/gcc.dg/20040310-1.c b/gcc/testsuite/gcc.dg/20040310-1.c
deleted file mode 100644
index 104e98d0889..00000000000
--- a/gcc/testsuite/gcc.dg/20040310-1.c
+++ /dev/null
@@ -1,34 +0,0 @@
-/* This caused cc1 to segfault on s390x-ibm-linux
- due to a bug in if_then_else_cond (combine.c). */
-
-/* { dg-do compile } */
-/* { dg-options "-O1" } */
-
-extern void use (unsigned int x);
-
-int main (void)
-{
- union
- {
- unsigned int x;
- unsigned long pad;
- } A;
-
- struct
- {
- unsigned int x : 1;
- } B;
-
- A.x = 1;
- B.x = 1;
- A.x /= B.x;
- use (A.x);
-
- A.x = 1;
- B.x = 1;
- B.x /= A.x;
- use (B.x);
-
- return 0;
-}
-
diff --git a/gcc/testsuite/gcc.dg/20040311-2.c b/gcc/testsuite/gcc.dg/20040311-2.c
deleted file mode 100644
index 0d0d5da3259..00000000000
--- a/gcc/testsuite/gcc.dg/20040311-2.c
+++ /dev/null
@@ -1,36 +0,0 @@
-/* PR target/14533 */
-/* { dg-do compile } */
-/* { dg-options "-O2 -fpic" } */
-
-void bar (char *, int);
-
-extern char b[];
-extern int d, e;
-struct S
-{
- struct S *m;
- int n;
-} **g;
-
-void
-foo (int x, char *y)
-{
- struct S *h;
- int k = 1, l;
-
-again:
- for (h = *g; h != (struct S *) g; h = h->m)
- {
- if (k == 0 && h->n & 0x100000);
- l = y - b;
- if (e)
- bar (b, l);
- if (d)
- bar (b, l);
- }
- if (k)
- {
- k = 0;
- goto again;
- }
-}
diff --git a/gcc/testsuite/gcc.dg/alias-2.c b/gcc/testsuite/gcc.dg/alias-2.c
deleted file mode 100644
index d507416b0ff..00000000000
--- a/gcc/testsuite/gcc.dg/alias-2.c
+++ /dev/null
@@ -1,16 +0,0 @@
-// { dg-do compile }
-// { dg-options "-Wstrict-aliasing=2 -fstrict-aliasing" }
-
-struct foo {
- char c;
- char d;
- short s;
- int i;
-} bar;
-
-int
-sub1 (long long int foobar)
-{
- struct foo *tmp = (struct foo *) &foobar; // { dg-warning "type-punned pointer might" "" }
- return tmp->i;
-}
diff --git a/gcc/testsuite/gcc.dg/altivec-2.c b/gcc/testsuite/gcc.dg/altivec-2.c
index f64081ff813..f3074fe6796 100644
--- a/gcc/testsuite/gcc.dg/altivec-2.c
+++ b/gcc/testsuite/gcc.dg/altivec-2.c
@@ -4,8 +4,6 @@
/* Program to test the vector_size attribute. This needs to run on a
target that has vectors, so use AltiVec. */
-#define vector __attribute__((vector_size(16)))
-
vector int foobar;
/* Only floats and integrals allowed. We don't care if they map to SIs. */
diff --git a/gcc/testsuite/gcc.dg/altivec-4.c b/gcc/testsuite/gcc.dg/altivec-4.c
index 175663581ac..f5a46493152 100644
--- a/gcc/testsuite/gcc.dg/altivec-4.c
+++ b/gcc/testsuite/gcc.dg/altivec-4.c
@@ -1,8 +1,6 @@
/* { dg-do compile { target powerpc*-*-* } } */
/* { dg-options "-maltivec -O0 -Wall" } */
-#define vector __attribute__((vector_size(16)))
-
static int __attribute__((mode(V4SI))) x, y;
static vector signed int i,j;
diff --git a/gcc/testsuite/gcc.dg/altivec-5.c b/gcc/testsuite/gcc.dg/altivec-5.c
index 0adfdb84d19..37c9a9fa79b 100644
--- a/gcc/testsuite/gcc.dg/altivec-5.c
+++ b/gcc/testsuite/gcc.dg/altivec-5.c
@@ -1,8 +1,6 @@
/* { dg-do compile { target powerpc*-*-* } } */
/* { dg-options "-maltivec -O2" } */
-#define vector __attribute__((vector_size(16)))
-
void foo (const unsigned long x,
vector signed int a, vector signed int b)
{
diff --git a/gcc/testsuite/gcc.dg/builtin-inf-1.c b/gcc/testsuite/gcc.dg/builtin-inf-1.c
index d2d28415899..0e97114cfca 100644
--- a/gcc/testsuite/gcc.dg/builtin-inf-1.c
+++ b/gcc/testsuite/gcc.dg/builtin-inf-1.c
@@ -1,5 +1,5 @@
/* { dg-do compile } */
-
+/* { dg-options "-Wno-long-double" { target *-apple-darwin* } } */
float fi = __builtin_inff();
double di = __builtin_inf();
long double li = __builtin_infl();
diff --git a/gcc/testsuite/gcc.dg/builtins-34.c b/gcc/testsuite/gcc.dg/builtins-34.c
deleted file mode 100644
index d2bf4d41219..00000000000
--- a/gcc/testsuite/gcc.dg/builtins-34.c
+++ /dev/null
@@ -1,66 +0,0 @@
-/* Copyright (C) 2004 Free Software Foundation.
-
- Check that exp10, exp10f, exp10l, exp2, exp2f, exp2l, pow10, pow10f
- and pow10l built-in functions compile.
-
- Written by Uros Bizjak, 13th February 2004. */
-
-/* { dg-do compile } */
-/* { dg-options "-O2 -ffast-math" } */
-
-extern double exp10(double);
-extern double exp2(double);
-extern double pow10(double);
-extern float exp10f(float);
-extern float exp2f(float);
-extern float pow10f(float);
-extern long double exp10l(long double);
-extern long double exp2l(long double);
-extern long double pow10l(long double);
-
-
-double test1(double x)
-{
- return exp10(x);
-}
-
-double test2(double x)
-{
- return exp2(x);
-}
-
-double test3(double x)
-{
- return pow10(x);
-}
-
-float test1f(float x)
-{
- return exp10f(x);
-}
-
-float test2f(float x)
-{
- return exp2f(x);
-}
-
-float test3f(float x)
-{
- return pow10f(x);
-}
-
-long double test1l(long double x)
-{
- return exp10l(x);
-}
-
-long double test2l(long double x)
-{
- return exp2l(x);
-}
-
-long double test3l(long double x)
-{
- return pow10l(x);
-}
-
diff --git a/gcc/testsuite/gcc.dg/c90-dupqual-1.c b/gcc/testsuite/gcc.dg/c90-dupqual-1.c
deleted file mode 100644
index 14838c7367f..00000000000
--- a/gcc/testsuite/gcc.dg/c90-dupqual-1.c
+++ /dev/null
@@ -1,12 +0,0 @@
-/* { dg-do compile } */
-/* { dg-options "-std=iso9899:1990 -pedantic-errors" } */
-
-typedef const int CI;
-const const int c1; /* { dg-error "duplicate" } */
-const CI c2; /* { dg-error "duplicate" } */
-const CI *c3; /* { dg-error "duplicate" } */
-
-typedef volatile int VI;
-volatile volatile int v1; /* { dg-error "duplicate" } */
-volatile VI v2; /* { dg-error "duplicate" } */
-volatile VI *v3; /* { dg-error "duplicate" } */
diff --git a/gcc/testsuite/gcc.dg/c99-complex-1.c b/gcc/testsuite/gcc.dg/c99-complex-1.c
index 2e1ba7df539..494cdd6a266 100644
--- a/gcc/testsuite/gcc.dg/c99-complex-1.c
+++ b/gcc/testsuite/gcc.dg/c99-complex-1.c
@@ -1,8 +1,8 @@
/* Test for _Complex: in C99 only. A few basic tests. */
/* Origin: Joseph Myers <jsm28@cam.ac.uk> */
/* { dg-do compile } */
-/* { dg-options "-std=iso9899:1999 -pedantic-errors" } */
-
+/* APPLE LOCAL -Wlong-double */
+/* { dg-options "-std=iso9899:1999 -pedantic-errors -Wno-long-double" } */
/* Test _Complex allowed on floating types. */
float _Complex a;
diff --git a/gcc/testsuite/gcc.dg/c99-dupqual-1.c b/gcc/testsuite/gcc.dg/c99-dupqual-1.c
deleted file mode 100644
index 2e6d7e1bc5a..00000000000
--- a/gcc/testsuite/gcc.dg/c99-dupqual-1.c
+++ /dev/null
@@ -1,12 +0,0 @@
-/* { dg-do compile } */
-/* { dg-options "-std=iso9899:1999 -pedantic-errors" } */
-
-typedef const int CI;
-const const int c1; /* { dg-bogus "duplicate" } */
-const CI c2; /* { dg-bogus "duplicate" } */
-const CI *c3; /* { dg-bogus "duplicate" } */
-
-typedef volatile int VI;
-volatile volatile int v1; /* { dg-bogus "duplicate" } */
-volatile VI v2; /* { dg-bogus "duplicate" } */
-volatile VI *v3; /* { dg-bogus "duplicate" } */
diff --git a/gcc/testsuite/gcc.dg/cast-ptr-1.c b/gcc/testsuite/gcc.dg/cast-ptr-1.c
new file mode 100644
index 00000000000..cb42d13ac48
--- /dev/null
+++ b/gcc/testsuite/gcc.dg/cast-ptr-1.c
@@ -0,0 +1,15 @@
+/* APPLE LOCAL file pointer casts */
+/* Test that casts of pointer to unsigned long long aren't sign extended */
+/* Author: Matt Austern <austern@apple.com> */
+/* { dg-do run } */
+/* { dg-options "-Wno-error -w" } */
+
+int main () {
+ /* Note: test assumes sizeof(long long) >= sizeof(void*) */
+
+ unsigned long x1 = 0x80000000ul;
+ void* p = (void*) x1;
+ unsigned long long x2 = (unsigned long long) p;
+
+ return !(x1 == x2);
+}
diff --git a/gcc/testsuite/gcc.dg/charset/asm1.c b/gcc/testsuite/gcc.dg/charset/asm1.c
deleted file mode 100644
index d7578d418f6..00000000000
--- a/gcc/testsuite/gcc.dg/charset/asm1.c
+++ /dev/null
@@ -1,14 +0,0 @@
-/* { dg-do compile }
- { dg-require-iconv "IBM-1047" }
- { dg-final { scan-assembler ".ascii bar" } }
- { dg-final { scan-assembler ".ascii foo" } }
- */
-extern int x, y;
-
-asm (".ascii bar");
-
-int foo (void)
-{
- __asm__ (".ascii foo");
- return 0;
-}
diff --git a/gcc/testsuite/gcc.dg/charset/asm3.c b/gcc/testsuite/gcc.dg/charset/asm3.c
deleted file mode 100644
index 8d8dbbb524d..00000000000
--- a/gcc/testsuite/gcc.dg/charset/asm3.c
+++ /dev/null
@@ -1,33 +0,0 @@
-/* Test for complex asm statements. Make sure it compiles
- then test for some of the asm statements not being translated. */
-/* { dg-do compile { target i?86-*-* } }
- { dg-require-iconv "IBM-1047" }
- { dg-final { scan-assembler "std" } }
- { dg-final { scan-assembler "cld" } }
- { dg-final { scan-assembler "rep" } }
- { dg-final { scan-assembler "movsb" } } */
-#define size_t int
-void *
-memmove (void *__dest, __const void *__src, size_t __n)
-{
- register unsigned long int __d0, __d1, __d2;
- if (__dest < __src)
- __asm__ __volatile__
- ("cld\n\t"
- "rep\n\t"
- "movsb"
- : "=&c" (__d0), "=&S" (__d1), "=&D" (__d2)
- : "0" (__n), "1" (__src), "2" (__dest)
- : "memory");
- else
- __asm__ __volatile__
- ("std\n\t"
- "rep\n\t"
- "movsb\n\t"
- "cld"
- : "=&c" (__d0), "=&S" (__d1), "=&D" (__d2)
- : "0" (__n), "1" (__n - 1 + (const char *) __src),
- "2" (__n - 1 + (char *) __dest)
- : "memory");
- return __dest;
-}
diff --git a/gcc/testsuite/gcc.dg/charset/asm4.c b/gcc/testsuite/gcc.dg/charset/asm4.c
deleted file mode 100644
index cd850c3e81f..00000000000
--- a/gcc/testsuite/gcc.dg/charset/asm4.c
+++ /dev/null
@@ -1,10 +0,0 @@
-/* Simple asm test. */
-/* { dg-do compile }
- { dg-require-iconv "IBM-1047" }
- { dg-final { scan-assembler "foo" } } */
-extern int bar;
-
-int main (void)
-{
- asm ("foo %0" : "=r" (bar));
-}
diff --git a/gcc/testsuite/gcc.dg/charset/asm5.c b/gcc/testsuite/gcc.dg/charset/asm5.c
deleted file mode 100644
index fa93f40fdaf..00000000000
--- a/gcc/testsuite/gcc.dg/charset/asm5.c
+++ /dev/null
@@ -1,8 +0,0 @@
-/* Test for string translation. */
-/* { dg-do compile }
- { dg-require-iconv "IBM-1047" }
- { dg-final { scan-assembler-not "translate" } } */
-void foo (void)
-{
- asm ("xx" : : "r"("translate") : "cc");
-}
diff --git a/gcc/testsuite/gcc.dg/charset/attribute1.c b/gcc/testsuite/gcc.dg/charset/attribute1.c
deleted file mode 100644
index 993c7934c80..00000000000
--- a/gcc/testsuite/gcc.dg/charset/attribute1.c
+++ /dev/null
@@ -1,10 +0,0 @@
-/* Test for attribute non-translation. */
-/* { dg-do compile }
- { dg-require-iconv "IBM-1047" }
- { dg-final { scan-assembler "foo" } } */
-int walrus __attribute__ ((section (".foo")));
-
-int main (void)
-{
- return 0;
-}
diff --git a/gcc/testsuite/gcc.dg/charset/attribute2.c b/gcc/testsuite/gcc.dg/charset/attribute2.c
deleted file mode 100644
index 4ce95a51f84..00000000000
--- a/gcc/testsuite/gcc.dg/charset/attribute2.c
+++ /dev/null
@@ -1,8 +0,0 @@
-/* Test to make sure that invalid attributes aren't translated.
- If error recovery is ever testable then "foobar" should be
- translated. */
-/* { dg-do compile }
- { dg-require-iconv "IBM-1047" }
- */
-int foo __attribute__ ((walrus)); /* { dg-error "walrus" "ignored" } */
-char x[] = "foobar";
diff --git a/gcc/testsuite/gcc.dg/charset/string.c b/gcc/testsuite/gcc.dg/charset/string.c
deleted file mode 100644
index 375e28a2ed6..00000000000
--- a/gcc/testsuite/gcc.dg/charset/string.c
+++ /dev/null
@@ -1,5 +0,0 @@
-/* Simple character translation test. */
-/* { dg-do compile }
- { dg-require-iconv "IBM-1047" }
- { dg-final { scan-assembler-not "string foobar" } } */
-char *foo = "string foobar";
diff --git a/gcc/testsuite/gcc.dg/compat/struct-by-value-21_main.c b/gcc/testsuite/gcc.dg/compat/struct-by-value-21_main.c
deleted file mode 100644
index b722bccd2ca..00000000000
--- a/gcc/testsuite/gcc.dg/compat/struct-by-value-21_main.c
+++ /dev/null
@@ -1,13 +0,0 @@
-/* Test function argument passing. This was written when correcting
- a deviation from the ABI on SPARC64 between 3.3 and 3.4. */
-
-extern void struct_by_value_21_x (void);
-extern void exit (int);
-int fails;
-
-int
-main ()
-{
- struct_by_value_21_x ();
- exit (0);
-}
diff --git a/gcc/testsuite/gcc.dg/compat/struct-by-value-21_x.c b/gcc/testsuite/gcc.dg/compat/struct-by-value-21_x.c
deleted file mode 100644
index 3b01ba86eb1..00000000000
--- a/gcc/testsuite/gcc.dg/compat/struct-by-value-21_x.c
+++ /dev/null
@@ -1,168 +0,0 @@
-#include "compat-common.h"
-
-#define T(TYPE) \
-TYPE g1s##TYPE, g2s##TYPE, g3s##TYPE, g4s##TYPE; \
-TYPE g5s##TYPE, g6s##TYPE, g7s##TYPE, g8s##TYPE; \
-TYPE g9s##TYPE, g10s##TYPE, g11s##TYPE, g12s##TYPE; \
-TYPE g13s##TYPE, g14s##TYPE, g15s##TYPE, g16s##TYPE; \
- \
-extern void init##TYPE (TYPE *p, int i); \
-extern void checkg##TYPE (void); \
-extern void \
-test##TYPE (TYPE s1, TYPE s2, TYPE s3, TYPE s4, \
- TYPE s5, TYPE s6, TYPE s7, TYPE s8, \
- TYPE s9, TYPE s10, TYPE s11, TYPE s12, \
- TYPE s13, TYPE s14, TYPE s15, TYPE s16); \
-extern void testva##TYPE (int n, ...); \
- \
-void \
-test2_##TYPE (TYPE s1, TYPE s2, TYPE s3, TYPE s4, \
- TYPE s5, TYPE s6, TYPE s7, TYPE s8) \
-{ \
- test##TYPE (s1, g2s##TYPE, s2, g4s##TYPE, \
- s3, g6s##TYPE, s4, g8s##TYPE, \
- s5, g10s##TYPE, s6, g12s##TYPE, \
- s7, g14s##TYPE, s8, g16s##TYPE); \
-} \
- \
-void \
-testit##TYPE (void) \
-{ \
- DEBUG_FPUTS (#TYPE); \
- DEBUG_FPUTS (" init: "); \
- init##TYPE ( &g1s##TYPE, 1); \
- init##TYPE ( &g2s##TYPE, 2); \
- init##TYPE ( &g3s##TYPE, 3); \
- init##TYPE ( &g4s##TYPE, 4); \
- init##TYPE ( &g5s##TYPE, 5); \
- init##TYPE ( &g6s##TYPE, 6); \
- init##TYPE ( &g7s##TYPE, 7); \
- init##TYPE ( &g8s##TYPE, 8); \
- init##TYPE ( &g9s##TYPE, 9); \
- init##TYPE (&g10s##TYPE, 10); \
- init##TYPE (&g11s##TYPE, 11); \
- init##TYPE (&g12s##TYPE, 12); \
- init##TYPE (&g13s##TYPE, 13); \
- init##TYPE (&g14s##TYPE, 14); \
- init##TYPE (&g15s##TYPE, 15); \
- init##TYPE (&g16s##TYPE, 16); \
- checkg##TYPE (); \
- DEBUG_NL; \
- DEBUG_FPUTS (#TYPE); \
- DEBUG_FPUTS (" test: "); \
- test##TYPE (g1s##TYPE, g2s##TYPE, g3s##TYPE, g4s##TYPE, \
- g5s##TYPE, g6s##TYPE, g7s##TYPE, g8s##TYPE, \
- g9s##TYPE, g10s##TYPE, g11s##TYPE, g12s##TYPE, \
- g13s##TYPE, g14s##TYPE, g15s##TYPE, g16s##TYPE); \
- DEBUG_NL; \
- DEBUG_FPUTS (#TYPE); \
- DEBUG_FPUTS (" testva:"); \
- DEBUG_NL; \
- testva##TYPE (1, \
- g1s##TYPE); \
- DEBUG_NL; \
- testva##TYPE (2, \
- g1s##TYPE, g2s##TYPE); \
- DEBUG_NL; \
- testva##TYPE (3, \
- g1s##TYPE, g2s##TYPE, g3s##TYPE); \
- DEBUG_NL; \
- testva##TYPE (4, \
- g1s##TYPE, g2s##TYPE, g3s##TYPE, g4s##TYPE); \
- DEBUG_NL; \
- testva##TYPE (5, \
- g1s##TYPE, g2s##TYPE, g3s##TYPE, g4s##TYPE, \
- g5s##TYPE); \
- DEBUG_NL; \
- testva##TYPE (6, \
- g1s##TYPE, g2s##TYPE, g3s##TYPE, g4s##TYPE, \
- g5s##TYPE, g6s##TYPE); \
- DEBUG_NL; \
- testva##TYPE (7, \
- g1s##TYPE, g2s##TYPE, g3s##TYPE, g4s##TYPE, \
- g5s##TYPE, g6s##TYPE, g7s##TYPE); \
- DEBUG_NL; \
- testva##TYPE (8, \
- g1s##TYPE, g2s##TYPE, g3s##TYPE, g4s##TYPE, \
- g5s##TYPE, g6s##TYPE, g7s##TYPE, g8s##TYPE); \
- DEBUG_NL; \
- testva##TYPE (9, \
- g1s##TYPE, g2s##TYPE, g3s##TYPE, g4s##TYPE, \
- g5s##TYPE, g6s##TYPE, g7s##TYPE, g8s##TYPE, \
- g9s##TYPE); \
- DEBUG_NL; \
- testva##TYPE (10, \
- g1s##TYPE, g2s##TYPE, g3s##TYPE, g4s##TYPE, \
- g5s##TYPE, g6s##TYPE, g7s##TYPE, g8s##TYPE, \
- g9s##TYPE, g10s##TYPE); \
- DEBUG_NL; \
- testva##TYPE (11, \
- g1s##TYPE, g2s##TYPE, g3s##TYPE, g4s##TYPE, \
- g5s##TYPE, g6s##TYPE, g7s##TYPE, g8s##TYPE, \
- g9s##TYPE, g10s##TYPE, g11s##TYPE); \
- DEBUG_NL; \
- testva##TYPE (12, \
- g1s##TYPE, g2s##TYPE, g3s##TYPE, g4s##TYPE, \
- g5s##TYPE, g6s##TYPE, g7s##TYPE, g8s##TYPE, \
- g9s##TYPE, g10s##TYPE, g11s##TYPE, g12s##TYPE); \
- DEBUG_NL; \
- testva##TYPE (13, \
- g1s##TYPE, g2s##TYPE, g3s##TYPE, g4s##TYPE, \
- g5s##TYPE, g6s##TYPE, g7s##TYPE, g8s##TYPE, \
- g9s##TYPE, g10s##TYPE, g11s##TYPE, g12s##TYPE, \
- g13s##TYPE); \
- DEBUG_NL; \
- testva##TYPE (14, \
- g1s##TYPE, g2s##TYPE, g3s##TYPE, g4s##TYPE, \
- g5s##TYPE, g6s##TYPE, g7s##TYPE, g8s##TYPE, \
- g9s##TYPE, g10s##TYPE, g11s##TYPE, g12s##TYPE, \
- g13s##TYPE, g14s##TYPE); \
- DEBUG_NL; \
- testva##TYPE (15, \
- g1s##TYPE, g2s##TYPE, g3s##TYPE, g4s##TYPE, \
- g5s##TYPE, g6s##TYPE, g7s##TYPE, g8s##TYPE, \
- g9s##TYPE, g10s##TYPE, g11s##TYPE, g12s##TYPE, \
- g13s##TYPE, g14s##TYPE, g15s##TYPE); \
- DEBUG_NL; \
- testva##TYPE (16, \
- g1s##TYPE, g2s##TYPE, g3s##TYPE, g4s##TYPE, \
- g5s##TYPE, g6s##TYPE, g7s##TYPE, g8s##TYPE, \
- g9s##TYPE, g10s##TYPE, g11s##TYPE, g12s##TYPE, \
- g13s##TYPE, g14s##TYPE, g15s##TYPE, g16s##TYPE); \
- DEBUG_NL; \
- DEBUG_FPUTS (#TYPE); \
- DEBUG_FPUTS (" test2:"); \
- test2_##TYPE (g1s##TYPE, g3s##TYPE, g5s##TYPE, g7s##TYPE, \
- g9s##TYPE, g11s##TYPE, g13s##TYPE, g15s##TYPE); \
- DEBUG_NL; \
-}
-
-#include "mixed-struct-defs.h"
-#include "mixed-struct-check.h"
-
-T(Sfi)
-T(Sfii)
-T(Sfifi)
-T(Sfiifii)
-
-#undef T
-
-void
-struct_by_value_21_x ()
-{
-DEBUG_INIT
-
-#define T(TYPE) testit##TYPE ();
-
-T(Sfi)
-T(Sfii)
-T(Sfifi)
-T(Sfiifii)
-
-DEBUG_FINI
-
-if (fails != 0)
- abort ();
-
-#undef T
-}
diff --git a/gcc/testsuite/gcc.dg/compat/struct-by-value-21_y.c b/gcc/testsuite/gcc.dg/compat/struct-by-value-21_y.c
deleted file mode 100644
index fc06d9d4fce..00000000000
--- a/gcc/testsuite/gcc.dg/compat/struct-by-value-21_y.c
+++ /dev/null
@@ -1,86 +0,0 @@
-#include <stdarg.h>
-
-#include "compat-common.h"
-
-#ifdef SKIP_VA
-const int test_va = 0;
-#else
-const int test_va = 1;
-#endif
-
-#include "mixed-struct-defs.h"
-#include "mixed-struct-init.h"
-
-#define T(TYPE) \
-extern void check##TYPE (TYPE x, int i); \
-extern TYPE g1s##TYPE, g2s##TYPE, g3s##TYPE, g4s##TYPE; \
-extern TYPE g5s##TYPE, g6s##TYPE, g7s##TYPE, g8s##TYPE; \
-extern TYPE g9s##TYPE, g10s##TYPE, g11s##TYPE, g12s##TYPE; \
-extern TYPE g13s##TYPE, g14s##TYPE, g15s##TYPE, g16s##TYPE; \
- \
-void \
-checkg##TYPE (void) \
-{ \
- check##TYPE ( g1s##TYPE, 1); \
- check##TYPE ( g2s##TYPE, 2); \
- check##TYPE ( g3s##TYPE, 3); \
- check##TYPE ( g4s##TYPE, 4); \
- check##TYPE ( g5s##TYPE, 5); \
- check##TYPE ( g6s##TYPE, 6); \
- check##TYPE ( g7s##TYPE, 7); \
- check##TYPE ( g8s##TYPE, 8); \
- check##TYPE ( g9s##TYPE, 9); \
- check##TYPE ( g10s##TYPE, 10); \
- check##TYPE ( g11s##TYPE, 11); \
- check##TYPE ( g12s##TYPE, 12); \
- check##TYPE ( g13s##TYPE, 13); \
- check##TYPE ( g14s##TYPE, 14); \
- check##TYPE ( g15s##TYPE, 15); \
- check##TYPE ( g16s##TYPE, 16); \
-} \
- \
-void \
-test##TYPE (TYPE s1, TYPE s2, TYPE s3, TYPE s4, \
- TYPE s5, TYPE s6, TYPE s7, TYPE s8, \
- TYPE s9, TYPE s10, TYPE s11, TYPE s12, \
- TYPE s13, TYPE s14, TYPE s15, TYPE s16) \
-{ \
- check##TYPE (s1, 1); \
- check##TYPE (s2, 2); \
- check##TYPE (s3, 3); \
- check##TYPE (s4, 4); \
- check##TYPE (s5, 5); \
- check##TYPE (s6, 6); \
- check##TYPE (s7, 7); \
- check##TYPE (s8, 8); \
- check##TYPE (s9, 9); \
- check##TYPE (s10, 10); \
- check##TYPE (s11, 11); \
- check##TYPE (s12, 12); \
- check##TYPE (s13, 13); \
- check##TYPE (s14, 14); \
- check##TYPE (s15, 15); \
- check##TYPE (s16, 16); \
-} \
- \
-void \
-testva##TYPE (int n, ...) \
-{ \
- int i; \
- va_list ap; \
- if (test_va) \
- { \
- va_start (ap, n); \
- for (i = 0; i < n; i++) \
- { \
- TYPE t = va_arg (ap, TYPE); \
- check##TYPE (t, i+1); \
- } \
- va_end (ap); \
- } \
-}
-
-T(Sfi)
-T(Sfii)
-T(Sfifi)
-T(Sfiifii)
diff --git a/gcc/testsuite/gcc.dg/compat/struct-return-21_main.c b/gcc/testsuite/gcc.dg/compat/struct-return-21_main.c
deleted file mode 100644
index 34e0ab42996..00000000000
--- a/gcc/testsuite/gcc.dg/compat/struct-return-21_main.c
+++ /dev/null
@@ -1,13 +0,0 @@
-/* Test function return values. This was written when correcting
- a deviation from the ABI on SPARC64 between 3.3 and 3.4. */
-
-extern void struct_return_21_x (void);
-extern void exit (int);
-int fails;
-
-int
-main ()
-{
- struct_return_21_x ();
- exit (0);
-}
diff --git a/gcc/testsuite/gcc.dg/compat/struct-return-21_x.c b/gcc/testsuite/gcc.dg/compat/struct-return-21_x.c
deleted file mode 100644
index 721deff036e..00000000000
--- a/gcc/testsuite/gcc.dg/compat/struct-return-21_x.c
+++ /dev/null
@@ -1,112 +0,0 @@
-#include "compat-common.h"
-
-#ifdef SKIP_VA
-const int test_va = 0;
-#else
-const int test_va = 1;
-#endif
-
-#define T(TYPE) \
-TYPE g01##TYPE, g02##TYPE, g03##TYPE, g04##TYPE; \
-TYPE g05##TYPE, g06##TYPE, g07##TYPE, g08##TYPE; \
-TYPE g09##TYPE, g10##TYPE, g11##TYPE, g12##TYPE; \
-TYPE g13##TYPE, g14##TYPE, g15##TYPE, g16##TYPE; \
- \
-extern void init##TYPE (TYPE *p, int i); \
-extern void checkg##TYPE (void); \
-extern TYPE test0##TYPE (void); \
-extern TYPE test1##TYPE (TYPE); \
-extern TYPE testva##TYPE (int n, ...); \
- \
-void \
-testit##TYPE (void) \
-{ \
- TYPE rslt; \
- DEBUG_FPUTS (#TYPE); \
- DEBUG_FPUTS (" init: "); \
- init##TYPE (&g01##TYPE, 1); \
- init##TYPE (&g02##TYPE, 2); \
- init##TYPE (&g03##TYPE, 3); \
- init##TYPE (&g04##TYPE, 4); \
- init##TYPE (&g05##TYPE, 5); \
- init##TYPE (&g06##TYPE, 6); \
- init##TYPE (&g07##TYPE, 7); \
- init##TYPE (&g08##TYPE, 8); \
- init##TYPE (&g09##TYPE, 9); \
- init##TYPE (&g10##TYPE, 10); \
- init##TYPE (&g11##TYPE, 11); \
- init##TYPE (&g12##TYPE, 12); \
- init##TYPE (&g13##TYPE, 13); \
- init##TYPE (&g14##TYPE, 14); \
- init##TYPE (&g15##TYPE, 15); \
- init##TYPE (&g16##TYPE, 16); \
- checkg##TYPE (); \
- DEBUG_NL; \
- DEBUG_FPUTS (#TYPE); \
- DEBUG_FPUTS (" test0: "); \
- rslt = test0##TYPE (); \
- check##TYPE (rslt, 1); \
- DEBUG_NL; \
- DEBUG_FPUTS (#TYPE); \
- DEBUG_FPUTS (" test1: "); \
- rslt = test1##TYPE (g01##TYPE); \
- check##TYPE (rslt, 1); \
- if (test_va) \
- { \
- DEBUG_NL; \
- DEBUG_FPUTS (#TYPE); \
- DEBUG_FPUTS (" testva: "); \
- rslt = testva##TYPE (1, g01##TYPE); \
- check##TYPE (rslt, 1); \
- rslt = testva##TYPE (5, g01##TYPE, g02##TYPE, \
- g03##TYPE, g04##TYPE, \
- g05##TYPE); \
- check##TYPE (rslt, 5); \
- rslt = testva##TYPE (9, g01##TYPE, g02##TYPE, \
- g03##TYPE, g04##TYPE, \
- g05##TYPE, g06##TYPE, \
- g07##TYPE, g08##TYPE, \
- g09##TYPE); \
- check##TYPE (rslt, 9); \
- rslt = testva##TYPE (16, g01##TYPE, g02##TYPE, \
- g03##TYPE, g04##TYPE, \
- g05##TYPE, g06##TYPE, \
- g07##TYPE, g08##TYPE, \
- g09##TYPE, g10##TYPE, \
- g11##TYPE, g12##TYPE, \
- g13##TYPE, g14##TYPE, \
- g15##TYPE, g16##TYPE); \
- check##TYPE (rslt, 16); \
- } \
- DEBUG_NL; \
-}
-
-#include "mixed-struct-defs.h"
-#include "mixed-struct-check.h"
-
-T(Sfi)
-T(Sfii)
-T(Sfifi)
-T(Sfiifii)
-
-#undef T
-
-void
-struct_return_21_x ()
-{
-DEBUG_INIT
-
-#define T(TYPE) testit##TYPE ();
-
-T(Sfi)
-T(Sfii)
-T(Sfifi)
-T(Sfiifii)
-
-DEBUG_FINI
-
-if (fails != 0)
- abort ();
-
-#undef T
-}
diff --git a/gcc/testsuite/gcc.dg/compat/struct-return-21_y.c b/gcc/testsuite/gcc.dg/compat/struct-return-21_y.c
deleted file mode 100644
index b44d7f58e69..00000000000
--- a/gcc/testsuite/gcc.dg/compat/struct-return-21_y.c
+++ /dev/null
@@ -1,65 +0,0 @@
-#include <stdarg.h>
-
-#include "compat-common.h"
-
-#include "mixed-struct-defs.h"
-#include "mixed-struct-init.h"
-
-#define T(TYPE) \
-extern TYPE g01##TYPE, g02##TYPE, g03##TYPE, g04##TYPE; \
-extern TYPE g05##TYPE, g06##TYPE, g07##TYPE, g08##TYPE; \
-extern TYPE g09##TYPE, g10##TYPE, g11##TYPE, g12##TYPE; \
-extern TYPE g13##TYPE, g14##TYPE, g15##TYPE, g16##TYPE; \
- \
-extern void check##TYPE (TYPE x, int i); \
- \
-void \
-checkg##TYPE (void) \
-{ \
- check##TYPE (g01##TYPE, 1); \
- check##TYPE (g02##TYPE, 2); \
- check##TYPE (g03##TYPE, 3); \
- check##TYPE (g04##TYPE, 4); \
- check##TYPE (g05##TYPE, 5); \
- check##TYPE (g06##TYPE, 6); \
- check##TYPE (g07##TYPE, 7); \
- check##TYPE (g08##TYPE, 8); \
- check##TYPE (g09##TYPE, 9); \
- check##TYPE (g10##TYPE, 10); \
- check##TYPE (g11##TYPE, 11); \
- check##TYPE (g12##TYPE, 12); \
- check##TYPE (g13##TYPE, 13); \
- check##TYPE (g14##TYPE, 14); \
- check##TYPE (g15##TYPE, 15); \
- check##TYPE (g16##TYPE, 16); \
-} \
- \
-TYPE \
-test0##TYPE (void) \
-{ \
- return g01##TYPE; \
-} \
- \
-TYPE \
-test1##TYPE (TYPE x01) \
-{ \
- return x01; \
-} \
- \
-TYPE \
-testva##TYPE (int n, ...) \
-{ \
- int i; \
- TYPE rslt; \
- va_list ap; \
- va_start (ap, n); \
- for (i = 0; i < n; i++) \
- rslt = va_arg (ap, TYPE); \
- va_end (ap); \
- return rslt; \
-}
-
-T(Sfi)
-T(Sfii)
-T(Sfifi)
-T(Sfiifii)
diff --git a/gcc/testsuite/gcc.dg/compat/union-by-value-1_main.c b/gcc/testsuite/gcc.dg/compat/union-by-value-1_main.c
deleted file mode 100644
index cd9065920f6..00000000000
--- a/gcc/testsuite/gcc.dg/compat/union-by-value-1_main.c
+++ /dev/null
@@ -1,13 +0,0 @@
-/* Test function argument passing. This was written when correcting
- a deviation from the ABI on SPARC64 between 3.3 and 3.4. */
-
-extern void union_by_value_1_x (void);
-extern void exit (int);
-int fails;
-
-int
-main ()
-{
- union_by_value_1_x ();
- exit (0);
-}
diff --git a/gcc/testsuite/gcc.dg/compat/union-by-value-1_x.c b/gcc/testsuite/gcc.dg/compat/union-by-value-1_x.c
deleted file mode 100644
index a3efd4ed7d8..00000000000
--- a/gcc/testsuite/gcc.dg/compat/union-by-value-1_x.c
+++ /dev/null
@@ -1,180 +0,0 @@
-#include "compat-common.h"
-
-#define T(TYPE) \
-TYPE g1s##TYPE, g2s##TYPE, g3s##TYPE, g4s##TYPE; \
-TYPE g5s##TYPE, g6s##TYPE, g7s##TYPE, g8s##TYPE; \
-TYPE g9s##TYPE, g10s##TYPE, g11s##TYPE, g12s##TYPE; \
-TYPE g13s##TYPE, g14s##TYPE, g15s##TYPE, g16s##TYPE; \
- \
-extern void init##TYPE (TYPE *p, int i); \
-extern void checkg##TYPE (void); \
-extern void \
-test##TYPE (TYPE s1, TYPE s2, TYPE s3, TYPE s4, \
- TYPE s5, TYPE s6, TYPE s7, TYPE s8, \
- TYPE s9, TYPE s10, TYPE s11, TYPE s12, \
- TYPE s13, TYPE s14, TYPE s15, TYPE s16); \
-extern void testva##TYPE (int n, ...); \
- \
-void \
-test2_##TYPE (TYPE s1, TYPE s2, TYPE s3, TYPE s4, \
- TYPE s5, TYPE s6, TYPE s7, TYPE s8) \
-{ \
- test##TYPE (s1, g2s##TYPE, s2, g4s##TYPE, \
- s3, g6s##TYPE, s4, g8s##TYPE, \
- s5, g10s##TYPE, s6, g12s##TYPE, \
- s7, g14s##TYPE, s8, g16s##TYPE); \
-} \
- \
-void \
-testit##TYPE (void) \
-{ \
- DEBUG_FPUTS (#TYPE); \
- DEBUG_FPUTS (" init: "); \
- init##TYPE ( &g1s##TYPE, 1); \
- init##TYPE ( &g2s##TYPE, 2); \
- init##TYPE ( &g3s##TYPE, 3); \
- init##TYPE ( &g4s##TYPE, 4); \
- init##TYPE ( &g5s##TYPE, 5); \
- init##TYPE ( &g6s##TYPE, 6); \
- init##TYPE ( &g7s##TYPE, 7); \
- init##TYPE ( &g8s##TYPE, 8); \
- init##TYPE ( &g9s##TYPE, 9); \
- init##TYPE (&g10s##TYPE, 10); \
- init##TYPE (&g11s##TYPE, 11); \
- init##TYPE (&g12s##TYPE, 12); \
- init##TYPE (&g13s##TYPE, 13); \
- init##TYPE (&g14s##TYPE, 14); \
- init##TYPE (&g15s##TYPE, 15); \
- init##TYPE (&g16s##TYPE, 16); \
- checkg##TYPE (); \
- DEBUG_NL; \
- DEBUG_FPUTS (#TYPE); \
- DEBUG_FPUTS (" test: "); \
- test##TYPE (g1s##TYPE, g2s##TYPE, g3s##TYPE, g4s##TYPE, \
- g5s##TYPE, g6s##TYPE, g7s##TYPE, g8s##TYPE, \
- g9s##TYPE, g10s##TYPE, g11s##TYPE, g12s##TYPE, \
- g13s##TYPE, g14s##TYPE, g15s##TYPE, g16s##TYPE); \
- DEBUG_NL; \
- DEBUG_FPUTS (#TYPE); \
- DEBUG_FPUTS (" testva:"); \
- DEBUG_NL; \
- testva##TYPE (1, \
- g1s##TYPE); \
- DEBUG_NL; \
- testva##TYPE (2, \
- g1s##TYPE, g2s##TYPE); \
- DEBUG_NL; \
- testva##TYPE (3, \
- g1s##TYPE, g2s##TYPE, g3s##TYPE); \
- DEBUG_NL; \
- testva##TYPE (4, \
- g1s##TYPE, g2s##TYPE, g3s##TYPE, g4s##TYPE); \
- DEBUG_NL; \
- testva##TYPE (5, \
- g1s##TYPE, g2s##TYPE, g3s##TYPE, g4s##TYPE, \
- g5s##TYPE); \
- DEBUG_NL; \
- testva##TYPE (6, \
- g1s##TYPE, g2s##TYPE, g3s##TYPE, g4s##TYPE, \
- g5s##TYPE, g6s##TYPE); \
- DEBUG_NL; \
- testva##TYPE (7, \
- g1s##TYPE, g2s##TYPE, g3s##TYPE, g4s##TYPE, \
- g5s##TYPE, g6s##TYPE, g7s##TYPE); \
- DEBUG_NL; \
- testva##TYPE (8, \
- g1s##TYPE, g2s##TYPE, g3s##TYPE, g4s##TYPE, \
- g5s##TYPE, g6s##TYPE, g7s##TYPE, g8s##TYPE); \
- DEBUG_NL; \
- testva##TYPE (9, \
- g1s##TYPE, g2s##TYPE, g3s##TYPE, g4s##TYPE, \
- g5s##TYPE, g6s##TYPE, g7s##TYPE, g8s##TYPE, \
- g9s##TYPE); \
- DEBUG_NL; \
- testva##TYPE (10, \
- g1s##TYPE, g2s##TYPE, g3s##TYPE, g4s##TYPE, \
- g5s##TYPE, g6s##TYPE, g7s##TYPE, g8s##TYPE, \
- g9s##TYPE, g10s##TYPE); \
- DEBUG_NL; \
- testva##TYPE (11, \
- g1s##TYPE, g2s##TYPE, g3s##TYPE, g4s##TYPE, \
- g5s##TYPE, g6s##TYPE, g7s##TYPE, g8s##TYPE, \
- g9s##TYPE, g10s##TYPE, g11s##TYPE); \
- DEBUG_NL; \
- testva##TYPE (12, \
- g1s##TYPE, g2s##TYPE, g3s##TYPE, g4s##TYPE, \
- g5s##TYPE, g6s##TYPE, g7s##TYPE, g8s##TYPE, \
- g9s##TYPE, g10s##TYPE, g11s##TYPE, g12s##TYPE); \
- DEBUG_NL; \
- testva##TYPE (13, \
- g1s##TYPE, g2s##TYPE, g3s##TYPE, g4s##TYPE, \
- g5s##TYPE, g6s##TYPE, g7s##TYPE, g8s##TYPE, \
- g9s##TYPE, g10s##TYPE, g11s##TYPE, g12s##TYPE, \
- g13s##TYPE); \
- DEBUG_NL; \
- testva##TYPE (14, \
- g1s##TYPE, g2s##TYPE, g3s##TYPE, g4s##TYPE, \
- g5s##TYPE, g6s##TYPE, g7s##TYPE, g8s##TYPE, \
- g9s##TYPE, g10s##TYPE, g11s##TYPE, g12s##TYPE, \
- g13s##TYPE, g14s##TYPE); \
- DEBUG_NL; \
- testva##TYPE (15, \
- g1s##TYPE, g2s##TYPE, g3s##TYPE, g4s##TYPE, \
- g5s##TYPE, g6s##TYPE, g7s##TYPE, g8s##TYPE, \
- g9s##TYPE, g10s##TYPE, g11s##TYPE, g12s##TYPE, \
- g13s##TYPE, g14s##TYPE, g15s##TYPE); \
- DEBUG_NL; \
- testva##TYPE (16, \
- g1s##TYPE, g2s##TYPE, g3s##TYPE, g4s##TYPE, \
- g5s##TYPE, g6s##TYPE, g7s##TYPE, g8s##TYPE, \
- g9s##TYPE, g10s##TYPE, g11s##TYPE, g12s##TYPE, \
- g13s##TYPE, g14s##TYPE, g15s##TYPE, g16s##TYPE); \
- DEBUG_NL; \
- DEBUG_FPUTS (#TYPE); \
- DEBUG_FPUTS (" test2:"); \
- test2_##TYPE (g1s##TYPE, g3s##TYPE, g5s##TYPE, g7s##TYPE, \
- g9s##TYPE, g11s##TYPE, g13s##TYPE, g15s##TYPE); \
- DEBUG_NL; \
-}
-
-#include "union-defs.h"
-#include "union-check.h"
-
-T(Ucs)
-T(Uci)
-T(Ucl)
-T(Ucll)
-T(Usi)
-T(Usl)
-T(Usll)
-T(Uil)
-T(Uill)
-T(Ulll)
-
-#undef T
-
-void
-union_by_value_1_x ()
-{
-DEBUG_INIT
-
-#define T(TYPE) testit##TYPE ();
-
-T(Ucs)
-T(Uci)
-T(Ucl)
-T(Ucll)
-T(Usi)
-T(Usl)
-T(Usll)
-T(Uil)
-T(Uill)
-T(Ulll)
-
-DEBUG_FINI
-
-if (fails != 0)
- abort ();
-
-#undef T
-}
diff --git a/gcc/testsuite/gcc.dg/compat/union-by-value-1_y.c b/gcc/testsuite/gcc.dg/compat/union-by-value-1_y.c
deleted file mode 100644
index b17613e9952..00000000000
--- a/gcc/testsuite/gcc.dg/compat/union-by-value-1_y.c
+++ /dev/null
@@ -1,92 +0,0 @@
-#include <stdarg.h>
-
-#include "compat-common.h"
-
-#ifdef SKIP_VA
-const int test_va = 0;
-#else
-const int test_va = 1;
-#endif
-
-#include "union-defs.h"
-#include "union-init.h"
-
-#define T(TYPE) \
-extern void check##TYPE (TYPE x, int i); \
-extern TYPE g1s##TYPE, g2s##TYPE, g3s##TYPE, g4s##TYPE; \
-extern TYPE g5s##TYPE, g6s##TYPE, g7s##TYPE, g8s##TYPE; \
-extern TYPE g9s##TYPE, g10s##TYPE, g11s##TYPE, g12s##TYPE; \
-extern TYPE g13s##TYPE, g14s##TYPE, g15s##TYPE, g16s##TYPE; \
- \
-void \
-checkg##TYPE (void) \
-{ \
- check##TYPE ( g1s##TYPE, 1); \
- check##TYPE ( g2s##TYPE, 2); \
- check##TYPE ( g3s##TYPE, 3); \
- check##TYPE ( g4s##TYPE, 4); \
- check##TYPE ( g5s##TYPE, 5); \
- check##TYPE ( g6s##TYPE, 6); \
- check##TYPE ( g7s##TYPE, 7); \
- check##TYPE ( g8s##TYPE, 8); \
- check##TYPE ( g9s##TYPE, 9); \
- check##TYPE ( g10s##TYPE, 10); \
- check##TYPE ( g11s##TYPE, 11); \
- check##TYPE ( g12s##TYPE, 12); \
- check##TYPE ( g13s##TYPE, 13); \
- check##TYPE ( g14s##TYPE, 14); \
- check##TYPE ( g15s##TYPE, 15); \
- check##TYPE ( g16s##TYPE, 16); \
-} \
- \
-void \
-test##TYPE (TYPE s1, TYPE s2, TYPE s3, TYPE s4, \
- TYPE s5, TYPE s6, TYPE s7, TYPE s8, \
- TYPE s9, TYPE s10, TYPE s11, TYPE s12, \
- TYPE s13, TYPE s14, TYPE s15, TYPE s16) \
-{ \
- check##TYPE (s1, 1); \
- check##TYPE (s2, 2); \
- check##TYPE (s3, 3); \
- check##TYPE (s4, 4); \
- check##TYPE (s5, 5); \
- check##TYPE (s6, 6); \
- check##TYPE (s7, 7); \
- check##TYPE (s8, 8); \
- check##TYPE (s9, 9); \
- check##TYPE (s10, 10); \
- check##TYPE (s11, 11); \
- check##TYPE (s12, 12); \
- check##TYPE (s13, 13); \
- check##TYPE (s14, 14); \
- check##TYPE (s15, 15); \
- check##TYPE (s16, 16); \
-} \
- \
-void \
-testva##TYPE (int n, ...) \
-{ \
- int i; \
- va_list ap; \
- if (test_va) \
- { \
- va_start (ap, n); \
- for (i = 0; i < n; i++) \
- { \
- TYPE t = va_arg (ap, TYPE); \
- check##TYPE (t, i+1); \
- } \
- va_end (ap); \
- } \
-}
-
-T(Ucs)
-T(Uci)
-T(Ucl)
-T(Ucll)
-T(Usi)
-T(Usl)
-T(Usll)
-T(Uil)
-T(Uill)
-T(Ulll)
diff --git a/gcc/testsuite/gcc.dg/compat/union-check.h b/gcc/testsuite/gcc.dg/compat/union-check.h
deleted file mode 100644
index b5157814d58..00000000000
--- a/gcc/testsuite/gcc.dg/compat/union-check.h
+++ /dev/null
@@ -1,34 +0,0 @@
-/* Function definitions that are used by multiple tests. */
-
-#define CHECK_CHAR(TYPE) \
- void check##TYPE (TYPE p, int i) \
- { if (p.c != (char)i) DEBUG_CHECK }
-
-CHECK_CHAR(Ucs)
-CHECK_CHAR(Uci)
-CHECK_CHAR(Ucl)
-CHECK_CHAR(Ucll)
-
-
-#define CHECK_SHORT(TYPE) \
- void check##TYPE (TYPE p, int i) \
- { if (p.s != (short)i) DEBUG_CHECK }
-
-CHECK_SHORT(Usi)
-CHECK_SHORT(Usl)
-CHECK_SHORT(Usll)
-
-
-#define CHECK_INT(TYPE) \
- void check##TYPE (TYPE p, int i) \
- { if (p.i != i) DEBUG_CHECK }
-
-CHECK_INT(Uil)
-CHECK_INT(Uill)
-
-
-#define CHECK_LONG(TYPE) \
- void check##TYPE (TYPE p, int i) \
- { if (p.l != (long)i) DEBUG_CHECK }
-
-CHECK_LONG(Ulll)
diff --git a/gcc/testsuite/gcc.dg/compat/union-defs.h b/gcc/testsuite/gcc.dg/compat/union-defs.h
deleted file mode 100644
index 887cd6da8e8..00000000000
--- a/gcc/testsuite/gcc.dg/compat/union-defs.h
+++ /dev/null
@@ -1,15 +0,0 @@
-/* Type definitions that are used by multiple tests. */
-
-typedef union { char c; short s; } Ucs;
-typedef union { char c; int i; } Uci;
-typedef union { char c; long l; } Ucl;
-typedef union { char c; long long ll; } Ucll;
-
-typedef union { short s; int i; } Usi;
-typedef union { short s; long l; } Usl;
-typedef union { short s; long long ll; } Usll;
-
-typedef union { int i; long l; } Uil;
-typedef union { int i; long long ll; } Uill;
-
-typedef union { long l; long long ll; } Ulll;
diff --git a/gcc/testsuite/gcc.dg/compat/union-init.h b/gcc/testsuite/gcc.dg/compat/union-init.h
deleted file mode 100644
index 5add7b4a800..00000000000
--- a/gcc/testsuite/gcc.dg/compat/union-init.h
+++ /dev/null
@@ -1,34 +0,0 @@
-/* Function definitions that are used by multiple tests. */
-
-#define INIT_CHAR(TYPE) \
- void init##TYPE (TYPE *p, int i) \
- { p->c = (char)i; }
-
-INIT_CHAR(Ucs)
-INIT_CHAR(Uci)
-INIT_CHAR(Ucl)
-INIT_CHAR(Ucll)
-
-
-#define INIT_SHORT(TYPE) \
- void init##TYPE (TYPE *p, int i) \
- { p->s = (short)i; }
-
-INIT_SHORT(Usi)
-INIT_SHORT(Usl)
-INIT_SHORT(Usll)
-
-
-#define INIT_INT(TYPE) \
- void init##TYPE (TYPE *p, int i) \
- { p->i = i; }
-
-INIT_INT(Uil)
-INIT_INT(Uill)
-
-
-#define INIT_LONG(TYPE) \
- void init##TYPE (TYPE *p, int i) \
- { p->l = (long)i; }
-
-INIT_LONG(Ulll)
diff --git a/gcc/testsuite/gcc.dg/compat/union-return-1_main.c b/gcc/testsuite/gcc.dg/compat/union-return-1_main.c
deleted file mode 100644
index edf15166b95..00000000000
--- a/gcc/testsuite/gcc.dg/compat/union-return-1_main.c
+++ /dev/null
@@ -1,13 +0,0 @@
-/* Test function return values. This was written when correcting
- a deviation from the ABI on SPARC64 between 3.3 and 3.4. */
-
-extern void union_return_1_x (void);
-extern void exit (int);
-int fails;
-
-int
-main ()
-{
- union_return_1_x ();
- exit (0);
-}
diff --git a/gcc/testsuite/gcc.dg/compat/union-return-1_x.c b/gcc/testsuite/gcc.dg/compat/union-return-1_x.c
deleted file mode 100644
index 761f000aa11..00000000000
--- a/gcc/testsuite/gcc.dg/compat/union-return-1_x.c
+++ /dev/null
@@ -1,124 +0,0 @@
-#include "compat-common.h"
-
-#ifdef SKIP_VA
-const int test_va = 0;
-#else
-const int test_va = 1;
-#endif
-
-#define T(TYPE) \
-TYPE g01##TYPE, g02##TYPE, g03##TYPE, g04##TYPE; \
-TYPE g05##TYPE, g06##TYPE, g07##TYPE, g08##TYPE; \
-TYPE g09##TYPE, g10##TYPE, g11##TYPE, g12##TYPE; \
-TYPE g13##TYPE, g14##TYPE, g15##TYPE, g16##TYPE; \
- \
-extern void init##TYPE (TYPE *p, int i); \
-extern void checkg##TYPE (void); \
-extern TYPE test0##TYPE (void); \
-extern TYPE test1##TYPE (TYPE); \
-extern TYPE testva##TYPE (int n, ...); \
- \
-void \
-testit##TYPE (void) \
-{ \
- TYPE rslt; \
- DEBUG_FPUTS (#TYPE); \
- DEBUG_FPUTS (" init: "); \
- init##TYPE (&g01##TYPE, 1); \
- init##TYPE (&g02##TYPE, 2); \
- init##TYPE (&g03##TYPE, 3); \
- init##TYPE (&g04##TYPE, 4); \
- init##TYPE (&g05##TYPE, 5); \
- init##TYPE (&g06##TYPE, 6); \
- init##TYPE (&g07##TYPE, 7); \
- init##TYPE (&g08##TYPE, 8); \
- init##TYPE (&g09##TYPE, 9); \
- init##TYPE (&g10##TYPE, 10); \
- init##TYPE (&g11##TYPE, 11); \
- init##TYPE (&g12##TYPE, 12); \
- init##TYPE (&g13##TYPE, 13); \
- init##TYPE (&g14##TYPE, 14); \
- init##TYPE (&g15##TYPE, 15); \
- init##TYPE (&g16##TYPE, 16); \
- checkg##TYPE (); \
- DEBUG_NL; \
- DEBUG_FPUTS (#TYPE); \
- DEBUG_FPUTS (" test0: "); \
- rslt = test0##TYPE (); \
- check##TYPE (rslt, 1); \
- DEBUG_NL; \
- DEBUG_FPUTS (#TYPE); \
- DEBUG_FPUTS (" test1: "); \
- rslt = test1##TYPE (g01##TYPE); \
- check##TYPE (rslt, 1); \
- if (test_va) \
- { \
- DEBUG_NL; \
- DEBUG_FPUTS (#TYPE); \
- DEBUG_FPUTS (" testva: "); \
- rslt = testva##TYPE (1, g01##TYPE); \
- check##TYPE (rslt, 1); \
- rslt = testva##TYPE (5, g01##TYPE, g02##TYPE, \
- g03##TYPE, g04##TYPE, \
- g05##TYPE); \
- check##TYPE (rslt, 5); \
- rslt = testva##TYPE (9, g01##TYPE, g02##TYPE, \
- g03##TYPE, g04##TYPE, \
- g05##TYPE, g06##TYPE, \
- g07##TYPE, g08##TYPE, \
- g09##TYPE); \
- check##TYPE (rslt, 9); \
- rslt = testva##TYPE (16, g01##TYPE, g02##TYPE, \
- g03##TYPE, g04##TYPE, \
- g05##TYPE, g06##TYPE, \
- g07##TYPE, g08##TYPE, \
- g09##TYPE, g10##TYPE, \
- g11##TYPE, g12##TYPE, \
- g13##TYPE, g14##TYPE, \
- g15##TYPE, g16##TYPE); \
- check##TYPE (rslt, 16); \
- } \
- DEBUG_NL; \
-}
-
-#include "union-defs.h"
-#include "union-check.h"
-
-T(Ucs)
-T(Uci)
-T(Ucl)
-T(Ucll)
-T(Usi)
-T(Usl)
-T(Usll)
-T(Uil)
-T(Uill)
-T(Ulll)
-
-#undef T
-
-void
-union_return_1_x ()
-{
-DEBUG_INIT
-
-#define T(TYPE) testit##TYPE ();
-
-T(Ucs)
-T(Uci)
-T(Ucl)
-T(Ucll)
-T(Usi)
-T(Usl)
-T(Usll)
-T(Uil)
-T(Uill)
-T(Ulll)
-
-DEBUG_FINI
-
-if (fails != 0)
- abort ();
-
-#undef T
-}
diff --git a/gcc/testsuite/gcc.dg/compat/union-return-1_y.c b/gcc/testsuite/gcc.dg/compat/union-return-1_y.c
deleted file mode 100644
index 9eaa9777e0a..00000000000
--- a/gcc/testsuite/gcc.dg/compat/union-return-1_y.c
+++ /dev/null
@@ -1,71 +0,0 @@
-#include <stdarg.h>
-
-#include "compat-common.h"
-
-#include "union-defs.h"
-#include "union-init.h"
-
-#define T(TYPE) \
-extern TYPE g01##TYPE, g02##TYPE, g03##TYPE, g04##TYPE; \
-extern TYPE g05##TYPE, g06##TYPE, g07##TYPE, g08##TYPE; \
-extern TYPE g09##TYPE, g10##TYPE, g11##TYPE, g12##TYPE; \
-extern TYPE g13##TYPE, g14##TYPE, g15##TYPE, g16##TYPE; \
- \
-extern void check##TYPE (TYPE x, int i); \
- \
-void \
-checkg##TYPE (void) \
-{ \
- check##TYPE (g01##TYPE, 1); \
- check##TYPE (g02##TYPE, 2); \
- check##TYPE (g03##TYPE, 3); \
- check##TYPE (g04##TYPE, 4); \
- check##TYPE (g05##TYPE, 5); \
- check##TYPE (g06##TYPE, 6); \
- check##TYPE (g07##TYPE, 7); \
- check##TYPE (g08##TYPE, 8); \
- check##TYPE (g09##TYPE, 9); \
- check##TYPE (g10##TYPE, 10); \
- check##TYPE (g11##TYPE, 11); \
- check##TYPE (g12##TYPE, 12); \
- check##TYPE (g13##TYPE, 13); \
- check##TYPE (g14##TYPE, 14); \
- check##TYPE (g15##TYPE, 15); \
- check##TYPE (g16##TYPE, 16); \
-} \
- \
-TYPE \
-test0##TYPE (void) \
-{ \
- return g01##TYPE; \
-} \
- \
-TYPE \
-test1##TYPE (TYPE x01) \
-{ \
- return x01; \
-} \
- \
-TYPE \
-testva##TYPE (int n, ...) \
-{ \
- int i; \
- TYPE rslt; \
- va_list ap; \
- va_start (ap, n); \
- for (i = 0; i < n; i++) \
- rslt = va_arg (ap, TYPE); \
- va_end (ap); \
- return rslt; \
-}
-
-T(Ucs)
-T(Uci)
-T(Ucl)
-T(Ucll)
-T(Usi)
-T(Usl)
-T(Usll)
-T(Uil)
-T(Uill)
-T(Ulll)
diff --git a/gcc/testsuite/gcc.dg/const-cfstring-2.c b/gcc/testsuite/gcc.dg/const-cfstring-2.c
new file mode 100644
index 00000000000..90475112453
--- /dev/null
+++ b/gcc/testsuite/gcc.dg/const-cfstring-2.c
@@ -0,0 +1,13 @@
+/* APPLE LOCAL file constant cfstrings */
+/* Test whether the __builtin__CFStringMakeConstantString
+ "function" fails gracefully when used without the
+ -fconstant-cfstrings flag. */
+/* Developed by Ziemowit Laski <zlaski@apple.com>. */
+
+/* { dg-options "-fno-constant-cfstrings" } */
+/* { dg-do compile { target *-*-darwin* } } */
+
+#include <CoreFoundation/CFBase.h>
+
+const CFStringRef S = ((CFStringRef)__builtin___CFStringMakeConstantString("Testing"));
+/* { dg-error "built-in" "built-in function .* requires .* flag" { target *-*-* } 12 } */
diff --git a/gcc/testsuite/gcc.dg/cpp/c++98-pedantic.cc b/gcc/testsuite/gcc.dg/cpp/c++98-pedantic.cc
new file mode 100644
index 00000000000..1e8c160a96f
--- /dev/null
+++ b/gcc/testsuite/gcc.dg/cpp/c++98-pedantic.cc
@@ -0,0 +1,11 @@
+/* APPLE LOCAL file rename for HFS */
+/* Copyright (C) 2000 Free Software Foundation, Inc. */
+
+/* { dg-do preprocess } */
+/* { dg-options "-std=c++98 -pedantic" } */
+
+/* This file is for testing the preprocessor in -std=c++98 -pedantic mode.
+ Neil Booth, 2 Dec 2000. */
+
+#if 1LL /* { dg-warning "long long" } */
+#endif
diff --git a/gcc/testsuite/gcc.dg/cpp/c++98.cc b/gcc/testsuite/gcc.dg/cpp/c++98.cc
new file mode 100644
index 00000000000..a9843b878fd
--- /dev/null
+++ b/gcc/testsuite/gcc.dg/cpp/c++98.cc
@@ -0,0 +1,11 @@
+/* APPLE LOCAL file rename for HFS */
+/* Copyright (C) 2000 Free Software Foundation, Inc. */
+
+/* { dg-do preprocess } */
+/* { dg-options "-std=c++98" } */
+
+/* This file is for testing the preprocessor in -std=c++98 mode.
+ Neil Booth, 2 Dec 2000. */
+
+#if 1LL
+#endif
diff --git a/gcc/testsuite/gcc.dg/cpp/endif-pedantic2.c b/gcc/testsuite/gcc.dg/cpp/endif-pedantic2.c
index d5c6eb960e6..a5db0fbc80f 100644
--- a/gcc/testsuite/gcc.dg/cpp/endif-pedantic2.c
+++ b/gcc/testsuite/gcc.dg/cpp/endif-pedantic2.c
@@ -1,8 +1,8 @@
/* Copyright (C) 2002 Free Software Foundation, Inc. */
-
/* { dg-do preprocess } */
/* { dg-options "-Wno-endif-labels -pedantic" } */
-
+/* APPLE LOCAL No error emit by Apple's default, use -Wextra-tokens to enable */
+/* { dg-options "-Wextra-tokens -Wno-endif-labels -pedantic" { target *-apple-darwin* } } */
/* Tests combinations of -pedantic and -Wno-endif-labels; see extratokens2.c
for more general tests. */
diff --git a/gcc/testsuite/gcc.dg/cpp/extratokens.c b/gcc/testsuite/gcc.dg/cpp/extratokens.c
index c06a41d4c2b..e57374cef93 100644
--- a/gcc/testsuite/gcc.dg/cpp/extratokens.c
+++ b/gcc/testsuite/gcc.dg/cpp/extratokens.c
@@ -1,7 +1,8 @@
/* Copyright (C) 2000 Free Software Foundation, Inc. */
/* { dg-do preprocess } */
-/* { dg-options "-fno-show-column" } */
+/* APPLE LOCAL Wextra-tokens */
+/* { dg-options "-fno-show-column -Wextra-tokens" } */
/* Tests all directives that do not permit excess tokens at the end of
the line. */
diff --git a/gcc/testsuite/gcc.dg/cpp/if-2.c b/gcc/testsuite/gcc.dg/cpp/if-2.c
index 866d25c3a60..6630bf55d65 100644
--- a/gcc/testsuite/gcc.dg/cpp/if-2.c
+++ b/gcc/testsuite/gcc.dg/cpp/if-2.c
@@ -18,6 +18,8 @@
#endif
#if 'abcd' /* { dg-warning "multi-character character constant" "multi-character charconst" } */
+# /* APPLE LOCAL enable the warning with the -Wfour-char-constants flag */
+# /* { dg-options "-Wfour-char-constants" { target *-apple-darwin* } } */
#endif
#if 'abcdefghi' /* { dg-error "character constant (is )?too long" "charconst too long" } */
diff --git a/gcc/testsuite/gcc.dg/cpp/include2.c b/gcc/testsuite/gcc.dg/cpp/include2.c
index 60edfccb0cd..e935703b614 100644
--- a/gcc/testsuite/gcc.dg/cpp/include2.c
+++ b/gcc/testsuite/gcc.dg/cpp/include2.c
@@ -1,10 +1,10 @@
/* Copyright (C) 2000 Free Software Foundation, Inc. */
/* { dg-do preprocess } */
-
+/* APPLE LOCAL BEGIN Apple disable this warning by default */
/* Tests that #include does not allow the terminating '>' or '"' to be
escaped, as per the standard. */
-
+/* { dg-options "-Wextra-tokens" } */
/* Source: Neil Booth, 4 Nov 2000. */
#include <silly\>> /* { dg-warning "extra tokens" "" } */
@@ -13,4 +13,4 @@
/* These error is No such file or directory, just once. However, this
message is locale-dependent, so don't test for it. */
/* { dg-error "silly" "" { target *-*-* } 10 } */
-
+/* APPLE LOCAL END */
diff --git a/gcc/testsuite/gcc.dg/cpp/skipping2.c b/gcc/testsuite/gcc.dg/cpp/skipping2.c
index 3b0d0f32c8e..21378003fe2 100644
--- a/gcc/testsuite/gcc.dg/cpp/skipping2.c
+++ b/gcc/testsuite/gcc.dg/cpp/skipping2.c
@@ -6,6 +6,9 @@
/* Source: Neil Booth, 25 Jul 2001. */
+/* APPLE LOCAL -Wextra-tokens required in Apple's compiler to elicit req'd warnings here */
+/* { dg-options "-Wextra-tokens" } */
+
#if 0
#if foo
#else foo /* { dg-bogus "extra tokens" "extra tokens in skipped block" } */
diff --git a/gcc/testsuite/gcc.dg/cpp/sysmac2.c b/gcc/testsuite/gcc.dg/cpp/sysmac2.c
index 0d1efabdc07..19ddf6ccb94 100644
--- a/gcc/testsuite/gcc.dg/cpp/sysmac2.c
+++ b/gcc/testsuite/gcc.dg/cpp/sysmac2.c
@@ -1,7 +1,8 @@
/* Copyright (C) 2001 Free Software Foundation, Inc. */
/* { dg-do compile } */
-/* { dg-options "-std=gnu99 -pedantic -Wtraditional -fno-show-column" } */
+/* APPLE LOCAL -Wlong-double */
+/* { dg-options "-std=gnu99 -pedantic -Wtraditional -fno-show-column -Wno-long-double" } */
/* Tests diagnostics are suppressed for some macros defined in system
headers. */
diff --git a/gcc/testsuite/gcc.dg/debug/20020220-1.c b/gcc/testsuite/gcc.dg/debug/20020220-1.c
index 07109e86a98..21bdc22b62b 100644
--- a/gcc/testsuite/gcc.dg/debug/20020220-1.c
+++ b/gcc/testsuite/gcc.dg/debug/20020220-1.c
@@ -3,6 +3,8 @@
constant -4.0 in constant pool was never referenced by anything
but Dwarf-2 location descriptor. */
/* { dg-do run } */
+/* APPLE LOCAL -Wlong-double */
+/* { dg-options "-Wno-long-double" } */
void __attribute__((noinline))
foo (const char *x __attribute__((unused)),
diff --git a/gcc/testsuite/gcc.dg/debug/debug-1.c b/gcc/testsuite/gcc.dg/debug/debug-1.c
index 8cc520dcd79..b6faed04519 100644
--- a/gcc/testsuite/gcc.dg/debug/debug-1.c
+++ b/gcc/testsuite/gcc.dg/debug/debug-1.c
@@ -1,7 +1,8 @@
/* Verify that the scheduler does not discard the lexical block. */
/* { dg-do compile } */
/* { dg-options "-dA" } */
-/* { dg-final { scan-assembler "xyzzy" } } */
+/* APPLE LOCAL xfail for Apple only, serena */
+/* { dg-final { scan-assembler "xyzzy" { xfail *-apple-darwin* } } } */
long p;
diff --git a/gcc/testsuite/gcc.dg/debug/debug-2.c b/gcc/testsuite/gcc.dg/debug/debug-2.c
index b164ff97734..f3a3cf80777 100644
--- a/gcc/testsuite/gcc.dg/debug/debug-2.c
+++ b/gcc/testsuite/gcc.dg/debug/debug-2.c
@@ -1,7 +1,8 @@
/* Verify that the scheduler does not discard the lexical block. */
/* { dg-do compile } */
/* { dg-options "-dA" } */
-/* { dg-final { scan-assembler "xyzzy" } } */
+/* APPLE LOCAL xfail for Apple only, serena */
+/* { dg-final { scan-assembler "xyzzy" { xfail *-apple-darwin* } } } */
long p;
diff --git a/gcc/testsuite/gcc.dg/debug/dwarf2/dwarf-die1.c b/gcc/testsuite/gcc.dg/debug/dwarf2/dwarf-die1.c
deleted file mode 100644
index 39f0bf2792a..00000000000
--- a/gcc/testsuite/gcc.dg/debug/dwarf2/dwarf-die1.c
+++ /dev/null
@@ -1,8 +0,0 @@
-/* Verify that inline function never actually inlined has no abstract DIE. */
-/* { dg-do compile */
-/* { dg-options "-O2 -gdwarf-2 -dA" } */
-/* { dg-final { scan-assembler-not "DW_AT_inline" } } */
-inline int t()
-{
-}
-int (*q)()=t;
diff --git a/gcc/testsuite/gcc.dg/debug/dwarf2/dwarf-die2.c b/gcc/testsuite/gcc.dg/debug/dwarf2/dwarf-die2.c
deleted file mode 100644
index 48bce243d41..00000000000
--- a/gcc/testsuite/gcc.dg/debug/dwarf2/dwarf-die2.c
+++ /dev/null
@@ -1,7 +0,0 @@
-/* Verify that inline function never actually emit has no DIE. */
-/* { dg-do compile */
-/* { dg-options "-O0 -gdwarf-2 -dA" } */
-/* { dg-final { scan-assembler-not "CIE Version" } } */
-static inline int t()
-{
-}
diff --git a/gcc/testsuite/gcc.dg/debug/dwarf2/dwarf-die3.c b/gcc/testsuite/gcc.dg/debug/dwarf2/dwarf-die3.c
deleted file mode 100644
index 34fddfaffc0..00000000000
--- a/gcc/testsuite/gcc.dg/debug/dwarf2/dwarf-die3.c
+++ /dev/null
@@ -1,11 +0,0 @@
-/* Verify that extern inline function never actually inlined has no abstract DIE. */
-/* { dg-do compile */
-/* { dg-options "-O0 -gdwarf-2 -dA" } */
-/* { dg-final { scan-assembler-not "DW_AT_inline" } } */
-extern inline int t()
-{
-}
-int (*q)()=t;
-int t()
-{
-}
diff --git a/gcc/testsuite/gcc.dg/debug/dwarf2/dwarf-die5.c b/gcc/testsuite/gcc.dg/debug/dwarf2/dwarf-die5.c
deleted file mode 100644
index b3a245d2b11..00000000000
--- a/gcc/testsuite/gcc.dg/debug/dwarf2/dwarf-die5.c
+++ /dev/null
@@ -1,12 +0,0 @@
-/* Inlined inline function must have abstract DIE */
-/* { dg-do compile */
-/* { dg-options "-O2 -gdwarf-2 -dA -fpreprocessed" } */
-/* { dg-final { scan-assembler "3.*DW_AT_inline" } } */
-#1 "test.h"
-inline int t()
-{
-}
-int q()
-{
- t();
-}
diff --git a/gcc/testsuite/gcc.dg/debug/dwarf2/dwarf-die6.c b/gcc/testsuite/gcc.dg/debug/dwarf2/dwarf-die6.c
deleted file mode 100644
index 40cdc8dee37..00000000000
--- a/gcc/testsuite/gcc.dg/debug/dwarf2/dwarf-die6.c
+++ /dev/null
@@ -1,12 +0,0 @@
-/* not inline inline function must not have abstract DIE */
-/* { dg-do compile */
-/* { dg-options "-O2 -fno-inline -gdwarf-2 -dA -fpreprocessed" } */
-/* { dg-final { scan-assembler-not "DW_AT_inline" } } */
-#1 "test.h"
-inline int t()
-{
-}
-int q()
-{
- t();
-}
diff --git a/gcc/testsuite/gcc.dg/debug/dwarf2/dwarf-die7.c b/gcc/testsuite/gcc.dg/debug/dwarf2/dwarf-die7.c
deleted file mode 100644
index d8d013af38c..00000000000
--- a/gcc/testsuite/gcc.dg/debug/dwarf2/dwarf-die7.c
+++ /dev/null
@@ -1,14 +0,0 @@
-/* Inlined non-inline function must have abstract DIE */
-/* { dg-do compile */
-/* { dg-options "-O2 -gdwarf-2 -dA -fpreprocessed" } */
-/* { dg-final { scan-assembler "1.*DW_AT_inline" } } */
-#1 "test.h"
-void f(void);
-static int t()
-{
- f();
-}
-int q()
-{
- t();
-}
diff --git a/gcc/testsuite/gcc.dg/dg.exp b/gcc/testsuite/gcc.dg/dg.exp
index 14cf79d7e14..eb11a3a70c5 100644
--- a/gcc/testsuite/gcc.dg/dg.exp
+++ b/gcc/testsuite/gcc.dg/dg.exp
@@ -22,7 +22,7 @@ load_lib gcc-dg.exp
# If a testcase doesn't have special options, use these.
global DEFAULT_CFLAGS
if ![info exists DEFAULT_CFLAGS] then {
- set DEFAULT_CFLAGS " -ansi -pedantic-errors"
+ set DEFAULT_CFLAGS " -ansi -pedantic-errors -Wno-long-double"
}
# Initialize `dg'.
diff --git a/gcc/testsuite/gcc.dg/format/c90-printf-1.c b/gcc/testsuite/gcc.dg/format/c90-printf-1.c
index e4c18f76862..f2a566aa5fa 100644
--- a/gcc/testsuite/gcc.dg/format/c90-printf-1.c
+++ b/gcc/testsuite/gcc.dg/format/c90-printf-1.c
@@ -4,7 +4,8 @@
*/
/* Origin: Joseph Myers <jsm28@cam.ac.uk> */
/* { dg-do compile } */
-/* { dg-options "-std=iso9899:1990 -pedantic -Wformat" } */
+/* APPLE LOCAL -Wlong-double */
+/* { dg-options "-std=iso9899:1990 -pedantic -Wformat -Wno-long-double" } */
#include "format.h"
diff --git a/gcc/testsuite/gcc.dg/format/c90-scanf-1.c b/gcc/testsuite/gcc.dg/format/c90-scanf-1.c
index ea42f1e131e..2a949f937a7 100644
--- a/gcc/testsuite/gcc.dg/format/c90-scanf-1.c
+++ b/gcc/testsuite/gcc.dg/format/c90-scanf-1.c
@@ -4,7 +4,8 @@
*/
/* Origin: Joseph Myers <jsm28@cam.ac.uk> */
/* { dg-do compile } */
-/* { dg-options "-std=iso9899:1990 -pedantic -Wformat" } */
+/* APPLE LOCAL -Wlong-double */
+/* { dg-options "-std=iso9899:1990 -pedantic -Wformat -Wno-long-double" } */
#include "format.h"
diff --git a/gcc/testsuite/gcc.dg/format/strfmon-1.c b/gcc/testsuite/gcc.dg/format/strfmon-1.c
index d163751328c..94c68586f49 100644
--- a/gcc/testsuite/gcc.dg/format/strfmon-1.c
+++ b/gcc/testsuite/gcc.dg/format/strfmon-1.c
@@ -1,7 +1,8 @@
/* Test for strfmon format checking. */
/* Origin: Joseph Myers <jsm28@cam.ac.uk> */
/* { dg-do compile } */
-/* { dg-options "-std=gnu99 -Wformat" } */
+/* APPLE LOCAL -Wlong-double */
+/* { dg-options "-std=gnu99 -Wformat -Wno-long-double" } */
#include "format.h"
diff --git a/gcc/testsuite/gcc.dg/gnu89-dupqual-1.c b/gcc/testsuite/gcc.dg/gnu89-dupqual-1.c
deleted file mode 100644
index 9bd1db01569..00000000000
--- a/gcc/testsuite/gcc.dg/gnu89-dupqual-1.c
+++ /dev/null
@@ -1,12 +0,0 @@
-/* { dg-do compile } */
-/* { dg-options "-std=gnu89 -Werror" } */
-
-typedef const int CI;
-const const int c1; /* { dg-bogus "duplicate" } */
-const CI c2; /* { dg-bogus "duplicate" } */
-const CI *c3; /* { dg-bogus "duplicate" } */
-
-typedef volatile int VI;
-volatile volatile int v1; /* { dg-bogus "duplicate" } */
-volatile VI v2; /* { dg-bogus "duplicate" } */
-volatile VI *v3; /* { dg-bogus "duplicate" } */
diff --git a/gcc/testsuite/gcc.dg/pch/apple-altivec-1.c b/gcc/testsuite/gcc.dg/pch/apple-altivec-1.c
new file mode 100644
index 00000000000..7dc24c0d797
--- /dev/null
+++ b/gcc/testsuite/gcc.dg/pch/apple-altivec-1.c
@@ -0,0 +1,126 @@
+/* APPLE LOCAL file AltiVec */
+/* { dg-do compile { target powerpc-*-darwin* } } */
+/* { dg-options "-faltivec -Wno-long-double -I." } */
+
+#include "apple-altivec-1.h"
+
+/* Test for correct handling of AltiVec constants passed
+ through '...' (va_arg). */
+
+#include <stdarg.h>
+#include <stdio.h>
+#include <stdlib.h>
+
+#define CHECK_INVARIANT(expr) \
+ if (!(expr)) { \
+ printf ("ASSERT FAILED: %d: %s\n", __LINE__, #expr); \
+ abort (); \
+ }
+
+struct foo { int x; int y; };
+struct vfoo { int x; __vector signed int v; int y; };
+union u { __vector signed int v; signed int i[4]; };
+
+struct foo x_g = { 3, 4};
+struct vfoo vx_g = { 10, (vector signed int)(11, 12, 13, 14), 15 };
+__vector signed int v_g = (vector signed int) (22, 23, 24, 25);
+struct vfoo vx2_g = { 30, (vector signed int)(31, 32, 33, 34), 35 };
+__vector signed int v2_g = (vector signed int)(40, 41, 42, 43);
+int i_1 = 99, i_2 = 33;
+double d_2 = 1.5, d_3 = 1.75;
+long double ld_1 = 1.25;
+
+void bar (int i, ... )
+{
+ struct foo xi;
+ double d;
+ long double ld;
+ float f;
+ char c;
+ short s;
+ va_list ap;
+ va_start(ap, i);
+ xi = va_arg(ap, struct foo);
+ s = (short)va_arg(ap, int);
+ f = (float)va_arg(ap, double);
+ ld = va_arg(ap, long double);
+ c = (char)va_arg(ap, int);
+ d = va_arg(ap, double);
+ va_end(ap);
+
+ CHECK_INVARIANT (xi.x == x_g.x && xi.y == x_g.y);
+ CHECK_INVARIANT (s == (short)i_2);
+ CHECK_INVARIANT (f == (float)d_2);
+ CHECK_INVARIANT (ld == ld_1);
+ CHECK_INVARIANT (c == (char)i_1);
+ CHECK_INVARIANT (d == d_3);
+}
+
+void baz (int i, ... )
+{
+ struct vfoo vx, vx2;
+ __vector signed int v_i, v2_i;
+ int j, k, l;
+ va_list ap;
+ va_start(ap, i);
+ v_i = va_arg(ap, __vector signed int);
+ j = va_arg(ap, int);
+ vx = va_arg(ap, struct vfoo);
+ k = va_arg(ap, int);
+ v2_i = va_arg(ap, __vector signed int);
+ l = va_arg(ap, int);
+ vx2 = va_arg(ap, struct vfoo);
+ va_end(ap);
+
+ CHECK_INVARIANT (vec_all_eq (v_i, v_g));
+ CHECK_INVARIANT (j == i_1);
+ CHECK_INVARIANT (vx.x == vx_g.x && vec_all_eq(vx.v, vx_g.v) && vx.y == vx_g.y);
+ CHECK_INVARIANT (k == i_1);
+ CHECK_INVARIANT (vec_all_eq (v2_i, v2_g));
+ CHECK_INVARIANT (l == i_1);
+ CHECK_INVARIANT (vx2.x == vx2_g.x && vec_all_eq(vx2.v, vx2_g.v) && vx2.y == vx2_g.y);
+}
+
+void quux (int i, ... )
+{
+ __vector signed int v_i, v2_i;
+ union u vi, v2i;
+ va_list ap;
+ va_start(ap, i);
+ v_i = va_arg(ap, __vector signed int);
+ v2_i = va_arg(ap, __vector signed int);
+ va_end(ap);
+ vi.v = v_i;
+ v2i.v = v2_i;
+
+ CHECK_INVARIANT (vec_all_eq (v_i, v_g));
+ CHECK_INVARIANT (vec_all_eq (v2_i, v_g));
+ CHECK_INVARIANT (vec_all_eq (vi.v, v_g));
+ CHECK_INVARIANT (vec_all_eq (v2i.v, v_g));
+}
+
+void baz2 (int i, ... )
+{
+ struct vfoo vx;
+ union u vxi;
+ va_list ap;
+ va_start(ap, i);
+ vx = va_arg(ap, struct vfoo);
+ va_end(ap);
+ vxi.v = vx.v;
+
+ CHECK_INVARIANT (vx.x == vx_g.x && vec_all_eq(vx.v, vx_g.v) && vx.y == vx_g.y);
+ CHECK_INVARIANT (vec_all_eq (vxi.v, vx_g.v));
+}
+
+int main(void)
+{
+ CHECK_INVARIANT (sizeof(struct foo) == 8 && sizeof(struct vfoo) == 48);
+
+ bar(i_1, x_g, (short)i_2, (float)d_2, ld_1, (char)i_1, d_3);
+ baz(i_1, v_g, i_1, vx_g, i_1, v2_g, i_1, vx2_g);
+ quux(i_1, v_g, v_g);
+ baz2(i_1, vx_g);
+
+ return 0;
+}
diff --git a/gcc/testsuite/gcc.dg/pch/apple-altivec-1.hs b/gcc/testsuite/gcc.dg/pch/apple-altivec-1.hs
new file mode 100644
index 00000000000..d31591ae112
--- /dev/null
+++ b/gcc/testsuite/gcc.dg/pch/apple-altivec-1.hs
@@ -0,0 +1,2 @@
+/* APPLE LOCAL file AltiVec */
+/* { dg-options "-faltivec -Wno-long-double" } */
diff --git a/gcc/testsuite/gcc.dg/pr14289-1.c b/gcc/testsuite/gcc.dg/pr14289-1.c
deleted file mode 100644
index 652916325c2..00000000000
--- a/gcc/testsuite/gcc.dg/pr14289-1.c
+++ /dev/null
@@ -1,12 +0,0 @@
-/* PR middle-end/14289 */
-/* { dg-do compile { target i?86-*-* } } */
-/* { dg-options "-O0" } */
-
-register int a[2] asm("ebx");
-
-void Nase(void)
-{
- int i=6;
- a[i]=5; /* { dg-error "address of global" } */
-}
-
diff --git a/gcc/testsuite/gcc.dg/pr14289-2.c b/gcc/testsuite/gcc.dg/pr14289-2.c
deleted file mode 100644
index 7530b468cac..00000000000
--- a/gcc/testsuite/gcc.dg/pr14289-2.c
+++ /dev/null
@@ -1,12 +0,0 @@
-/* PR middle-end/14289 */
-/* { dg-do compile { target i?86-*-* } } */
-/* { dg-options "-O0" } */
-
-static register int a[2] asm("ebx"); /* { dg-error "multiple storage" } */
-
-void Nase(void)
-{
- int i=6;
- a[i]=5; /* { dg-error "address of global" } */
-}
-
diff --git a/gcc/testsuite/gcc.dg/pr14289-3.c b/gcc/testsuite/gcc.dg/pr14289-3.c
deleted file mode 100644
index 7cfbf78ce05..00000000000
--- a/gcc/testsuite/gcc.dg/pr14289-3.c
+++ /dev/null
@@ -1,12 +0,0 @@
-/* PR middle-end/14289 */
-/* { dg-do compile { target i?86-*-* } } */
-/* { dg-options "-O0" } */
-
-extern register int a[2] asm("ebx"); /* { dg-error "multiple storage" } */
-
-void Nase(void)
-{
- int i=6;
- a[i]=5; /* { dg-error "address of global" } */
-}
-
diff --git a/gcc/testsuite/gcc.dg/ss/README b/gcc/testsuite/gcc.dg/ss/README
new file mode 100644
index 00000000000..ca8a96a5483
--- /dev/null
+++ b/gcc/testsuite/gcc.dg/ss/README
@@ -0,0 +1,17 @@
+APPLE LOCAL entire file
+
+This directory contains tests for Symbol Separation.
+
+Information about various files in this directory:
+
+README : This file
+ss.exp : Driver for Symbol Separation tests
+*.h : Normal header file
+*.ssh : Header file is candidate for making separate
+ repository. This header is included in source
+ file as *.h. It will renamed on the fly during
+ test.
+
+*.c : Normal source file
+*_part_2.c : Second source file associated with corrosponding
+ *.c source file.
diff --git a/gcc/testsuite/gcc.dg/ss/one.c b/gcc/testsuite/gcc.dg/ss/one.c
new file mode 100644
index 00000000000..866177926c9
--- /dev/null
+++ b/gcc/testsuite/gcc.dg/ss/one.c
@@ -0,0 +1,18 @@
+/* APPLE LOCAL entire file */
+/* Copyright (C) 2003 Free Software Foundation.
+ Contributed by Devang Patel <dpatel@apple.com> */
+
+/* Test simple use of symbol repository.
+ Include file one.h is supplied as one.ssh in this directory,
+ so that ss.exp can pick it up as candidate for making
+ repository. */
+/* { dg-do assemble } */
+
+#include "one.h"
+int main ()
+{
+ struct x_y_point a;
+ a.x = 0;
+ a.y = 0;
+ return 0;
+}
diff --git a/gcc/testsuite/gcc.dg/ss/one.ssh b/gcc/testsuite/gcc.dg/ss/one.ssh
new file mode 100644
index 00000000000..57d77bbf06d
--- /dev/null
+++ b/gcc/testsuite/gcc.dg/ss/one.ssh
@@ -0,0 +1,13 @@
+/* APPLE LOCAL entire file */
+
+/* Copyright (C) 2003 Free Software Foundation.
+ Contributed by Devang Patel <dpatel@apple.com> */
+
+/* Test simple use of symbol repository.
+ Part of one.c test. */
+
+struct x_y_point
+{
+ int x;
+ int y;
+};
diff --git a/gcc/testsuite/gcc.dg/ss/ss-cmd1.c b/gcc/testsuite/gcc.dg/ss/ss-cmd1.c
new file mode 100644
index 00000000000..167d666f63e
--- /dev/null
+++ b/gcc/testsuite/gcc.dg/ss/ss-cmd1.c
@@ -0,0 +1,10 @@
+/* APPLE LOCAL entire file */
+/* Copyright (C) 2003 Free Software Foundation.
+ Contributed by Devang Patel <dpatel@apple.com> */
+/* Test command line option -grepository */
+/* { dg-do compile } */
+/* { dg-options "-grepository" } */
+int main()
+{
+ return 0;
+}
diff --git a/gcc/testsuite/gcc.dg/ss/ss.exp b/gcc/testsuite/gcc.dg/ss/ss.exp
new file mode 100644
index 00000000000..b393f973425
--- /dev/null
+++ b/gcc/testsuite/gcc.dg/ss/ss.exp
@@ -0,0 +1,235 @@
+# APPLE LOCAL entire file
+# Copyright (C) 1997, 2002, 2003 Free Software Foundation, Inc.
+
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program; if not, write to the Free Software
+# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
+
+# GCC testsuite for symbol separation interaction,
+# that uses the `dg.exp' driver.
+
+# Load support procs.
+load_lib gcc-dg.exp
+
+# Initialize `dg'.
+dg-init
+
+# Get checksum (first field of BINCL and EXCL stab information
+proc get_checksum {input_file search_string} {
+
+ # Regular expression to extract hexadecimal word
+ set hexexp {[0-9a-fA-F]+}
+
+ # Do nm on input_file and grep for search_string
+ catch {exec nm -ap $input_file >& $input_file.nm}
+ catch {exec grep "$search_string" $input_file.nm >& $input_file.grep}
+
+ # Extract dummy-checksum from the grep result (first hexdecimal word)
+ # and save it in RESULT
+ set file_h [open $input_file.grep r]
+ while {[gets $file_h line] >= 0} {
+ # We expect only one line in file_h
+ regexp $hexexp $line RESULT
+ }
+ close $file_h
+
+ # Clean up
+ catch { file delete "$input_file.nm" }
+ catch { file delete "$input_file.grep" }
+
+ # Return check sum
+ return $RESULT
+}
+
+set old_dg_do_what_default "${dg-do-what-default}"
+
+# Main loop.
+foreach test [lsort [glob -nocomplain $srcdir/$subdir/*.c]] {
+ global runtests torture_without_loops dg-do-what-default
+
+ # If we're only testing specific files and this isn't one of them, skip it.
+ if ![runtest_file_p $runtests $test] {
+ continue
+ }
+
+ # [file tail name] returns part of name after last /
+ set nshort "$subdir/[file tail $test]"
+ set short_bname "[file rootname [file tail $test]]"
+ set bname "[file rootname $test]"
+ set hexexp {[0-9a-fA-F]+}
+ set ss_exp_debug 0
+
+ catch { file delete "$bname.h" }
+ catch { file delete "$bname.h.cinfo" }
+ catch { file delete "$bname.o" }
+ catch { file delete "$bname.h.o" }
+
+ # We don't try to use the loop-optimizing options, since they are highly
+ # unlikely to make any difference to CINFO.
+ foreach flags $torture_without_loops {
+ verbose "Testing $nshort, $flags" 1
+
+ if {$ss_exp_debug == 1} {
+ puts "ss_exp_debug: various names"
+ puts "ss_exp_debug bname:"; puts $bname
+ puts "ss_exp_debug bname.ssh:"; puts $bname.ssh
+ puts "ss_exp_debug test:"; puts $test
+ puts "ss_exp_debug short_bname:"; puts $short_bname
+ }
+
+ # 1) compile foo.h to create foo.cinfo and foo.h.o
+ if { [ file exists "$bname.ssh" ] } {
+
+ # For the header files, the default is to make repository
+ set dg-do-what-default assemble
+
+ # Header files are supplied using .ssh extension, so that we can
+ # identify candidates for makeing symbol repository. Get header copy
+ # with .h here.
+ file copy -force "$bname.ssh" "$bname.h"
+ file copy -force "$bname.ssh" "$short_bname.h"
+
+ # Make repository
+ # This will create two output files, $short_bname.o and $short_h.cinfo
+ dg-test -keep-output "$bname.h" $flags "-fsave-repository=. "
+
+ if { [ file exists "$short_bname.o" ] } {
+ file rename -force "$short_bname.o" "$bname.h.o"
+
+ # Do nm on $bname.h.o and grep for "BINCL $bname.h"
+ # Extract dummy-checksum from the grep result and save it in RESULT1
+ set RESULT1 [get_checksum $bname.h.o "BINCL $bname.h"]
+
+ if {$ss_exp_debug == 1} {
+ puts "ss_exp_debug: RESULT1"; puts $RESULT1
+ }
+
+ pass "$nshort $flags Make Repository"
+
+ } else {
+ set RESULT1 " "
+ fail "$nshort $flags Make Repository"
+ }
+
+ if { [ file exists "$short_bname.h.cinfo" ] } {
+
+ # 2) compile foo.c to create foo.o
+ dg-test -keep-output $test $flags "-I. -grepository -Winvalid-sr"
+ if { [ file exists "$short_bname.o" ] } {
+
+ # Do nm on $bname.o and grep for "EXCL $bname.h"
+ # Extract dummy-checksum from the grep result and save it in RESULT2
+ set RESULT2 [get_checksum $short_bname.o "EXCL $bname.h"]
+
+ if {$ss_exp_debug == 1} {
+ puts "ss_exp_debug: RESULT2"; puts $RESULT2
+ }
+
+ pass "$nshort $flags Use symbol repository"
+
+ } else {
+ set RESULT2 " "
+ fail "$nshort $flags Use symbol repository YES"
+ }
+
+
+ if { [ file exists "$bname.part_2.c" ] } {
+
+ # 3) compile foo_part_2.c to create foo_part_2.o
+ dg-test -keep-output "$bname_part_2.c" $flags "-I. -grepository"
+ if { [ file exists "$short_bname_part_2.o" ] } {
+
+ # Do nm on $bname_part_2.o and grep for "EXCL $bname.h"
+ # Extract dummy-checksum from the grep result and save it in RESULT3
+ set RESULT3 [get_checksum $short_bname_part_2.o "EXCL $bname.h"]
+
+ if {$ss_exp_debug == 1} {
+ puts "ss_exp_debug: RESULT3"; puts $RESULT3
+ }
+
+ pass "$nshort $flags Use symbol repository"
+
+ } else {
+ set RESULT3 " "
+ fail "$nshort $flags Use symbol repository"
+ }
+
+ # 4) Link foo.h.o foo.o and foo_part_2.o to create foo
+ set dg-do-what-default link
+ dg-test -keep-output "$bname.h.o" "$bname.o" "$bname_part_2.o" "-o $short_bname.out"
+
+ # 5) do 'nm |grep ' on final assembler and save result in RES4
+ # Do nm on $bname.out and grep for "EXCL $bname.h"
+ # Extract dummy-checksum from the grep result and save it in RESULT4
+ set RESULT4 [get_checksum $short_bname.out "EXCL $bname.h"]
+
+ # Do nm on $bname.out and grep for "BINCL $bname.h"
+ # Extract dummy-checksum from the grep result and save it in RESULT5
+ set RESULT5 [get_checksum $short_bname.out "BINCL $bname.h"]
+
+ if {$ss_exp_debug == 1} {
+ puts "ss_exp_debug: RESULT4"; puts $RESULT4
+ puts "ss_exp_debug: RESULT5"; puts $RESULT5
+ }
+
+ pass "$nshort $flags symbol separation: linking"
+
+ } else {
+
+ # If we are not testing second part then set values so that comparison test succeeds
+ set RESULT3 $RESULT2
+ set RESULT4 $RESULT2
+ set RESULT5 $RESULT2
+ if {$ss_exp_debug == 1} {
+ puts "ss_exp_debug: RESULT3"; puts $RESULT3
+ puts "ss_exp_debug: RESULT4"; puts $RESULT4
+ puts "ss_exp_debug: RESULT5"; puts $RESULT5
+ }
+ }
+
+ # 6) Compare RES1 and RES2 and RES3 and RES4
+ if { ( $RESULT1 == $RESULT2 )
+ && ( $RESULT1 == $RESULT3 )
+ && ( $RESULT1 == $RESULT4 ) } {
+ pass "$nshort $flags symbol separation valid use test"
+ } else {
+ fail "$nshort $flags symbol separation valid use test"
+ }
+ if { ( $RESULT1 == $RESULT5 ) } {
+ pass "$nshort $flags symbol separation link test"
+ } else {
+ fail "$nshort $flags symbol separation link test"
+ }
+
+ } else {
+ fail "$nshort $flags Make repository"
+ }
+ } else {
+
+ # Normal test
+ set dg-do-what-default compile
+ dg-test -keep-output $test $flags "-I."
+ }
+
+ # Clean up
+ catch { file delete "$bname.h" }
+ catch { file delete "$bname.h.cinfo" }
+ catch { file delete "$bname.o" }
+ catch { file delete "$bname.h.o" }
+ }
+}
+
+set dg-do-what-default "$old_dg_do_what_default"
+
+# All done.
+dg-finish
diff --git a/gcc/testsuite/gcc.dg/torture/builtin-integral-1.c b/gcc/testsuite/gcc.dg/torture/builtin-integral-1.c
deleted file mode 100644
index 1f2990dd2f0..00000000000
--- a/gcc/testsuite/gcc.dg/torture/builtin-integral-1.c
+++ /dev/null
@@ -1,58 +0,0 @@
-/* Copyright (C) 2004 Free Software Foundation.
-
- Verify that integral FP expressions are optimized.
-
- Written by Kaveh Ghazi, 2004-03-16. */
-
-/* { dg-do link } */
-/* { dg-options "-ffast-math" } */
-
-#define PROTOTYPE1(FN) extern double FN(double); extern float FN##f(float); \
- extern long double FN##l(long double);
-
-PROTOTYPE1(fabs)
-
-void test(int i1, int i2)
-{
- /* Test that the various FP truncation builtins detect integral
- arguments. */
-#define CHECK_FN(MATHFN) \
- PROTOTYPE1 (MATHFN) \
- extern void link_failure_##MATHFN(void); \
- extern void link_failure_##MATHFN##f(void); \
- extern void link_failure_##MATHFN##l(void); \
- if (MATHFN(i1) != i1) link_failure_##MATHFN(); \
- if (MATHFN##f(i1) != i1) link_failure_##MATHFN##f(); \
- if (MATHFN##l(i1) != i1) link_failure_##MATHFN##l(); \
-
- CHECK_FN(ceil);
- CHECK_FN(floor);
- CHECK_FN(nearbyint);
- CHECK_FN(rint);
- CHECK_FN(round);
- CHECK_FN(trunc);
-
- /* Check that various other integral expressions are detected. */
-#define CHECK_EXPR(EXPR,NAME) \
- extern void link_failure_##NAME(void); \
- if (ceill(EXPR) != (EXPR)) link_failure_##NAME(); \
-
- CHECK_EXPR (5.0, REAL_CST);
- CHECK_EXPR (5.0F, REAL_CSTf);
- CHECK_EXPR (5.0L, REAL_CSTl);
- CHECK_EXPR ((double)i1, FLOAT_EXPR);
- CHECK_EXPR ((float)i1, FLOAT_EXPRf);
- CHECK_EXPR ((long double)i1, FLOAT_EXPRl);
- CHECK_EXPR (fabs(i1), ABS_EXPR);
- CHECK_EXPR (fabsf(i1), ABS_EXPRf);
- CHECK_EXPR (fabsl(i1), ABS_EXPRl);
- CHECK_EXPR (((void)i1,(double)i2), COMPOUND_EXPR);
- CHECK_EXPR ((double)i1+i2, PLUS_EXPR);
- CHECK_EXPR ((double)i1-i2, MINUS_EXPR);
- CHECK_EXPR ((double)i1*i2, MULT_EXPR);
-}
-
-int main (void)
-{
- return 0;
-}
diff --git a/gcc/testsuite/gcc.dg/torture/builtin-nonneg-1.c b/gcc/testsuite/gcc.dg/torture/builtin-nonneg-1.c
deleted file mode 100644
index 80cf3e3c83b..00000000000
--- a/gcc/testsuite/gcc.dg/torture/builtin-nonneg-1.c
+++ /dev/null
@@ -1,172 +0,0 @@
-/* Copyright (C) 2004 Free Software Foundation.
-
- Verify that GCC can determine which built-in functions produce a
- nonnegative result.
-
- Written by Kaveh Ghazi, 2004-03-10. */
-
-/* { dg-do link } */
-/* { dg-options "-ffast-math" } */
-
-#define PROTOTYPE_RTYPE(FN,RTYPE) extern RTYPE FN(double); \
- extern RTYPE FN##f(float); \
- extern RTYPE FN##l(long double);
-#define PROTOTYPE(FN) extern double FN(double); extern float FN##f(float); \
- extern long double FN##l(long double);
-#define PROTOTYPE2(FN) extern double FN(double, double); \
- extern float FN##f(float, float); \
- extern long double FN##l(long double, long double);
-#define CPROTOTYPE1(FN) extern double FN(_Complex double); \
- extern float FN##f(_Complex float); \
- extern long double FN##l(_Complex long double);
-#define CPROTOTYPE1(FN) extern double FN(_Complex double); \
- extern float FN##f(_Complex float); \
- extern long double FN##l(_Complex long double);
-#define IPROTOTYPE(FN) extern int FN(int); extern int FN##l(long); \
- extern int FN##ll(long long);
-#define PROTOTYPE2TYPE2(FN,A2TYPE) extern double FN(double, A2TYPE); \
- extern float FN##f(float, A2TYPE); \
- extern long double FN##l(long double, A2TYPE);
-#define PROTOTYPE2_A2FPTR(FN) extern double FN(double, double *); \
- extern float FN##f(float, float *); \
- extern long double FN##l(long double, long double *);
-
-extern int signbit (double);
-extern int signbitf (float);
-extern int signbitl (long double);
-
-void test(double d1, double d2, float f1, float f2,
- long double ld1, long double ld2)
-{
- /* These are always nonnegative. */
-
-#define TEST1(FN) \
- extern void link_failure_##FN (void); PROTOTYPE(FN) \
- if (signbit(FN(d1)) || signbitf(FN##f(f1)) || signbitl(FN##l(ld1))) \
- link_failure_##FN()
-
-#define TEST2(FN) \
- extern void link_failure_##FN (void); PROTOTYPE2(FN) \
- if (signbit(FN(d1,d2)) || signbitf(FN##f(f1,f2)) || signbitl(FN##l(ld1,ld2))) \
- link_failure_##FN()
-
-#define CTEST1(FN) \
- extern void link_failure_##FN (void); CPROTOTYPE1(FN) \
- if (signbit(FN(d1)) || signbitf(FN##f(f1)) || signbitl(FN##l(ld1))) \
- link_failure_##FN()
-
-#define ITEST1(FN) \
- extern void link_failure_##FN (void); IPROTOTYPE(FN) \
- if (signbit(FN(d1)) || signbitf(FN##l(f1)) || signbitl(FN##ll(ld1))) \
- link_failure_##FN()
-
- TEST1 (acos);
- TEST1 (acosh);
- CTEST1 (cabs);
- TEST1 (cosh);
- TEST1 (erfc);
- TEST1 (exp);
- TEST1 (exp10);
- TEST1 (exp2);
- TEST1 (fabs);
- TEST2 (fdim);
- TEST2 (hypot);
- TEST1 (pow10);
- TEST1 (sqrt);
- ITEST1 (ffs);
- ITEST1 (__builtin_parity);
- ITEST1 (__builtin_popcount);
-
- /* These are nonnegative if the first argument is. */
-#define ARG1TEST1(FN) \
- extern void link_failure_##FN (void); PROTOTYPE(FN) \
- if (signbit(FN(fabs(d1))) || signbitf(FN##f(fabsf(f1))) \
- || signbitl(FN##l(fabsl(ld1)))) \
- link_failure_##FN()
-
- /* Same, but allow specifying the return type. */
-#define ARG1TEST1_RTYPE(FN,RTYPE) \
- extern void link_failure_##FN (void); PROTOTYPE_RTYPE(FN,RTYPE) \
- if (signbit(FN(fabs(d1))) || signbitf(FN##f(fabsf(f1))) \
- || signbitl(FN##l(fabsl(ld1)))) \
- link_failure_##FN()
-
- /* These are nonnegative if the first argument is. */
-#define ARG1TEST2(FN) \
- extern void link_failure_##FN (void); PROTOTYPE2(FN) \
- if (signbit(FN(fabs(d1),d2)) || signbitf(FN##f(fabsf(f1),f2)) \
- || signbitl(FN##l(fabsl(ld1),ld2))) \
- link_failure_##FN()
-
- /* These are nonnegative if the second argument is. */
-#define ARG2TEST2(FN) \
- extern void link_failure_##FN (void); PROTOTYPE2(FN) \
- if (signbit(FN(d1,fabs(d2))) || signbitf(FN##f(f1,fabsf(f2))) \
- || signbitl(FN##l(ld1,fabsl(ld2)))) \
- link_failure_##FN()
-
- /* These are nonnegative if the first OR second argument is. */
-#define ARG2TESTor(FN) \
- extern void link_failure_##FN (void); PROTOTYPE2(FN) \
- if (signbit(FN(fabs(d1),d2)) || signbitf(FN##f(fabsf(f1),f2)) \
- || signbitl(FN##l(fabsl(ld1),ld2)) || signbit(FN(d1,fabs(d2))) \
- || signbitf(FN##f(f1,fabsf(f2))) || signbitl(FN##l(ld1,fabsl(ld2)))) \
- link_failure_##FN()
-
- /* These are nonnegative if the first AND second argument is. */
-#define ARG2TESTand(FN) \
- extern void link_failure_##FN (void); PROTOTYPE2(FN) \
- if (signbit(FN(fabs(d1),fabs(d2))) || signbitf(FN##f(fabsf(f1),fabsf(f2))) \
- || signbitl(FN##l(fabsl(ld1),fabsl(ld2)))) \
- link_failure_##FN()
-
- /* These are nonnegative if the first argument is, 2nd arg is int. */
-#define ARG2TEST1_A2INT(FN) \
- extern void link_failure_##FN (void); PROTOTYPE2TYPE2(FN, int) \
- if (signbit(FN(fabs(d1),d2)) || signbitf(FN##f(fabsf(f1),f2)) \
- || signbitl(FN##l(fabsl(ld1),ld2))) \
- link_failure_##FN()
-
- /* These are nonnegative if the first argument is, specify 2nd arg. */
-#define ARG2TEST1_A2FPTR(FN) \
- extern void link_failure_##FN (void); PROTOTYPE2_A2FPTR(FN) \
- if (signbit(FN(fabs(d1),&d2)) || signbitf(FN##f(fabsf(f1),&f2)) \
- || signbitl(FN##l(fabsl(ld1),&ld2))) \
- link_failure_##FN()
-
- ARG1TEST1 (asinh);
- ARG1TEST1 (atan);
- ARG1TEST1 (atanh);
- ARG1TEST1 (cbrt);
- ARG1TEST1 (ceil);
- ARG1TEST1 (erf);
- ARG1TEST1 (expm1);
- ARG1TEST1 (floor);
- ARG1TEST2 (fmod);
- ARG2TEST1_A2INT (ldexp);
- ARG1TEST1_RTYPE (llrint, long long);
- ARG1TEST1_RTYPE (llround, long long);
- ARG1TEST1_RTYPE (lrint, long);
- ARG1TEST1_RTYPE (lround, long);
- /* The modf* functions aren't ever "const" or "pure" even with
- -ffast-math so they won't be eliminated and yield a link failure. */
- /* ARG2TEST1_A2FPTR (modf);*/
- ARG1TEST1 (nearbyint);
- ARG1TEST2 (pow);
- ARG1TEST1 (rint);
- ARG1TEST1 (round);
- ARG1TEST1_RTYPE (signbit, int);
- ARG1TEST1 (sinh);
- ARG1TEST1 (tanh);
- ARG1TEST1 (trunc);
-
- ARG2TESTor (fmax);
- ARG2TESTand (fmin);
- ARG2TEST2 (copysign);
-
-}
-
-int main (void)
-{
- return 0;
-}
diff --git a/gcc/testsuite/gcc.dg/typespec-1.c b/gcc/testsuite/gcc.dg/typespec-1.c
index 1acaaf73676..a0e0c1a9992 100644
--- a/gcc/testsuite/gcc.dg/typespec-1.c
+++ b/gcc/testsuite/gcc.dg/typespec-1.c
@@ -11,7 +11,8 @@
not requiring -pedantic. */
/* Origin: Joseph Myers <jsm28@cam.ac.uk> */
/* { dg-do compile } */
-/* { dg-options "-std=gnu99" } */
+/* APPLE LOCAL -Wlong-double */
+/* { dg-options "-std=gnu99 -Wno-long-double" } */
typedef char type;
void *x0;
diff --git a/gcc/testsuite/gcc.dg/va-arg-2.c b/gcc/testsuite/gcc.dg/va-arg-2.c
index 2e2849c1528..5140545f121 100644
--- a/gcc/testsuite/gcc.dg/va-arg-2.c
+++ b/gcc/testsuite/gcc.dg/va-arg-2.c
@@ -6,7 +6,10 @@
#include <varargs.h> /* { dg-bogus "varargs.h" "missing file" } */
/* { dg-error "" "In file included from" { target *-*-* } 6 } */
-/* { dg-error "no longer implements" "#error 1" { target *-*-* } 4 } */
-/* { dg-error "Revise your code" "#error 2" { target *-*-* } 5 } */
+
+/* APPLE LOCAL BEGIN - varargs.h changes to line numbers hartoog@apple.com */
+/* { dg-error "no longer implements" "#error 1" { target *-*-* } 10 } */
+/* { dg-error "Revise your code" "#error 2" { target *-*-* } 11 } */
+/* APPLE LOCAL END - varargs.h changes to line numbers hartoog@apple.com */
int x; /* prevent empty-source-file warning */
diff --git a/gcc/testsuite/gcc.dg/verbose-asm-2.c b/gcc/testsuite/gcc.dg/verbose-asm-2.c
new file mode 100644
index 00000000000..4a8b1b45972
--- /dev/null
+++ b/gcc/testsuite/gcc.dg/verbose-asm-2.c
@@ -0,0 +1,13 @@
+/* APPLE LOCAL entire file */
+/* Test whether -fverbose-asm emits option values. */
+/* Contibuted by Devang Patel <dpatel@apple.com>. */
+
+/* { dg-do compile } */
+/* { dg-options "-fverbose-asm" } */
+/* { dg-final { scan-assembler "fpeephole=0" } } */
+
+int
+main (int argc, char *argv [])
+{
+ return 0;
+}
diff --git a/gcc/testsuite/gcc.dg/wtr-conversion-1.c b/gcc/testsuite/gcc.dg/wtr-conversion-1.c
index 18d26165f2a..b133ff1e8c4 100644
--- a/gcc/testsuite/gcc.dg/wtr-conversion-1.c
+++ b/gcc/testsuite/gcc.dg/wtr-conversion-1.c
@@ -2,7 +2,8 @@
Note, gcc should omit these warnings in system header files.
By Kaveh R. Ghazi <ghazi@caip.rutgers.edu> 4/09/2001. */
/* { dg-do compile } */
-/* { dg-options "-Wtraditional" } */
+/* APPLE LOCAL -Wlong-double */
+/* { dg-options "-Wtraditional -Wno-long-double" } */
extern void foo_i (int);
extern void foo_f (float);
diff --git a/gcc/testsuite/lib/g++.exp b/gcc/testsuite/lib/g++.exp
index 518e836020c..48226db72a9 100644
--- a/gcc/testsuite/lib/g++.exp
+++ b/gcc/testsuite/lib/g++.exp
@@ -299,12 +299,20 @@ proc g++_target_compile { source dest type options } {
}
lappend options "additional_flags=[libio_include_flags]"
+ # APPLE LOCAL begin testsuite multiply defined
+ if [ istarget *-*-darwin* ] {
+ lappend options "ldflags=-Wl,-multiply_defined,suppress"
+ }
+ # APPLE LOCAL end testsuite multiply defined
lappend options "compiler=$GXX_UNDER_TEST";
set options [concat $gpp_compile_options $options]
set options [concat "$ALWAYS_CXXFLAGS" $options];
+ # APPLE LOCAL long double warning
+ lappend options "additional_flags=-Wno-long-double"
+
if { [regexp "(^| )-frepo( |$)" $options] && \
[regexp "\.o(|bj)$" $dest] } then {
regsub "\.o(|bj)$" $dest ".rpo" rponame
diff --git a/gcc/testsuite/lib/gcc.exp b/gcc/testsuite/lib/gcc.exp
index ac4dc35e8e9..a27b3583d90 100644
--- a/gcc/testsuite/lib/gcc.exp
+++ b/gcc/testsuite/lib/gcc.exp
@@ -143,7 +143,7 @@ proc gcc_target_compile { source dest type options } {
if [target_info exists gcc,no_trampolines] {
lappend options "additional_flags=-DNO_TRAMPOLINES"
}
- if [target_info exists gcc,no_label_values] {
+ if { 1 } {
lappend options "additional_flags=-DNO_LABEL_VALUES"
}
# TOOL_OPTIONS must come first, so that it doesn't override testcase
@@ -154,6 +154,11 @@ proc gcc_target_compile { source dest type options } {
if [target_info exists gcc,timeout] {
lappend options "timeout=[target_info gcc,timeout]"
}
+ # APPLE LOCAL begin testsuite multiply defined
+ if [ istarget *-*-darwin* ] {
+ lappend options "ldflags=-Wl,-multiply_defined,suppress"
+ }
+ # APPLE LOCAL end testsuite multiply defined
lappend options "compiler=$GCC_UNDER_TEST"
set options [dg-additional-files-options $options $source]
return [target_compile $source $dest $type $options]
diff --git a/gcc/testsuite/lib/obj-c++-dg.exp b/gcc/testsuite/lib/obj-c++-dg.exp
new file mode 100644
index 00000000000..90e4a37a940
--- /dev/null
+++ b/gcc/testsuite/lib/obj-c++-dg.exp
@@ -0,0 +1,165 @@
+# APPLE LOCAL file Objective-C++
+# Copyright (C) 2002 Free Software Foundation, Inc.
+
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program; if not, write to the Free Software
+# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
+
+load_lib dg.exp
+load_lib file-format.exp
+load_lib target-supports.exp
+load_lib scanasm.exp
+
+# For prune_gcc_output.
+load_lib gcc.exp
+
+if ![info exists TORTURE_OPTIONS] {
+ # It is theoretically beneficial to group all of the O2/O3 options together,
+ # as in many cases the compiler will generate identical executables for
+ # all of them--and the c-torture testsuite will skip testing identical
+ # executables multiple times.
+ # Also note that -finline-functions is explicitly included in one of the
+ # items below, even though -O3 is also specified, because some ports may
+ # choose to disable inlining functions by default, even when optimizing.
+ set TORTURE_OPTIONS [list \
+ { -O0 } \
+ { -O1 } \
+ { -O2 } \
+ { -O3 -fomit-frame-pointer } \
+ { -O3 -fomit-frame-pointer -funroll-loops } \
+ { -O3 -fomit-frame-pointer -funroll-all-loops -finline-functions } \
+ { -O3 -g } \
+ { -Os } ]
+}
+
+
+# Split TORTURE_OPTIONS into two choices: one for testcases with loops and
+# one for testcases without loops.
+
+set torture_with_loops $TORTURE_OPTIONS
+set torture_without_loops ""
+foreach option $TORTURE_OPTIONS {
+ if ![string match "*loop*" $option] {
+ lappend torture_without_loops $option
+ }
+}
+
+# Define gcc callbacks for dg.exp.
+
+proc obj-c++-dg-test { prog do_what extra_tool_flags } {
+ # Set up the compiler flags, based on what we're going to do.
+
+ switch $do_what {
+ "preprocess" {
+ set compile_type "preprocess"
+ set output_file "[file rootname [file tail $prog]].i"
+ }
+ "compile" {
+ set compile_type "assembly"
+ set output_file "[file rootname [file tail $prog]].s"
+ }
+ "assemble" {
+ set compile_type "object"
+ set output_file "[file rootname [file tail $prog]].o"
+ }
+ "link" {
+ set compile_type "executable"
+ set output_file "[file rootname [file tail $prog]].exe"
+ # The following line is needed for targets like the i960 where
+ # the default output file is b.out. Sigh.
+ }
+ "run" {
+ set compile_type "executable"
+ # FIXME: "./" is to cope with "." not being in $PATH.
+ # Should this be handled elsewhere?
+ # YES.
+ set output_file "./[file rootname [file tail $prog]].exe"
+ # This is the only place where we care if an executable was
+ # created or not. If it was, dg.exp will try to run it.
+ remote_file build delete $output_file;
+ }
+ default {
+ perror "$do_what: not a valid dg-do keyword"
+ return ""
+ }
+ }
+ set options ""
+ if { $extra_tool_flags != "" } {
+ lappend options "additional_flags=$extra_tool_flags"
+ }
+
+ set comp_output [obj-c++_target_compile "$prog" "$output_file" "$compile_type" $options];
+
+ return [list $comp_output $output_file]
+}
+
+proc obj-c++-dg-prune { system text } {
+ set text [prune_gcc_output $text]
+
+ # If we see "region xxx is full" then the testcase is too big for ram.
+ # This is tricky to deal with in a large testsuite like c-torture so
+ # deal with it here. Just mark the testcase as unsupported.
+ if [regexp "(^|\n)\[^\n\]*: region \[^\n\]* is full" $text] {
+ # The format here is important. See dg.exp.
+ return "::unsupported::memory full"
+ }
+
+ return $text
+}
+
+# Utility routines.
+
+#
+# search_for -- looks for a string match in a file
+#
+proc search_for { file pattern } {
+ set fd [open $file r]
+ while { [gets $fd cur_line]>=0 } {
+ if [string match "*$pattern*" $cur_line] then {
+ close $fd
+ return 1
+ }
+ }
+ close $fd
+ return 0
+}
+
+# Modified dg-runtest that can cycle through a list of optimization options
+# as c-torture does.
+proc obj-c++-dg-runtest { testcases default-extra-flags } {
+ global runtests
+
+ foreach test $testcases {
+ # If we're only testing specific files and this isn't one of
+ # them, skip it.
+ if ![runtest_file_p $runtests $test] {
+ continue
+ }
+
+ # Look for a loop within the source code - if we don't find one,
+ # don't pass -funroll[-all]-loops.
+ global torture_with_loops torture_without_loops
+ if [expr [search_for $test "for*("]+[search_for $test "while*("]] {
+ set option_list $torture_with_loops
+ } else {
+ set option_list $torture_without_loops
+ }
+
+ set nshort [file tail [file dirname $test]]/[file tail $test]
+
+ foreach flags $option_list {
+ verbose "Testing $nshort, $flags" 1
+ dg-test $test $flags ${default-extra-flags}
+ }
+ }
+}
diff --git a/gcc/testsuite/lib/obj-c++.exp b/gcc/testsuite/lib/obj-c++.exp
new file mode 100644
index 00000000000..05a84268758
--- /dev/null
+++ b/gcc/testsuite/lib/obj-c++.exp
@@ -0,0 +1,311 @@
+# APPLE LOCAL file Objective-C++
+# Copyright (C) 2002 Free Software Foundation, Inc.
+
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program; if not, write to the Free Software
+# Foundation, 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
+
+# This file was written by Rob Savoye (rob@cygnus.com)
+# Currently maintained by Doug Evans (dje@cygnus.com)
+
+# This file is loaded by the tool init file (eg: unix.exp). It provides
+# default definitions for objc_start, etc. and other supporting cast members.
+
+# These globals are used by objc_start if no compiler arguments are provided.
+# They are also used by the various testsuites to define the environment:
+# where to find stdio.h, libc.a, etc.
+
+load_lib libgloss.exp
+load_lib prune.exp
+load_lib gcc-defs.exp
+
+# We want to sponge off many G++ goodies.
+load_lib g++.exp
+
+#
+# OBJCXX_UNDER_TEST is the compiler under test.
+#
+
+#
+# default_obj-c++_version -- extract and print the version number of the compiler
+#
+
+proc default_obj-c++_version { } {
+ global OBJCXX_UNDER_TEST
+
+ obj-c++_init;
+
+ # ignore any arguments after the command
+ set compiler [lindex $OBJCXX_UNDER_TEST 0]
+
+ if ![is_remote host] {
+ set compiler_name [which $compiler];
+ } else {
+ set compiler_name $compiler;
+ }
+
+ # verify that the compiler exists
+ if { $compiler_name != 0 } then {
+ set tmp [remote_exec host "$compiler -v"]
+ set status [lindex $tmp 0];
+ set output [lindex $tmp 1];
+ regexp "version.*$" $output version
+ if { $status == 0 && [info exists version] } then {
+ clone_output "$compiler_name $version\n"
+ } else {
+ clone_output "Couldn't determine version of $compiler_name: $output\n"
+ }
+ } else {
+ # compiler does not exist (this should have already been detected)
+ warning "$compiler does not exist"
+ }
+}
+
+#
+# Call obj-c++_version. We do it this way so we can override it if needed.
+#
+proc obj-c++_version { } {
+ default_obj-c++_version;
+}
+
+#
+# obj-c++_init -- called at the start of each .exp script.
+#
+# There currently isn't much to do, but always using it allows us to
+# make some enhancements without having to go back and rewrite the scripts.
+#
+
+set objcxx_initialized 0
+
+proc obj-c++_init { args } {
+ global subdir
+ global objcxx_initialized
+ global base_dir
+ global tmpdir
+ global libdir
+ global gluefile wrap_flags
+ global ALWAYS_CXXFLAGS
+ global GXX_UNDER_TEST
+ global OBJCXX_UNDER_TEST
+ global TOOL_EXECUTABLE
+ global TESTING_IN_BUILD_TREE
+
+ if { $objcxx_initialized == 1 } { return; }
+
+ if ![info exists GXX_UNDER_TEST] then {
+ if [info exists TOOL_EXECUTABLE] {
+ set GXX_UNDER_TEST $TOOL_EXECUTABLE;
+ } else {
+ if { [is_remote host] || ! [info exists TESTING_IN_BUILD_TREE] } {
+ set GXX_UNDER_TEST [transform c++]
+ } else {
+ set GXX_UNDER_TEST [findfile $base_dir/../g++ "$base_dir/../g++ -B$base_dir/../" [findfile $base_dir/g++ "$base_dir/g++ -B$base_dir/" [transform c++]]]
+ }
+ }
+ }
+
+ set OBJCXX_UNDER_TEST "$GXX_UNDER_TEST -x objective-c++"
+
+ if ![info exists tmpdir] then {
+ set tmpdir /tmp
+ }
+ if { [target_info needs_status_wrapper]!="" && ![info exists gluefile] } {
+ set gluefile ${tmpdir}/testglue.o;
+ set result [build_wrapper $gluefile];
+ if { $result != "" } {
+ set gluefile [lindex $result 0];
+ set wrap_flags [lindex $result 1];
+ } else {
+ unset gluefile
+ }
+ }
+
+ set ALWAYS_CXXFLAGS ""
+
+ if ![is_remote host] {
+ if [info exists TOOL_OPTIONS] {
+ lappend ALWAYS_CXXFLAGS "additional_flags=[g++_include_flags [get_multilibs ${TOOL_OPTIONS}] ]";
+ lappend ALWAYS_CXXFLAGS "ldflags=[g++_link_flags [get_multilibs ${TOOL_OPTIONS}] ]";
+ } else {
+ lappend ALWAYS_CXXFLAGS "additional_flags=[g++_include_flags [get_multilibs] ]";
+ lappend ALWAYS_CXXFLAGS "ldflags=[g++_link_flags [get_multilibs] ]";
+ }
+ }
+
+ if [info exists TOOL_OPTIONS] {
+ lappend ALWAYS_CXXFLAGS "additional_flags=$TOOL_OPTIONS";
+ }
+
+ # Make sure that lines are not wrapped. That can confuse the
+ # error-message parsing machinery.
+ lappend ALWAYS_CXXFLAGS "additional_flags=-fmessage-length=0"
+
+ verbose -log "ALWAYS_CXXFLAGS set to $ALWAYS_CXXFLAGS"
+
+ verbose "obj-c++ is initialized" 3
+}
+
+proc obj-c++_target_compile { source dest type options } {
+ global rootme;
+ global tmpdir;
+ global gluefile wrap_flags;
+ global ALWAYS_CXXFLAGS
+ global OBJCXX_UNDER_TEST
+ global TOOL_OPTIONS
+ global ld_library_path
+
+ lappend options "compiler=$OBJCXX_UNDER_TEST"
+
+ #set ld_library_path ".:${rootme}"
+ lappend options "libs=-lstdc++"
+
+ if { [target_info needs_status_wrapper]!="" && [info exists gluefile] } {
+ lappend options "libs=${gluefile}"
+ lappend options "ldflags=$wrap_flags"
+ }
+
+ if [target_info exists obj-c++,stack_size] {
+ lappend options "additional_flags=-DSTACK_SIZE=[target_info obj-c++,stack_size]"
+ }
+ if [target_info exists obj-c++,no_trampolines] {
+ lappend options "additional_flags=-DNO_TRAMPOLINES"
+ }
+ if [target_info exists obj-c++,no_label_values] {
+ lappend options "additional_flags=-DNO_LABEL_VALUES"
+ }
+ if [info exists TOOL_OPTIONS] {
+ lappend options "additional_flags=$TOOL_OPTIONS"
+ }
+
+ set options [concat "$ALWAYS_CXXFLAGS" $options];
+
+ return [target_compile $source $dest $type $options]
+}
+
+#
+# obj-c++_pass -- utility to record a testcase passed
+#
+
+proc obj-c++_pass { testcase cflags } {
+ if { "$cflags" == "" } {
+ pass "$testcase"
+ } else {
+ pass "$testcase, $cflags"
+ }
+}
+
+#
+# obj-c++_fail -- utility to record a testcase failed
+#
+
+proc obj-c++_fail { testcase cflags } {
+ if { "$cflags" == "" } {
+ fail "$testcase"
+ } else {
+ fail "$testcase, $cflags"
+ }
+}
+
+#
+# obj-c++_finish -- called at the end of every .exp script that calls obj-c++_init
+#
+# The purpose of this proc is to hide all quirks of the testing environment
+# from the testsuites. It also exists to undo anything that obj-c++_init did
+# (that needs undoing).
+#
+
+proc obj-c++_finish { } {
+ # The testing harness apparently requires this.
+ global errorInfo;
+
+ if [info exists errorInfo] then {
+ unset errorInfo
+ }
+
+ # Might as well reset these (keeps our caller from wondering whether
+ # s/he has to or not).
+ global prms_id bug_id
+ set prms_id 0
+ set bug_id 0
+}
+
+proc obj-c++_exit { } {
+ global gluefile;
+
+ if [info exists gluefile] {
+ file_on_build delete $gluefile;
+ unset gluefile;
+ }
+}
+
+# If this is an older version of dejagnu (without runtest_file_p),
+# provide one and assume the old syntax: foo1.exp bar1.c foo2.exp bar2.c.
+# This can be deleted after next dejagnu release.
+
+if { [info procs runtest_file_p] == "" } then {
+ proc runtest_file_p { runtests testcase } {
+ if { $runtests != "" && [regexp "\[.\]\[cC\]" $runtests] } then {
+ if { [lsearch $runtests [file tail $testcase]] >= 0 } then {
+ return 1
+ } else {
+ return 0
+ }
+ }
+ return 1
+ }
+}
+
+# Provide a definition of this if missing (delete after next dejagnu release).
+
+if { [info procs prune_warnings] == "" } then {
+ proc prune_warnings { text } {
+ return $text
+ }
+}
+
+# Utility used by mike-gcc.exp and c-torture.exp.
+# Check the compiler(/assembler/linker) output for text indicating that
+# the testcase should be marked as "unsupported".
+#
+# When dealing with a large number of tests, it's difficult to weed out the
+# ones that are too big for a particular cpu (eg: 16 bit with a small amount
+# of memory). There are various ways to deal with this. Here's one.
+# Fortunately, all of the cases where this is likely to happen will be using
+# gld so we can tell what the error text will look like.
+
+proc ${tool}_check_unsupported_p { output } {
+ if [regexp "(^|\n)\[^\n\]*: region \[^\n\]* is full" $output] {
+ return "memory full"
+ }
+ return ""
+}
+
+# Prune messages from obj-c++ that aren't useful.
+
+proc prune_obj-c++_output { text } {
+ #send_user "Before:$text\n"
+ regsub -all "(^|\n)\[^\n\]*: In (function|method) \[^\n\]*" $text "" text
+ regsub -all "(^|\n)\[^\n\]*: At top level:\[^\n\]*" $text "" text
+
+ # It would be nice to avoid passing anything to obj-c++ that would cause it to
+ # issue these messages (since ignoring them seems like a hack on our part),
+ # but that's too difficult in the general case. For example, sometimes
+ # you need to use -B to point obj-c++ at crt0.o, but there are some targets
+ # that don't have crt0.o.
+ regsub -all "(^|\n)\[^\n\]*file path prefix \[^\n\]* never used" $text "" text
+ regsub -all "(^|\n)\[^\n\]*linker input file unused since linking not done" $text "" text
+
+ #send_user "After:$text\n"
+
+ return $text
+}
diff --git a/gcc/testsuite/lib/scanasm.exp b/gcc/testsuite/lib/scanasm.exp
index 79d93cbf089..527813139f6 100644
--- a/gcc/testsuite/lib/scanasm.exp
+++ b/gcc/testsuite/lib/scanasm.exp
@@ -156,12 +156,13 @@ proc scan-assembler-dem { args } {
}
# Find c++filt like we find g++ in g++.exp.
+ # APPLE LOCAL - c++filt3
if ![info exists cxxfilt] {
set cxxfilt [findfile $base_dir/../../binutils/cxxfilt \
$base_dir/../../binutils/cxxfilt \
[findfile $base_dir/../c++filt $base_dir/../c++filt \
[findfile $base_dir/c++filt $base_dir/c++filt \
- [transform c++filt]]]]
+ [transform c++filt3]]]]
verbose -log "c++filt is $cxxfilt"
}
@@ -202,12 +203,13 @@ proc scan-assembler-dem-not { args } {
}
# Find c++filt like we find g++ in g++.exp.
+ # APPLE LOCAL - c++filt3
if ![info exists cxxfilt] {
set cxxfilt [findfile $base_dir/../../binutils/cxxfilt \
$base_dir/../../binutils/cxxfilt \
[findfile $base_dir/../c++filt $base_dir/../c++filt \
[findfile $base_dir/c++filt $base_dir/c++filt \
- [transform c++filt]]]]
+ [transform c++filt3]]]]
verbose -log "c++filt is $cxxfilt"
}
diff --git a/gcc/testsuite/obj-c++.dg/basic.mm b/gcc/testsuite/obj-c++.dg/basic.mm
new file mode 100644
index 00000000000..6a0de713825
--- /dev/null
+++ b/gcc/testsuite/obj-c++.dg/basic.mm
@@ -0,0 +1,24 @@
+// APPLE LOCAL file Objective-C++
+// A basic sanity check for Objective-C++.
+// { dg-do run }
+
+#include <objc/objc.h>
+#include <objc/Object.h>
+
+#include <iostream>
+
+@interface Greeter : Object
+- (void) greet;
+@end
+
+@implementation Greeter
+- (void) greet { printf ("Hello from Objective-C\n"); }
+@end
+
+int
+main ()
+{
+ std::cout << "Hello from C++\n";
+ Greeter *obj = [Greeter new];
+ [obj greet];
+}
diff --git a/gcc/testsuite/gcc.dg/charset/charset.exp b/gcc/testsuite/obj-c++.dg/dg.exp
index ad75cb55af8..52109d30131 100644
--- a/gcc/testsuite/gcc.dg/charset/charset.exp
+++ b/gcc/testsuite/obj-c++.dg/dg.exp
@@ -1,44 +1,40 @@
-# Copyright (C) 2004 Free Software Foundation, Inc.
+# APPLE LOCAL file Objective-C++
+# GCC Objective-C++ testsuite that uses the `dg.exp' driver.
+# Copyright (C) 2002 Free Software Foundation, Inc.
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.
-#
+#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
# GNU General Public License for more details.
-#
+#
# You should have received a copy of the GNU General Public License
# along with this program; if not, write to the Free Software
-# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
-
-# GCC testsuite that uses the 'dg.exp' driver.
-
-# There's a bunch of headers we need.
-if [is_remote host] {
- foreach header [glob -nocomplain $srcdir/$subdir/*.{h,def} ] {
- remote_download host $header
- }
-}
+# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
# Load support procs.
-load_lib gcc-dg.exp
-load_lib target-supports.exp
+load_lib obj-c++-dg.exp
# If a testcase doesn't have special options, use these.
-global DEFAULT_CHARSETCFLAGS
-if ![info exists DEFAULT_CHARSETCFLAGS] then {
- set DEFAULT_CHARSETCFLAGS "-fexec-charset=IBM-1047"
+global DEFAULT_CXXFLAGS
+if ![info exists DEFAULT_CXXFLAGS] then {
+ set DEFAULT_CXXFLAGS ""
}
# Initialize `dg'.
dg-init
+# Gather a list of all tests.
+set all [lsort [find $srcdir/$subdir *.mm]]
+
# Main loop.
-dg-runtest [lsort [glob -nocomplain $srcdir/$subdir/*.{c,S} ]] \
- "" $DEFAULT_CHARSETCFLAGS
+# (The -lobjc is a cheap hack, should be fixed to account for both
+# installed and uninstalled objc libs)
+dg-runtest $all "" "$DEFAULT_CXXFLAGS -lobjc"
# All done.
dg-finish
diff --git a/gcc/testsuite/obj-c++.dg/method-1.mm b/gcc/testsuite/obj-c++.dg/method-1.mm
new file mode 100644
index 00000000000..7b6f9364140
--- /dev/null
+++ b/gcc/testsuite/obj-c++.dg/method-1.mm
@@ -0,0 +1,30 @@
+/* APPLE LOCAL file Objective-C++ */
+/* Test whether casting 'id' to a specific class removes method lookup
+ ambiguity. */
+/* Author: Ziemowit Laski <zlaski@apple.com>. */
+/* { dg-do compile } */
+
+#import <objc/objc.h>
+
+@class Int1, Int2;
+
+@interface Int1
++ (Int1 *)classMethod1;
++ (id)classMethod2;
+- (Int1 *)instanceMethod:(Int2 *)arg; /* { dg-bogus "using" } */
+@end
+
+@interface Int2: Int1
++ (Int1 *)classMethod1;
++ (id)classMethod2;
+- (id)int2Method;
+- (int)instanceMethod:(int)arg; /* { dg-bogus "also found" } */
+@end
+
+int main(void) {
+ id i = [(Int2 *)[Int1 classMethod1] int2Method]; /* { dg-bogus "does not respond to" } */
+ int j = [(Int2 *)[Int2 classMethod2] instanceMethod: 45]; /* { dg-bogus "multiple declarations" } */
+ /* { dg-bogus "invalid conversion" "" { target *-*-* } 26 } */
+ /* { dg-bogus "invalid conversion" "" { target *-*-* } 26 } */
+ return j;
+}
diff --git a/gcc/testsuite/obj-c++.dg/super-class-1.mm b/gcc/testsuite/obj-c++.dg/super-class-1.mm
new file mode 100644
index 00000000000..5b1bd6c0236
--- /dev/null
+++ b/gcc/testsuite/obj-c++.dg/super-class-1.mm
@@ -0,0 +1,30 @@
+/* APPLE LOCAL file call super */
+/* Test calling super from within a category method. */
+/* { dg-do compile } */
+#import <objc/objc.h>
+
+@interface NSObject
+@end
+@interface NSMenuItem: NSObject
+@end
+
+@interface NSObject (Test)
++ (int) test_func;
+@end
+
+@implementation NSObject (Test)
++ (int) test_func
+{}
+@end
+
+@interface NSMenuItem (Test)
++ (int) test_func;
+@end
+
+@implementation NSMenuItem (Test)
++ (int) test_func
+{
+ return [super test_func]; /* { dg-bogus "invalid use of undefined type" } */
+} /* { dg-bogus "forward declaration of" "" { target *-*-* } 27 } */
+@end
+
diff --git a/gcc/testsuite/obj-c++/redo-dg.exp b/gcc/testsuite/obj-c++/redo-dg.exp
new file mode 100644
index 00000000000..be5eebd632d
--- /dev/null
+++ b/gcc/testsuite/obj-c++/redo-dg.exp
@@ -0,0 +1,38 @@
+# APPLE LOCAL file Objective-C++
+# GCC Objective-C++ testsuite that uses the `dg.exp' driver.
+# Copyright (C) 2002 Free Software Foundation, Inc.
+
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program; if not, write to the Free Software
+# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
+
+# Load support procs.
+load_lib obj-c++-dg.exp
+
+# If a testcase doesn't have special options, use these.
+global DEFAULT_CXXFLAGS
+if ![info exists DEFAULT_CXXFLAGS] then {
+ set DEFAULT_CXXFLAGS ""
+}
+
+# Initialize `dg'.
+dg-init
+
+# Gather a list of all tests.
+set all [lsort [find $srcdir/g++.dg *.C]]
+
+# Main loop.
+dg-runtest $all "" "$DEFAULT_CXXFLAGS"
+
+# All done.
+dg-finish
diff --git a/gcc/testsuite/obj-c++/redo-old-deja.exp b/gcc/testsuite/obj-c++/redo-old-deja.exp
new file mode 100644
index 00000000000..1e06c55460e
--- /dev/null
+++ b/gcc/testsuite/obj-c++/redo-old-deja.exp
@@ -0,0 +1,63 @@
+# APPLE LOCAL file Objective-C++
+# Copyright (C) 2002 Free Software Foundation, Inc.
+
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program; if not, write to the Free Software
+# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
+
+# This file was written by Rob Savoye. (rob@cygnus.com)
+
+#
+# these tests come from the original DejaGnu test suite
+# developed at Cygnus Support. If this isn't deja gnu, I
+# don't know what is...
+#
+
+# load support procs
+load_lib old-dejagnu.exp
+load_lib obj-c++.exp
+
+
+# When a testcase doesn't have any special options, use these.
+if ![info exists DEFAULT_CXXFLAGS] {
+ set DEFAULT_CXXFLAGS "-ansi -pedantic-errors -Wno-long-long"
+
+}
+
+old-dejagnu-init
+global OBJCXX_UNDER_TEST
+
+#
+# main test loop
+#
+
+set dirlen [expr [string length "$srcdir/$subdir"] + 1];
+foreach file [lsort [find $srcdir/g++.old-deja *.C]] {
+ # If we're only testing specific files and this isn't one of them, skip it.
+ set tfile [string range $file $dirlen end];
+ if ![runtest_file_p $runtests $tfile] then {
+ continue
+ }
+ verbose "Testing $file"
+
+ # We don't want old-dejagnu.exp to have to know about all the global
+ # variables we use. For now we tell it about CXXFLAGS and LIBS and
+ # leave LDFLAGS alone.
+ old-dejagnu $OBJCXX_UNDER_TEST "$file" "$tfile" "" "$DEFAULT_CXXFLAGS" "-lstdc++"
+}
+
+# The framework doesn't like to see any error remnants,
+# so remove them.
+if [info exists errorInfo] then {
+ unset errorInfo
+}
diff --git a/gcc/testsuite/objc.dg/call-super-1.m b/gcc/testsuite/objc.dg/call-super-1.m
index 19e0d4900dd..b33af776f49 100644
--- a/gcc/testsuite/objc.dg/call-super-1.m
+++ b/gcc/testsuite/objc.dg/call-super-1.m
@@ -1,7 +1,8 @@
+/* APPLE LOCAL file msg send super */
/* Check if objc_super stack variables are created correctly (and
not clobbered by other values). */
/* Contributed by Ziemowit Laski <zlaski@apple.com>. */
-/* { dg-options "-std=c99 -lobjc" } */
+/* { dg-options "-std=c99" } */
/* { dg-do run } */
#include <objc/objc.h>
diff --git a/gcc/testsuite/objc.dg/category-1.m b/gcc/testsuite/objc.dg/category-1.m
index 1d29e374aea..251b125a617 100644
--- a/gcc/testsuite/objc.dg/category-1.m
+++ b/gcc/testsuite/objc.dg/category-1.m
@@ -1,16 +1,10 @@
+/* APPLE LOCAL file objc test suite */
/* Test class methods inside categories. */
/* Author: Ziemowit Laski <zlaski@apple.com>. */
/* { dg-options "-lobjc" } */
/* { dg-do run } */
#include <objc/Object.h>
-
-#ifdef __NEXT_RUNTIME__
-#define SUPERCLASS superclass
-#else
-#define SUPERCLASS superClass
-#endif
-
extern int strcmp(const char *s1, const char *s2);
extern void abort(void);
#define CHECK_IF(expr) if(!(expr)) abort()
@@ -20,7 +14,7 @@ extern void abort(void);
@end
@implementation MyObject
-+ (Class)whatever1 { return [super SUPERCLASS]; }
++ (Class)whatever1 { return [super superclass]; }
@end
@interface MyObject (ThisWontCompile)
@@ -28,7 +22,7 @@ extern void abort(void);
@end
@implementation MyObject (ThisWontCompile)
-+(Class)whatever2 { return [super SUPERCLASS]; }
++(Class)whatever2 { return [super superclass]; }
@end
int main (int argc, const char * argv[])
diff --git a/gcc/testsuite/objc.dg/const-cfstring-1.m b/gcc/testsuite/objc.dg/const-cfstring-1.m
new file mode 100644
index 00000000000..24242db02ea
--- /dev/null
+++ b/gcc/testsuite/objc.dg/const-cfstring-1.m
@@ -0,0 +1,57 @@
+/* APPLE LOCAL file constant cfstrings */
+/* Test the -fconstant-cfstrings option for constructing
+ compile-time immutable CFStrings, and their interoperation
+ with both Cocoa and CoreFoundation. This will only work
+ on MacOS X 10.1.2 and later. */
+/* Developed by Ziemowit Laski <zlaski@apple.com>. */
+
+/* { dg-do run { target powerpc-apple-darwin* } } */
+/* { dg-options "-fconstant-cfstrings -framework Cocoa" } */
+
+#import <Foundation/NSString.h>
+#import <CoreFoundation/CFString.h>
+
+#ifdef __CONSTANT_CFSTRINGS__
+#undef CFSTR
+#define CFSTR(STR) ((CFStringRef) __builtin___CFStringMakeConstantString (STR))
+#endif
+
+void printOut(NSString *str) {
+ NSLog(@"The value of str is: %@", str);
+}
+
+void checkNSRange(NSRange r) {
+ if (r.location != 6 || r.length != 5) {
+ printOut(@"Range check failed");
+ abort();
+ }
+}
+
+void checkCFRange(CFRange r) {
+ if (r.location != 6 || r.length != 5) {
+ printOut(@"Range check failed");
+ abort();
+ }
+}
+
+int main(void) {
+ NSString *s1 = @"Compile-time string literal";
+ CFStringRef s2 = CFSTR("Compile-time string literal");
+
+ if (s1 != (id)s2) {
+ NSLog(@"String comparison failed");
+ abort ();
+ }
+
+ checkNSRange([@"Hello World" rangeOfString:@"World"]);
+ checkNSRange([(id)CFSTR("Hello World") rangeOfString:@"World"]);
+ checkNSRange([@"Hello World" rangeOfString:(id)CFSTR("World")]);
+ checkNSRange([(id)CFSTR("Hello World") rangeOfString:(id)CFSTR("World")]);
+
+ checkCFRange(CFStringFind((CFStringRef)@"Hello World", (CFStringRef)@"World", 0));
+ checkCFRange(CFStringFind(CFSTR("Hello World"), (CFStringRef)@"World", 0));
+ checkCFRange(CFStringFind((CFStringRef)@"Hello World", CFSTR("World"), 0));
+ checkCFRange(CFStringFind(CFSTR("Hello World"), CFSTR("World"), 0));
+
+ return 0;
+}
diff --git a/gcc/testsuite/objc.dg/const-cfstring-2.m b/gcc/testsuite/objc.dg/const-cfstring-2.m
new file mode 100644
index 00000000000..64113c9ee3a
--- /dev/null
+++ b/gcc/testsuite/objc.dg/const-cfstring-2.m
@@ -0,0 +1,26 @@
+/* APPLE LOCAL file constant cfstrings */
+/* Test the -Wnonportable-cfstrings option, which should give
+ warnings if non-ASCII characters are embedded in constant
+ CFStrings. This will only work on MacOS X 10.2 and later. */
+/* Developed by Ziemowit Laski <zlaski@apple.com>. */
+
+/* { dg-do compile { target *-apple-darwin* } } */
+/* { dg-options "-fconstant-cfstrings -Wnonportable-cfstrings" } */
+
+#import <Foundation/NSString.h>
+#import <CoreFoundation/CFString.h>
+
+#ifndef __CONSTANT_CFSTRINGS__
+#error The -fconstant-cfstrings option is not functioning properly
+#endif
+
+void foo(void) {
+ NSString *s1 = @"Compile-time string literal";
+ CFStringRef s2 = CFSTR("Compile-time string literal");
+ NSString *s3 = @"Non-ASCII literal - \222"; /* { dg-warning "non-ASCII character in CFString literal" } */
+ CFStringRef s4 = CFSTR("\222 - Non-ASCII literal"); /* { dg-warning "non-ASCII character in CFString literal" } */
+ CFStringRef s5 = CFSTR("Non-ASCII (\222) literal"); /* { dg-warning "non-ASCII character in CFString literal" } */
+ NSString *s6 = @"\0Embedded NUL"; /* { dg-warning "embedded NUL in CFString literal" } */
+ CFStringRef s7 = CFSTR("Embedded \0NUL"); /* { dg-warning "embedded NUL in CFString literal" } */
+ CFStringRef s8 = CFSTR("Embedded NUL\0"); /* { dg-warning "embedded NUL in CFString literal" } */
+}
diff --git a/gcc/testsuite/objc.dg/const-str-3.m b/gcc/testsuite/objc.dg/const-str-3.m
index edc03ff62c7..9fe508b525c 100644
--- a/gcc/testsuite/objc.dg/const-str-3.m
+++ b/gcc/testsuite/objc.dg/const-str-3.m
@@ -1,9 +1,10 @@
+/* APPLE LOCAL file constant strings */
/* Test the -fconstant-string-class=Foo option under the NeXT
runtime. */
/* Developed by Markus Hitter <mah@jump-ing.de>. */
/* { dg-options "-fnext-runtime -fconstant-string-class=Foo -lobjc" } */
-/* { dg-do run { target *-*-darwin* } } */
+/* { dg-do run } */
#include <stdio.h>
#include <objc/objc.h>
@@ -26,11 +27,6 @@ struct objc_class _FooClassReference;
int main () {
Foo *string = @"bla";
- Foo *string2 = @"bla";
-
- if(string != string2)
- abort();
- printf("Strings are being uniqued properly\n");
/* This memcpy has to be done before the first message is sent to a
constant string object. Can't be moved to +initialize since _that_
diff --git a/gcc/testsuite/objc.dg/dg.exp b/gcc/testsuite/objc.dg/dg.exp
index ebf952967c7..7b3eba41d98 100644
--- a/gcc/testsuite/objc.dg/dg.exp
+++ b/gcc/testsuite/objc.dg/dg.exp
@@ -28,7 +28,8 @@ if ![info exists DEFAULT_CFLAGS] then {
dg-init
# Main loop.
-dg-runtest [lsort [glob -nocomplain $srcdir/$subdir/*.\[m\]]] \
+# APPLE LOCAL -ObjC
+dg-runtest [lsort [glob -nocomplain $srcdir/$subdir/*.\[mc\]]] \
"" $DEFAULT_CFLAGS
# All done.
diff --git a/gcc/testsuite/objc.dg/encode-1.m b/gcc/testsuite/objc.dg/encode-1.m
index 868c3254753..126e5d010f4 100644
--- a/gcc/testsuite/objc.dg/encode-1.m
+++ b/gcc/testsuite/objc.dg/encode-1.m
@@ -1,9 +1,9 @@
+/* APPLE LOCAL file bool encoding */
/* Test if the Objective-C @encode machinery distinguishes between
- 'BOOL *' (which should be encoded as a pointer to BOOL) and 'char *' (which
- should be encoded as '*'). This is somewhat tricky wrt the NeXT runtime,
- where we have 'typedef char BOOL'. */
+ 'BOOL *' (which should be encoded as '^c') and 'char *' (which
+ should be encoded as '*'). */
/* Contributed by Ziemowit Laski <zlaski@apple.com>. */
-/* { dg-options "-fnext-runtime -lobjc" } */
+/* { dg-options "-lobjc" } */
/* { dg-do run } */
#include <string.h>
@@ -12,10 +12,9 @@
int main(void) {
const char *BOOL_ptr = @encode(BOOL *);
- const char *BOOL_ = @encode(BOOL);
const char *char_ptr = @encode(char *);
-
- if(*BOOL_ptr != '^' || strcmp(BOOL_ptr + 1, BOOL_))
+
+ if(strcmp(BOOL_ptr, "^c"))
abort();
if(strcmp(char_ptr, "*"))
diff --git a/gcc/testsuite/objc.dg/nested-func-1.m b/gcc/testsuite/objc.dg/nested-func-1.m
index 7a182bd938e..ae45fee8621 100644
--- a/gcc/testsuite/objc.dg/nested-func-1.m
+++ b/gcc/testsuite/objc.dg/nested-func-1.m
@@ -1,3 +1,4 @@
+/* APPLE LOCAL file nested functions */
/* Test basic nested C function functionality within ObjC
methods. */
/* Contributed by Ziemowit Laski <zlaski@apple.com>. */
diff --git a/gcc/testsuite/objc.dg/objc.c b/gcc/testsuite/objc.dg/objc.c
new file mode 100644
index 00000000000..748111c26eb
--- /dev/null
+++ b/gcc/testsuite/objc.dg/objc.c
@@ -0,0 +1,6 @@
+/* APPLE LOCAL file -ObjC */
+
+/* { dg-do compile } */
+/* { dg-options "-ObjC" } */
+
+@class foo;
diff --git a/gcc/timevar.c b/gcc/timevar.c
index 1b5d2443c19..84d9a2af80b 100644
--- a/gcc/timevar.c
+++ b/gcc/timevar.c
@@ -27,6 +27,17 @@ Software Foundation, 59 Temple Place - Suite 330, Boston, MA
#ifdef HAVE_SYS_RESOURCE_H
#include <sys/resource.h>
#endif
+
+/* APPLE LOCAL begin Mach time */
+#ifdef HAVE_MACH_MACH_TIME_H
+#include <mach/mach_time.h>
+#define HAVE_MACH_TIME 1
+static double timeBaseRatio;
+static struct mach_timebase_info tbase;
+#else
+#define HAVE_MACH_TIME 0
+#endif
+/* APPLE LOCAL end Mach time */
#include "coretypes.h"
#include "tm.h"
#include "intl.h"
@@ -69,6 +80,33 @@ struct tms
/* Prefer times to getrusage to clock (each gives successively less
information). */
+/* APPLE LOCAL begin Mach time */
+/* On Darwin, prefer getrusage, plus Mach absolute time for the wall
+ clock time. Use PPC intrinsics if possible. */
+#if defined(__APPLE__) && defined(__POWERPC__) && HAVE_MACH_TIME
+#if __POWERPC__
+# include "../more-hdrs/ppc_intrinsics.h"
+# define HAVE_WALL_TIME
+# define USE_PPC_INTRINSICS
+inline double ppc_intrinsic_time()
+{
+ unsigned long hi, lo;
+ do
+ {
+ hi = __mftbu();
+ lo = __mftb();
+ } while (hi != __mftbu());
+ return (hi * 0x100000000ull + lo) * timeBaseRatio;
+}
+#endif /* __POWERPC__ */
+#elif HAVE_MACH_TIME
+# define USE_GETRUSAGE
+# define USE_MACH_TIME
+# define HAVE_USER_TIME
+# define HAVE_SYS_TIME
+# define HAVE_WALL_TIME
+# else
+/* APPLE LOCAL end Mach time */
#ifdef HAVE_TIMES
# if defined HAVE_DECL_TIMES && !HAVE_DECL_TIMES
extern clock_t times (struct tms *);
@@ -95,6 +133,8 @@ struct tms
#endif
#endif
#endif
+/* APPLE LOCAL Mach time */
+#endif /* HAVE_MACH_TIME */
/* libc is very likely to have snuck a call to sysconf() into one of
the underlying constants, and that can be very slow, so we have to
@@ -203,6 +243,14 @@ get_time (struct timevar_time_def *now)
#ifdef USE_CLOCK
now->user = clock () * clocks_to_msec;
#endif
+ /* APPLE LOCAL begin Mach time */
+#ifdef USE_MACH_TIME
+ now->wall = mach_absolute_time() * timeBaseRatio;
+#endif
+#ifdef USE_PPC_INTRINSICS
+ now->wall = ppc_intrinsic_time();
+#endif
+ /* APPLE LOCAL end Mach time */
}
}
@@ -240,6 +288,12 @@ timevar_init (void)
#ifdef USE_CLOCK
clocks_to_msec = CLOCKS_TO_MSEC;
#endif
+ /* APPLE LOCAL begin Mach time */
+#if defined(USE_MACH_TIME) || defined(USE_PPC_INTRINSICS)
+ mach_timebase_info(&tbase);
+ timeBaseRatio = ((double) tbase.numer / (double) tbase.denom) * 1e-9;
+#endif
+ /* APPLE LOCAL end Mach time */
}
/* Push TIMEVAR onto the timing stack. No further elapsed time is
@@ -489,22 +543,33 @@ timevar_print (FILE *fp)
/* Print total time. */
fputs (_(" TOTAL :"), fp);
#ifdef HAVE_USER_TIME
- fprintf (fp, "%7.2f ", total->user);
-#endif
+ /* APPLE LOCAL time formatting */
+ fprintf (fp, "%7.2f", total->user);
+#endif
#ifdef HAVE_SYS_TIME
- fprintf (fp, "%7.2f ", total->sys);
+ /* APPLE LOCAL time formatting */
+ fprintf (fp, " %7.2f", total->sys);
#endif
#ifdef HAVE_WALL_TIME
- fprintf (fp, "%7.2f\n", total->wall);
+ /* APPLE LOCAL time formatting */
+ fprintf (fp, " %7.2f", total->wall);
#endif
+ /* APPLE LOCAL time formatting */
+ putc ('\n', fp);
+
+#endif /* defined (HAVE_USER_TIME) || defined (HAVE_SYS_TIME)
+ || defined (HAVE_WALL_TIME) */
+}
-#ifdef ENABLE_CHECKING
- fprintf (fp, "Extra diagnostic checks enabled; compiler may run slowly.\n");
- fprintf (fp, "Configure with --disable-checking to disable checks.\n");
-#endif
+/* Returns time (user + system) used so far by the compiler process,
+ in microseconds. */
-#endif /* defined (HAVE_USER_TIME) || defined (HAVE_SYS_TIME)
- || defined (HAVE_WALL_TIME) */
+long
+get_run_time ()
+{
+ struct timevar_time_def total_elapsed;
+ timevar_get (TV_TOTAL, &total_elapsed);
+ return total_elapsed.user + total_elapsed.sys;
}
/* Prints a message to stderr stating that time elapsed in STR is
diff --git a/gcc/timevar.def b/gcc/timevar.def
index ec942588c0e..f729bc1fe34 100644
--- a/gcc/timevar.def
+++ b/gcc/timevar.def
@@ -125,6 +125,8 @@ DEFTIMEVAR (TV_SHORTEN_BRANCH , "shorten branches")
DEFTIMEVAR (TV_REG_STACK , "reg stack")
DEFTIMEVAR (TV_FINAL , "final")
DEFTIMEVAR (TV_SYMOUT , "symout")
+/* APPLE LOCAL */
+DEFTIMEVAR (TV_OV_RESOLUTION , "overload resolution")
DEFTIMEVAR (TV_VAR_TRACKING , "variable tracking")
/* Everything else in rest_of_compilation not included above. */
diff --git a/gcc/toplev.c b/gcc/toplev.c
index 2a3b5ec73ec..233aa757d67 100644
--- a/gcc/toplev.c
+++ b/gcc/toplev.c
@@ -108,6 +108,8 @@ static void init_asm_output (const char *);
static void finalize (void);
static void crash_signal (int) ATTRIBUTE_NORETURN;
+/* APPLE LOCAL interrupt signal handler (radar 2941633) ilr */
+static void interrupt_signal (int) ATTRIBUTE_NORETURN;
static void setup_core_dumping (void);
static void compile_file (void);
@@ -139,6 +141,11 @@ static const char **save_argv;
const char *main_input_filename;
+/* APPLE LOCAL fat builds */
+/* for radar 2865464 ilr */
+static int arch_specified = 0;
+/* APPLE LOCAL end fat builds */
+
/* Current position in real source file. */
location_t input_location;
@@ -255,6 +262,13 @@ int flag_branch_probabilities = 0;
int flag_reorder_blocks = 0;
+/* APPLE LOCAL begin hot/cold partitioning */
+/* Nonzero if blocks should be partitioned into hot and cold sections in
+ addition to being reordered. */
+
+int flag_reorder_blocks_and_partition = 0;
+/* APPLE LOCAL end hot/cold partitioning */
+
/* Nonzero if functions should be reordered. */
int flag_reorder_functions = 0;
@@ -309,12 +323,37 @@ int flag_signed_char;
int flag_short_enums;
+/* APPLE LOCAL begin -fast */
+/* Nonzero if we should perform SPEC oriented optimizations. */
+int flag_fast = 0;
+int flag_fastf = 0;
+int flag_fastcp = 0;
+/* APPLE LOCAL end -fast */
+
+/* APPLE LOCAL begin constant cfstrings */
+/* Nonzero means that: (1) the __CONSTANT_CFSTRINGS__ manifest constant
+ is defined, possibly allowing for conditional use of the
+ __builtin__CFStringMakeConstantString function (the latter is always
+ available, regardless of the setting of this flag), and (2) use
+ the CFString layout to create @"..." strings in ObjC/ObjC++. */
+int flag_constant_cfstrings;
+/* Nonzero means that we should warn whenever non-ASCII characters appear
+ inside of @"..." literals (as they may be non-portable). */
+int warn_nonportable_cfstrings;
+/* APPLE LOCAL end constant cfstrings */
+
/* Nonzero for -fcaller-saves: allocate values in regs that need to
be saved across function calls, if that produces overall better code.
Optional now, so people can test it. */
int flag_caller_saves = 0;
+/* APPLE LOCAL begin -ffppc 2001-08-01 sts */
+/* Nonzero if the floating point precision control pass should
+ be performed. (x86 only really, but we pretend it's generic) */
+int flag_fppc = 0;
+/* APPLE LOCAL end -ffppc 2001-08-01 sts */
+
/* Nonzero if structures and unions should be returned in memory.
This should only be defined if compatibility with another compiler or
@@ -564,6 +603,13 @@ int flag_rerun_loop_opt;
int flag_inline_functions;
+/* APPLE LOCAL begin -fobey-inline */
+/* Nonzero for -fobey-inline: 'inline' keyword must be obeyed, regardless
+ of codesize. */
+
+int flag_obey_inline;
+/* APPLE LOCAL end -fobey-inline */
+
/* Nonzero for -fkeep-inline-functions: even if we make a function
go inline everywhere, keep its definition around for debugging
purposes. */
@@ -840,10 +886,21 @@ int flag_tree_dse = 0;
/* Nonzero if we perform superblock formation. */
int flag_tracer = 0;
+/* APPLE LOCAL begin loop transposition */
+/* Nonzero if we should perform automatic loop transposition. */
+int flag_loop_transpose = 0;
+/* APPLE LOCAL end loop transposition */
+
/* Nonzero if we perform whole unit at a time compilation. */
int flag_unit_at_a_time = 0;
+/* APPLE LOCAL BEGIN pch distcc mrs */
+/* True if PCH should omit from the -E output all lines from PCH files
+ found in PCH files. */
+int flag_pch_preprocess = 0;
+/* APPLE LOCAL END pch distcc mrs */
+
/* Nonzero if we should track variables. When
flag_var_tracking == AUTODETECT_FLAG_VAR_TRACKING it will be set according
to optimize, debug_info_level and debug_hooks in process_options (). */
@@ -892,6 +949,40 @@ int flag_evaluation_order = 0;
/* Add or remove a leading underscore from user symbols. */
int flag_leading_underscore = -1;
+/* APPLE LOCAL begin Pascal strings 2001-07-12 sts */
+/* Nonzero means initial "\p" in string becomes a length byte and
+ string type becomes _unsigned_ char* . Although currently this is
+ a C/C++-only flag, it may be of future use with other frontends,
+ thus we define it here. */
+
+int flag_pascal_strings;
+/* APPLE LOCAL end Pascal strings 2001-07-12 sts */
+
+/* APPLE LOCAL begin coalescing turly 20020319 */
+/* Don't enable coalescing by default unless we have one of these
+ features in cctools. */
+#if defined(APPLE_WEAK_SECTION_ATTRIBUTE) || defined(APPLE_WEAK_ASSEMBLER_DIRECTIVE)
+#define COALESCE_BY_DEFAULT 1
+#else
+#define COALESCE_BY_DEFAULT 0
+#endif
+/* Nonzero means that certain data and code items can be marked as
+ coalesced, which is a lesser form of ELF weak symbols. */
+int flag_coalescing_enabled = COALESCE_BY_DEFAULT;
+
+/* Nonzero means mark template instantiations as coalesced. */
+int flag_coalesce_templates = COALESCE_BY_DEFAULT;
+
+/* Nonzero means use the OS X 10.2 "weak_definitions" section attribute.
+ If this is set, then explicit template instantiations DO NOT get
+ coalesced, but are plain old text or data instead. */
+int flag_weak_coalesced_definitions = COALESCE_BY_DEFAULT;
+
+/* Coalesced symbols are private export by default. This EXPERIMENTAL
+ flag will make them global instead. */
+int flag_export_coalesced = 0;
+/* APPLE LOCAL end coalescing turly 20020319 */
+
/* The version of the C++ ABI in use. The following values are
allowed:
@@ -942,6 +1033,7 @@ static const lang_independent_options f_options[] =
{"expensive-optimizations", &flag_expensive_optimizations, 1 },
{"thread-jumps", &flag_thread_jumps, 1 },
{"strength-reduce", &flag_strength_reduce, 1 },
+ {"loop-transpose", &flag_loop_transpose, 1, },
{"unroll-loops", &flag_unroll_loops, 1 },
{"unroll-all-loops", &flag_unroll_all_loops, 1 },
{"old-unroll-loops", &flag_old_unroll_loops, 1 },
@@ -958,6 +1050,8 @@ static const lang_independent_options f_options[] =
{"inline-functions", &flag_inline_functions, 1 },
{"keep-inline-functions", &flag_keep_inline_functions, 1 },
{"inline", &flag_no_inline, 0 },
+ /* APPLE LOCAL -fobey-inline */
+ {"obey-inline", &flag_obey_inline, 1, },
{"keep-static-consts", &flag_keep_static_consts, 1 },
{"syntax-only", &flag_syntax_only, 1 },
{"shared-data", &flag_shared_data, 1 },
@@ -1008,6 +1102,7 @@ static const lang_independent_options f_options[] =
{"profile", &profile_flag, 1 },
{"tree-based-profiling", &flag_tree_based_profiling, 1 },
{"reorder-blocks", &flag_reorder_blocks, 1 },
+ {"reorder-blocks-and-partition", &flag_reorder_blocks_and_partition, 1},
{"reorder-functions", &flag_reorder_functions, 1 },
{"rename-registers", &flag_rename_registers, 1 },
{"cprop-registers", &flag_cprop_registers, 1 },
@@ -1049,6 +1144,16 @@ static const lang_independent_options f_options[] =
{"mem-report", &mem_report, 1 },
{ "trapv", &flag_trapv, 1 },
{ "wrapv", &flag_wrapv, 1 },
+ /* APPLE LOCAL -ffppc 2001-08-01 sts */
+ { "fppc", &flag_fppc, 1 },
+ /* APPLE LOCAL begin coalescing turly */
+ { "coalesce", &flag_coalescing_enabled, 1 },
+ { "weak-coalesced", &flag_weak_coalesced_definitions, 1 },
+ { "coalesce-templates", &flag_coalesce_templates, 1 },
+ { "export-coalesced", &flag_export_coalesced, 1 },
+ /* APPLE LOCAL end coalescing turly */
+ /* APPLE LOCAL Pascal strings 2001-07-05 zll */
+ { "pascal-strings", &flag_pascal_strings, 1 },
{ "new-ra", &flag_new_regalloc, 1 },
{ "var-tracking", &flag_var_tracking, 1},
{ "tree-gvn", &flag_tree_gvn, 1 },
@@ -1253,6 +1358,31 @@ floor_log2_wide (unsigned HOST_WIDE_INT x)
return log;
}
+/* APPLE LOCAL begin interrupt signal handler (radar 2941633) ilr */
+/* If the compilation is interrupted do some cleanup. Any files created
+ by the compilation are deleted. The compilation is terminated from
+ here. */
+static void
+interrupt_signal (int signo ATTRIBUTE_UNUSED)
+{
+ /* Close the dump files. */
+ if (flag_gen_aux_info)
+ {
+ fclose (aux_info_file);
+ unlink (aux_info_file_name);
+ }
+
+ if (asm_out_file)
+ {
+ fclose (asm_out_file);
+ if (asm_file_name && *asm_file_name)
+ unlink (asm_file_name);
+ }
+
+ exit (FATAL_EXIT_CODE);
+}
+/* APPLE LOCAL end interrupt signal handler */
+
/* Handler for fatal signals, such as SIGSEGV. These are transformed
into ICE messages, which is much more user friendly. In case the
error printer crashes, reset the signal to prevent infinite recursion. */
@@ -1575,6 +1705,46 @@ warn_deprecated_use (tree node)
}
}
+/* APPLE LOCAL begin unavailable ilr */
+/* Warn about a use of an identifier which was marked deprecated. */
+void
+warn_unavailable_use (tree node)
+{
+ if (node == 0)
+ return;
+
+ if (DECL_P (node))
+ warning ("`%s' is unavailable (declared at %s:%d)",
+ IDENTIFIER_POINTER (DECL_NAME (node)),
+ DECL_SOURCE_FILE (node), DECL_SOURCE_LINE (node));
+ else if (TYPE_P (node))
+ {
+ const char *what = NULL;
+ tree decl = TYPE_STUB_DECL (node);
+
+ if (TREE_CODE (TYPE_NAME (node)) == IDENTIFIER_NODE)
+ what = IDENTIFIER_POINTER (TYPE_NAME (node));
+ else if (TREE_CODE (TYPE_NAME (node)) == TYPE_DECL
+ && DECL_NAME (TYPE_NAME (node)))
+ what = IDENTIFIER_POINTER (DECL_NAME (TYPE_NAME (node)));
+
+ if (what)
+ {
+ if (decl)
+ warning ("`%s' is unavailable (declared at %s:%d)", what,
+ DECL_SOURCE_FILE (decl), DECL_SOURCE_LINE (decl));
+ else
+ warning ("`%s' is unavailable", what);
+ }
+ else if (decl)
+ warning ("type is unavailable (declared at %s:%d)",
+ DECL_SOURCE_FILE (decl), DECL_SOURCE_LINE (decl));
+ else
+ warning ("type is unavailable");
+ }
+}
+/* APPLE LOCAL end unavailable ilr */
+
/* Save the current INPUT_LOCATION on the top entry in the
INPUT_FILE_STACK. Push a new entry for FILE and LINE, and set the
INPUT_LOCATION accordingly. */
@@ -1677,6 +1847,19 @@ compile_file (void)
#endif
}
+/* This is called from various places for FUNCTION_DECL, VAR_DECL,
+ and TYPE_DECL nodes.
+
+ This does nothing for local (non-static) variables, unless the
+ variable is a register variable with an ASMSPEC. In that case, or
+ if the variable is not an automatic, it sets up the RTL and
+ outputs any assembler code (label definition, storage allocation
+ and initialization).
+
+ DECL is the declaration. If ASMSPEC is nonzero, it specifies
+ the assembler symbol name to be used. TOP_LEVEL is nonzero
+ if this declaration is not within a function. */
+
/* Display help for target options. */
void
display_target_options (void)
@@ -1849,7 +2032,12 @@ set_target_switch (const char *name)
}
#endif
- if (!valid_target_option)
+ /* APPLE LOCAL begin fat builds */
+ /* Note, the driver guarantees that -arch will precede the -m
+ options so that arch_specified will be known by the time we get
+ here. For Radar 2865464. */
+ if (!valid_target_option && !arch_specified)
+ /* APPLE LOCAL end fat builds */
error ("invalid option `%s'", name);
}
@@ -1942,6 +2130,18 @@ print_switch_values (FILE *file, int pos, int max,
continue;
if ((*p)[1] == 'd')
continue;
+ /* APPLE LOCAL begin -fast or -fastf or -fastcp */
+ if ((flag_fast || flag_fastf || flag_fastcp)
+ && (*p)[0] == '-' && (*p)[1] == 'O')
+ {
+ int optimize_val;
+ if ((*p)[2] == 's' && (*p)[3] == '\0')
+ continue;
+ optimize_val = read_integral_parameter (*p+2, 0, -1);
+ if (optimize_val != 3)
+ continue;
+ }
+ /* APPLE LOCAL end -fast or -fastf or -fastcp */
pos = print_single_switch (file, pos, max, indent, sep, term, *p, "");
}
@@ -1957,8 +2157,15 @@ print_switch_values (FILE *file, int pos, int max,
for (j = 0; j < ARRAY_SIZE (f_options); j++)
if (*f_options[j].variable == f_options[j].on_value)
- pos = print_single_switch (file, pos, max, indent, sep, term,
- "-f", f_options[j].string);
+ /* APPLE LOCAL begin 3372156 */
+ /* FSF candidate */
+ {
+ char value[256];
+ sprintf (value, "-f%s=%d", f_options[j].string,f_options[j].on_value);
+ pos = print_single_switch (file, pos, max, indent, sep, term,
+ "", value);
+ }
+ /* APPLE LOCAL end 3372156 */
/* Print target specific options. */
@@ -2220,6 +2427,15 @@ general_init (const char *argv0)
#if defined SIGIOT && (!defined SIGABRT || SIGABRT != SIGIOT)
signal (SIGIOT, crash_signal);
#endif
+ /* APPLE LOCAL begin interrupt signal handler (radar 2941633) ilr */
+ /* Handle compilation interrupts. */
+ if (signal (SIGINT, SIG_IGN) != SIG_IGN)
+ signal (SIGINT, interrupt_signal);
+ if (signal (SIGKILL, SIG_IGN) != SIG_IGN)
+ signal (SIGINT, interrupt_signal);
+ if (signal (SIGTERM, SIG_IGN) != SIG_IGN)
+ signal (SIGTERM, interrupt_signal);
+ /* APPLE LOCAL end interrupt signal handler */
#ifdef SIGFPE
signal (SIGFPE, crash_signal);
#endif
@@ -2227,6 +2443,22 @@ general_init (const char *argv0)
/* Other host-specific signal setup. */
(*host_hooks.extra_signals)();
+ /* APPLE LOCAL begin setrlimit */
+#ifdef RLIMIT_STACK
+ /* Get rid of any avoidable limit on stack size. */
+ {
+ struct rlimit rlim;
+
+ /* Set the stack limit huge. (Compiles normally work within
+ a megabyte of stack, but the normal limit on OSX is 512K for
+ some reason.) */
+ getrlimit (RLIMIT_STACK, &rlim);
+ rlim.rlim_cur = rlim.rlim_max;
+ setrlimit (RLIMIT_STACK, &rlim);
+ }
+#endif /* RLIMIT_STACK defined */
+ /* APPLE LOCAL end setrlimit */
+
/* Initialize the garbage-collector, string pools and tree type hash
table. */
init_ggc ();
diff --git a/gcc/toplev.h b/gcc/toplev.h
index daad92fa10e..6c32e044c28 100644
--- a/gcc/toplev.h
+++ b/gcc/toplev.h
@@ -78,6 +78,8 @@ extern void announce_function (tree);
extern void error_for_asm (rtx, const char *, ...) ATTRIBUTE_GCC_DIAG(2,3);
extern void warning_for_asm (rtx, const char *, ...) ATTRIBUTE_GCC_DIAG(2,3);
extern void warn_deprecated_use (tree);
+/* APPLE LOCAL unavailable */
+extern void warn_unavailable_use (tree);
#ifdef BUFSIZ
extern void output_quoted_string (FILE *, const char *);
diff --git a/gcc/tree-dump.c b/gcc/tree-dump.c
index d45498ed455..2e43a744d19 100644
--- a/gcc/tree-dump.c
+++ b/gcc/tree-dump.c
@@ -604,6 +604,14 @@ dump_node (tree t, int flags, FILE *stream)
dump_queue_p dq;
dump_queue_p next_dq;
+ /* APPLE LOCAL begin new tree dump ilr */
+ /* The -fdmp-xxxx options indicate that we are to use dmp_tree() as
+ opposed to the dump format provided here. */
+ if (flags & TDF_DMP_TREE)
+ if ((*lang_hooks.dmp_tree3) (stream, t, flags))
+ return;
+ /* APPLE LOCAL end new tree dump ilr */
+
/* Initialize the dump-information structure. */
di.stream = stream;
di.index = 0;
@@ -643,7 +651,8 @@ struct dump_file_info
/* Table of tree dump switches. This must be consistent with the
TREE_DUMP_INDEX enumeration in tree.h */
-static struct dump_file_info dump_files[TDI_end] =
+/* APPLE LOCAL new tree dump ilr */
+static struct dump_file_info dump_files[TDI_end*2] =
{
{NULL, NULL, 0, 0},
{".tu", "translation-unit", 0, 0},
@@ -654,6 +663,13 @@ static struct dump_file_info dump_files[TDI_end] =
{".inlined", "tree-inlined", 0, 0},
{".dot", "tree-dot", 0, 0},
{".xml", "call-graph", 0, 0},
+ /* APPLE LOCAL begin new tree dump ilr */
+ {".dmp-tu", "dmp-translation-unit", 0, 0},
+ {".dmp-class", "dmp-class-hierarchy", 0, 0},
+ {".dmp-original", "dmp-tree-original", 0, 0},
+ {".dmp-optimized", "dmp-tree-optimized", 0, 0},
+ {".dmp-inlined", "dmp-tree-inlined", 0, 0},
+ /* APPLE LOCAL end new tree dump ilr */
{NULL, "tree-all", 0, 0},
};
@@ -841,6 +857,14 @@ dump_switch_p_1 (const char *arg, struct dump_file_info *dfi)
end_ptr = ptr + strlen (ptr);
length = end_ptr - ptr;
+ /* APPLE LOCAL begin new tree dump ilr */
+ if (strncmp (ptr, "dmp", 3) == 0)
+ {
+ flags |= TDF_DMP_TREE;
+ ptr += 3;
+ }
+ /* APPLE LOCAL end new tree dump ilr */
+
for (option_ptr = dump_options; option_ptr->name; option_ptr++)
if (strlen (option_ptr->name) == length
&& !memcmp (option_ptr->name, ptr, length))
diff --git a/gcc/tree-inline.c b/gcc/tree-inline.c
index b52b4a80447..ed7fc40b68e 100644
--- a/gcc/tree-inline.c
+++ b/gcc/tree-inline.c
@@ -95,6 +95,9 @@ typedef struct inline_data
int in_target_cleanup_p;
/* A list of the functions current function has inlined. */
varray_type inlined_fns;
+ /* The approximate number of instructions we have inlined in the
+ current call stack. */
+ int inlined_insns;
/* We use the same mechanism to build clones that we do to perform
inlining. However, there are a few places where we need to
distinguish between those two situations. This flag is true if
@@ -1678,6 +1681,11 @@ expand_call_inline (tree *tp, int *walk_subtrees, void *data)
the equivalent inlined version either. */
TREE_USED (*tp) = 1;
+ /* Our function now has more statements than it did before. */
+ DECL_ESTIMATED_INSNS (VARRAY_TREE (id->fns, 0)) += DECL_ESTIMATED_INSNS (fn);
+ /* For accounting, subtract one for the saved call/ret. */
+ id->inlined_insns += DECL_ESTIMATED_INSNS (fn) - 1;
+
/* Update callgraph if needed. */
cgraph_remove_node (edge->callee);
@@ -1685,6 +1693,11 @@ expand_call_inline (tree *tp, int *walk_subtrees, void *data)
expand_calls_inline (inlined_body, id);
VARRAY_POP (id->fns);
+ /* If we've returned to the top level, clear out the record of how
+ much inlining has been done. */
+ if (VARRAY_ACTIVE_SIZE (id->fns) == id->first_inlined_fn)
+ id->inlined_insns = 0;
+
/* Don't walk into subtrees. We've already handled them above. */
*walk_subtrees = 0;
@@ -1816,6 +1829,8 @@ optimize_inline_calls (tree fn)
/* Don't allow recursion into FN. */
VARRAY_TREE_INIT (id.fns, 32, "fns");
VARRAY_PUSH_TREE (id.fns, fn);
+ if (!DECL_ESTIMATED_INSNS (fn))
+ DECL_ESTIMATED_INSNS (fn) = estimate_num_insns (fn);
/* Or any functions that aren't finished yet. */
prev_fn = NULL_TREE;
if (current_function_decl)
diff --git a/gcc/tree.c b/gcc/tree.c
index 5cc8967ede9..ad10ad69092 100644
--- a/gcc/tree.c
+++ b/gcc/tree.c
@@ -94,7 +94,8 @@ struct type_hash GTY(())
};
/* Initial size of the hash table (rounded to next prime). */
-#define TYPE_HASH_INITIAL_SIZE 1000
+/* APPLE LOCAL fsf candidate */
+#define TYPE_HASH_INITIAL_SIZE 4111
/* Now here is the hash table. When recording a type, it is added to
the slot whose index is the hash code. Note that the hash table is
@@ -464,6 +465,8 @@ build_vector (tree type, tree vals)
{
tree value = TREE_VALUE (link);
+ /* APPLE LOCAL AltiVec */
+ TREE_VALUE (link) = fold (value);
over1 |= TREE_OVERFLOW (value);
over2 |= TREE_CONSTANT_OVERFLOW (value);
}
@@ -2471,6 +2474,8 @@ build2_stat (enum tree_code code, tree tt, tree arg0, tree arg1 MEM_STAT_DECL)
/* Expressions without side effects may be constant if their
arguments are as well. */
constant = (TREE_CODE_CLASS (code) == '<'
+ /* APPLE LOCAL AltiVec */
+ || TREE_CODE_CLASS (code) == 'e'
|| TREE_CODE_CLASS (code) == '2');
read_only = 1;
side_effects = TREE_SIDE_EFFECTS (t);
@@ -5026,6 +5031,27 @@ finish_vector_type (tree t)
}
}
+static tree
+make_or_reuse_type (unsigned size, int unsignedp)
+{
+ if (size == INT_TYPE_SIZE)
+ return unsignedp ? unsigned_type_node : integer_type_node;
+ if (size == CHAR_TYPE_SIZE)
+ return unsignedp ? unsigned_char_type_node : signed_char_type_node;
+ if (size == SHORT_TYPE_SIZE)
+ return unsignedp ? short_unsigned_type_node : short_integer_type_node;
+ if (size == LONG_TYPE_SIZE)
+ return unsignedp ? long_unsigned_type_node : long_integer_type_node;
+ if (size == LONG_LONG_TYPE_SIZE)
+ return (unsignedp ? long_long_unsigned_type_node
+ : long_long_integer_type_node);
+
+ if (unsignedp)
+ return make_unsigned_type (size);
+ else
+ return make_signed_type (size);
+}
+
/* Create nodes for all integer types (and error_mark_node) using the sizes
of C datatypes. The caller should call set_sizetype soon after calling
this function to select one of the types as sizetype. */
@@ -5068,17 +5094,19 @@ build_common_tree_nodes (int signed_char)
TREE_TYPE (TYPE_MAX_VALUE (boolean_type_node)) = boolean_type_node;
TYPE_PRECISION (boolean_type_node) = 1;
- intQI_type_node = make_signed_type (GET_MODE_BITSIZE (QImode));
- intHI_type_node = make_signed_type (GET_MODE_BITSIZE (HImode));
- intSI_type_node = make_signed_type (GET_MODE_BITSIZE (SImode));
- intDI_type_node = make_signed_type (GET_MODE_BITSIZE (DImode));
- intTI_type_node = make_signed_type (GET_MODE_BITSIZE (TImode));
-
- unsigned_intQI_type_node = make_unsigned_type (GET_MODE_BITSIZE (QImode));
- unsigned_intHI_type_node = make_unsigned_type (GET_MODE_BITSIZE (HImode));
- unsigned_intSI_type_node = make_unsigned_type (GET_MODE_BITSIZE (SImode));
- unsigned_intDI_type_node = make_unsigned_type (GET_MODE_BITSIZE (DImode));
- unsigned_intTI_type_node = make_unsigned_type (GET_MODE_BITSIZE (TImode));
+ /* Fill in the rest of the sized types. Reuse existing type nodes
+ when possible. */
+ intQI_type_node = make_or_reuse_type (GET_MODE_BITSIZE (QImode), 0);
+ intHI_type_node = make_or_reuse_type (GET_MODE_BITSIZE (HImode), 0);
+ intSI_type_node = make_or_reuse_type (GET_MODE_BITSIZE (SImode), 0);
+ intDI_type_node = make_or_reuse_type (GET_MODE_BITSIZE (DImode), 0);
+ intTI_type_node = make_or_reuse_type (GET_MODE_BITSIZE (TImode), 0);
+
+ unsigned_intQI_type_node = make_or_reuse_type (GET_MODE_BITSIZE (QImode), 1);
+ unsigned_intHI_type_node = make_or_reuse_type (GET_MODE_BITSIZE (HImode), 1);
+ unsigned_intSI_type_node = make_or_reuse_type (GET_MODE_BITSIZE (SImode), 1);
+ unsigned_intDI_type_node = make_or_reuse_type (GET_MODE_BITSIZE (DImode), 1);
+ unsigned_intTI_type_node = make_or_reuse_type (GET_MODE_BITSIZE (TImode), 1);
access_public_node = get_identifier ("public");
access_protected_node = get_identifier ("protected");
@@ -5170,40 +5198,6 @@ build_common_tree_nodes_2 (int short_double)
va_list_type_node = t;
}
-
- unsigned_V4SI_type_node
- = make_vector (V4SImode, unsigned_intSI_type_node, 1);
- unsigned_V2HI_type_node
- = make_vector (V2HImode, unsigned_intHI_type_node, 1);
- unsigned_V2SI_type_node
- = make_vector (V2SImode, unsigned_intSI_type_node, 1);
- unsigned_V2DI_type_node
- = make_vector (V2DImode, unsigned_intDI_type_node, 1);
- unsigned_V4HI_type_node
- = make_vector (V4HImode, unsigned_intHI_type_node, 1);
- unsigned_V8QI_type_node
- = make_vector (V8QImode, unsigned_intQI_type_node, 1);
- unsigned_V8HI_type_node
- = make_vector (V8HImode, unsigned_intHI_type_node, 1);
- unsigned_V16QI_type_node
- = make_vector (V16QImode, unsigned_intQI_type_node, 1);
- unsigned_V1DI_type_node
- = make_vector (V1DImode, unsigned_intDI_type_node, 1);
-
- V16SF_type_node = make_vector (V16SFmode, float_type_node, 0);
- V4SF_type_node = make_vector (V4SFmode, float_type_node, 0);
- V4SI_type_node = make_vector (V4SImode, intSI_type_node, 0);
- V2HI_type_node = make_vector (V2HImode, intHI_type_node, 0);
- V2SI_type_node = make_vector (V2SImode, intSI_type_node, 0);
- V2DI_type_node = make_vector (V2DImode, intDI_type_node, 0);
- V4HI_type_node = make_vector (V4HImode, intHI_type_node, 0);
- V8QI_type_node = make_vector (V8QImode, intQI_type_node, 0);
- V8HI_type_node = make_vector (V8HImode, intHI_type_node, 0);
- V2SF_type_node = make_vector (V2SFmode, float_type_node, 0);
- V2DF_type_node = make_vector (V2DFmode, double_type_node, 0);
- V16QI_type_node = make_vector (V16QImode, intQI_type_node, 0);
- V1DI_type_node = make_vector (V1DImode, intDI_type_node, 0);
- V4DF_type_node = make_vector (V4DFmode, double_type_node, 0);
}
/* HACK. GROSS. This is absolutely disgusting. I wish there was a
@@ -5252,23 +5246,39 @@ reconstruct_complex_type (tree type, tree bottom)
return outer;
}
-/* Returns a vector tree node given a vector mode, the inner type, and
- the signness. */
-
+/* Returns a vector tree node given a vector mode and inner type. */
tree
-make_vector (enum machine_mode mode, tree innertype, int unsignedp)
+build_vector_type_for_mode (tree innertype, enum machine_mode mode)
{
tree t;
-
t = make_node (VECTOR_TYPE);
TREE_TYPE (t) = innertype;
TYPE_MODE (t) = mode;
- TREE_UNSIGNED (TREE_TYPE (t)) = unsignedp;
+ TREE_UNSIGNED (t) = TREE_UNSIGNED (innertype);
finish_vector_type (t);
-
return t;
}
+/* Similarly, but takes inner type and units. */
+
+tree
+build_vector_type (tree innertype, int nunits)
+{
+ enum machine_mode innermode = TYPE_MODE (innertype);
+ enum machine_mode mode;
+
+ if (GET_MODE_CLASS (innermode) == MODE_FLOAT)
+ mode = MIN_MODE_VECTOR_FLOAT;
+ else
+ mode = MIN_MODE_VECTOR_INT;
+
+ for (; mode != VOIDmode ; mode = GET_MODE_WIDER_MODE (mode))
+ if (GET_MODE_NUNITS (mode) == nunits && GET_MODE_INNER (mode) == innermode)
+ return build_vector_type_for_mode (innertype, mode);
+
+ return NULL_TREE;
+}
+
/* Given an initializer INIT, return TRUE if INIT is zero or some
aggregate of zeros. Otherwise return FALSE. */
diff --git a/gcc/tree.h b/gcc/tree.h
index 0e875e0a851..679cf7e42ac 100644
--- a/gcc/tree.h
+++ b/gcc/tree.h
@@ -180,6 +180,9 @@ struct tree_common GTY(())
unsigned lang_flag_5 : 1;
unsigned lang_flag_6 : 1;
unsigned visited : 1;
+
+ /* APPLE LOCAL unavailable (Radar 2809697) ilr */
+ unsigned unavailable_flag : 1;
};
/* The following table lists the uses of each of the above flags and
@@ -270,6 +273,9 @@ struct tree_common GTY(())
INTEGER_TYPE, ENUMERAL_TYPE, FIELD_DECL
SAVE_EXPR_NOPLACEHOLDER in
SAVE_EXPR
+ APPLE LOCAL weak import
+ IDENTIFIER_WEAK_IMPORT in
+ IDENTIFIER
asm_written_flag:
@@ -295,6 +301,13 @@ struct tree_common GTY(())
TREE_DEPRECATED in
..._DECL
+ APPLE LOCAL begin unavailable (Radar 2809697) ilr
+ unavailable_flag:
+
+ TREE_UNAVAILABLE in
+ ..._DECL
+ APPLE LOCAL end unavailable ilr
+
visited:
Used in tree traversals to mark visited nodes.
@@ -754,6 +767,12 @@ extern void tree_operand_check_failed (int, enum tree_code,
deprecated feature by __attribute__((deprecated)). */
#define TREE_DEPRECATED(NODE) ((NODE)->common.deprecated_flag)
+/* APPLE LOCAL begin unavailable (Radar 2809697) ilr */
+/* Nonzero in a IDENTIFIER_NODE if the use of the name is defined as a
+ unavailable feature by __attribute__((unavailable)). */
+#define TREE_UNAVAILABLE(NODE) ((NODE)->common.unavailable_flag)
+/* APPLE LOCAL end unavailable ilr */
+
/* Value of expression is function invariant. A strict subset of
TREE_CONSTANT, such an expression is constant over any one function
invocation, though not across different invocations. May appear in
@@ -2000,6 +2019,18 @@ struct tree_type GTY(())
/* Used to indicate that this DECL has weak linkage. */
#define DECL_WEAK(NODE) (DECL_CHECK (NODE)->decl.weak_flag)
+/* APPLE LOCAL begin weak_import (Radar 2809704) ilr */
+/* Used to indicate that this DECL has weak-import linkage. */
+#define DECL_WEAK_IMPORT(NODE) (DECL_CHECK (NODE)->decl.weak_import_flag)
+/* The same information in IDENTIFIERs. */
+#define IDENTIFIER_WEAK_IMPORT(NODE) (IDENTIFIER_NODE_CHECK (NODE)->common.unsigned_flag)
+/* APPLE LOCAL end weak_import (Radar 2809704) ilr */
+
+/* APPLE LOCAL coalescing */
+/* "coalesced" symbols are similar to, but have more restrictions than,
+ ELF-style "weak" symbols. */
+#define DECL_COALESCED(NODE) (DECL_CHECK (NODE)->decl.coalesced_flag)
+
/* Used in TREE_PUBLIC decls to indicate that copies of this DECL in
multiple translation units should be merged. */
#define DECL_ONE_ONLY(NODE) (DECL_CHECK (NODE)->decl.transparent_union)
@@ -2064,6 +2095,13 @@ struct tree_type GTY(())
#define DECL_POINTER_ALIAS_SET_KNOWN_P(NODE) \
(DECL_POINTER_ALIAS_SET (NODE) != - 1)
+/* In a FUNCTION_DECL for which DECL_BUILT_IN does not hold, this is
+ the approximate number of statements in this function. There is
+ no need for this number to be exact; it is only used in various
+ heuristics regarding optimization. */
+#define DECL_ESTIMATED_INSNS(NODE) \
+ (FUNCTION_DECL_CHECK (NODE)->decl.u1.i)
+
/* Nonzero for a decl which is at file scope. */
#define DECL_FILE_SCOPE_P(EXP) \
(! DECL_CONTEXT (EXP) \
@@ -2142,7 +2180,12 @@ struct tree_decl GTY(())
unsigned lang_flag_7 : 1;
unsigned needs_to_live_in_memory : 1;
- /* 15 unused bits. */
+ /* APPLE LOCAL weak_import (Radar 2809704) ilr */
+ unsigned weak_import_flag : 1;
+ /* APPLE LOCAL coalescing */
+ unsigned coalesced_flag : 1;
+ /* APPLE LOCAL unused bits */
+ /* 13 unused bits. */
union tree_decl_u1 {
/* In a FUNCTION_DECL for which DECL_BUILT_IN holds, this is
@@ -2336,33 +2379,6 @@ enum tree_index
TI_VOID_LIST_NODE,
- TI_UV4SF_TYPE,
- TI_UV4SI_TYPE,
- TI_UV8HI_TYPE,
- TI_UV8QI_TYPE,
- TI_UV4HI_TYPE,
- TI_UV2HI_TYPE,
- TI_UV2SI_TYPE,
- TI_UV2SF_TYPE,
- TI_UV2DI_TYPE,
- TI_UV1DI_TYPE,
- TI_UV16QI_TYPE,
-
- TI_V4SF_TYPE,
- TI_V16SF_TYPE,
- TI_V4SI_TYPE,
- TI_V8HI_TYPE,
- TI_V8QI_TYPE,
- TI_V4HI_TYPE,
- TI_V2HI_TYPE,
- TI_V2SI_TYPE,
- TI_V2SF_TYPE,
- TI_V2DF_TYPE,
- TI_V2DI_TYPE,
- TI_V1DI_TYPE,
- TI_V16QI_TYPE,
- TI_V4DF_TYPE,
-
TI_MAIN_IDENTIFIER,
TI_MAX
@@ -2438,31 +2454,6 @@ extern GTY(()) tree global_trees[TI_MAX];
#define main_identifier_node global_trees[TI_MAIN_IDENTIFIER]
#define MAIN_NAME_P(NODE) (IDENTIFIER_NODE_CHECK (NODE) == main_identifier_node)
-#define unsigned_V16QI_type_node global_trees[TI_UV16QI_TYPE]
-#define unsigned_V4SI_type_node global_trees[TI_UV4SI_TYPE]
-#define unsigned_V8QI_type_node global_trees[TI_UV8QI_TYPE]
-#define unsigned_V8HI_type_node global_trees[TI_UV8HI_TYPE]
-#define unsigned_V4HI_type_node global_trees[TI_UV4HI_TYPE]
-#define unsigned_V2HI_type_node global_trees[TI_UV2HI_TYPE]
-#define unsigned_V2SI_type_node global_trees[TI_UV2SI_TYPE]
-#define unsigned_V2DI_type_node global_trees[TI_UV2DI_TYPE]
-#define unsigned_V1DI_type_node global_trees[TI_UV1DI_TYPE]
-
-#define V16QI_type_node global_trees[TI_V16QI_TYPE]
-#define V4SF_type_node global_trees[TI_V4SF_TYPE]
-#define V4SI_type_node global_trees[TI_V4SI_TYPE]
-#define V8QI_type_node global_trees[TI_V8QI_TYPE]
-#define V8HI_type_node global_trees[TI_V8HI_TYPE]
-#define V4HI_type_node global_trees[TI_V4HI_TYPE]
-#define V2HI_type_node global_trees[TI_V2HI_TYPE]
-#define V2SI_type_node global_trees[TI_V2SI_TYPE]
-#define V2SF_type_node global_trees[TI_V2SF_TYPE]
-#define V2DI_type_node global_trees[TI_V2DI_TYPE]
-#define V2DF_type_node global_trees[TI_V2DF_TYPE]
-#define V16SF_type_node global_trees[TI_V16SF_TYPE]
-#define V1DI_type_node global_trees[TI_V1DI_TYPE]
-#define V4DF_type_node global_trees[TI_V4DF_TYPE]
-
/* An enumeration of the standard C integer types. These must be
ordered so that shorter types appear before longer ones, and so
that signed types appear before unsigned ones, for the correct
@@ -2671,6 +2662,8 @@ extern tree build_pointer_type_for_mode (tree, enum machine_mode);
extern tree build_pointer_type (tree);
extern tree build_reference_type_for_mode (tree, enum machine_mode);
extern tree build_reference_type (tree);
+extern tree build_vector_type_for_mode (tree, enum machine_mode);
+extern tree build_vector_type (tree innertype, int nunits);
extern tree build_type_no_quals (tree);
extern tree build_index_type (tree);
extern tree build_index_2_type (tree, tree);
@@ -2783,6 +2776,10 @@ enum attribute_flags
name indicates known behavior, and should be silently ignored if they
are not in fact compatible with the function type. */
ATTR_FLAG_BUILT_IN = 16
+ /* APPLE LOCAL begin weak_import (Radar 2809704) ilr */
+ /* The attributes are being applied to a function definition. */
+ ,ATTR_FLAG_FUNCTION_DEF = 16
+ /* APPLE LOCAL end weak_import ilr */
};
/* Default versions of target-overridable functions. */
@@ -3626,6 +3623,13 @@ enum tree_dump_index
TDI_dot, /* create a dot graph file for each
function's flowgraph. */
TDI_xml, /* dump function call graph. */
+ /* APPLE LOCAL begin new tree dump */
+ TDI_dmp_tu, /* dmp the whole translation unit */
+ TDI_dmp_class, /* dmp class hierarchy */
+ TDI_dmp_original, /* dmp each function before optimizing it */
+ TDI_dmp_optimized, /* dmp each function after optimizing it */
+ TDI_dmp_inlined, /* dmp each function after inlining within it */
+ /* APPLE LOCAL end new tree dump */
TDI_all, /* enable all the dumps. */
TDI_end
};
@@ -3644,7 +3648,8 @@ enum tree_dump_index
#define TDF_VOPS (1 << 6) /* display virtual operands */
#define TDF_LINENO (1 << 7) /* display statement line numbers */
#define TDF_UID (1 << 8) /* display decl UIDs */
-
+/* APPLE LOCAL new tree dump ilr */
+#define TDF_DMP_TREE (1 << 9) /* use dmp_tree() to display nodes */
typedef struct dump_info *dump_info_p;
diff --git a/gcc/varasm.c b/gcc/varasm.c
index d2126fd2bae..e45e4d53ea7 100644
--- a/gcc/varasm.c
+++ b/gcc/varasm.c
@@ -50,6 +50,9 @@ Software Foundation, 59 Temple Place - Suite 330, Boston, MA
#include "target.h"
#include "tree-mudflap.h"
#include "cgraph.h"
+/* APPLE LOCAL begin hot/cold partitioning */
+#include "cfglayout.h"
+/* APPLE LOCAl end hot/cold partitioning */
#ifdef XCOFF_DEBUGGING_INFO
#include "xcoffout.h" /* Needed for external data
@@ -97,6 +100,16 @@ int size_directive_output;
tree last_assemble_variable_decl;
+/* APPLE LOCAL begin hot/cold partitioning */
+/* The following global variable indicates if the section label for the
+ "cold" section of code has been output yet to the assembler. The
+ label is useful when running gdb. This is part of the optimization that
+ partitions hot and cold basic blocks into separate sections of the .o
+ file. */
+
+bool unlikely_section_label_printed = false;
+/* APPLE LOCAL end hot/cold partitioning */
+
/* RTX_UNCHANGING_P in a MEM can mean it is stored into, for initialization.
So giving constant the alias set for the type will allow such
initializations to appear to conflict with the load of the constant. We
@@ -142,7 +155,10 @@ static bool asm_emit_uninitialised (tree, const char*,
unsigned HOST_WIDE_INT);
static void mark_weak (tree);
-enum in_section { no_section, in_text, in_data, in_named
+/* APPLE LOCAL begin hot/cold partitioning */
+enum in_section { no_section, in_text, in_unlikely_executed_text, in_data,
+ in_named
+/* APPLE LOCAL end hot/cold partitioning */
#ifdef BSS_SECTION_ASM_OP
, in_bss
#endif
@@ -195,10 +211,43 @@ text_section (void)
if (in_section != in_text)
{
in_section = in_text;
+ /* APPLE LOCAL begin hot/cold partitioning */
fprintf (asm_out_file, "%s\n", TEXT_SECTION_ASM_OP);
+ assemble_align (FUNCTION_BOUNDARY);
+ /* APPLE LOCAL end hot/cold partitioning */
}
}
+/* APPLE LOCAL begin hot/cold partitioning */
+/* Tell assembler to switch to unlikely-to-be-executed text section. */
+
+void
+unlikely_text_section (void)
+{
+ if ((in_section != in_unlikely_executed_text)
+ && (in_section != in_named
+ || strcmp (in_named_name, UNLIKELY_EXECUTED_TEXT_SECTION_NAME) != 0))
+ {
+ named_section (NULL_TREE, UNLIKELY_EXECUTED_TEXT_SECTION_NAME, 0);
+ assemble_align (FUNCTION_BOUNDARY);
+ in_section = in_unlikely_executed_text;
+
+ if (!unlikely_section_label_printed)
+ {
+ char *unlikely_section_name;
+ unlikely_section_name = xmalloc ((strlen (current_function_name ())
+ + 20) *
+ sizeof (char));
+ sprintf (unlikely_section_name, "_%s_unlikely_section:",
+ current_function_name ());
+ ASM_OUTPUT_LABEL (asm_out_file, unlikely_section_name);
+ unlikely_section_label_printed = true;
+ free (unlikely_section_name);
+ }
+ }
+}
+/* APPLE LOCAL end hot/cold partitioning */
+
/* Tell assembler to switch to data section. */
void
@@ -241,6 +290,23 @@ in_text_section (void)
return in_section == in_text;
}
+/* APPLE LOCAL begin hot/cold partitioning */
+/* Determine if we're in the unlikely-to-be-executed text section. */
+
+int
+in_unlikely_text_section (void)
+{
+ bool ret_val;
+
+ ret_val = ((in_section == in_unlikely_executed_text)
+ || (in_section == in_named
+ && (strcmp (in_named_name, UNLIKELY_EXECUTED_TEXT_SECTION_NAME)
+ == 0)));
+
+ return ret_val;
+}
+/* APPLE LOCAL end hot/cold partitioning */
+
/* Determine if we're in the data section. */
int
@@ -480,11 +546,15 @@ asm_output_aligned_bss (FILE *file, tree decl ATTRIBUTE_UNUSED,
void
function_section (tree decl)
{
+ /* APPLE LOCAL begin hot/cold partitioning */
if (decl != NULL_TREE
&& DECL_SECTION_NAME (decl) != NULL_TREE)
named_section (decl, (char *) 0, 0);
+ else if (scan_ahead_for_unlikely_executed_note (get_insns()))
+ unlikely_text_section ();
else
- text_section ();
+ text_section ();
+ /* APPLE LOCAL end hot/cold partitioning */
}
/* Switch to section for variable DECL. RELOC is the same as the
@@ -818,6 +888,8 @@ make_decl_rtl (tree decl, const char *asmspec)
x = gen_rtx_SYMBOL_REF (Pmode, name);
SYMBOL_REF_WEAK (x) = DECL_WEAK (decl);
+ /* APPLE LOCAL weak import */
+ SYMBOL_REF_WEAK_IMPORT (x) = DECL_WEAK_IMPORT (decl);
SYMBOL_REF_DECL (x) = decl;
x = gen_rtx_MEM (DECL_MODE (decl), x);
@@ -1036,6 +1108,10 @@ assemble_start_function (tree decl, const char *fnname)
{
int align;
+ /* APPLE LOCAL begin hot/cold partitioning */
+ unlikely_section_label_printed = false;
+ /* APPLE LOCAL end hot/cold partitioning */
+
/* The following code does not need preprocessing in the assembler. */
app_disable ();
@@ -1123,7 +1199,10 @@ assemble_zeros (unsigned HOST_WIDE_INT size)
#ifdef ASM_NO_SKIP_IN_TEXT
/* The `space' pseudo in the text section outputs nop insns rather than 0s,
so we must output 0s explicitly in the text section. */
- if (ASM_NO_SKIP_IN_TEXT && in_text_section ())
+ /* APPLE LOCAL begin hot/cold partitioning */
+ if ((ASM_NO_SKIP_IN_TEXT && in_text_section ())
+ || (ASM_NO_SKIP_IN_TEXT && in_unlikely_text_section ()))
+ /* APPLE LOCAL end hot/cold partitioning */
{
unsigned HOST_WIDE_INT i;
for (i = 0; i < size; i++)
@@ -1484,8 +1563,31 @@ assemble_variable (tree decl, int top_level ATTRIBUTE_UNUSED,
/* Switch to the appropriate section. */
variable_section (decl, reloc);
+ /* APPLE LOCAL begin zerofill turly 20020218 */
+#ifdef ASM_OUTPUT_ZEROFILL
+ /* We need a ZEROFILL COALESCED option! */
+ if (flag_no_common
+ && ! dont_output_data
+ /* APPLE LOCAL coalescing */
+ && ! DECL_COALESCED (decl)
+ && (DECL_INITIAL (decl) == 0 || DECL_INITIAL (decl) == error_mark_node))
+ {
+ ASM_OUTPUT_ZEROFILL (asm_out_file, name,
+ tree_low_cst (DECL_SIZE_UNIT (decl), 1),
+ floor_log2 (DECL_ALIGN (decl) / BITS_PER_UNIT));
+
+ /********************************/
+ /* NOTE THE EARLY RETURN HERE!! */
+ /********************************/
+ return;
+ }
+#endif
+ /* APPLE LOCAL end zerofill turly 20020218 */
+
/* dbxout.c needs to know this. */
- if (in_text_section ())
+ /* APPLE LOCAL begin hot/cold partitioning */
+ if (in_text_section () || in_unlikely_text_section ())
+ /* APPLE LOCAL end hot/cold partitioning */
DECL_IN_TEXT_SECTION (decl) = 1;
/* Output the alignment of this data. */
@@ -3250,6 +3352,8 @@ initializer_constant_valid_p (tree value, tree endtype)
{
case CONSTRUCTOR:
if ((TREE_CODE (TREE_TYPE (value)) == UNION_TYPE
+ /* APPLE LOCAL AltiVec */
+ || TREE_CODE (TREE_TYPE (value)) == VECTOR_TYPE
|| TREE_CODE (TREE_TYPE (value)) == RECORD_TYPE)
&& TREE_CONSTANT (value)
&& CONSTRUCTOR_ELTS (value))
@@ -4032,6 +4136,16 @@ merge_weak (tree newdecl, tree olddecl)
/* OLDDECL was weak, but NEWDECL was not explicitly marked as
weak. Just update NEWDECL to indicate that it's weak too. */
mark_weak (newdecl);
+
+ /* APPLE LOCAL begin weak_import (Radar 2809704) ilr */
+ if (DECL_WEAK_IMPORT (olddecl) != DECL_WEAK_IMPORT (newdecl))
+ {
+ if (! DECL_EXTERNAL (olddecl) && ! DECL_EXTERNAL (newdecl))
+ warning (
+ "%Jinconsistent weak_import attribute with previous declaration of `%D'", newdecl, olddecl);
+ DECL_WEAK_IMPORT (newdecl) = 1;
+ }
+ /* APPLE LOCAL end weak_import ilr */
}
/* Declare DECL to be a weak symbol. */
@@ -4117,6 +4231,16 @@ globalize_decl (tree decl)
}
#endif
+ /* APPLE LOCAL begin coalescing */
+ /* Weak definitions are used for coalesced symbols. They're not the
+ same thing as weak references. The naming is unfortunate. */
+#ifdef ASM_WEAK_DEFINITIONIZE_LABEL
+ if (DECL_COALESCED (decl) && flag_weak_coalesced_definitions)
+ ASM_WEAK_DEFINITIONIZE_LABEL (asm_out_file, name);
+#endif /* ASM_WEAK_DEFINITIONIZE_LABEL */
+
+ /* APPLE LOCAL end coalescing */
+
(*targetm.asm_out.globalize_label) (asm_out_file, name);
}
@@ -4334,6 +4458,10 @@ default_section_type_flags_1 (tree decl, const char *name, int reloc,
flags = SECTION_CODE;
else if (decl && decl_readonly_section_1 (decl, reloc, shlib))
flags = 0;
+ /* APPLE LOCAL begin hot/cold partitioning */
+ else if (strcmp (name, UNLIKELY_EXECUTED_TEXT_SECTION_NAME) == 0)
+ flags = SECTION_CODE;
+ /* APPLE LOCAL end hot/cold partitioning */
else
flags = SECTION_WRITE;
@@ -4933,6 +5061,15 @@ default_globalize_label (FILE * stream, const char *name)
}
#endif /* GLOBAL_ASM_OP */
+/* APPLE LOCAL begin coalescing */
+int
+darwin_named_section_is (const char* name)
+{
+ return (in_section == in_named
+ && strcmp (in_named_name, name) == 0);
+}
+/* APPLE LOCAL end coalescing */
+
/* This is how to output an internal numbered label where PREFIX is
the class of label and LABELNO is the number within the class. */
diff --git a/gcc/version.c b/gcc/version.c
index 9c8201ee97c..dc8c67ec4d1 100644
--- a/gcc/version.c
+++ b/gcc/version.c
@@ -5,7 +5,18 @@
please modify this string to indicate that, e.g. by putting your
organization's name in parentheses at the end of the string. */
-const char version_string[] = "3.5-tree-ssa 20040321 (merged 20040307)";
+/* APPLE LOCAL begin Apple version */
+/* When updating this string:
+ - For each internal build, increment the build number.
+ - When merging from the FSF, delete any (experimental) or (prerelease).
+ Apple doesn't mark its GCC versions as 'prerelease', because a released
+ compiler will be identical to the last prerelease compiler and it
+ makes no sense to mark released compilers as 'prerelease'.
+ - There are other scripts that search for first word of the string
+ to get version number string. Do not use new line.
+*/
+const char version_string[] = "3.5.0-tree-ssa 20040321 (merged 20040322) (Apple Computer, Inc. build 1741)";
+/* APPLE LOCAL end Apple version */
/* This is the location of the online document giving instructions for
reporting bugs. If you distribute a modified version of GCC,
@@ -14,4 +25,6 @@ const char version_string[] = "3.5-tree-ssa 20040321 (merged 20040307)";
forward us bugs reported to you, if you determine that they are
not bugs in your modifications.) */
-const char bug_report_url[] = "<URL:http://gcc.gnu.org/bugs.html>";
+/* APPLE LOCAL begin Apple bug-report */
+const char bug_report_url[] = "<URL:http://developer.apple.com/bugreporter>";
+/* APPLE LOCAL end Apple bug-report */
diff --git a/include/demangle.h b/include/demangle.h
index 6e995e4817d..9ee90150304 100644
--- a/include/demangle.h
+++ b/include/demangle.h
@@ -141,6 +141,8 @@ enum gnu_v3_ctor_kinds {
gnu_v3_complete_object_ctor = 1,
gnu_v3_base_object_ctor,
gnu_v3_complete_object_allocating_ctor
+ /* APPLE LOCAL decloning */
+ , gnu_v3_unified_ctor
};
/* Return non-zero iff NAME is the mangled form of a constructor name
@@ -155,6 +157,8 @@ enum gnu_v3_dtor_kinds {
gnu_v3_deleting_dtor = 1,
gnu_v3_complete_object_dtor,
gnu_v3_base_object_dtor
+ /* APPLE LOCAL decloning */
+ , gnu_v3_unified_dtor
};
/* Return non-zero iff NAME is the mangled form of a destructor name
diff --git a/libada/configure.ac b/libada/configure.ac
deleted file mode 100644
index e2d6198e4e7..00000000000
--- a/libada/configure.ac
+++ /dev/null
@@ -1,65 +0,0 @@
-# Configure script for libada.
-# Copyright 2003, 2004 Free Software Foundation, Inc.
-#
-# This file is free software; you can redistribute it and/or modify it
-# under the terms of the GNU General Public License as published by
-# the Free Software Foundation; either version 2 of the License, or
-# (at your option) any later version.
-#
-# This program is distributed in the hope that it will be useful, but
-# WITHOUT ANY WARRANTY; without even the implied warranty of
-# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-# General Public License for more details.
-#
-# You should have received a copy of the GNU General Public License
-# along with this program; if not, write to the Free Software
-# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
-
-AC_INIT
-AC_CONFIG_SRCDIR([Makefile.in])
-
-# This is an autoconf 2.5x script.
-AC_PREREQ([2.59])
-
-# Very limited version of AC_MAINTAINER_MODE.
-AC_ARG_ENABLE(
- [maintainer-mode],
- AC_HELP_STRING([--enable-maintainer-mode],
- [enable make rules and dependencies not useful (and
- sometimes confusing) to the casual installer]),
- [case ${enable_maintainer_mode} in
- yes) MAINT='' ;;
- no) MAINT='#' ;;
- *) AC_MSG_ERROR([--enable-maintainer-mode must be yes or no]) ;;
- esac
- maintainer_mode=${enableval}],
- [MAINT='#'])
-AC_SUBST([MAINT])dnl
-
-# Start of actual configure tests
-
-# Output: create a Makefile.
-AC_CONFIG_FILES([Makefile])
-
-AC_CANONICAL_SYSTEM
-
-AC_ARG_ENABLE(shared,
-[ --disable-shared don't provide a shared libgnat],
-[
- case $enable_shared in
- yes | no) ;;
- *)
- enable_shared=no
- IFS="${IFS= }"; ac_save_ifs="$IFS"; IFS="${IFS}:,"
- for pkg in $enableval; do
- if test "$pkg" = "ada" || test "$pkg" = "libada"; then
- enable_shared=yes
- fi
- done
- IFS="$ac_save_ifs"
- ;;
- esac
-], [enable_shared=yes])
-AC_SUBST(enable_shared)
-
-AC_OUTPUT
diff --git a/libiberty/vasprintf.c b/libiberty/vasprintf.c
index d3d4f3a1553..1d4a2952bcf 100644
--- a/libiberty/vasprintf.c
+++ b/libiberty/vasprintf.c
@@ -156,7 +156,8 @@ int
vasprintf (result, format, args)
char **result;
const char *format;
-#if defined (_BSD_VA_LIST_) && defined (__FreeBSD__)
+ /* APPLE LOCAL Agree with <stdio.h> prototype */
+#if defined (_BSD_VA_LIST_) && (defined (__FreeBSD__) || defined (__APPLE__))
_BSD_VA_LIST_ args;
#else
va_list args;
diff --git a/libjava/gnu/java/awt/peer/gtk/GdkGraphicsEnvironment.java b/libjava/gnu/java/awt/peer/gtk/GdkGraphicsEnvironment.java
deleted file mode 100644
index dbcd2d1c437..00000000000
--- a/libjava/gnu/java/awt/peer/gtk/GdkGraphicsEnvironment.java
+++ /dev/null
@@ -1,87 +0,0 @@
-/* GdkGraphicsEnvironment.java -- information about the graphics environment
- Copyright (C) 2004 Free Software Foundation, Inc.
-
-This file is part of GNU Classpath.
-
-GNU Classpath is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2, or (at your option)
-any later version.
-
-GNU Classpath is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with GNU Classpath; see the file COPYING. If not, write to the
-Free Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA
-02111-1307 USA.
-
-Linking this library statically or dynamically with other modules is
-making a combined work based on this library. Thus, the terms and
-conditions of the GNU General Public License cover the whole
-combination.
-
-As a special exception, the copyright holders of this library give you
-permission to link this library with independent modules to produce an
-executable, regardless of the license terms of these independent
-modules, and to copy and distribute the resulting executable under
-terms of your choice, provided that you also meet, for each linked
-independent module, the terms and conditions of the license of that
-module. An independent module is a module which is not derived from
-or based on this library. If you modify this library, you may extend
-this exception to your version of the library, but you are not
-obligated to do so. If you do not wish to do so, delete this
-exception statement from your version. */
-
-
-package gnu.java.awt.peer.gtk;
-
-import java.awt.*;
-import java.awt.GraphicsEnvironment;
-import java.awt.image.BufferedImage;
-import java.util.Locale;
-
-
-public class GdkGraphicsEnvironment extends GraphicsEnvironment
-{
-
- public GdkGraphicsEnvironment ()
- {
- super();
- }
-
- public GraphicsDevice[] getScreenDevices ()
- {
- throw new java.lang.UnsupportedOperationException ();
- }
-
- public GraphicsDevice getDefaultScreenDevice ()
- {
- throw new java.lang.UnsupportedOperationException ();
- }
-
- public Graphics2D createGraphics (BufferedImage image)
- {
- return new GdkGraphics2D (image);
- }
-
- public Font[] getAllFonts ()
- {
- throw new java.lang.UnsupportedOperationException ();
- }
-
- public String[] getAvailableFontFamilyNames ()
- {
- throw new java.lang.UnsupportedOperationException ();
- }
-
- public String[] getAvailableFontFamilyNames (Locale l)
- {
- throw new java.lang.UnsupportedOperationException ();
- }
-
-
-} // class GdkGraphicsEnvironment
-
diff --git a/libjava/gnu/java/net/protocol/core/Connection.java b/libjava/gnu/java/net/protocol/core/Connection.java
deleted file mode 100644
index 2319c0be923..00000000000
--- a/libjava/gnu/java/net/protocol/core/Connection.java
+++ /dev/null
@@ -1,172 +0,0 @@
-// Connection.java - Implementation of URLConnection for core protocol.
-
-/* Copyright (C) 2001, 2003 Free Software Foundation
-
- This file is part of libgcj.
-
-This software is copyrighted work licensed under the terms of the
-Libgcj License. Please consult the file "LIBGCJ_LICENSE" for
-details. */
-
-package gnu.java.net.protocol.core;
-
-import gnu.gcj.Core;
-import java.io.InputStream;
-import java.io.IOException;
-import java.net.ProtocolException;
-import java.net.URL;
-import java.net.URLConnection;
-import java.util.Map;
-import java.util.Vector;
-import java.util.Hashtable;
-import java.util.Enumeration;
-
-/**
- * @author Anthony Green <green@redhat.com>
- * @date August 13, 2001
- */
-
-class Connection extends URLConnection
-{
- private Hashtable hdrHash = new Hashtable();
- private Vector hdrVec = new Vector();
- private boolean gotHeaders = false;
-
- private Core core;
-
- public Connection (URL url)
- {
- super(url);
- }
-
- // Implementation of abstract method.
- public void connect() throws IOException
- {
- // Call is ignored if already connected.
- if (connected)
- return;
-
- // If not connected, then file needs to be opened.
- core = Core.create (url.getFile());
- connected = true;
- }
-
- public InputStream getInputStream() throws IOException
- {
- if (!connected)
- connect();
-
- if (! doInput)
- throw new ProtocolException("Can't open InputStream if doInput is false");
- return new CoreInputStream (core);
- }
-
- // Override default method in URLConnection.
- public String getHeaderField(String name)
- {
- try
- {
- getHeaders();
- }
- catch (IOException x)
- {
- return null;
- }
- return (String) hdrHash.get(name.toLowerCase());
- }
-
- // Override default method in URLConnection.
- public Map getHeaderFields()
- {
- try
- {
- getHeaders();
- }
- catch (IOException x)
- {
- return null;
- }
- return hdrHash;
- }
-
- // Override default method in URLConnection.
- public String getHeaderField(int n)
- {
- try
- {
- getHeaders();
- }
- catch (IOException x)
- {
- return null;
- }
- if (n < hdrVec.size())
- return getField ((String) hdrVec.elementAt(n));
-
- return null;
- }
-
- // Override default method in URLConnection.
- public String getHeaderFieldKey(int n)
- {
- try
- {
- getHeaders();
- }
- catch (IOException x)
- {
- return null;
- }
- if (n < hdrVec.size())
- return getKey ((String) hdrVec.elementAt(n));
-
- return null;
- }
-
- private String getKey(String str)
- {
- if (str == null)
- return null;
- int index = str.indexOf(':');
- if (index >= 0)
- return str.substring(0, index);
- else
- return null;
- }
-
- private String getField(String str)
- {
- if (str == null)
- return null;
- int index = str.indexOf(':');
- if (index >= 0)
- return str.substring(index + 1).trim();
- else
- return str;
- }
-
- private void getHeaders() throws IOException
- {
- if (gotHeaders)
- return;
- gotHeaders = true;
-
- connect();
-
- // Yes, it is overkill to use the hash table and vector here since
- // we're only putting one header in the file, but in case we need
- // to add others later and for consistency, we'll implement it this way.
-
- // Add the only header we know about right now: Content-length.
- long len = core.length;
- String line = "Content-length: " + len;
- hdrVec.addElement(line);
-
- // The key will never be null in this scenario since we build up the
- // headers ourselves. If we ever rely on getting a header from somewhere
- // else, then we may have to check if the result of getKey() is null.
- String key = getKey(line);
- hdrHash.put(key.toLowerCase(), Long.toString(len));
- }
-}
-
diff --git a/libjava/gnu/java/net/protocol/core/CoreInputStream.java b/libjava/gnu/java/net/protocol/core/CoreInputStream.java
deleted file mode 100644
index 421bb1c4765..00000000000
--- a/libjava/gnu/java/net/protocol/core/CoreInputStream.java
+++ /dev/null
@@ -1,90 +0,0 @@
-// Handler.java - URLStreamHandler for core protocol.
-
-/* Copyright (C) 2001 Free Software Foundation
-
- This file is part of libgcj.
-
-This software is copyrighted work licensed under the terms of the
-Libgcj License. Please consult the file "LIBGCJ_LICENSE" for
-details. */
-
-package gnu.java.net.protocol.core;
-
-import gnu.gcj.Core;
-import gnu.gcj.RawData;
-import java.io.InputStream;
-import java.io.IOException;
-
-public class CoreInputStream extends InputStream
-{
- /* A pointer to the object in memory. */
- protected RawData ptr;
-
- /* Position of the next byte in core to be read. */
- protected int pos;
-
- /* The currently marked position in the stream. */
- protected int mark;
-
- /* The index in core one greater than the last valid character. */
- protected int count;
-
- private native int unsafeGetByte (long offset);
- private native int copyIntoByteArray (byte[] dest, int offset, int numBytes);
-
- public CoreInputStream (Core core)
- {
- ptr = core.ptr;
- count = core.length;
- }
-
- public synchronized int available()
- {
- return count - pos;
- }
-
- public synchronized void mark(int readAheadLimit)
- {
- // readAheadLimit is ignored per Java Class Lib. book, p.220.
- mark = pos;
- }
-
- public boolean markSupported()
- {
- return true;
- }
-
- public synchronized int read()
- {
- if (pos < count)
- return ((int) unsafeGetByte(pos++)) & 0xFF;
- return -1;
- }
-
- public synchronized int read(byte[] b, int off, int len)
- {
- if (pos >= count)
- return -1;
-
- int numBytes = Math.min(count - pos, len);
- copyIntoByteArray (b, off, numBytes);
- pos += numBytes;
- return numBytes;
- }
-
- public synchronized void reset()
- {
- pos = mark;
- }
-
- public synchronized long skip(long n)
- {
- // Even though the var numBytes is a long, in reality it can never
- // be larger than an int since the result of subtracting 2 positive
- // ints will always fit in an int. Since we have to return a long
- // anyway, numBytes might as well just be a long.
- long numBytes = Math.min ((long) (count - pos), n < 0 ? 0L : n);
- pos += numBytes;
- return numBytes;
- }
-}
diff --git a/libjava/gnu/java/net/protocol/core/Handler.java b/libjava/gnu/java/net/protocol/core/Handler.java
deleted file mode 100644
index 8726172d2cd..00000000000
--- a/libjava/gnu/java/net/protocol/core/Handler.java
+++ /dev/null
@@ -1,28 +0,0 @@
-// Handler.java - URLStreamHandler for core protocol.
-
-/* Copyright (C) 2001 Free Software Foundation
-
- This file is part of libgcj.
-
-This software is copyrighted work licensed under the terms of the
-Libgcj License. Please consult the file "LIBGCJ_LICENSE" for
-details. */
-
-package gnu.java.net.protocol.core;
-
-import java.io.IOException;
-import java.net.URL;
-import java.net.URLConnection;
-import java.net.URLStreamHandler;
-
-/**
- * @author Anthony Green <green@redhat.com>
- * @date August 13, 2001.
- */
-public class Handler extends URLStreamHandler
-{
- protected URLConnection openConnection(URL url) throws IOException
- {
- return new Connection(url);
- }
-}
diff --git a/libjava/gnu/java/net/protocol/core/natCoreInputStream.cc b/libjava/gnu/java/net/protocol/core/natCoreInputStream.cc
deleted file mode 100644
index 4053efcd16a..00000000000
--- a/libjava/gnu/java/net/protocol/core/natCoreInputStream.cc
+++ /dev/null
@@ -1,51 +0,0 @@
-// natCoreInputStream.cc -- C++ side of CoreInputStream
-
-/* Copyright (C) 2001 Free Software Foundation
-
- This file is part of libgcj.
-
-This software is copyrighted work licensed under the terms of the
-Libgcj License. Please consult the file "LIBGCJ_LICENSE" for
-details. */
-
-/* Author: Anthony Green <green@redhat.com>. */
-
-#include <config.h>
-
-#include <gcj/cni.h>
-#include <jvm.h>
-#include <string.h>
-
-#include <java/lang/NullPointerException.h>
-#include <java/lang/ArrayIndexOutOfBoundsException.h>
-#include <gnu/java/net/protocol/core/CoreInputStream.h>
-
-jint
-gnu::java::net::protocol::core::CoreInputStream::unsafeGetByte (jlong offset)
-{
- return ((char*) ptr) [offset];
-}
-
-jint
-gnu::java::net::protocol::core::CoreInputStream::copyIntoByteArray (jbyteArray dest,
- jint offset,
- jint numBytes)
-{
- if (!dest)
- throw new ::java::lang::NullPointerException;
-
- jsize destSize = JvGetArrayLength (dest);
-
- if (offset < 0 || numBytes < 0 || offset + numBytes < 0
- || offset + numBytes > destSize
- || pos + numBytes > count)
- throw new ::java::lang::ArrayIndexOutOfBoundsException;
-
- void *pcore = (void *) &((char*) ptr) [pos];
- void *pdest = (void *) (elements (dest) + offset);
-
- memcpy (pdest, pcore, numBytes);
-
- return 0;
-}
-
diff --git a/libjava/gnu/regexp/CharIndexed.java b/libjava/gnu/regexp/CharIndexed.java
deleted file mode 100644
index eb1be13fd78..00000000000
--- a/libjava/gnu/regexp/CharIndexed.java
+++ /dev/null
@@ -1,84 +0,0 @@
-/* gnu/regexp/CharIndexed.java
- Copyright (C) 1998-2001, 2004 Free Software Foundation, Inc.
-
-This file is part of GNU Classpath.
-
-GNU Classpath is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2, or (at your option)
-any later version.
-
-GNU Classpath is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with GNU Classpath; see the file COPYING. If not, write to the
-Free Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA
-02111-1307 USA.
-
-Linking this library statically or dynamically with other modules is
-making a combined work based on this library. Thus, the terms and
-conditions of the GNU General Public License cover the whole
-combination.
-
-As a special exception, the copyright holders of this library give you
-permission to link this library with independent modules to produce an
-executable, regardless of the license terms of these independent
-modules, and to copy and distribute the resulting executable under
-terms of your choice, provided that you also meet, for each linked
-independent module, the terms and conditions of the license of that
-module. An independent module is a module which is not derived from
-or based on this library. If you modify this library, you may extend
-this exception to your version of the library, but you are not
-obligated to do so. If you do not wish to do so, delete this
-exception statement from your version. */
-
-package gnu.regexp;
-
-/**
- * Defines the interface used internally so that different types of source
- * text can be accessed in the same way. Built-in concrete classes provide
- * support for String, StringBuffer, InputStream and char[] types.
- * A class that is CharIndexed supports the notion of a cursor within a
- * block of text. The cursor must be able to be advanced via the move()
- * method. The charAt() method returns the character at the cursor position
- * plus a given offset.
- *
- * @author <A HREF="mailto:wes@cacas.org">Wes Biggs</A>
- */
-public interface CharIndexed {
- /**
- * Defines a constant (0xFFFF was somewhat arbitrarily chosen)
- * that can be returned by the charAt() function indicating that
- * the specified index is out of range.
- */
- char OUT_OF_BOUNDS = '\uFFFF';
-
- /**
- * Returns the character at the given offset past the current cursor
- * position in the input. The index of the current position is zero.
- * It is possible for this method to be called with a negative index.
- * This happens when using the '^' operator in multiline matching mode
- * or the '\b' or '\<' word boundary operators. In any case, the lower
- * bound is currently fixed at -2 (for '^' with a two-character newline).
- *
- * @param index the offset position in the character field to examine
- * @return the character at the specified index, or the OUT_OF_BOUNDS
- * character defined by this interface.
- */
- char charAt(int index);
-
- /**
- * Shifts the input buffer by a given number of positions. Returns
- * true if the new cursor position is valid.
- */
- boolean move(int index);
-
- /**
- * Returns true if the most recent move() operation placed the cursor
- * position at a valid position in the input.
- */
- boolean isValid();
-}
diff --git a/libjava/gnu/regexp/CharIndexedCharArray.java b/libjava/gnu/regexp/CharIndexedCharArray.java
deleted file mode 100644
index dc488ba44ea..00000000000
--- a/libjava/gnu/regexp/CharIndexedCharArray.java
+++ /dev/null
@@ -1,62 +0,0 @@
-/* gnu/regexp/CharIndexedCharArray.java
- Copyright (C) 1998-2001, 2004 Free Software Foundation, Inc.
-
-This file is part of GNU Classpath.
-
-GNU Classpath is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2, or (at your option)
-any later version.
-
-GNU Classpath is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with GNU Classpath; see the file COPYING. If not, write to the
-Free Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA
-02111-1307 USA.
-
-Linking this library statically or dynamically with other modules is
-making a combined work based on this library. Thus, the terms and
-conditions of the GNU General Public License cover the whole
-combination.
-
-As a special exception, the copyright holders of this library give you
-permission to link this library with independent modules to produce an
-executable, regardless of the license terms of these independent
-modules, and to copy and distribute the resulting executable under
-terms of your choice, provided that you also meet, for each linked
-independent module, the terms and conditions of the license of that
-module. An independent module is a module which is not derived from
-or based on this library. If you modify this library, you may extend
-this exception to your version of the library, but you are not
-obligated to do so. If you do not wish to do so, delete this
-exception statement from your version. */
-
-package gnu.regexp;
-import java.io.Serializable;
-
-class CharIndexedCharArray implements CharIndexed, Serializable {
- private char[] s;
- private int anchor;
-
- CharIndexedCharArray(char[] str, int index) {
- s = str;
- anchor = index;
- }
-
- public char charAt(int index) {
- int pos = anchor + index;
- return ((pos < s.length) && (pos >= 0)) ? s[pos] : OUT_OF_BOUNDS;
- }
-
- public boolean isValid() {
- return (anchor < s.length);
- }
-
- public boolean move(int index) {
- return ((anchor += index) < s.length);
- }
-}
diff --git a/libjava/gnu/regexp/CharIndexedInputStream.java b/libjava/gnu/regexp/CharIndexedInputStream.java
deleted file mode 100644
index 776f533ca81..00000000000
--- a/libjava/gnu/regexp/CharIndexedInputStream.java
+++ /dev/null
@@ -1,149 +0,0 @@
-/* gnu/regexp/CharIndexedInputStream.java
- Copyright (C) 1998-2001, 2004 Free Software Foundation, Inc.
-
-This file is part of GNU Classpath.
-
-GNU Classpath is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2, or (at your option)
-any later version.
-
-GNU Classpath is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with GNU Classpath; see the file COPYING. If not, write to the
-Free Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA
-02111-1307 USA.
-
-Linking this library statically or dynamically with other modules is
-making a combined work based on this library. Thus, the terms and
-conditions of the GNU General Public License cover the whole
-combination.
-
-As a special exception, the copyright holders of this library give you
-permission to link this library with independent modules to produce an
-executable, regardless of the license terms of these independent
-modules, and to copy and distribute the resulting executable under
-terms of your choice, provided that you also meet, for each linked
-independent module, the terms and conditions of the license of that
-module. An independent module is a module which is not derived from
-or based on this library. If you modify this library, you may extend
-this exception to your version of the library, but you are not
-obligated to do so. If you do not wish to do so, delete this
-exception statement from your version. */
-
-package gnu.regexp;
-import java.io.InputStream;
-import java.io.BufferedInputStream;
-import java.io.IOException;
-
-// TODO: move(x) shouldn't rely on calling next() x times
-
-class CharIndexedInputStream implements CharIndexed {
- private static final int BUFFER_INCREMENT = 1024;
- private static final int UNKNOWN = Integer.MAX_VALUE; // value for end
-
- private BufferedInputStream br;
-
- // so that we don't try to reset() right away
- private int index = -1;
-
- private int bufsize = BUFFER_INCREMENT;
-
- private int end = UNKNOWN;
-
- private char cached = OUT_OF_BOUNDS;
-
- // Big enough for a \r\n pair
- // lookBehind[0] = most recent
- // lookBehind[1] = second most recent
- private char[] lookBehind = new char[] { OUT_OF_BOUNDS, OUT_OF_BOUNDS };
-
- CharIndexedInputStream(InputStream str, int index) {
- if (str instanceof BufferedInputStream) br = (BufferedInputStream) str;
- else br = new BufferedInputStream(str,BUFFER_INCREMENT);
- next();
- if (index > 0) move(index);
- }
-
- private boolean next() {
- if (end == 1) return false;
- end--; // closer to end
-
- try {
- if (index != -1) {
- br.reset();
- }
- int i = br.read();
- br.mark(bufsize);
- if (i == -1) {
- end = 1;
- cached = OUT_OF_BOUNDS;
- return false;
- }
- cached = (char) i;
- index = 1;
- } catch (IOException e) {
- e.printStackTrace();
- cached = OUT_OF_BOUNDS;
- return false;
- }
- return true;
- }
-
- public char charAt(int index) {
- if (index == 0) {
- return cached;
- } else if (index >= end) {
- return OUT_OF_BOUNDS;
- } else if (index == -1) {
- return lookBehind[0];
- } else if (index == -2) {
- return lookBehind[1];
- } else if (index < -2) {
- return OUT_OF_BOUNDS;
- } else if (index >= bufsize) {
- // Allocate more space in the buffer.
- try {
- while (bufsize <= index) bufsize += BUFFER_INCREMENT;
- br.reset();
- br.mark(bufsize);
- br.skip(index-1);
- } catch (IOException e) { }
- } else if (this.index != index) {
- try {
- br.reset();
- br.skip(index-1);
- } catch (IOException e) { }
- }
- char ch = OUT_OF_BOUNDS;
-
- try {
- int i = br.read();
- this.index = index+1; // this.index is index of next pos relative to charAt(0)
- if (i == -1) {
- // set flag that next should fail next time?
- end = index;
- return ch;
- }
- ch = (char) i;
- } catch (IOException ie) { }
-
- return ch;
- }
-
- public boolean move(int index) {
- // move read position [index] clicks from 'charAt(0)'
- boolean retval = true;
- while (retval && (index-- > 0)) retval = next();
- return retval;
- }
-
- public boolean isValid() {
- return (cached != OUT_OF_BOUNDS);
- }
-}
-
diff --git a/libjava/gnu/regexp/CharIndexedReader.java b/libjava/gnu/regexp/CharIndexedReader.java
deleted file mode 100644
index aa0fa5a313d..00000000000
--- a/libjava/gnu/regexp/CharIndexedReader.java
+++ /dev/null
@@ -1,142 +0,0 @@
-/*
- * gnu/regexp/CharIndexedReader.java
- * Copyright (C) 2001 Lee Sau Dan
- * Based on gnu.regexp.CharIndexedInputStream by Wes Biggs
- *
- * This library is free software; you can redistribute it and/or modify
- * it under the terms of the GNU Lesser General Public License as published
- * by the Free Software Foundation; either version 2.1 of the License, or
- * (at your option) any later version.
- *
- * This library is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU Lesser General Public License for more details.
- *
- * You should have received a copy of the GNU Lesser General Public License
- * along with this program; if not, write to the Free Software
- * Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
- */
-
-package gnu.regexp;
-import java.io.Reader;
-import java.io.BufferedReader;
-import java.io.IOException;
-
-// TODO: move(x) shouldn't rely on calling next() x times
-
-class CharIndexedReader implements CharIndexed {
- private static final int BUFFER_INCREMENT = 1024;
- private static final int UNKNOWN = Integer.MAX_VALUE; // value for end
-
- private final BufferedReader br;
- // so that we don't try to reset() right away
- private int index = -1;
-
- private int bufsize = BUFFER_INCREMENT;
-
- private int end = UNKNOWN;
-
- private char cached = OUT_OF_BOUNDS;
-
- // Big enough for a \r\n pair
- // lookBehind[0] = most recent
- // lookBehind[1] = second most recent
- private char[] lookBehind = new char[] { OUT_OF_BOUNDS, OUT_OF_BOUNDS };
-
- CharIndexedReader(Reader reader, int index) {
- if (reader instanceof BufferedReader) {
- br = (BufferedReader) reader;
- } else {
- br = new BufferedReader(reader,BUFFER_INCREMENT);
- }
- next();
- if (index > 0) move(index);
- }
-
- private boolean next() {
- lookBehind[1] = lookBehind[0];
- lookBehind[0] = cached;
-
- if (end == 1) {
- cached = OUT_OF_BOUNDS;
- return false;
- }
- end--; // closer to end
-
- try {
- if (index != -1) {
- br.reset();
- }
- int i = br.read();
- br.mark(bufsize);
- if (i == -1) {
- end = 1;
- cached = OUT_OF_BOUNDS;
- return false;
- }
-
- // convert the byte read into a char
- cached = (char) i;
- index = 1;
- } catch (IOException e) {
- e.printStackTrace();
- cached = OUT_OF_BOUNDS;
- return false;
- }
- return true;
- }
-
- public char charAt(int index) {
- if (index == 0) {
- return cached;
- } else if (index >= end) {
- return OUT_OF_BOUNDS;
- } else if (index >= bufsize) {
- // Allocate more space in the buffer.
- try {
- while (bufsize <= index) bufsize += BUFFER_INCREMENT;
- br.reset();
- br.mark(bufsize);
- br.skip(index-1);
- } catch (IOException e) { }
- } else if (this.index != index) {
- try {
- br.reset();
- br.skip(index-1);
- } catch (IOException e) { }
- } else if (index == -1) {
- return lookBehind[0];
- } else if (index == -2) {
- return lookBehind[1];
- } else if (index < -2) {
- return OUT_OF_BOUNDS;
- }
-
- char ch = OUT_OF_BOUNDS;
-
- try {
- int i = br.read();
- this.index = index+1; // this.index is index of next pos relative to charAt(0)
- if (i == -1) {
- // set flag that next should fail next time?
- end = index;
- return ch;
- }
- ch = (char) i;
- } catch (IOException ie) { }
-
- return ch;
- }
-
- public boolean move(int index) {
- // move read position [index] clicks from 'charAt(0)'
- boolean retval = true;
- while (retval && (index-- > 0)) retval = next();
- return retval;
- }
-
- public boolean isValid() {
- return (cached != OUT_OF_BOUNDS);
- }
-}
diff --git a/libjava/gnu/regexp/CharIndexedString.java b/libjava/gnu/regexp/CharIndexedString.java
deleted file mode 100644
index adff7ac7186..00000000000
--- a/libjava/gnu/regexp/CharIndexedString.java
+++ /dev/null
@@ -1,64 +0,0 @@
-/* gnu/regexp/CharIndexedString.java
- Copyright (C) 1998-2001, 2004 Free Software Foundation, Inc.
-
-This file is part of GNU Classpath.
-
-GNU Classpath is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2, or (at your option)
-any later version.
-
-GNU Classpath is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with GNU Classpath; see the file COPYING. If not, write to the
-Free Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA
-02111-1307 USA.
-
-Linking this library statically or dynamically with other modules is
-making a combined work based on this library. Thus, the terms and
-conditions of the GNU General Public License cover the whole
-combination.
-
-As a special exception, the copyright holders of this library give you
-permission to link this library with independent modules to produce an
-executable, regardless of the license terms of these independent
-modules, and to copy and distribute the resulting executable under
-terms of your choice, provided that you also meet, for each linked
-independent module, the terms and conditions of the license of that
-module. An independent module is a module which is not derived from
-or based on this library. If you modify this library, you may extend
-this exception to your version of the library, but you are not
-obligated to do so. If you do not wish to do so, delete this
-exception statement from your version. */
-
-package gnu.regexp;
-import java.io.Serializable;
-
-class CharIndexedString implements CharIndexed, Serializable {
- private String s;
- private int anchor;
- private int len;
-
- CharIndexedString(String str, int index) {
- s = str;
- len = s.length();
- anchor = index;
- }
-
- public char charAt(int index) {
- int pos = anchor + index;
- return ((pos < len) && (pos >= 0)) ? s.charAt(pos) : OUT_OF_BOUNDS;
- }
-
- public boolean isValid() {
- return (anchor < len);
- }
-
- public boolean move(int index) {
- return ((anchor += index) < len);
- }
-}
diff --git a/libjava/gnu/regexp/CharIndexedStringBuffer.java b/libjava/gnu/regexp/CharIndexedStringBuffer.java
deleted file mode 100644
index 2eb8c23f36a..00000000000
--- a/libjava/gnu/regexp/CharIndexedStringBuffer.java
+++ /dev/null
@@ -1,62 +0,0 @@
-/* gnu/regexp/CharIndexedStringBuffer.java
- Copyright (C) 1998-2001, 2004 Free Software Foundation, Inc.
-
-This file is part of GNU Classpath.
-
-GNU Classpath is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2, or (at your option)
-any later version.
-
-GNU Classpath is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with GNU Classpath; see the file COPYING. If not, write to the
-Free Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA
-02111-1307 USA.
-
-Linking this library statically or dynamically with other modules is
-making a combined work based on this library. Thus, the terms and
-conditions of the GNU General Public License cover the whole
-combination.
-
-As a special exception, the copyright holders of this library give you
-permission to link this library with independent modules to produce an
-executable, regardless of the license terms of these independent
-modules, and to copy and distribute the resulting executable under
-terms of your choice, provided that you also meet, for each linked
-independent module, the terms and conditions of the license of that
-module. An independent module is a module which is not derived from
-or based on this library. If you modify this library, you may extend
-this exception to your version of the library, but you are not
-obligated to do so. If you do not wish to do so, delete this
-exception statement from your version. */
-
-package gnu.regexp;
-import java.io.Serializable;
-
-class CharIndexedStringBuffer implements CharIndexed, Serializable {
- private StringBuffer s;
- private int anchor;
-
- CharIndexedStringBuffer(StringBuffer str, int index) {
- s = str;
- anchor = index;
- }
-
- public char charAt(int index) {
- int pos = anchor + index;
- return ((pos < s.length()) && (pos >= 0)) ? s.charAt(pos) : OUT_OF_BOUNDS;
- }
-
- public boolean isValid() {
- return (anchor < s.length());
- }
-
- public boolean move(int index) {
- return ((anchor += index) < s.length());
- }
-}
diff --git a/libjava/gnu/regexp/MessagesBundle.properties b/libjava/gnu/regexp/MessagesBundle.properties
deleted file mode 100644
index 1e077a4033c..00000000000
--- a/libjava/gnu/regexp/MessagesBundle.properties
+++ /dev/null
@@ -1,22 +0,0 @@
-# Localized error messages for gnu.regexp
-
-# Prefix for REException messages
-error.prefix=At position {0} in regular expression pattern:
-
-# REException (parse error) messages
-repeat.assertion=repeated token is zero-width assertion
-repeat.chained=attempted to repeat a token that is already repeated
-repeat.no.token=quantifier (?*+{}) without preceding token
-repeat.empty.token=repeated token may be empty
-unmatched.brace=unmatched brace
-unmatched.bracket=unmatched bracket
-unmatched.paren=unmatched parenthesis
-interval.no.end=expected end of interval
-class.no.end=expected end of character class
-subexpr.no.end=expected end of subexpression
-interval.order=interval minimum is greater than maximum
-interval.error=interval is empty or contains illegal characters
-ends.with.backslash=backslash at end of pattern
-
-# RESyntax message
-syntax.final=Syntax has been declared final and cannot be modified
diff --git a/libjava/gnu/regexp/MessagesBundle_fr.properties b/libjava/gnu/regexp/MessagesBundle_fr.properties
deleted file mode 100644
index 8ab8356c17b..00000000000
--- a/libjava/gnu/regexp/MessagesBundle_fr.properties
+++ /dev/null
@@ -1,22 +0,0 @@
-# Localized error messages for gnu.regexp
-
-# Prefix for REException messages
-error.prefix=A l''index {0} dans le modèle d''expression régulière:
-
-# REException (parse error) messages
-repeat.assertion=l'élément répété est de largeur zéro
-repeat.chained=tentative de répétition d'un élément déjà répété
-repeat.no.token=quantifieur (?*+{}) sans élément précédent
-repeat.empty.token=l'élément répété peut être vide
-unmatched.brace=accolade inégalée
-unmatched.bracket=crochet inégalé
-unmatched.paren=parenthèse inégalée
-interval.no.end=fin d'interval attendue
-class.no.end=fin de classe de caractères attendue
-subexpr.no.end=fin de sous-expression attendue
-interval.order=l'interval minimum est supérieur à l'interval maximum
-interval.error=l'interval est vide ou contient des caractères illégaux
-ends.with.backslash=antislash à la fin du modèle
-
-# RESyntax message
-syntax.final=La syntaxe a été déclarée finale et ne peut pas être modifiée
diff --git a/libjava/gnu/regexp/RE.java b/libjava/gnu/regexp/RE.java
deleted file mode 100644
index fdc00feb3fb..00000000000
--- a/libjava/gnu/regexp/RE.java
+++ /dev/null
@@ -1,1350 +0,0 @@
-/* gnu/regexp/RE.java
- Copyright (C) 1998-2001, 2004 Free Software Foundation, Inc.
-
-This file is part of GNU Classpath.
-
-GNU Classpath is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2, or (at your option)
-any later version.
-
-GNU Classpath is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with GNU Classpath; see the file COPYING. If not, write to the
-Free Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA
-02111-1307 USA.
-
-Linking this library statically or dynamically with other modules is
-making a combined work based on this library. Thus, the terms and
-conditions of the GNU General Public License cover the whole
-combination.
-
-As a special exception, the copyright holders of this library give you
-permission to link this library with independent modules to produce an
-executable, regardless of the license terms of these independent
-modules, and to copy and distribute the resulting executable under
-terms of your choice, provided that you also meet, for each linked
-independent module, the terms and conditions of the license of that
-module. An independent module is a module which is not derived from
-or based on this library. If you modify this library, you may extend
-this exception to your version of the library, but you are not
-obligated to do so. If you do not wish to do so, delete this
-exception statement from your version. */
-
-package gnu.regexp;
-import java.io.InputStream;
-import java.io.Serializable;
-import java.util.Locale;
-import java.util.PropertyResourceBundle;
-import java.util.ResourceBundle;
-import java.util.Vector;
-
-class IntPair implements Serializable {
- public int first, second;
-}
-
-class CharUnit implements Serializable {
- public char ch;
- public boolean bk;
-}
-
-/**
- * RE provides the user interface for compiling and matching regular
- * expressions.
- * <P>
- * A regular expression object (class RE) is compiled by constructing it
- * from a String, StringBuffer or character array, with optional
- * compilation flags (below)
- * and an optional syntax specification (see RESyntax; if not specified,
- * <code>RESyntax.RE_SYNTAX_PERL5</code> is used).
- * <P>
- * Once compiled, a regular expression object is reusable as well as
- * threadsafe: multiple threads can use the RE instance simultaneously
- * to match against different input text.
- * <P>
- * Various methods attempt to match input text against a compiled
- * regular expression. These methods are:
- * <LI><code>isMatch</code>: returns true if the input text in its
- * entirety matches the regular expression pattern.
- * <LI><code>getMatch</code>: returns the first match found in the
- * input text, or null if no match is found.
- * <LI><code>getAllMatches</code>: returns an array of all
- * non-overlapping matches found in the input text. If no matches are
- * found, the array is zero-length.
- * <LI><code>substitute</code>: substitute the first occurence of the
- * pattern in the input text with a replacement string (which may
- * include metacharacters $0-$9, see REMatch.substituteInto).
- * <LI><code>substituteAll</code>: same as above, but repeat for each
- * match before returning.
- * <LI><code>getMatchEnumeration</code>: returns an REMatchEnumeration
- * object that allows iteration over the matches (see
- * REMatchEnumeration for some reasons why you may want to do this
- * instead of using <code>getAllMatches</code>.
- * <P>
- *
- * These methods all have similar argument lists. The input can be a
- * String, a character array, a StringBuffer, or an
- * InputStream of some sort. Note that when using an
- * InputStream, the stream read position cannot be guaranteed after
- * attempting a match (this is not a bug, but a consequence of the way
- * regular expressions work). Using an REMatchEnumeration can
- * eliminate most positioning problems.
- *
- * <P>
- *
- * The optional index argument specifies the offset from the beginning
- * of the text at which the search should start (see the descriptions
- * of some of the execution flags for how this can affect positional
- * pattern operators). For an InputStream, this means an
- * offset from the current read position, so subsequent calls with the
- * same index argument on an InputStream will not
- * necessarily access the same position on the stream, whereas
- * repeated searches at a given index in a fixed string will return
- * consistent results.
- *
- * <P>
- * You can optionally affect the execution environment by using a
- * combination of execution flags (constants listed below).
- *
- * <P>
- * All operations on a regular expression are performed in a
- * thread-safe manner.
- *
- * @author <A HREF="mailto:wes@cacas.org">Wes Biggs</A>
- * @version 1.1.5-dev, to be released
- */
-
-public class RE extends REToken {
- // This String will be returned by getVersion()
- private static final String VERSION = "1.1.5-dev";
-
- // The localized strings are kept in a separate file
- private static ResourceBundle messages = PropertyResourceBundle.getBundle("gnu/regexp/MessagesBundle", Locale.getDefault());
-
- // These are, respectively, the first and last tokens in our linked list
- // If there is only one token, firstToken == lastToken
- private REToken firstToken, lastToken;
-
- // This is the number of subexpressions in this regular expression,
- // with a minimum value of zero. Returned by getNumSubs()
- private int numSubs;
-
- /** Minimum length, in characters, of any possible match. */
- private int minimumLength;
-
- /**
- * Compilation flag. Do not differentiate case. Subsequent
- * searches using this RE will be case insensitive.
- */
- public static final int REG_ICASE = 2;
-
- /**
- * Compilation flag. The match-any-character operator (dot)
- * will match a newline character. When set this overrides the syntax
- * bit RE_DOT_NEWLINE (see RESyntax for details). This is equivalent to
- * the "/s" operator in Perl.
- */
- public static final int REG_DOT_NEWLINE = 4;
-
- /**
- * Compilation flag. Use multiline mode. In this mode, the ^ and $
- * anchors will match based on newlines within the input. This is
- * equivalent to the "/m" operator in Perl.
- */
- public static final int REG_MULTILINE = 8;
-
- /**
- * Execution flag.
- * The match-beginning operator (^) will not match at the beginning
- * of the input string. Useful for matching on a substring when you
- * know the context of the input is such that position zero of the
- * input to the match test is not actually position zero of the text.
- * <P>
- * This example demonstrates the results of various ways of matching on
- * a substring.
- * <P>
- * <CODE>
- * String s = "food bar fool";<BR>
- * RE exp = new RE("^foo.");<BR>
- * REMatch m0 = exp.getMatch(s);<BR>
- * REMatch m1 = exp.getMatch(s.substring(8));<BR>
- * REMatch m2 = exp.getMatch(s.substring(8),0,RE.REG_NOTBOL); <BR>
- * REMatch m3 = exp.getMatch(s,8); <BR>
- * REMatch m4 = exp.getMatch(s,8,RE.REG_ANCHORINDEX); <BR>
- * <P>
- * // Results:<BR>
- * // m0.toString(): "food"<BR>
- * // m1.toString(): "fool"<BR>
- * // m2.toString(): null<BR>
- * // m3.toString(): null<BR>
- * // m4.toString(): "fool"<BR>
- * </CODE>
- */
- public static final int REG_NOTBOL = 16;
-
- /**
- * Execution flag.
- * The match-end operator ($) does not match at the end
- * of the input string. Useful for matching on substrings.
- */
- public static final int REG_NOTEOL = 32;
-
- /**
- * Execution flag.
- * When a match method is invoked that starts matching at a non-zero
- * index into the input, treat the input as if it begins at the index
- * given. The effect of this flag is that the engine does not "see"
- * any text in the input before the given index. This is useful so
- * that the match-beginning operator (^) matches not at position 0
- * in the input string, but at the position the search started at
- * (based on the index input given to the getMatch function). See
- * the example under REG_NOTBOL. It also affects the use of the \&lt;
- * and \b operators.
- */
- public static final int REG_ANCHORINDEX = 64;
-
- /**
- * Execution flag.
- * The substitute and substituteAll methods will not attempt to
- * interpolate occurrences of $1-$9 in the replacement text with
- * the corresponding subexpressions. For example, you may want to
- * replace all matches of "one dollar" with "$1".
- */
- public static final int REG_NO_INTERPOLATE = 128;
-
- /** Returns a string representing the version of the gnu.regexp package. */
- public static final String version() {
- return VERSION;
- }
-
- // Retrieves a message from the ResourceBundle
- static final String getLocalizedMessage(String key) {
- return messages.getString(key);
- }
-
- /**
- * Constructs a regular expression pattern buffer without any compilation
- * flags set, and using the default syntax (RESyntax.RE_SYNTAX_PERL5).
- *
- * @param pattern A regular expression pattern, in the form of a String,
- * StringBuffer or char[]. Other input types will be converted to
- * strings using the toString() method.
- * @exception REException The input pattern could not be parsed.
- * @exception NullPointerException The pattern was null.
- */
- public RE(Object pattern) throws REException {
- this(pattern,0,RESyntax.RE_SYNTAX_PERL5,0,0);
- }
-
- /**
- * Constructs a regular expression pattern buffer using the specified
- * compilation flags and the default syntax (RESyntax.RE_SYNTAX_PERL5).
- *
- * @param pattern A regular expression pattern, in the form of a String,
- * StringBuffer, or char[]. Other input types will be converted to
- * strings using the toString() method.
- * @param cflags The logical OR of any combination of the compilation flags listed above.
- * @exception REException The input pattern could not be parsed.
- * @exception NullPointerException The pattern was null.
- */
- public RE(Object pattern, int cflags) throws REException {
- this(pattern,cflags,RESyntax.RE_SYNTAX_PERL5,0,0);
- }
-
- /**
- * Constructs a regular expression pattern buffer using the specified
- * compilation flags and regular expression syntax.
- *
- * @param pattern A regular expression pattern, in the form of a String,
- * StringBuffer, or char[]. Other input types will be converted to
- * strings using the toString() method.
- * @param cflags The logical OR of any combination of the compilation flags listed above.
- * @param syntax The type of regular expression syntax to use.
- * @exception REException The input pattern could not be parsed.
- * @exception NullPointerException The pattern was null.
- */
- public RE(Object pattern, int cflags, RESyntax syntax) throws REException {
- this(pattern,cflags,syntax,0,0);
- }
-
- // internal constructor used for alternation
- private RE(REToken first, REToken last,int subs, int subIndex, int minLength) {
- super(subIndex);
- firstToken = first;
- lastToken = last;
- numSubs = subs;
- minimumLength = minLength;
- addToken(new RETokenEndSub(subIndex));
- }
-
- private RE(Object patternObj, int cflags, RESyntax syntax, int myIndex, int nextSub) throws REException {
- super(myIndex); // Subexpression index of this token.
- initialize(patternObj, cflags, syntax, myIndex, nextSub);
- }
-
- // For use by subclasses
- protected RE() { super(0); }
-
- // The meat of construction
- protected void initialize(Object patternObj, int cflags, RESyntax syntax, int myIndex, int nextSub) throws REException {
- char[] pattern;
- if (patternObj instanceof String) {
- pattern = ((String) patternObj).toCharArray();
- } else if (patternObj instanceof char[]) {
- pattern = (char[]) patternObj;
- } else if (patternObj instanceof StringBuffer) {
- pattern = new char [((StringBuffer) patternObj).length()];
- ((StringBuffer) patternObj).getChars(0,pattern.length,pattern,0);
- } else {
- pattern = patternObj.toString().toCharArray();
- }
-
- int pLength = pattern.length;
-
- numSubs = 0; // Number of subexpressions in this token.
- Vector branches = null;
-
- // linked list of tokens (sort of -- some closed loops can exist)
- firstToken = lastToken = null;
-
- // Precalculate these so we don't pay for the math every time we
- // need to access them.
- boolean insens = ((cflags & REG_ICASE) > 0);
-
- // Parse pattern into tokens. Does anyone know if it's more efficient
- // to use char[] than a String.charAt()? I'm assuming so.
-
- // index tracks the position in the char array
- int index = 0;
-
- // this will be the current parse character (pattern[index])
- CharUnit unit = new CharUnit();
-
- // This is used for {x,y} calculations
- IntPair minMax = new IntPair();
-
- // Buffer a token so we can create a TokenRepeated, etc.
- REToken currentToken = null;
- char ch;
-
- while (index < pLength) {
- // read the next character unit (including backslash escapes)
- index = getCharUnit(pattern,index,unit);
-
- // ALTERNATION OPERATOR
- // \| or | (if RE_NO_BK_VBAR) or newline (if RE_NEWLINE_ALT)
- // not available if RE_LIMITED_OPS is set
-
- // TODO: the '\n' literal here should be a test against REToken.newline,
- // which unfortunately may be more than a single character.
- if ( ( (unit.ch == '|' && (syntax.get(RESyntax.RE_NO_BK_VBAR) ^ unit.bk))
- || (syntax.get(RESyntax.RE_NEWLINE_ALT) && (unit.ch == '\n') && !unit.bk) )
- && !syntax.get(RESyntax.RE_LIMITED_OPS)) {
- // make everything up to here be a branch. create vector if nec.
- addToken(currentToken);
- RE theBranch = new RE(firstToken, lastToken, numSubs, subIndex, minimumLength);
- minimumLength = 0;
- if (branches == null) {
- branches = new Vector();
- }
- branches.addElement(theBranch);
- firstToken = lastToken = currentToken = null;
- }
-
- // INTERVAL OPERATOR:
- // {x} | {x,} | {x,y} (RE_INTERVALS && RE_NO_BK_BRACES)
- // \{x\} | \{x,\} | \{x,y\} (RE_INTERVALS && !RE_NO_BK_BRACES)
- //
- // OPEN QUESTION:
- // what is proper interpretation of '{' at start of string?
-
- else if ((unit.ch == '{') && syntax.get(RESyntax.RE_INTERVALS) && (syntax.get(RESyntax.RE_NO_BK_BRACES) ^ unit.bk)) {
- int newIndex = getMinMax(pattern,index,minMax,syntax);
- if (newIndex > index) {
- if (minMax.first > minMax.second)
- throw new REException(getLocalizedMessage("interval.order"),REException.REG_BADRPT,newIndex);
- if (currentToken == null)
- throw new REException(getLocalizedMessage("repeat.no.token"),REException.REG_BADRPT,newIndex);
- if (currentToken instanceof RETokenRepeated)
- throw new REException(getLocalizedMessage("repeat.chained"),REException.REG_BADRPT,newIndex);
- if (currentToken instanceof RETokenWordBoundary || currentToken instanceof RETokenWordBoundary)
- throw new REException(getLocalizedMessage("repeat.assertion"),REException.REG_BADRPT,newIndex);
- if ((currentToken.getMinimumLength() == 0) && (minMax.second == Integer.MAX_VALUE))
- throw new REException(getLocalizedMessage("repeat.empty.token"),REException.REG_BADRPT,newIndex);
- index = newIndex;
- currentToken = setRepeated(currentToken,minMax.first,minMax.second,index);
- }
- else {
- addToken(currentToken);
- currentToken = new RETokenChar(subIndex,unit.ch,insens);
- }
- }
-
- // LIST OPERATOR:
- // [...] | [^...]
-
- else if ((unit.ch == '[') && !unit.bk) {
- Vector options = new Vector();
- boolean negative = false;
- char lastChar = 0;
- if (index == pLength) throw new REException(getLocalizedMessage("unmatched.bracket"),REException.REG_EBRACK,index);
-
- // Check for initial caret, negation
- if ((ch = pattern[index]) == '^') {
- negative = true;
- if (++index == pLength) throw new REException(getLocalizedMessage("class.no.end"),REException.REG_EBRACK,index);
- ch = pattern[index];
- }
-
- // Check for leading right bracket literal
- if (ch == ']') {
- lastChar = ch;
- if (++index == pLength) throw new REException(getLocalizedMessage("class.no.end"),REException.REG_EBRACK,index);
- }
-
- while ((ch = pattern[index++]) != ']') {
- if ((ch == '-') && (lastChar != 0)) {
- if (index == pLength) throw new REException(getLocalizedMessage("class.no.end"),REException.REG_EBRACK,index);
- if ((ch = pattern[index]) == ']') {
- options.addElement(new RETokenChar(subIndex,lastChar,insens));
- lastChar = '-';
- } else {
- options.addElement(new RETokenRange(subIndex,lastChar,ch,insens));
- lastChar = 0;
- index++;
- }
- } else if ((ch == '\\') && syntax.get(RESyntax.RE_BACKSLASH_ESCAPE_IN_LISTS)) {
- if (index == pLength) throw new REException(getLocalizedMessage("class.no.end"),REException.REG_EBRACK,index);
- int posixID = -1;
- boolean negate = false;
- char asciiEsc = 0;
- if (("dswDSW".indexOf(pattern[index]) != -1) && syntax.get(RESyntax.RE_CHAR_CLASS_ESC_IN_LISTS)) {
- switch (pattern[index]) {
- case 'D':
- negate = true;
- case 'd':
- posixID = RETokenPOSIX.DIGIT;
- break;
- case 'S':
- negate = true;
- case 's':
- posixID = RETokenPOSIX.SPACE;
- break;
- case 'W':
- negate = true;
- case 'w':
- posixID = RETokenPOSIX.ALNUM;
- break;
- }
- }
- else if ("nrt".indexOf(pattern[index]) != -1) {
- switch (pattern[index]) {
- case 'n':
- asciiEsc = '\n';
- break;
- case 't':
- asciiEsc = '\t';
- break;
- case 'r':
- asciiEsc = '\r';
- break;
- }
- }
- if (lastChar != 0) options.addElement(new RETokenChar(subIndex,lastChar,insens));
-
- if (posixID != -1) {
- options.addElement(new RETokenPOSIX(subIndex,posixID,insens,negate));
- } else if (asciiEsc != 0) {
- lastChar = asciiEsc;
- } else {
- lastChar = pattern[index];
- }
- ++index;
- } else if ((ch == '[') && (syntax.get(RESyntax.RE_CHAR_CLASSES)) && (index < pLength) && (pattern[index] == ':')) {
- StringBuffer posixSet = new StringBuffer();
- index = getPosixSet(pattern,index+1,posixSet);
- int posixId = RETokenPOSIX.intValue(posixSet.toString());
- if (posixId != -1)
- options.addElement(new RETokenPOSIX(subIndex,posixId,insens,false));
- } else {
- if (lastChar != 0) options.addElement(new RETokenChar(subIndex,lastChar,insens));
- lastChar = ch;
- }
- if (index == pLength) throw new REException(getLocalizedMessage("class.no.end"),REException.REG_EBRACK,index);
- } // while in list
- // Out of list, index is one past ']'
-
- if (lastChar != 0) options.addElement(new RETokenChar(subIndex,lastChar,insens));
-
- // Create a new RETokenOneOf
- addToken(currentToken);
- options.trimToSize();
- currentToken = new RETokenOneOf(subIndex,options,negative);
- }
-
- // SUBEXPRESSIONS
- // (...) | \(...\) depending on RE_NO_BK_PARENS
-
- else if ((unit.ch == '(') && (syntax.get(RESyntax.RE_NO_BK_PARENS) ^ unit.bk)) {
- boolean pure = false;
- boolean comment = false;
- if ((index+1 < pLength) && (pattern[index] == '?')) {
- switch (pattern[index+1]) {
- case ':':
- if (syntax.get(RESyntax.RE_PURE_GROUPING)) {
- pure = true;
- index += 2;
- }
- break;
- case '#':
- if (syntax.get(RESyntax.RE_COMMENTS)) {
- comment = true;
- }
- break;
- default:
- throw new REException(getLocalizedMessage("repeat.no.token"), REException.REG_BADRPT, index);
- }
- }
-
- if (index >= pLength) {
- throw new REException(getLocalizedMessage("unmatched.paren"), REException.REG_ESUBREG,index);
- }
-
- // find end of subexpression
- int endIndex = index;
- int nextIndex = index;
- int nested = 0;
-
- while ( ((nextIndex = getCharUnit(pattern,endIndex,unit)) > 0)
- && !(nested == 0 && (unit.ch == ')') && (syntax.get(RESyntax.RE_NO_BK_PARENS) ^ unit.bk)) )
- if ((endIndex = nextIndex) >= pLength)
- throw new REException(getLocalizedMessage("subexpr.no.end"),REException.REG_ESUBREG,nextIndex);
- else if (unit.ch == '(' && (syntax.get(RESyntax.RE_NO_BK_PARENS) ^ unit.bk))
- nested++;
- else if (unit.ch == ')' && (syntax.get(RESyntax.RE_NO_BK_PARENS) ^ unit.bk))
- nested--;
-
- // endIndex is now position at a ')','\)'
- // nextIndex is end of string or position after ')' or '\)'
-
- if (comment) index = nextIndex;
- else { // not a comment
- // create RE subexpression as token.
- addToken(currentToken);
- if (!pure) {
- numSubs++;
- }
-
- int useIndex = (pure) ? 0 : nextSub + numSubs;
- currentToken = new RE(String.valueOf(pattern,index,endIndex-index).toCharArray(),cflags,syntax,useIndex,nextSub + numSubs);
- numSubs += ((RE) currentToken).getNumSubs();
-
- index = nextIndex;
- } // not a comment
- } // subexpression
-
- // UNMATCHED RIGHT PAREN
- // ) or \) throw exception if
- // !syntax.get(RESyntax.RE_UNMATCHED_RIGHT_PAREN_ORD)
- else if (!syntax.get(RESyntax.RE_UNMATCHED_RIGHT_PAREN_ORD) && ((unit.ch == ')') && (syntax.get(RESyntax.RE_NO_BK_PARENS) ^ unit.bk))) {
- throw new REException(getLocalizedMessage("unmatched.paren"),REException.REG_EPAREN,index);
- }
-
- // START OF LINE OPERATOR
- // ^
-
- else if ((unit.ch == '^') && !unit.bk) {
- addToken(currentToken);
- currentToken = null;
- addToken(new RETokenStart(subIndex,((cflags & REG_MULTILINE) > 0) ? syntax.getLineSeparator() : null));
- }
-
- // END OF LINE OPERATOR
- // $
-
- else if ((unit.ch == '$') && !unit.bk) {
- addToken(currentToken);
- currentToken = null;
- addToken(new RETokenEnd(subIndex,((cflags & REG_MULTILINE) > 0) ? syntax.getLineSeparator() : null));
- }
-
- // MATCH-ANY-CHARACTER OPERATOR (except possibly newline and null)
- // .
-
- else if ((unit.ch == '.') && !unit.bk) {
- addToken(currentToken);
- currentToken = new RETokenAny(subIndex,syntax.get(RESyntax.RE_DOT_NEWLINE) || ((cflags & REG_DOT_NEWLINE) > 0),syntax.get(RESyntax.RE_DOT_NOT_NULL));
- }
-
- // ZERO-OR-MORE REPEAT OPERATOR
- // *
-
- else if ((unit.ch == '*') && !unit.bk) {
- if (currentToken == null)
- throw new REException(getLocalizedMessage("repeat.no.token"),REException.REG_BADRPT,index);
- if (currentToken instanceof RETokenRepeated)
- throw new REException(getLocalizedMessage("repeat.chained"),REException.REG_BADRPT,index);
- if (currentToken instanceof RETokenWordBoundary || currentToken instanceof RETokenWordBoundary)
- throw new REException(getLocalizedMessage("repeat.assertion"),REException.REG_BADRPT,index);
- if (currentToken.getMinimumLength() == 0)
- throw new REException(getLocalizedMessage("repeat.empty.token"),REException.REG_BADRPT,index);
- currentToken = setRepeated(currentToken,0,Integer.MAX_VALUE,index);
- }
-
- // ONE-OR-MORE REPEAT OPERATOR
- // + | \+ depending on RE_BK_PLUS_QM
- // not available if RE_LIMITED_OPS is set
-
- else if ((unit.ch == '+') && !syntax.get(RESyntax.RE_LIMITED_OPS) && (!syntax.get(RESyntax.RE_BK_PLUS_QM) ^ unit.bk)) {
- if (currentToken == null)
- throw new REException(getLocalizedMessage("repeat.no.token"),REException.REG_BADRPT,index);
- if (currentToken instanceof RETokenRepeated)
- throw new REException(getLocalizedMessage("repeat.chained"),REException.REG_BADRPT,index);
- if (currentToken instanceof RETokenWordBoundary || currentToken instanceof RETokenWordBoundary)
- throw new REException(getLocalizedMessage("repeat.assertion"),REException.REG_BADRPT,index);
- if (currentToken.getMinimumLength() == 0)
- throw new REException(getLocalizedMessage("repeat.empty.token"),REException.REG_BADRPT,index);
- currentToken = setRepeated(currentToken,1,Integer.MAX_VALUE,index);
- }
-
- // ZERO-OR-ONE REPEAT OPERATOR / STINGY MATCHING OPERATOR
- // ? | \? depending on RE_BK_PLUS_QM
- // not available if RE_LIMITED_OPS is set
- // stingy matching if RE_STINGY_OPS is set and it follows a quantifier
-
- else if ((unit.ch == '?') && !syntax.get(RESyntax.RE_LIMITED_OPS) && (!syntax.get(RESyntax.RE_BK_PLUS_QM) ^ unit.bk)) {
- if (currentToken == null) throw new REException(getLocalizedMessage("repeat.no.token"),REException.REG_BADRPT,index);
-
- // Check for stingy matching on RETokenRepeated
- if (currentToken instanceof RETokenRepeated) {
- if (syntax.get(RESyntax.RE_STINGY_OPS) && !((RETokenRepeated)currentToken).isStingy())
- ((RETokenRepeated)currentToken).makeStingy();
- else
- throw new REException(getLocalizedMessage("repeat.chained"),REException.REG_BADRPT,index);
- }
- else if (currentToken instanceof RETokenWordBoundary || currentToken instanceof RETokenWordBoundary)
- throw new REException(getLocalizedMessage("repeat.assertion"),REException.REG_BADRPT,index);
- else
- currentToken = setRepeated(currentToken,0,1,index);
- }
-
- // BACKREFERENCE OPERATOR
- // \1 \2 ... \9
- // not available if RE_NO_BK_REFS is set
-
- else if (unit.bk && Character.isDigit(unit.ch) && !syntax.get(RESyntax.RE_NO_BK_REFS)) {
- addToken(currentToken);
- currentToken = new RETokenBackRef(subIndex,Character.digit(unit.ch,10),insens);
- }
-
- // START OF STRING OPERATOR
- // \A if RE_STRING_ANCHORS is set
-
- else if (unit.bk && (unit.ch == 'A') && syntax.get(RESyntax.RE_STRING_ANCHORS)) {
- addToken(currentToken);
- currentToken = new RETokenStart(subIndex,null);
- }
-
- // WORD BREAK OPERATOR
- // \b if ????
-
- else if (unit.bk && (unit.ch == 'b') && syntax.get(RESyntax.RE_STRING_ANCHORS)) {
- addToken(currentToken);
- currentToken = new RETokenWordBoundary(subIndex, RETokenWordBoundary.BEGIN | RETokenWordBoundary.END, false);
- }
-
- // WORD BEGIN OPERATOR
- // \< if ????
- else if (unit.bk && (unit.ch == '<')) {
- addToken(currentToken);
- currentToken = new RETokenWordBoundary(subIndex, RETokenWordBoundary.BEGIN, false);
- }
-
- // WORD END OPERATOR
- // \> if ????
- else if (unit.bk && (unit.ch == '>')) {
- addToken(currentToken);
- currentToken = new RETokenWordBoundary(subIndex, RETokenWordBoundary.END, false);
- }
-
- // NON-WORD BREAK OPERATOR
- // \B if ????
-
- else if (unit.bk && (unit.ch == 'B') && syntax.get(RESyntax.RE_STRING_ANCHORS)) {
- addToken(currentToken);
- currentToken = new RETokenWordBoundary(subIndex, RETokenWordBoundary.BEGIN | RETokenWordBoundary.END, true);
- }
-
-
- // DIGIT OPERATOR
- // \d if RE_CHAR_CLASS_ESCAPES is set
-
- else if (unit.bk && (unit.ch == 'd') && syntax.get(RESyntax.RE_CHAR_CLASS_ESCAPES)) {
- addToken(currentToken);
- currentToken = new RETokenPOSIX(subIndex,RETokenPOSIX.DIGIT,insens,false);
- }
-
- // NON-DIGIT OPERATOR
- // \D
-
- else if (unit.bk && (unit.ch == 'D') && syntax.get(RESyntax.RE_CHAR_CLASS_ESCAPES)) {
- addToken(currentToken);
- currentToken = new RETokenPOSIX(subIndex,RETokenPOSIX.DIGIT,insens,true);
- }
-
- // NEWLINE ESCAPE
- // \n
-
- else if (unit.bk && (unit.ch == 'n')) {
- addToken(currentToken);
- currentToken = new RETokenChar(subIndex,'\n',false);
- }
-
- // RETURN ESCAPE
- // \r
-
- else if (unit.bk && (unit.ch == 'r')) {
- addToken(currentToken);
- currentToken = new RETokenChar(subIndex,'\r',false);
- }
-
- // WHITESPACE OPERATOR
- // \s if RE_CHAR_CLASS_ESCAPES is set
-
- else if (unit.bk && (unit.ch == 's') && syntax.get(RESyntax.RE_CHAR_CLASS_ESCAPES)) {
- addToken(currentToken);
- currentToken = new RETokenPOSIX(subIndex,RETokenPOSIX.SPACE,insens,false);
- }
-
- // NON-WHITESPACE OPERATOR
- // \S
-
- else if (unit.bk && (unit.ch == 'S') && syntax.get(RESyntax.RE_CHAR_CLASS_ESCAPES)) {
- addToken(currentToken);
- currentToken = new RETokenPOSIX(subIndex,RETokenPOSIX.SPACE,insens,true);
- }
-
- // TAB ESCAPE
- // \t
-
- else if (unit.bk && (unit.ch == 't')) {
- addToken(currentToken);
- currentToken = new RETokenChar(subIndex,'\t',false);
- }
-
- // ALPHANUMERIC OPERATOR
- // \w
-
- else if (unit.bk && (unit.ch == 'w') && syntax.get(RESyntax.RE_CHAR_CLASS_ESCAPES)) {
- addToken(currentToken);
- currentToken = new RETokenPOSIX(subIndex,RETokenPOSIX.ALNUM,insens,false);
- }
-
- // NON-ALPHANUMERIC OPERATOR
- // \W
-
- else if (unit.bk && (unit.ch == 'W') && syntax.get(RESyntax.RE_CHAR_CLASS_ESCAPES)) {
- addToken(currentToken);
- currentToken = new RETokenPOSIX(subIndex,RETokenPOSIX.ALNUM,insens,true);
- }
-
- // END OF STRING OPERATOR
- // \Z
-
- else if (unit.bk && (unit.ch == 'Z') && syntax.get(RESyntax.RE_STRING_ANCHORS)) {
- addToken(currentToken);
- currentToken = new RETokenEnd(subIndex,null);
- }
-
- // NON-SPECIAL CHARACTER (or escape to make literal)
- // c | \* for example
-
- else { // not a special character
- addToken(currentToken);
- currentToken = new RETokenChar(subIndex,unit.ch,insens);
- }
- } // end while
-
- // Add final buffered token and an EndSub marker
- addToken(currentToken);
-
- if (branches != null) {
- branches.addElement(new RE(firstToken,lastToken,numSubs,subIndex,minimumLength));
- branches.trimToSize(); // compact the Vector
- minimumLength = 0;
- firstToken = lastToken = null;
- addToken(new RETokenOneOf(subIndex,branches,false));
- }
- else addToken(new RETokenEndSub(subIndex));
-
- }
-
- private static int getCharUnit(char[] input, int index, CharUnit unit) throws REException {
- unit.ch = input[index++];
- if (unit.bk = (unit.ch == '\\'))
- if (index < input.length)
- unit.ch = input[index++];
- else throw new REException(getLocalizedMessage("ends.with.backslash"),REException.REG_ESCAPE,index);
- return index;
- }
-
- /**
- * Checks if the regular expression matches the input in its entirety.
- *
- * @param input The input text.
- */
- public boolean isMatch(Object input) {
- return isMatch(input,0,0);
- }
-
- /**
- * Checks if the input string, starting from index, is an exact match of
- * this regular expression.
- *
- * @param input The input text.
- * @param index The offset index at which the search should be begin.
- */
- public boolean isMatch(Object input,int index) {
- return isMatch(input,index,0);
- }
-
-
- /**
- * Checks if the input, starting from index and using the specified
- * execution flags, is an exact match of this regular expression.
- *
- * @param input The input text.
- * @param index The offset index at which the search should be begin.
- * @param eflags The logical OR of any execution flags above.
- */
- public boolean isMatch(Object input,int index,int eflags) {
- return isMatchImpl(makeCharIndexed(input,index),index,eflags);
- }
-
- private boolean isMatchImpl(CharIndexed input, int index, int eflags) {
- if (firstToken == null) // Trivial case
- return (input.charAt(0) == CharIndexed.OUT_OF_BOUNDS);
- REMatch m = new REMatch(numSubs, index, eflags);
- if (firstToken.match(input, m)) {
- while (m != null) {
- if (input.charAt(m.index) == CharIndexed.OUT_OF_BOUNDS) {
- return true;
- }
- m = m.next;
- }
- }
- return false;
- }
-
- /**
- * Returns the maximum number of subexpressions in this regular expression.
- * If the expression contains branches, the value returned will be the
- * maximum subexpressions in any of the branches.
- */
- public int getNumSubs() {
- return numSubs;
- }
-
- // Overrides REToken.setUncle
- void setUncle(REToken uncle) {
- if (lastToken != null) {
- lastToken.setUncle(uncle);
- } else super.setUncle(uncle); // to deal with empty subexpressions
- }
-
- // Overrides REToken.chain
-
- boolean chain(REToken next) {
- super.chain(next);
- setUncle(next);
- return true;
- }
-
- /**
- * Returns the minimum number of characters that could possibly
- * constitute a match of this regular expression.
- */
- public int getMinimumLength() {
- return minimumLength;
- }
-
- /**
- * Returns an array of all matches found in the input.
- *
- * If the regular expression allows the empty string to match, it will
- * substitute matches at all positions except the end of the input.
- *
- * @param input The input text.
- * @return a non-null (but possibly zero-length) array of matches
- */
- public REMatch[] getAllMatches(Object input) {
- return getAllMatches(input,0,0);
- }
-
- /**
- * Returns an array of all matches found in the input,
- * beginning at the specified index position.
- *
- * If the regular expression allows the empty string to match, it will
- * substitute matches at all positions except the end of the input.
- *
- * @param input The input text.
- * @param index The offset index at which the search should be begin.
- * @return a non-null (but possibly zero-length) array of matches
- */
- public REMatch[] getAllMatches(Object input, int index) {
- return getAllMatches(input,index,0);
- }
-
- /**
- * Returns an array of all matches found in the input string,
- * beginning at the specified index position and using the specified
- * execution flags.
- *
- * If the regular expression allows the empty string to match, it will
- * substitute matches at all positions except the end of the input.
- *
- * @param input The input text.
- * @param index The offset index at which the search should be begin.
- * @param eflags The logical OR of any execution flags above.
- * @return a non-null (but possibly zero-length) array of matches
- */
- public REMatch[] getAllMatches(Object input, int index, int eflags) {
- return getAllMatchesImpl(makeCharIndexed(input,index),index,eflags);
- }
-
- // this has been changed since 1.03 to be non-overlapping matches
- private REMatch[] getAllMatchesImpl(CharIndexed input, int index, int eflags) {
- Vector all = new Vector();
- REMatch m = null;
- while ((m = getMatchImpl(input,index,eflags,null)) != null) {
- all.addElement(m);
- index = m.getEndIndex();
- if (m.end[0] == 0) { // handle pathological case of zero-length match
- index++;
- input.move(1);
- } else {
- input.move(m.end[0]);
- }
- if (!input.isValid()) break;
- }
- REMatch[] mset = new REMatch[all.size()];
- all.copyInto(mset);
- return mset;
- }
-
- /* Implements abstract method REToken.match() */
- boolean match(CharIndexed input, REMatch mymatch) {
- if (firstToken == null) return next(input, mymatch);
-
- // Note the start of this subexpression
- mymatch.start[subIndex] = mymatch.index;
-
- return firstToken.match(input, mymatch);
- }
-
- /**
- * Returns the first match found in the input. If no match is found,
- * null is returned.
- *
- * @param input The input text.
- * @return An REMatch instance referencing the match, or null if none.
- */
- public REMatch getMatch(Object input) {
- return getMatch(input,0,0);
- }
-
- /**
- * Returns the first match found in the input, beginning
- * the search at the specified index. If no match is found,
- * returns null.
- *
- * @param input The input text.
- * @param index The offset within the text to begin looking for a match.
- * @return An REMatch instance referencing the match, or null if none.
- */
- public REMatch getMatch(Object input, int index) {
- return getMatch(input,index,0);
- }
-
- /**
- * Returns the first match found in the input, beginning
- * the search at the specified index, and using the specified
- * execution flags. If no match is found, returns null.
- *
- * @param input The input text.
- * @param index The offset index at which the search should be begin.
- * @param eflags The logical OR of any execution flags above.
- * @return An REMatch instance referencing the match, or null if none.
- */
- public REMatch getMatch(Object input, int index, int eflags) {
- return getMatch(input,index,eflags,null);
- }
-
- /**
- * Returns the first match found in the input, beginning the search
- * at the specified index, and using the specified execution flags.
- * If no match is found, returns null. If a StringBuffer is
- * provided and is non-null, the contents of the input text from the
- * index to the beginning of the match (or to the end of the input,
- * if there is no match) are appended to the StringBuffer.
- *
- * @param input The input text.
- * @param index The offset index at which the search should be begin.
- * @param eflags The logical OR of any execution flags above.
- * @param buffer The StringBuffer to save pre-match text in.
- * @return An REMatch instance referencing the match, or null if none. */
- public REMatch getMatch(Object input, int index, int eflags, StringBuffer buffer) {
- return getMatchImpl(makeCharIndexed(input,index),index,eflags,buffer);
- }
-
- REMatch getMatchImpl(CharIndexed input, int anchor, int eflags, StringBuffer buffer) {
- // Create a new REMatch to hold results
- REMatch mymatch = new REMatch(numSubs, anchor, eflags);
- do {
- // Optimization: check if anchor + minimumLength > length
- if (minimumLength == 0 || input.charAt(minimumLength-1) != CharIndexed.OUT_OF_BOUNDS) {
- if (match(input, mymatch)) {
- // Find longest match of them all to observe leftmost longest
- REMatch longest = mymatch;
- while ((mymatch = mymatch.next) != null) {
- if (mymatch.index > longest.index) {
- longest = mymatch;
- }
- }
-
- longest.end[0] = longest.index;
- longest.finish(input);
- return longest;
- }
- }
- mymatch.clear(++anchor);
- // Append character to buffer if needed
- if (buffer != null && input.charAt(0) != CharIndexed.OUT_OF_BOUNDS) {
- buffer.append(input.charAt(0));
- }
- } while (input.move(1));
-
- // Special handling at end of input for e.g. "$"
- if (minimumLength == 0) {
- if (match(input, mymatch)) {
- mymatch.finish(input);
- return mymatch;
- }
- }
-
- return null;
- }
-
- /**
- * Returns an REMatchEnumeration that can be used to iterate over the
- * matches found in the input text.
- *
- * @param input The input text.
- * @return A non-null REMatchEnumeration instance.
- */
- public REMatchEnumeration getMatchEnumeration(Object input) {
- return getMatchEnumeration(input,0,0);
- }
-
-
- /**
- * Returns an REMatchEnumeration that can be used to iterate over the
- * matches found in the input text.
- *
- * @param input The input text.
- * @param index The offset index at which the search should be begin.
- * @return A non-null REMatchEnumeration instance, with its input cursor
- * set to the index position specified.
- */
- public REMatchEnumeration getMatchEnumeration(Object input, int index) {
- return getMatchEnumeration(input,index,0);
- }
-
- /**
- * Returns an REMatchEnumeration that can be used to iterate over the
- * matches found in the input text.
- *
- * @param input The input text.
- * @param index The offset index at which the search should be begin.
- * @param eflags The logical OR of any execution flags above.
- * @return A non-null REMatchEnumeration instance, with its input cursor
- * set to the index position specified.
- */
- public REMatchEnumeration getMatchEnumeration(Object input, int index, int eflags) {
- return new REMatchEnumeration(this,makeCharIndexed(input,index),index,eflags);
- }
-
-
- /**
- * Substitutes the replacement text for the first match found in the input.
- *
- * @param input The input text.
- * @param replace The replacement text, which may contain $x metacharacters (see REMatch.substituteInto).
- * @return A String interpolating the substituted text.
- * @see REMatch#substituteInto
- */
- public String substitute(Object input,String replace) {
- return substitute(input,replace,0,0);
- }
-
- /**
- * Substitutes the replacement text for the first match found in the input
- * beginning at the specified index position. Specifying an index
- * effectively causes the regular expression engine to throw away the
- * specified number of characters.
- *
- * @param input The input text.
- * @param replace The replacement text, which may contain $x metacharacters (see REMatch.substituteInto).
- * @param index The offset index at which the search should be begin.
- * @return A String containing the substring of the input, starting
- * at the index position, and interpolating the substituted text.
- * @see REMatch#substituteInto
- */
- public String substitute(Object input,String replace,int index) {
- return substitute(input,replace,index,0);
- }
-
- /**
- * Substitutes the replacement text for the first match found in the input
- * string, beginning at the specified index position and using the
- * specified execution flags.
- *
- * @param input The input text.
- * @param replace The replacement text, which may contain $x metacharacters (see REMatch.substituteInto).
- * @param index The offset index at which the search should be begin.
- * @param eflags The logical OR of any execution flags above.
- * @return A String containing the substring of the input, starting
- * at the index position, and interpolating the substituted text.
- * @see REMatch#substituteInto
- */
- public String substitute(Object input,String replace,int index,int eflags) {
- return substituteImpl(makeCharIndexed(input,index),replace,index,eflags);
- }
-
- private String substituteImpl(CharIndexed input,String replace,int index,int eflags) {
- StringBuffer buffer = new StringBuffer();
- REMatch m = getMatchImpl(input,index,eflags,buffer);
- if (m==null) return buffer.toString();
- buffer.append( ((eflags & REG_NO_INTERPOLATE) > 0) ?
- replace : m.substituteInto(replace) );
- if (input.move(m.end[0])) {
- do {
- buffer.append(input.charAt(0));
- } while (input.move(1));
- }
- return buffer.toString();
- }
-
- /**
- * Substitutes the replacement text for each non-overlapping match found
- * in the input text.
- *
- * @param input The input text.
- * @param replace The replacement text, which may contain $x metacharacters (see REMatch.substituteInto).
- * @return A String interpolating the substituted text.
- * @see REMatch#substituteInto
- */
- public String substituteAll(Object input,String replace) {
- return substituteAll(input,replace,0,0);
- }
-
- /**
- * Substitutes the replacement text for each non-overlapping match found
- * in the input text, starting at the specified index.
- *
- * If the regular expression allows the empty string to match, it will
- * substitute matches at all positions except the end of the input.
- *
- * @param input The input text.
- * @param replace The replacement text, which may contain $x metacharacters (see REMatch.substituteInto).
- * @param index The offset index at which the search should be begin.
- * @return A String containing the substring of the input, starting
- * at the index position, and interpolating the substituted text.
- * @see REMatch#substituteInto
- */
- public String substituteAll(Object input,String replace,int index) {
- return substituteAll(input,replace,index,0);
- }
-
- /**
- * Substitutes the replacement text for each non-overlapping match found
- * in the input text, starting at the specified index and using the
- * specified execution flags.
- *
- * @param input The input text.
- * @param replace The replacement text, which may contain $x metacharacters (see REMatch.substituteInto).
- * @param index The offset index at which the search should be begin.
- * @param eflags The logical OR of any execution flags above.
- * @return A String containing the substring of the input, starting
- * at the index position, and interpolating the substituted text.
- * @see REMatch#substituteInto
- */
- public String substituteAll(Object input,String replace,int index,int eflags) {
- return substituteAllImpl(makeCharIndexed(input,index),replace,index,eflags);
- }
-
- private String substituteAllImpl(CharIndexed input,String replace,int index,int eflags) {
- StringBuffer buffer = new StringBuffer();
- REMatch m;
- while ((m = getMatchImpl(input,index,eflags,buffer)) != null) {
- buffer.append( ((eflags & REG_NO_INTERPOLATE) > 0) ?
- replace : m.substituteInto(replace) );
- index = m.getEndIndex();
- if (m.end[0] == 0) {
- char ch = input.charAt(0);
- if (ch != CharIndexed.OUT_OF_BOUNDS)
- buffer.append(ch);
- input.move(1);
- } else {
- input.move(m.end[0]);
- }
-
- if (!input.isValid()) break;
- }
- return buffer.toString();
- }
-
- /* Helper function for constructor */
- private void addToken(REToken next) {
- if (next == null) return;
- minimumLength += next.getMinimumLength();
- if (firstToken == null) {
- lastToken = firstToken = next;
- } else {
- // if chain returns false, it "rejected" the token due to
- // an optimization, and next was combined with lastToken
- if (lastToken.chain(next)) {
- lastToken = next;
- }
- }
- }
-
- private static REToken setRepeated(REToken current, int min, int max, int index) throws REException {
- if (current == null) throw new REException(getLocalizedMessage("repeat.no.token"),REException.REG_BADRPT,index);
- return new RETokenRepeated(current.subIndex,current,min,max);
- }
-
- private static int getPosixSet(char[] pattern,int index,StringBuffer buf) {
- // Precondition: pattern[index-1] == ':'
- // we will return pos of closing ']'.
- int i;
- for (i=index; i<(pattern.length-1); i++) {
- if ((pattern[i] == ':') && (pattern[i+1] == ']'))
- return i+2;
- buf.append(pattern[i]);
- }
- return index; // didn't match up
- }
-
- private int getMinMax(char[] input,int index,IntPair minMax,RESyntax syntax) throws REException {
- // Precondition: input[index-1] == '{', minMax != null
-
- boolean mustMatch = !syntax.get(RESyntax.RE_NO_BK_BRACES);
- int startIndex = index;
- if (index == input.length) {
- if (mustMatch)
- throw new REException(getLocalizedMessage("unmatched.brace"),REException.REG_EBRACE,index);
- else
- return startIndex;
- }
-
- int min,max=0;
- CharUnit unit = new CharUnit();
- StringBuffer buf = new StringBuffer();
-
- // Read string of digits
- do {
- index = getCharUnit(input,index,unit);
- if (Character.isDigit(unit.ch))
- buf.append(unit.ch);
- } while ((index != input.length) && Character.isDigit(unit.ch));
-
- // Check for {} tomfoolery
- if (buf.length() == 0) {
- if (mustMatch)
- throw new REException(getLocalizedMessage("interval.error"),REException.REG_EBRACE,index);
- else
- return startIndex;
- }
-
- min = Integer.parseInt(buf.toString());
-
- if ((unit.ch == '}') && (syntax.get(RESyntax.RE_NO_BK_BRACES) ^ unit.bk))
- max = min;
- else if (index == input.length)
- if (mustMatch)
- throw new REException(getLocalizedMessage("interval.no.end"),REException.REG_EBRACE,index);
- else
- return startIndex;
- else if ((unit.ch == ',') && !unit.bk) {
- buf = new StringBuffer();
- // Read string of digits
- while (((index = getCharUnit(input,index,unit)) != input.length) && Character.isDigit(unit.ch))
- buf.append(unit.ch);
-
- if (!((unit.ch == '}') && (syntax.get(RESyntax.RE_NO_BK_BRACES) ^ unit.bk)))
- if (mustMatch)
- throw new REException(getLocalizedMessage("interval.error"),REException.REG_EBRACE,index);
- else
- return startIndex;
-
- // This is the case of {x,}
- if (buf.length() == 0) max = Integer.MAX_VALUE;
- else max = Integer.parseInt(buf.toString());
- } else
- if (mustMatch)
- throw new REException(getLocalizedMessage("interval.error"),REException.REG_EBRACE,index);
- else
- return startIndex;
-
- // We know min and max now, and they are valid.
-
- minMax.first = min;
- minMax.second = max;
-
- // return the index following the '}'
- return index;
- }
-
- /**
- * Return a human readable form of the compiled regular expression,
- * useful for debugging.
- */
- public String toString() {
- StringBuffer sb = new StringBuffer();
- dump(sb);
- return sb.toString();
- }
-
- void dump(StringBuffer os) {
- os.append('(');
- if (subIndex == 0)
- os.append("?:");
- if (firstToken != null)
- firstToken.dumpAll(os);
- os.append(')');
- }
-
- // Cast input appropriately or throw exception
- private static CharIndexed makeCharIndexed(Object input, int index) {
- // We could let a String fall through to final input, but since
- // it's the most likely input type, we check it first.
- if (input instanceof String)
- return new CharIndexedString((String) input,index);
- else if (input instanceof char[])
- return new CharIndexedCharArray((char[]) input,index);
- else if (input instanceof StringBuffer)
- return new CharIndexedStringBuffer((StringBuffer) input,index);
- else if (input instanceof InputStream)
- return new CharIndexedInputStream((InputStream) input,index);
- else if (input instanceof CharIndexed)
- return (CharIndexed) input; // do we lose index info?
- else
- return new CharIndexedString(input.toString(), index);
- }
-}
diff --git a/libjava/gnu/regexp/REException.java b/libjava/gnu/regexp/REException.java
deleted file mode 100644
index a10d2fc71fe..00000000000
--- a/libjava/gnu/regexp/REException.java
+++ /dev/null
@@ -1,182 +0,0 @@
-/* gnu/regexp/REException.java
- Copyright (C) 1998-2001, 2004 Free Software Foundation, Inc.
-
-This file is part of GNU Classpath.
-
-GNU Classpath is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2, or (at your option)
-any later version.
-
-GNU Classpath is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with GNU Classpath; see the file COPYING. If not, write to the
-Free Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA
-02111-1307 USA.
-
-Linking this library statically or dynamically with other modules is
-making a combined work based on this library. Thus, the terms and
-conditions of the GNU General Public License cover the whole
-combination.
-
-As a special exception, the copyright holders of this library give you
-permission to link this library with independent modules to produce an
-executable, regardless of the license terms of these independent
-modules, and to copy and distribute the resulting executable under
-terms of your choice, provided that you also meet, for each linked
-independent module, the terms and conditions of the license of that
-module. An independent module is a module which is not derived from
-or based on this library. If you modify this library, you may extend
-this exception to your version of the library, but you are not
-obligated to do so. If you do not wish to do so, delete this
-exception statement from your version. */
-
-package gnu.regexp;
-
-import java.text.MessageFormat;
-
-/**
- * This is the regular expression exception class. An exception of this type
- * defines the three attributes:
- * <OL>
- * <LI> A descriptive message of the error.
- * <LI> An integral type code equivalent to one of the statically
- * defined symbols listed below.
- * <LI> The approximate position in the input string where the error
- * occurred.
- * </OL>
- *
- * @author <A HREF="mailto:wes@cacas.org">Wes Biggs</A>
- */
-
-public class REException extends Exception {
- private int type;
- private int pos;
-
- // Error conditions from GNU regcomp(3) manual
-
- /**
- * Error flag.
- * Invalid use of repetition operators such as using
- * `*' as the first character.
- */
- public static final int REG_BADRPT = 1;
-
- /**
- * Error flag.
- * Invalid use of back reference operator.
- */
- public static final int REG_BADBR = 2;
-
- /**
- * Error flag.
- * Un-matched brace interval operators.
- */
- public static final int REG_EBRACE = 3;
-
- /**
- * Error flag.
- * Un-matched bracket list operators.
- */
- public static final int REG_EBRACK = 4;
-
- /**
- * Error flag.
- * Invalid use of the range operator, eg. the ending
- * point of the range occurs prior to the starting
- * point.
- */
- public static final int REG_ERANGE = 5;
-
- /**
- * Error flag.
- * Unknown character class name. <B>Not implemented</B>.
- */
- public static final int REG_ECTYPE = 6;
-
- /**
- * Error flag.
- * Un-matched parenthesis group operators.
- */
- public static final int REG_EPAREN = 7;
-
- /**
- * Error flag.
- * Invalid back reference to a subexpression.
- */
- public static final int REG_ESUBREG = 8;
-
- /**
- * Error flag.
- * Non specific error. <B>Not implemented</B>.
- */
- public static final int REG_EEND = 9;
-
- /**
- * Error flag.
- * Invalid escape sequence. <B>Not implemented</B>.
- */
- public static final int REG_ESCAPE = 10;
-
- /**
- * Error flag.
- * Invalid use of pattern operators such as group or list.
- */
- public static final int REG_BADPAT = 11;
-
- /**
- * Error flag.
- * Compiled regular expression requires a pattern
- * buffer larger than 64Kb. <B>Not implemented</B>.
- */
- public static final int REG_ESIZE = 12;
-
- /**
- * Error flag.
- * The regex routines ran out of memory. <B>Not implemented</B>.
- */
- public static final int REG_ESPACE = 13;
-
- REException(String msg, int type, int position) {
- super(msg);
- this.type = type;
- this.pos = position;
- }
-
- /**
- * Returns the type of the exception, one of the constants listed above.
- */
-
- public int getType() {
- return type;
- }
-
- /**
- * Returns the position, relative to the string or character array being
- * compiled, where the error occurred. This position is generally the point
- * where the error was detected, not necessarily the starting index of
- * a bad subexpression.
- */
- public int getPosition() {
- return pos;
- }
-
- /**
- * Reports the descriptive message associated with this exception
- * as well as its index position in the string or character array
- * being compiled.
- */
- public String getMessage() {
- Object[] args = {new Integer(pos)};
- StringBuffer sb = new StringBuffer();
- String prefix = RE.getLocalizedMessage("error.prefix");
- sb.append(MessageFormat.format(prefix, args));
- sb.append('\n');
- sb.append(super.getMessage());
- return sb.toString();
- }
-}
diff --git a/libjava/gnu/regexp/REFilterInputStream.java b/libjava/gnu/regexp/REFilterInputStream.java
deleted file mode 100644
index f56a9a2a9cb..00000000000
--- a/libjava/gnu/regexp/REFilterInputStream.java
+++ /dev/null
@@ -1,140 +0,0 @@
-/* gnu/regexp/REFilterInputStream.java
- Copyright (C) 1998-2001, 2004 Free Software Foundation, Inc.
-
-This file is part of GNU Classpath.
-
-GNU Classpath is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2, or (at your option)
-any later version.
-
-GNU Classpath is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with GNU Classpath; see the file COPYING. If not, write to the
-Free Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA
-02111-1307 USA.
-
-Linking this library statically or dynamically with other modules is
-making a combined work based on this library. Thus, the terms and
-conditions of the GNU General Public License cover the whole
-combination.
-
-As a special exception, the copyright holders of this library give you
-permission to link this library with independent modules to produce an
-executable, regardless of the license terms of these independent
-modules, and to copy and distribute the resulting executable under
-terms of your choice, provided that you also meet, for each linked
-independent module, the terms and conditions of the license of that
-module. An independent module is a module which is not derived from
-or based on this library. If you modify this library, you may extend
-this exception to your version of the library, but you are not
-obligated to do so. If you do not wish to do so, delete this
-exception statement from your version. */
-
-
-package gnu.regexp;
-import java.io.FilterInputStream;
-import java.io.InputStream;
-
-/**
- * Replaces instances of a given RE found within an InputStream
- * with replacement text. The replacements are interpolated into the
- * stream when a match is found.
- *
- * @author <A HREF="mailto:wes@cacas.org">Wes Biggs</A>
- * @deprecated This class cannot properly handle all character
- * encodings. For proper handling, use the REFilterReader
- * class instead.
- */
-
-public class REFilterInputStream extends FilterInputStream {
-
- private RE expr;
- private String replace;
- private String buffer;
- private int bufpos;
- private int offset;
- private CharIndexedInputStream stream;
-
- /**
- * Creates an REFilterInputStream. When reading from this stream,
- * occurrences of patterns matching the supplied regular expression
- * will be replaced with the supplied replacement text (the
- * metacharacters $0 through $9 may be used to refer to the full
- * match or subexpression matches).
- *
- * @param stream The InputStream to be filtered.
- * @param expr The regular expression to search for.
- * @param replace The text pattern to replace matches with.
- */
- public REFilterInputStream(InputStream stream, RE expr, String replace) {
- super(stream);
- this.stream = new CharIndexedInputStream(stream,0);
- this.expr = expr;
- this.replace = replace;
- }
-
- /**
- * Reads the next byte from the stream per the general contract of
- * InputStream.read(). Returns -1 on error or end of stream.
- */
- public int read() {
- // If we have buffered replace data, use it.
- if ((buffer != null) && (bufpos < buffer.length())) {
- return (int) buffer.charAt(bufpos++);
- }
-
- // check if input is at a valid position
- if (!stream.isValid()) return -1;
-
- REMatch mymatch = new REMatch(expr.getNumSubs(),offset,0);
- if (expr.match(stream, mymatch)) {
- mymatch.end[0] = mymatch.index;
- mymatch.finish(stream);
- stream.move(mymatch.toString().length());
- offset += mymatch.toString().length();
- buffer = mymatch.substituteInto(replace);
- bufpos = 1;
-
- // This is prone to infinite loops if replace string turns out empty.
- if (buffer.length() > 0) {
- return buffer.charAt(0);
- }
- }
- char ch = stream.charAt(0);
- if (ch == CharIndexed.OUT_OF_BOUNDS) return -1;
- stream.move(1);
- offset++;
- return ch;
- }
-
- /**
- * Returns false. REFilterInputStream does not support mark() and
- * reset() methods.
- */
- public boolean markSupported() {
- return false;
- }
-
- /** Reads from the stream into the provided array. */
- public int read(byte[] b, int off, int len) {
- int i;
- int ok = 0;
- while (len-- > 0) {
- i = read();
- if (i == -1) return (ok == 0) ? -1 : ok;
- b[off++] = (byte) i;
- ok++;
- }
- return ok;
- }
-
- /** Reads from the stream into the provided array. */
- public int read(byte[] b) {
- return read(b,0,b.length);
- }
-}
diff --git a/libjava/gnu/regexp/REFilterReader.java b/libjava/gnu/regexp/REFilterReader.java
deleted file mode 100644
index 449efcc9b1c..00000000000
--- a/libjava/gnu/regexp/REFilterReader.java
+++ /dev/null
@@ -1,117 +0,0 @@
-/*
- * gnu/regexp/REFilterReader.java
- * Copyright (C) 2001 Lee Sau Dan
- * Based on gnu.regexp.REFilterInputStream by Wes Biggs
- *
- * This library is free software; you can redistribute it and/or modify
- * it under the terms of the GNU Lesser General Public License as published
- * by the Free Software Foundation; either version 2.1 of the License, or
- * (at your option) any later version.
- *
- * This library is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU Lesser General Public License for more details.
- *
- * You should have received a copy of the GNU Lesser General Public License
- * along with this program; if not, write to the Free Software
- * Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
- */
-
-package gnu.regexp;
-import java.io.FilterReader;
-import java.io.Reader;
-
-/**
- * Replaces instances of a given RE with replacement text.
- *
- * @author <A HREF="http://www.csis.hku.hk/~sdlee/">Lee Sau Dan</A>
- * @since gnu.regexp 1.1.0
- */
-
-public class REFilterReader extends FilterReader {
-
- private RE expr;
- private String replace;
- private String buffer;
- private int bufpos;
- private int offset;
- private CharIndexedReader stream;
-
- /**
- * Creates an REFilterReader. When reading from this stream,
- * occurrences of patterns matching the supplied regular expression
- * will be replaced with the supplied replacement text (the
- * metacharacters $0 through $9 may be used to refer to the full
- * match or subexpression matches.
- *
- * @param stream The Reader to be filtered.
- * @param expr The regular expression to search for.
- * @param replace The text pattern to replace matches with.
- */
- public REFilterReader(Reader stream, RE expr, String replace) {
- super(stream);
- this.stream = new CharIndexedReader(stream,0);
- this.expr = expr;
- this.replace = replace;
- }
-
- /**
- * Reads the next character from the stream per the general contract of
- * Reader.read(). Returns -1 on error or end of stream.
- */
- public int read() {
- // If we have buffered replace data, use it.
- if ((buffer != null) && (bufpos < buffer.length())) {
- return (int) buffer.charAt(bufpos++);
- }
-
- // check if input is at a valid position
- if (!stream.isValid()) return -1;
-
- REMatch mymatch = new REMatch(expr.getNumSubs(),offset,0);
- if (expr.match(stream,mymatch)) {
- mymatch.end[0] = mymatch.index;
- mymatch.finish(stream);
- stream.move(mymatch.toString().length());
- offset += mymatch.toString().length();
- buffer = mymatch.substituteInto(replace);
- bufpos = 1;
-
- if (buffer.length() > 0) {
- return buffer.charAt(0);
- }
- }
- char ch = stream.charAt(0);
- if (ch == CharIndexed.OUT_OF_BOUNDS) return -1;
- stream.move(1);
- offset++;
- return ch;
- }
-
- /**
- * Returns false. REFilterReader does not support mark() and
- * reset() methods.
- */
- public boolean markSupported() {
- return false;
- }
-
- /** Reads from the stream into the provided array. */
- public int read(char[] b, int off, int len) {
- int i;
- int ok = 0;
- while (len-- > 0) {
- i = read();
- if (i == -1) return (ok == 0) ? -1 : ok;
- b[off++] = (char) i;
- ok++;
- }
- return ok;
- }
-
- /** Reads from the stream into the provided array. */
- public int read(char[] b) {
- return read(b,0,b.length);
- }
-}
diff --git a/libjava/gnu/regexp/REMatch.java b/libjava/gnu/regexp/REMatch.java
deleted file mode 100644
index ac6c80e9196..00000000000
--- a/libjava/gnu/regexp/REMatch.java
+++ /dev/null
@@ -1,263 +0,0 @@
-/* gnu/regexp/REMatch.java
- Copyright (C) 1998-2001, 2004 Free Software Foundation, Inc.
-
-This file is part of GNU Classpath.
-
-GNU Classpath is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2, or (at your option)
-any later version.
-
-GNU Classpath is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with GNU Classpath; see the file COPYING. If not, write to the
-Free Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA
-02111-1307 USA.
-
-Linking this library statically or dynamically with other modules is
-making a combined work based on this library. Thus, the terms and
-conditions of the GNU General Public License cover the whole
-combination.
-
-As a special exception, the copyright holders of this library give you
-permission to link this library with independent modules to produce an
-executable, regardless of the license terms of these independent
-modules, and to copy and distribute the resulting executable under
-terms of your choice, provided that you also meet, for each linked
-independent module, the terms and conditions of the license of that
-module. An independent module is a module which is not derived from
-or based on this library. If you modify this library, you may extend
-this exception to your version of the library, but you are not
-obligated to do so. If you do not wish to do so, delete this
-exception statement from your version. */
-
-
-package gnu.regexp;
-import java.io.Serializable;
-
-/**
- * An instance of this class represents a match
- * completed by a gnu.regexp matching function. It can be used
- * to obtain relevant information about the location of a match
- * or submatch.
- *
- * @author <A HREF="mailto:wes@cacas.org">Wes Biggs</A>
- */
-public final class REMatch implements Serializable, Cloneable {
- private String matchedText;
-
- // These variables are package scope for fast access within the engine
- int eflags; // execution flags this match was made using
-
- // Offset in source text where match was tried. This is zero-based;
- // the actual position in the source text is given by (offset + anchor).
- int offset;
-
- // Anchor position refers to the index into the source input
- // at which the matching operation began.
- // This is also useful for the ANCHORINDEX option.
- int anchor;
-
- // Package scope; used by RE.
- int index; // used while matching to mark current match position in input
- int[] start; // start positions (relative to offset) for each (sub)exp.
- int[] end; // end positions for the same
- REMatch next; // other possibility (to avoid having to use arrays)
-
- public Object clone() {
- try {
- REMatch copy = (REMatch) super.clone();
- copy.next = null;
-
- copy.start = (int[]) start.clone();
- copy.end = (int[]) end.clone();
-
- return copy;
- } catch (CloneNotSupportedException e) {
- throw new Error(); // doesn't happen
- }
- }
-
- void assignFrom(REMatch other) {
- start = other.start;
- end = other.end;
- index = other.index;
- // need to deep clone?
- next = other.next;
- }
-
- REMatch(int subs, int anchor, int eflags) {
- start = new int[subs+1];
- end = new int[subs+1];
- this.anchor = anchor;
- this.eflags = eflags;
- clear(anchor);
- }
-
- void finish(CharIndexed text) {
- start[0] = 0;
- StringBuffer sb = new StringBuffer();
- int i;
- for (i = 0; i < end[0]; i++)
- sb.append(text.charAt(i));
- matchedText = sb.toString();
- for (i = 0; i < start.length; i++) {
- // If any subexpressions didn't terminate, they don't count
- // TODO check if this code ever gets hit
- if ((start[i] == -1) ^ (end[i] == -1)) {
- start[i] = -1;
- end[i] = -1;
- }
- }
- next = null; // cut off alternates
- }
-
- /** Clears the current match and moves the offset to the new index. */
- void clear(int index) {
- offset = index;
- this.index = 0;
- for (int i = 0; i < start.length; i++) {
- start[i] = end[i] = -1;
- }
- next = null; // cut off alternates
- }
-
- /**
- * Returns the string matching the pattern. This makes it convenient
- * to write code like the following:
- * <P>
- * <code>
- * REMatch myMatch = myExpression.getMatch(myString);<br>
- * if (myMatch != null) System.out.println("Regexp found: "+myMatch);
- * </code>
- */
- public String toString() {
- return matchedText;
- }
-
- /**
- * Returns the index within the input text where the match in its entirety
- * began.
- */
- public int getStartIndex() {
- return offset + start[0];
- }
-
- /**
- * Returns the index within the input string where the match in
- * its entirety ends. The return value is the next position after
- * the end of the string; therefore, a match created by the
- * following call:
- *
- * <P>
- * <code>REMatch myMatch = myExpression.getMatch(myString);</code>
- * <P>
- * can be viewed (given that myMatch is not null) by creating
- * <P>
- * <code>String theMatch = myString.substring(myMatch.getStartIndex(),
- * myMatch.getEndIndex());</code>
- * <P>
- * But you can save yourself that work, since the <code>toString()</code>
- * method (above) does exactly that for you.
- */
- public int getEndIndex() {
- return offset + end[0];
- }
-
- /**
- * Returns the string matching the given subexpression. The subexpressions
- * are indexed starting with one, not zero. That is, the subexpression
- * identified by the first set of parentheses in a regular expression
- * could be retrieved from an REMatch by calling match.toString(1).
- *
- * @param sub Index of the subexpression.
- */
- public String toString(int sub) {
- if ((sub >= start.length) || (start[sub] == -1)) return "";
- return (matchedText.substring(start[sub],end[sub]));
- }
-
- /**
- * Returns the index within the input string used to generate this match
- * where subexpression number <i>sub</i> begins, or <code>-1</code> if
- * the subexpression does not exist. The initial position is zero.
- *
- * @param sub Subexpression index
- * @deprecated Use getStartIndex(int) instead.
- */
- public int getSubStartIndex(int sub) {
- if (sub >= start.length) return -1;
- int x = start[sub];
- return (x == -1) ? x : offset + x;
- }
-
- /**
- * Returns the index within the input string used to generate this match
- * where subexpression number <i>sub</i> begins, or <code>-1</code> if
- * the subexpression does not exist. The initial position is zero.
- *
- * @param sub Subexpression index
- * @since gnu.regexp 1.1.0
- */
- public int getStartIndex(int sub) {
- if (sub >= start.length) return -1;
- int x = start[sub];
- return (x == -1) ? x : offset + x;
- }
-
- /**
- * Returns the index within the input string used to generate this match
- * where subexpression number <i>sub</i> ends, or <code>-1</code> if
- * the subexpression does not exist. The initial position is zero.
- *
- * @param sub Subexpression index
- * @deprecated Use getEndIndex(int) instead
- */
- public int getSubEndIndex(int sub) {
- if (sub >= start.length) return -1;
- int x = end[sub];
- return (x == -1) ? x : offset + x;
- }
-
- /**
- * Returns the index within the input string used to generate this match
- * where subexpression number <i>sub</i> ends, or <code>-1</code> if
- * the subexpression does not exist. The initial position is zero.
- *
- * @param sub Subexpression index
- */
- public int getEndIndex(int sub) {
- if (sub >= start.length) return -1;
- int x = end[sub];
- return (x == -1) ? x : offset + x;
- }
-
- /**
- * Substitute the results of this match to create a new string.
- * This is patterned after PERL, so the tokens to watch out for are
- * <code>$0</code> through <code>$9</code>. <code>$0</code> matches
- * the full substring matched; <code>$<i>n</i></code> matches
- * subexpression number <i>n</i>.
- *
- * @param input A string consisting of literals and <code>$<i>n</i></code> tokens.
- */
- public String substituteInto(String input) {
- // a la Perl, $0 is whole thing, $1 - $9 are subexpressions
- StringBuffer output = new StringBuffer();
- int pos;
- for (pos = 0; pos < input.length()-1; pos++) {
- if ((input.charAt(pos) == '$') && (Character.isDigit(input.charAt(pos+1)))) {
- int val = Character.digit(input.charAt(++pos),10);
- if (val < start.length) {
- output.append(toString(val));
- }
- } else output.append(input.charAt(pos));
- }
- if (pos < input.length()) output.append(input.charAt(pos));
- return output.toString();
- }
-}
diff --git a/libjava/gnu/regexp/REMatchEnumeration.java b/libjava/gnu/regexp/REMatchEnumeration.java
deleted file mode 100644
index c8e208a9438..00000000000
--- a/libjava/gnu/regexp/REMatchEnumeration.java
+++ /dev/null
@@ -1,135 +0,0 @@
-/* gnu/regexp/REMatchEnumeration.java
- Copyright (C) 1998-2001, 2004 Free Software Foundation, Inc.
-
-This file is part of GNU Classpath.
-
-GNU Classpath is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2, or (at your option)
-any later version.
-
-GNU Classpath is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with GNU Classpath; see the file COPYING. If not, write to the
-Free Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA
-02111-1307 USA.
-
-Linking this library statically or dynamically with other modules is
-making a combined work based on this library. Thus, the terms and
-conditions of the GNU General Public License cover the whole
-combination.
-
-As a special exception, the copyright holders of this library give you
-permission to link this library with independent modules to produce an
-executable, regardless of the license terms of these independent
-modules, and to copy and distribute the resulting executable under
-terms of your choice, provided that you also meet, for each linked
-independent module, the terms and conditions of the license of that
-module. An independent module is a module which is not derived from
-or based on this library. If you modify this library, you may extend
-this exception to your version of the library, but you are not
-obligated to do so. If you do not wish to do so, delete this
-exception statement from your version. */
-
-package gnu.regexp;
-import java.io.Serializable;
-import java.util.Enumeration;
-import java.util.NoSuchElementException;
-
-/**
- * An REMatchEnumeration enumerates regular expression matches over a
- * given input text. You obtain a reference to an enumeration using
- * the <code>getMatchEnumeration()</code> methods on an instance of
- * RE.
- *
- * <P>
- *
- * REMatchEnumeration does lazy computation; that is, it will not
- * search for a match until it needs to. If you'd rather just get all
- * the matches at once in a big array, use the
- * <code>getAllMatches()</code> methods on RE. However, using an
- * enumeration can help speed performance when the entire text does
- * not need to be searched immediately.
- *
- * <P>
- *
- * The enumerated type is especially useful when searching on a Reader
- * or InputStream, because the InputStream read position cannot be
- * guaranteed after calling <code>getMatch()</code> (see the
- * description of that method for an explanation of why). Enumeration
- * also saves a lot of overhead required when calling
- * <code>getMatch()</code> multiple times.
- *
- * @author <A HREF="mailto:wes@cacas.org">Wes Biggs</A>
- */
-public class REMatchEnumeration implements Enumeration, Serializable {
- private static final int YES = 1;
- private static final int MAYBE = 0;
- private static final int NO = -1;
-
- private int more;
- private REMatch match;
- private RE expr;
- private CharIndexed input;
- private int eflags;
- private int index;
-
- // Package scope constructor is used by RE.getMatchEnumeration()
- REMatchEnumeration(RE expr, CharIndexed input, int index, int eflags) {
- more = MAYBE;
- this.expr = expr;
- this.input = input;
- this.index = index;
- this.eflags = eflags;
- }
-
- /** Returns true if there are more matches in the input text. */
- public boolean hasMoreElements() {
- return hasMoreMatches(null);
- }
-
- /** Returns true if there are more matches in the input text. */
- public boolean hasMoreMatches() {
- return hasMoreMatches(null);
- }
-
- /** Returns true if there are more matches in the input text.
- * Saves the text leading up to the match (or to the end of the input)
- * in the specified buffer.
- */
- public boolean hasMoreMatches(StringBuffer buffer) {
- if (more == MAYBE) {
- match = expr.getMatchImpl(input,index,eflags,buffer);
- if (match != null) {
- input.move((match.end[0] > 0) ? match.end[0] : 1);
-
- index = (match.end[0] > 0) ? match.end[0] + match.offset : index + 1;
- more = YES;
- } else more = NO;
- }
- return (more == YES);
- }
-
- /** Returns the next match in the input text. */
- public Object nextElement() throws NoSuchElementException {
- return nextMatch();
- }
-
- /**
- * Returns the next match in the input text. This method is provided
- * for convenience to avoid having to explicitly cast the return value
- * to class REMatch.
- */
- public REMatch nextMatch() throws NoSuchElementException {
- if (hasMoreElements()) {
- more = (input.isValid()) ? MAYBE : NO;
- return match;
- }
- throw new NoSuchElementException();
- }
-}
-
diff --git a/libjava/gnu/regexp/RESyntax.java b/libjava/gnu/regexp/RESyntax.java
deleted file mode 100644
index 649bd0df584..00000000000
--- a/libjava/gnu/regexp/RESyntax.java
+++ /dev/null
@@ -1,521 +0,0 @@
-/* gnu/regexp/RESyntax.java
- Copyright (C) 1998-2002, 2004 Free Software Foundation, Inc.
-
-This file is part of GNU Classpath.
-
-GNU Classpath is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2, or (at your option)
-any later version.
-
-GNU Classpath is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with GNU Classpath; see the file COPYING. If not, write to the
-Free Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA
-02111-1307 USA.
-
-Linking this library statically or dynamically with other modules is
-making a combined work based on this library. Thus, the terms and
-conditions of the GNU General Public License cover the whole
-combination.
-
-As a special exception, the copyright holders of this library give you
-permission to link this library with independent modules to produce an
-executable, regardless of the license terms of these independent
-modules, and to copy and distribute the resulting executable under
-terms of your choice, provided that you also meet, for each linked
-independent module, the terms and conditions of the license of that
-module. An independent module is a module which is not derived from
-or based on this library. If you modify this library, you may extend
-this exception to your version of the library, but you are not
-obligated to do so. If you do not wish to do so, delete this
-exception statement from your version. */
-
-
-package gnu.regexp;
-import java.io.Serializable;
-import java.util.BitSet;
-
-/**
- * An RESyntax specifies the way a regular expression will be compiled.
- * This class provides a number of predefined useful constants for
- * emulating popular regular expression syntaxes. Additionally the
- * user may construct his or her own syntax, using any combination of the
- * syntax bit constants. The syntax is an optional argument to any of the
- * matching methods on class RE.
- *
- * @author <A HREF="mailto:wes@cacas.org">Wes Biggs</A>
- */
-
-public final class RESyntax implements Serializable {
- static final String DEFAULT_LINE_SEPARATOR = System.getProperty("line.separator");
-
- private static final String SYNTAX_IS_FINAL = RE.getLocalizedMessage("syntax.final");
-
- private BitSet bits;
-
- // true for the constant defined syntaxes
- private boolean isFinal = false;
-
- private String lineSeparator = DEFAULT_LINE_SEPARATOR;
-
- // Values for constants are bit indexes
-
- /**
- * Syntax bit. Backslash is an escape character in lists.
- */
- public static final int RE_BACKSLASH_ESCAPE_IN_LISTS = 0;
-
- /**
- * Syntax bit. Use \? instead of ? and \+ instead of +.
- */
- public static final int RE_BK_PLUS_QM = 1;
-
- /**
- * Syntax bit. POSIX character classes ([:...:]) in lists are allowed.
- */
- public static final int RE_CHAR_CLASSES = 2;
-
- /**
- * Syntax bit. ^ and $ are special everywhere.
- * <B>Not implemented.</B>
- */
- public static final int RE_CONTEXT_INDEP_ANCHORS = 3;
-
- /**
- * Syntax bit. Repetition operators are only special in valid positions.
- * <B>Not implemented.</B>
- */
- public static final int RE_CONTEXT_INDEP_OPS = 4;
-
- /**
- * Syntax bit. Repetition and alternation operators are invalid
- * at start and end of pattern and other places.
- * <B>Not implemented</B>.
- */
- public static final int RE_CONTEXT_INVALID_OPS = 5;
-
- /**
- * Syntax bit. Match-any-character operator (.) matches a newline.
- */
- public static final int RE_DOT_NEWLINE = 6;
-
- /**
- * Syntax bit. Match-any-character operator (.) does not match a null.
- */
- public static final int RE_DOT_NOT_NULL = 7;
-
- /**
- * Syntax bit. Intervals ({x}, {x,}, {x,y}) are allowed.
- */
- public static final int RE_INTERVALS = 8;
-
- /**
- * Syntax bit. No alternation (|), match one-or-more (+), or
- * match zero-or-one (?) operators.
- */
- public static final int RE_LIMITED_OPS = 9;
-
- /**
- * Syntax bit. Newline is an alternation operator.
- */
- public static final int RE_NEWLINE_ALT = 10; // impl.
-
- /**
- * Syntax bit. Intervals use { } instead of \{ \}
- */
- public static final int RE_NO_BK_BRACES = 11;
-
- /**
- * Syntax bit. Grouping uses ( ) instead of \( \).
- */
- public static final int RE_NO_BK_PARENS = 12;
-
- /**
- * Syntax bit. Backreferences not allowed.
- */
- public static final int RE_NO_BK_REFS = 13;
-
- /**
- * Syntax bit. Alternation uses | instead of \|
- */
- public static final int RE_NO_BK_VBAR = 14;
-
- /**
- * Syntax bit. <B>Not implemented</B>.
- */
- public static final int RE_NO_EMPTY_RANGES = 15;
-
- /**
- * Syntax bit. An unmatched right parenthesis (')' or '\)', depending
- * on RE_NO_BK_PARENS) will throw an exception when compiling.
- */
- public static final int RE_UNMATCHED_RIGHT_PAREN_ORD = 16;
-
- /**
- * Syntax bit. <B>Not implemented.</B>
- */
- public static final int RE_HAT_LISTS_NOT_NEWLINE = 17;
-
- /**
- * Syntax bit. Stingy matching is allowed (+?, *?, ??, {x,y}?).
- */
- public static final int RE_STINGY_OPS = 18;
-
- /**
- * Syntax bit. Allow character class escapes (\d, \D, \s, \S, \w, \W).
- */
- public static final int RE_CHAR_CLASS_ESCAPES = 19;
-
- /**
- * Syntax bit. Allow use of (?:xxx) grouping (subexpression is not saved).
- */
- public static final int RE_PURE_GROUPING = 20;
-
- /**
- * Syntax bit. Allow use of (?=xxx) and (?!xxx) apply the subexpression
- * to the text following the current position without consuming that text.
- */
- public static final int RE_LOOKAHEAD = 21;
-
- /**
- * Syntax bit. Allow beginning- and end-of-string anchors (\A, \Z).
- */
- public static final int RE_STRING_ANCHORS = 22;
-
- /**
- * Syntax bit. Allow embedded comments, (?#comment), as in Perl5.
- */
- public static final int RE_COMMENTS = 23;
-
- /**
- * Syntax bit. Allow character class escapes within lists, as in Perl5.
- */
- public static final int RE_CHAR_CLASS_ESC_IN_LISTS = 24;
-
- private static final int BIT_TOTAL = 25;
-
- /**
- * Predefined syntax.
- * Emulates regular expression support in the awk utility.
- */
- public static final RESyntax RE_SYNTAX_AWK;
-
- /**
- * Predefined syntax.
- * Emulates regular expression support in the ed utility.
- */
- public static final RESyntax RE_SYNTAX_ED;
-
- /**
- * Predefined syntax.
- * Emulates regular expression support in the egrep utility.
- */
- public static final RESyntax RE_SYNTAX_EGREP;
-
- /**
- * Predefined syntax.
- * Emulates regular expression support in the GNU Emacs editor.
- */
- public static final RESyntax RE_SYNTAX_EMACS;
-
- /**
- * Predefined syntax.
- * Emulates regular expression support in the grep utility.
- */
- public static final RESyntax RE_SYNTAX_GREP;
-
- /**
- * Predefined syntax.
- * Emulates regular expression support in the POSIX awk specification.
- */
- public static final RESyntax RE_SYNTAX_POSIX_AWK;
-
- /**
- * Predefined syntax.
- * Emulates POSIX basic regular expression support.
- */
- public static final RESyntax RE_SYNTAX_POSIX_BASIC;
-
- /**
- * Predefined syntax.
- * Emulates regular expression support in the POSIX egrep specification.
- */
- public static final RESyntax RE_SYNTAX_POSIX_EGREP;
-
- /**
- * Predefined syntax.
- * Emulates POSIX extended regular expression support.
- */
- public static final RESyntax RE_SYNTAX_POSIX_EXTENDED;
-
- /**
- * Predefined syntax.
- * Emulates POSIX basic minimal regular expressions.
- */
- public static final RESyntax RE_SYNTAX_POSIX_MINIMAL_BASIC;
-
- /**
- * Predefined syntax.
- * Emulates POSIX extended minimal regular expressions.
- */
- public static final RESyntax RE_SYNTAX_POSIX_MINIMAL_EXTENDED;
-
- /**
- * Predefined syntax.
- * Emulates regular expression support in the sed utility.
- */
- public static final RESyntax RE_SYNTAX_SED;
-
- /**
- * Predefined syntax.
- * Emulates regular expression support in Larry Wall's perl, version 4,
- */
- public static final RESyntax RE_SYNTAX_PERL4;
-
- /**
- * Predefined syntax.
- * Emulates regular expression support in Larry Wall's perl, version 4,
- * using single line mode (/s modifier).
- */
- public static final RESyntax RE_SYNTAX_PERL4_S; // single line mode (/s)
-
- /**
- * Predefined syntax.
- * Emulates regular expression support in Larry Wall's perl, version 5.
- */
- public static final RESyntax RE_SYNTAX_PERL5;
-
- /**
- * Predefined syntax.
- * Emulates regular expression support in Larry Wall's perl, version 5,
- * using single line mode (/s modifier).
- */
- public static final RESyntax RE_SYNTAX_PERL5_S;
-
- /**
- * Predefined syntax.
- * Emulates regular expression support in Java 1.4's java.util.regex
- * package.
- */
- public static final RESyntax RE_SYNTAX_JAVA_1_4;
-
- static {
- // Define syntaxes
-
- RE_SYNTAX_EMACS = new RESyntax().makeFinal();
-
- RESyntax RE_SYNTAX_POSIX_COMMON = new RESyntax()
- .set(RE_CHAR_CLASSES)
- .set(RE_DOT_NEWLINE)
- .set(RE_DOT_NOT_NULL)
- .set(RE_INTERVALS)
- .set(RE_NO_EMPTY_RANGES)
- .makeFinal();
-
- RE_SYNTAX_POSIX_BASIC = new RESyntax(RE_SYNTAX_POSIX_COMMON)
- .set(RE_BK_PLUS_QM)
- .makeFinal();
-
- RE_SYNTAX_POSIX_EXTENDED = new RESyntax(RE_SYNTAX_POSIX_COMMON)
- .set(RE_CONTEXT_INDEP_ANCHORS)
- .set(RE_CONTEXT_INDEP_OPS)
- .set(RE_NO_BK_BRACES)
- .set(RE_NO_BK_PARENS)
- .set(RE_NO_BK_VBAR)
- .set(RE_UNMATCHED_RIGHT_PAREN_ORD)
- .makeFinal();
-
- RE_SYNTAX_AWK = new RESyntax()
- .set(RE_BACKSLASH_ESCAPE_IN_LISTS)
- .set(RE_DOT_NOT_NULL)
- .set(RE_NO_BK_PARENS)
- .set(RE_NO_BK_REFS)
- .set(RE_NO_BK_VBAR)
- .set(RE_NO_EMPTY_RANGES)
- .set(RE_UNMATCHED_RIGHT_PAREN_ORD)
- .makeFinal();
-
- RE_SYNTAX_POSIX_AWK = new RESyntax(RE_SYNTAX_POSIX_EXTENDED)
- .set(RE_BACKSLASH_ESCAPE_IN_LISTS)
- .makeFinal();
-
- RE_SYNTAX_GREP = new RESyntax()
- .set(RE_BK_PLUS_QM)
- .set(RE_CHAR_CLASSES)
- .set(RE_HAT_LISTS_NOT_NEWLINE)
- .set(RE_INTERVALS)
- .set(RE_NEWLINE_ALT)
- .makeFinal();
-
- RE_SYNTAX_EGREP = new RESyntax()
- .set(RE_CHAR_CLASSES)
- .set(RE_CONTEXT_INDEP_ANCHORS)
- .set(RE_CONTEXT_INDEP_OPS)
- .set(RE_HAT_LISTS_NOT_NEWLINE)
- .set(RE_NEWLINE_ALT)
- .set(RE_NO_BK_PARENS)
- .set(RE_NO_BK_VBAR)
- .makeFinal();
-
- RE_SYNTAX_POSIX_EGREP = new RESyntax(RE_SYNTAX_EGREP)
- .set(RE_INTERVALS)
- .set(RE_NO_BK_BRACES)
- .makeFinal();
-
- /* P1003.2/D11.2, section 4.20.7.1, lines 5078ff. */
-
- RE_SYNTAX_ED = new RESyntax(RE_SYNTAX_POSIX_BASIC)
- .makeFinal();
-
- RE_SYNTAX_SED = new RESyntax(RE_SYNTAX_POSIX_BASIC)
- .makeFinal();
-
- RE_SYNTAX_POSIX_MINIMAL_BASIC = new RESyntax(RE_SYNTAX_POSIX_COMMON)
- .set(RE_LIMITED_OPS)
- .makeFinal();
-
- /* Differs from RE_SYNTAX_POSIX_EXTENDED in that RE_CONTEXT_INVALID_OPS
- replaces RE_CONTEXT_INDEP_OPS and RE_NO_BK_REFS is added. */
-
- RE_SYNTAX_POSIX_MINIMAL_EXTENDED = new RESyntax(RE_SYNTAX_POSIX_COMMON)
- .set(RE_CONTEXT_INDEP_ANCHORS)
- .set(RE_CONTEXT_INVALID_OPS)
- .set(RE_NO_BK_BRACES)
- .set(RE_NO_BK_PARENS)
- .set(RE_NO_BK_REFS)
- .set(RE_NO_BK_VBAR)
- .set(RE_UNMATCHED_RIGHT_PAREN_ORD)
- .makeFinal();
-
- /* There is no official Perl spec, but here's a "best guess" */
-
- RE_SYNTAX_PERL4 = new RESyntax()
- .set(RE_BACKSLASH_ESCAPE_IN_LISTS)
- .set(RE_CONTEXT_INDEP_ANCHORS)
- .set(RE_CONTEXT_INDEP_OPS) // except for '{', apparently
- .set(RE_INTERVALS)
- .set(RE_NO_BK_BRACES)
- .set(RE_NO_BK_PARENS)
- .set(RE_NO_BK_VBAR)
- .set(RE_NO_EMPTY_RANGES)
- .set(RE_CHAR_CLASS_ESCAPES) // \d,\D,\w,\W,\s,\S
- .makeFinal();
-
- RE_SYNTAX_PERL4_S = new RESyntax(RE_SYNTAX_PERL4)
- .set(RE_DOT_NEWLINE)
- .makeFinal();
-
- RE_SYNTAX_PERL5 = new RESyntax(RE_SYNTAX_PERL4)
- .set(RE_PURE_GROUPING) // (?:)
- .set(RE_STINGY_OPS) // *?,??,+?,{}?
- .set(RE_LOOKAHEAD) // (?=)(?!)
- .set(RE_STRING_ANCHORS) // \A,\Z
- .set(RE_CHAR_CLASS_ESC_IN_LISTS)// \d,\D,\w,\W,\s,\S within []
- .set(RE_COMMENTS) // (?#)
- .makeFinal();
-
- RE_SYNTAX_PERL5_S = new RESyntax(RE_SYNTAX_PERL5)
- .set(RE_DOT_NEWLINE)
- .makeFinal();
-
- RE_SYNTAX_JAVA_1_4 = new RESyntax(RE_SYNTAX_PERL5)
- // XXX
- .makeFinal();
- }
-
- /**
- * Construct a new syntax object with all bits turned off.
- * This is equivalent to RE_SYNTAX_EMACS.
- */
- public RESyntax() {
- bits = new BitSet(BIT_TOTAL);
- }
-
- /**
- * Called internally when constructing predefined syntaxes
- * so their interpretation cannot vary. Conceivably useful
- * for your syntaxes as well. Causes IllegalAccessError to
- * be thrown if any attempt to modify the syntax is made.
- *
- * @return this object for convenient chaining
- */
- public RESyntax makeFinal() {
- isFinal = true;
- return this;
- }
-
- /**
- * Construct a new syntax object with all bits set the same
- * as the other syntax.
- */
- public RESyntax(RESyntax other) {
- bits = (BitSet) other.bits.clone();
- }
-
- /**
- * Check if a given bit is set in this syntax.
- */
- public boolean get(int index) {
- return bits.get(index);
- }
-
- /**
- * Set a given bit in this syntax.
- *
- * @param index the constant (RESyntax.RE_xxx) bit to set.
- * @return a reference to this object for easy chaining.
- */
- public RESyntax set(int index) {
- if (isFinal) throw new IllegalAccessError(SYNTAX_IS_FINAL);
- bits.set(index);
- return this;
- }
-
- /**
- * Clear a given bit in this syntax.
- *
- * @param index the constant (RESyntax.RE_xxx) bit to clear.
- * @return a reference to this object for easy chaining.
- */
- public RESyntax clear(int index) {
- if (isFinal) throw new IllegalAccessError(SYNTAX_IS_FINAL);
- bits.clear(index);
- return this;
- }
-
- /**
- * Changes the line separator string for regular expressions
- * created using this RESyntax. The default separator is the
- * value returned by the system property "line.separator", which
- * should be correct when reading platform-specific files from a
- * filesystem. However, many programs may collect input from
- * sources where the line separator is differently specified (for
- * example, in the applet environment, the text box widget
- * interprets line breaks as single-character newlines,
- * regardless of the host platform.
- *
- * Note that setting the line separator to a character or
- * characters that have specific meaning within the current syntax
- * can cause unexpected chronosynclastic infundibula.
- *
- * @return this object for convenient chaining
- */
- public RESyntax setLineSeparator(String aSeparator) {
- if (isFinal) throw new IllegalAccessError(SYNTAX_IS_FINAL);
- lineSeparator = aSeparator;
- return this;
- }
-
- /**
- * Returns the currently active line separator string. The default
- * is the platform-dependent system property "line.separator".
- */
- public String getLineSeparator() {
- return lineSeparator;
- }
-}
diff --git a/libjava/gnu/regexp/REToken.java b/libjava/gnu/regexp/REToken.java
deleted file mode 100644
index aa576a5adde..00000000000
--- a/libjava/gnu/regexp/REToken.java
+++ /dev/null
@@ -1,86 +0,0 @@
-/* gnu/regexp/REToken.java
- Copyright (C) 1998-2001, 2004 Free Software Foundation, Inc.
-
-This file is part of GNU Classpath.
-
-GNU Classpath is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2, or (at your option)
-any later version.
-
-GNU Classpath is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with GNU Classpath; see the file COPYING. If not, write to the
-Free Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA
-02111-1307 USA.
-
-Linking this library statically or dynamically with other modules is
-making a combined work based on this library. Thus, the terms and
-conditions of the GNU General Public License cover the whole
-combination.
-
-As a special exception, the copyright holders of this library give you
-permission to link this library with independent modules to produce an
-executable, regardless of the license terms of these independent
-modules, and to copy and distribute the resulting executable under
-terms of your choice, provided that you also meet, for each linked
-independent module, the terms and conditions of the license of that
-module. An independent module is a module which is not derived from
-or based on this library. If you modify this library, you may extend
-this exception to your version of the library, but you are not
-obligated to do so. If you do not wish to do so, delete this
-exception statement from your version. */
-
-package gnu.regexp;
-import java.io.Serializable;
-
-abstract class REToken implements Serializable {
-
- protected REToken next = null;
- protected REToken uncle = null;
- protected int subIndex;
-
- protected REToken(int subIndex) {
- this.subIndex = subIndex;
- }
-
- int getMinimumLength() {
- return 0;
- }
-
- void setUncle(REToken anUncle) {
- uncle = anUncle;
- }
-
- /** Returns true if the match succeeded, false if it failed. */
- abstract boolean match(CharIndexed input, REMatch mymatch);
-
- /** Returns true if the rest of the tokens match, false if they fail. */
- protected boolean next(CharIndexed input, REMatch mymatch) {
- if (next == null) {
- if (uncle == null) {
- return true;
- } else {
- return uncle.match(input, mymatch);
- }
- } else {
- return next.match(input, mymatch);
- }
- }
-
- boolean chain(REToken token) {
- next = token;
- return true; // Token was accepted
- }
-
- abstract void dump(StringBuffer os);
-
- void dumpAll(StringBuffer os) {
- dump(os);
- if (next != null) next.dumpAll(os);
- }
-}
diff --git a/libjava/gnu/regexp/RETokenAny.java b/libjava/gnu/regexp/RETokenAny.java
deleted file mode 100644
index 42fdd9e284c..00000000000
--- a/libjava/gnu/regexp/RETokenAny.java
+++ /dev/null
@@ -1,73 +0,0 @@
-/* gnu/regexp/RETokenAny.java
- Copyright (C) 1998-2001, 2004 Free Software Foundation, Inc.
-
-This file is part of GNU Classpath.
-
-GNU Classpath is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2, or (at your option)
-any later version.
-
-GNU Classpath is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with GNU Classpath; see the file COPYING. If not, write to the
-Free Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA
-02111-1307 USA.
-
-Linking this library statically or dynamically with other modules is
-making a combined work based on this library. Thus, the terms and
-conditions of the GNU General Public License cover the whole
-combination.
-
-As a special exception, the copyright holders of this library give you
-permission to link this library with independent modules to produce an
-executable, regardless of the license terms of these independent
-modules, and to copy and distribute the resulting executable under
-terms of your choice, provided that you also meet, for each linked
-independent module, the terms and conditions of the license of that
-module. An independent module is a module which is not derived from
-or based on this library. If you modify this library, you may extend
-this exception to your version of the library, but you are not
-obligated to do so. If you do not wish to do so, delete this
-exception statement from your version. */
-
-
-package gnu.regexp;
-
-final class RETokenAny extends REToken {
- /** True if '.' can match a newline (RE_DOT_NEWLINE) */
- private boolean newline;
-
- /** True if '.' can't match a null (RE_DOT_NOT_NULL) */
- private boolean matchNull;
-
- RETokenAny(int subIndex, boolean newline, boolean matchNull) {
- super(subIndex);
- this.newline = newline;
- this.matchNull = matchNull;
- }
-
- int getMinimumLength() {
- return 1;
- }
-
- boolean match(CharIndexed input, REMatch mymatch) {
- char ch = input.charAt(mymatch.index);
- if ((ch == CharIndexed.OUT_OF_BOUNDS)
- || (!newline && (ch == '\n'))
- || (matchNull && (ch == 0))) {
- return false;
- }
- ++mymatch.index;
- return next(input, mymatch);
- }
-
- void dump(StringBuffer os) {
- os.append('.');
- }
-}
-
diff --git a/libjava/gnu/regexp/RETokenBackRef.java b/libjava/gnu/regexp/RETokenBackRef.java
deleted file mode 100644
index a811e16a7b3..00000000000
--- a/libjava/gnu/regexp/RETokenBackRef.java
+++ /dev/null
@@ -1,72 +0,0 @@
-/* gnu/regexp/RETokenBackRef.java
- Copyright (C) 1998-2001, 2004 Free Software Foundation, Inc.
-
-This file is part of GNU Classpath.
-
-GNU Classpath is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2, or (at your option)
-any later version.
-
-GNU Classpath is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with GNU Classpath; see the file COPYING. If not, write to the
-Free Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA
-02111-1307 USA.
-
-Linking this library statically or dynamically with other modules is
-making a combined work based on this library. Thus, the terms and
-conditions of the GNU General Public License cover the whole
-combination.
-
-As a special exception, the copyright holders of this library give you
-permission to link this library with independent modules to produce an
-executable, regardless of the license terms of these independent
-modules, and to copy and distribute the resulting executable under
-terms of your choice, provided that you also meet, for each linked
-independent module, the terms and conditions of the license of that
-module. An independent module is a module which is not derived from
-or based on this library. If you modify this library, you may extend
-this exception to your version of the library, but you are not
-obligated to do so. If you do not wish to do so, delete this
-exception statement from your version. */
-
-
-package gnu.regexp;
-
-final class RETokenBackRef extends REToken {
- private int num;
- private boolean insens;
-
- RETokenBackRef(int subIndex, int num, boolean insens) {
- super(subIndex);
- this.num = num;
- this.insens = insens;
- }
-
- // should implement getMinimumLength() -- any ideas?
-
- boolean match(CharIndexed input, REMatch mymatch) {
- int b,e;
- b = mymatch.start[num];
- e = mymatch.end[num];
- if ((b==-1)||(e==-1)) return false; // this shouldn't happen, but...
- for (int i=b; i<e; i++) {
- if (input.charAt(mymatch.index+i-b) != input.charAt(i)) {
- return false;
- }
- }
- mymatch.index += e-b;
- return next(input, mymatch);
- }
-
- void dump(StringBuffer os) {
- os.append('\\').append(num);
- }
-}
-
-
diff --git a/libjava/gnu/regexp/RETokenChar.java b/libjava/gnu/regexp/RETokenChar.java
deleted file mode 100644
index 17712e34787..00000000000
--- a/libjava/gnu/regexp/RETokenChar.java
+++ /dev/null
@@ -1,91 +0,0 @@
-/* gnu/regexp/RETokenChar.java
- Copyright (C) 1998-2001, 2004 Free Software Foundation, Inc.
-
-This file is part of GNU Classpath.
-
-GNU Classpath is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2, or (at your option)
-any later version.
-
-GNU Classpath is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with GNU Classpath; see the file COPYING. If not, write to the
-Free Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA
-02111-1307 USA.
-
-Linking this library statically or dynamically with other modules is
-making a combined work based on this library. Thus, the terms and
-conditions of the GNU General Public License cover the whole
-combination.
-
-As a special exception, the copyright holders of this library give you
-permission to link this library with independent modules to produce an
-executable, regardless of the license terms of these independent
-modules, and to copy and distribute the resulting executable under
-terms of your choice, provided that you also meet, for each linked
-independent module, the terms and conditions of the license of that
-module. An independent module is a module which is not derived from
-or based on this library. If you modify this library, you may extend
-this exception to your version of the library, but you are not
-obligated to do so. If you do not wish to do so, delete this
-exception statement from your version. */
-
-
-package gnu.regexp;
-
-final class RETokenChar extends REToken {
- private char[] ch;
- private boolean insens;
-
- RETokenChar(int subIndex, char c, boolean ins) {
- super(subIndex);
- ch = new char [1];
- ch[0] = (insens = ins) ? Character.toLowerCase(c) : c;
- }
-
- int getMinimumLength() {
- return ch.length;
- }
-
- boolean match(CharIndexed input, REMatch mymatch) {
- int z = ch.length;
- char c;
- for (int i=0; i<z; i++) {
- c = input.charAt(mymatch.index+i);
- if (( (insens) ? Character.toLowerCase(c) : c ) != ch[i]) {
- return false;
- }
- }
- mymatch.index += z;
-
- return next(input, mymatch);
- }
-
- // Overrides REToken.chain() to optimize for strings
- boolean chain(REToken next) {
- if (next instanceof RETokenChar) {
- RETokenChar cnext = (RETokenChar) next;
- // assume for now that next can only be one character
- int newsize = ch.length + cnext.ch.length;
-
- char[] chTemp = new char [newsize];
-
- System.arraycopy(ch,0,chTemp,0,ch.length);
- System.arraycopy(cnext.ch,0,chTemp,ch.length,cnext.ch.length);
-
- ch = chTemp;
- return false;
- } else return super.chain(next);
- }
-
- void dump(StringBuffer os) {
- os.append(ch);
- }
-}
-
-
diff --git a/libjava/gnu/regexp/RETokenEnd.java b/libjava/gnu/regexp/RETokenEnd.java
deleted file mode 100644
index 08e57084da1..00000000000
--- a/libjava/gnu/regexp/RETokenEnd.java
+++ /dev/null
@@ -1,75 +0,0 @@
-/* gnu/regexp/RETokenEnd.java
- Copyright (C) 1998-2001, 2004 Free Software Foundation, Inc.
-
-This file is part of GNU Classpath.
-
-GNU Classpath is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2, or (at your option)
-any later version.
-
-GNU Classpath is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with GNU Classpath; see the file COPYING. If not, write to the
-Free Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA
-02111-1307 USA.
-
-Linking this library statically or dynamically with other modules is
-making a combined work based on this library. Thus, the terms and
-conditions of the GNU General Public License cover the whole
-combination.
-
-As a special exception, the copyright holders of this library give you
-permission to link this library with independent modules to produce an
-executable, regardless of the license terms of these independent
-modules, and to copy and distribute the resulting executable under
-terms of your choice, provided that you also meet, for each linked
-independent module, the terms and conditions of the license of that
-module. An independent module is a module which is not derived from
-or based on this library. If you modify this library, you may extend
-this exception to your version of the library, but you are not
-obligated to do so. If you do not wish to do so, delete this
-exception statement from your version. */
-
-
-package gnu.regexp;
-
-final class RETokenEnd extends REToken {
- /**
- * Indicates whether this token should match on a line break.
- */
- private String newline;
-
- RETokenEnd(int subIndex,String newline) {
- super(subIndex);
- this.newline = newline;
- }
-
- boolean match(CharIndexed input, REMatch mymatch) {
- char ch = input.charAt(mymatch.index);
- if (ch == CharIndexed.OUT_OF_BOUNDS)
- return ((mymatch.eflags & RE.REG_NOTEOL)>0) ?
- false : next(input, mymatch);
- if (newline != null) {
- char z;
- int i = 0; // position in newline
- do {
- z = newline.charAt(i);
- if (ch != z) return false;
- ++i;
- ch = input.charAt(mymatch.index + i);
- } while (i < newline.length());
-
- return next(input, mymatch);
- }
- return false;
- }
-
- void dump(StringBuffer os) {
- os.append('$');
- }
-}
diff --git a/libjava/gnu/regexp/RETokenEndSub.java b/libjava/gnu/regexp/RETokenEndSub.java
deleted file mode 100644
index 913d3f85c05..00000000000
--- a/libjava/gnu/regexp/RETokenEndSub.java
+++ /dev/null
@@ -1,53 +0,0 @@
-/* gnu/regexp/RETokenEndSub.java
- Copyright (C) 2001, 2004 Free Software Foundation, Inc.
-
-This file is part of GNU Classpath.
-
-GNU Classpath is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2, or (at your option)
-any later version.
-
-GNU Classpath is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with GNU Classpath; see the file COPYING. If not, write to the
-Free Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA
-02111-1307 USA.
-
-Linking this library statically or dynamically with other modules is
-making a combined work based on this library. Thus, the terms and
-conditions of the GNU General Public License cover the whole
-combination.
-
-As a special exception, the copyright holders of this library give you
-permission to link this library with independent modules to produce an
-executable, regardless of the license terms of these independent
-modules, and to copy and distribute the resulting executable under
-terms of your choice, provided that you also meet, for each linked
-independent module, the terms and conditions of the license of that
-module. An independent module is a module which is not derived from
-or based on this library. If you modify this library, you may extend
-this exception to your version of the library, but you are not
-obligated to do so. If you do not wish to do so, delete this
-exception statement from your version. */
-
-package gnu.regexp;
-
-final class RETokenEndSub extends REToken {
- RETokenEndSub(int subIndex) {
- super(subIndex);
- }
-
- boolean match(CharIndexed input, REMatch mymatch) {
- mymatch.end[subIndex] = mymatch.index;
- return next(input, mymatch);
- }
-
- void dump(StringBuffer os) {
- // handled by RE
- }
-}
diff --git a/libjava/gnu/regexp/RETokenLookAhead.java b/libjava/gnu/regexp/RETokenLookAhead.java
deleted file mode 100644
index 74a9bfe2465..00000000000
--- a/libjava/gnu/regexp/RETokenLookAhead.java
+++ /dev/null
@@ -1,68 +0,0 @@
-/*
- * gnu/regexp/RETokenOneOf.java
- * Copyright (C) 1998-2001 Wes Biggs
- *
- * This library is free software; you can redistribute it and/or modify
- * it under the terms of the GNU Lesser General Public License as published
- * by the Free Software Foundation; either version 2.1 of the License, or
- * (at your option) any later version.
- *
- * This library is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU Lesser General Public License for more details.
- *
- * You should have received a copy of the GNU Lesser General Public License
- * along with this program; if not, write to the Free Software
- * Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
- */
-package gnu.regexp;
-
-/**
- * @since gnu.regexp 1.1.3
- * @author Shashank Bapat
- */
-final class RETokenLookAhead extends REToken
-{
- REToken re;
- boolean negative;
-
- RETokenLookAhead(REToken re, boolean negative) throws REException {
- super(0);
- this.re = re;
- this.negative = negative;
- }
-
- boolean match(CharIndexed input, REMatch mymatch)
- {
- REMatch trymatch = (REMatch)mymatch.clone();
- REMatch trymatch1 = (REMatch)mymatch.clone();
- REMatch newMatch = null;
- if (re.match(input, trymatch)) {
- if (negative) return false;
- if (next(input, trymatch1))
- newMatch = trymatch1;
- }
-
- if (newMatch != null) {
- if (negative) return false;
- //else
- mymatch.assignFrom(newMatch);
- return true;
- }
- else { // no match
- if (negative)
- return next(input, mymatch);
- //else
- return false;
- }
- }
-
- void dump(StringBuffer os) {
- os.append("(?");
- os.append(negative ? '!' : '=');
- re.dumpAll(os);
- os.append(')');
- }
-}
-
diff --git a/libjava/gnu/regexp/RETokenOneOf.java b/libjava/gnu/regexp/RETokenOneOf.java
deleted file mode 100644
index 7752b25771c..00000000000
--- a/libjava/gnu/regexp/RETokenOneOf.java
+++ /dev/null
@@ -1,130 +0,0 @@
-/* gnu/regexp/RETokenOneOf.java
- Copyright (C) 1998-2001, 2004 Free Software Foundation, Inc.
-
-This file is part of GNU Classpath.
-
-GNU Classpath is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2, or (at your option)
-any later version.
-
-GNU Classpath is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with GNU Classpath; see the file COPYING. If not, write to the
-Free Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA
-02111-1307 USA.
-
-Linking this library statically or dynamically with other modules is
-making a combined work based on this library. Thus, the terms and
-conditions of the GNU General Public License cover the whole
-combination.
-
-As a special exception, the copyright holders of this library give you
-permission to link this library with independent modules to produce an
-executable, regardless of the license terms of these independent
-modules, and to copy and distribute the resulting executable under
-terms of your choice, provided that you also meet, for each linked
-independent module, the terms and conditions of the license of that
-module. An independent module is a module which is not derived from
-or based on this library. If you modify this library, you may extend
-this exception to your version of the library, but you are not
-obligated to do so. If you do not wish to do so, delete this
-exception statement from your version. */
-
-package gnu.regexp;
-import java.util.Vector;
-
-final class RETokenOneOf extends REToken {
- private Vector options;
- private boolean negative;
-
- // This constructor is used for convenience when we know the set beforehand,
- // e.g. \d --> new RETokenOneOf("0123456789",false, ..)
- // \D --> new RETokenOneOf("0123456789",true, ..)
-
- RETokenOneOf(int subIndex, String optionsStr, boolean negative, boolean insens) {
- super(subIndex);
- options = new Vector();
- this.negative = negative;
- for (int i = 0; i < optionsStr.length(); i++)
- options.addElement(new RETokenChar(subIndex,optionsStr.charAt(i),insens));
- }
-
- RETokenOneOf(int subIndex, Vector options, boolean negative) {
- super(subIndex);
- this.options = options;
- this.negative = negative;
- }
-
- int getMinimumLength() {
- int min = Integer.MAX_VALUE;
- int x;
- for (int i=0; i < options.size(); i++) {
- if ((x = ((REToken) options.elementAt(i)).getMinimumLength()) < min)
- min = x;
- }
- return min;
- }
-
- boolean match(CharIndexed input, REMatch mymatch) {
- if (negative && (input.charAt(mymatch.index) == CharIndexed.OUT_OF_BOUNDS))
- return false;
-
- REMatch newMatch = null;
- REMatch last = null;
- REToken tk;
- boolean isMatch;
- for (int i=0; i < options.size(); i++) {
- tk = (REToken) options.elementAt(i);
- REMatch tryMatch = (REMatch) mymatch.clone();
- if (tk.match(input, tryMatch)) { // match was successful
- if (negative) return false;
-
- if (next(input, tryMatch)) {
- // Add tryMatch to list of possibilities.
- if (last == null) {
- newMatch = tryMatch;
- last = tryMatch;
- } else {
- last.next = tryMatch;
- last = tryMatch;
- }
- } // next succeeds
- } // is a match
- } // try next option
-
- if (newMatch != null) {
- if (negative) {
- return false;
- } else {
- // set contents of mymatch equal to newMatch
-
- // try each one that matched
- mymatch.assignFrom(newMatch);
- return true;
- }
- } else {
- if (negative) {
- ++mymatch.index;
- return next(input, mymatch);
- } else {
- return false;
- }
- }
-
- // index+1 works for [^abc] lists, not for generic lookahead (--> index)
- }
-
- void dump(StringBuffer os) {
- os.append(negative ? "[^" : "(?:");
- for (int i = 0; i < options.size(); i++) {
- if (!negative && (i > 0)) os.append('|');
- ((REToken) options.elementAt(i)).dumpAll(os);
- }
- os.append(negative ? ']' : ')');
- }
-}
diff --git a/libjava/gnu/regexp/RETokenPOSIX.java b/libjava/gnu/regexp/RETokenPOSIX.java
deleted file mode 100644
index 00fcf301ad9..00000000000
--- a/libjava/gnu/regexp/RETokenPOSIX.java
+++ /dev/null
@@ -1,144 +0,0 @@
-/* gnu/regexp/RETokenPOSIX.java
- Copyright (C) 1998-2001, 2004 Free Software Foundation, Inc.
-
-This file is part of GNU Classpath.
-
-GNU Classpath is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2, or (at your option)
-any later version.
-
-GNU Classpath is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with GNU Classpath; see the file COPYING. If not, write to the
-Free Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA
-02111-1307 USA.
-
-Linking this library statically or dynamically with other modules is
-making a combined work based on this library. Thus, the terms and
-conditions of the GNU General Public License cover the whole
-combination.
-
-As a special exception, the copyright holders of this library give you
-permission to link this library with independent modules to produce an
-executable, regardless of the license terms of these independent
-modules, and to copy and distribute the resulting executable under
-terms of your choice, provided that you also meet, for each linked
-independent module, the terms and conditions of the license of that
-module. An independent module is a module which is not derived from
-or based on this library. If you modify this library, you may extend
-this exception to your version of the library, but you are not
-obligated to do so. If you do not wish to do so, delete this
-exception statement from your version. */
-
-
-package gnu.regexp;
-
-final class RETokenPOSIX extends REToken {
- int type;
- boolean insens;
- boolean negated;
-
- static final int ALNUM = 0;
- static final int ALPHA = 1;
- static final int BLANK = 2;
- static final int CNTRL = 3;
- static final int DIGIT = 4;
- static final int GRAPH = 5;
- static final int LOWER = 6;
- static final int PRINT = 7;
- static final int PUNCT = 8;
- static final int SPACE = 9;
- static final int UPPER = 10;
- static final int XDIGIT = 11;
-
- // Array indices correspond to constants defined above.
- static final String[] s_nameTable = {
- "alnum", "alpha", "blank", "cntrl", "digit", "graph", "lower",
- "print", "punct", "space", "upper", "xdigit"
- };
-
- // The RE constructor uses this to look up the constant for a string
- static int intValue(String key) {
- for (int i = 0; i < s_nameTable.length; i++) {
- if (s_nameTable[i].equals(key)) return i;
- }
- return -1;
- }
-
- RETokenPOSIX(int subIndex, int type, boolean insens, boolean negated) {
- super(subIndex);
- this.type = type;
- this.insens = insens;
- this.negated = negated;
- }
-
- int getMinimumLength() {
- return 1;
- }
-
- boolean match(CharIndexed input, REMatch mymatch) {
- char ch = input.charAt(mymatch.index);
- if (ch == CharIndexed.OUT_OF_BOUNDS)
- return false;
-
- boolean retval = false;
- switch (type) {
- case ALNUM:
- // Note that there is some debate over whether '_' should be included
- retval = Character.isLetterOrDigit(ch) || (ch == '_');
- break;
- case ALPHA:
- retval = Character.isLetter(ch);
- break;
- case BLANK:
- retval = ((ch == ' ') || (ch == '\t'));
- break;
- case CNTRL:
- retval = Character.isISOControl(ch);
- break;
- case DIGIT:
- retval = Character.isDigit(ch);
- break;
- case GRAPH:
- retval = (!(Character.isWhitespace(ch) || Character.isISOControl(ch)));
- break;
- case LOWER:
- retval = ((insens && Character.isLetter(ch)) || Character.isLowerCase(ch));
- break;
- case PRINT:
- retval = (!(Character.isWhitespace(ch) || Character.isISOControl(ch)))
- || (ch == ' ');
- break;
- case PUNCT:
- // This feels sloppy, especially for non-U.S. locales.
- retval = ("`~!@#$%^&*()-_=+[]{}\\|;:'\"/?,.<>".indexOf(ch)!=-1);
- break;
- case SPACE:
- retval = Character.isWhitespace(ch);
- break;
- case UPPER:
- retval = ((insens && Character.isLetter(ch)) || Character.isUpperCase(ch));
- break;
- case XDIGIT:
- retval = (Character.isDigit(ch) || ("abcdefABCDEF".indexOf(ch)!=-1));
- break;
- }
-
- if (negated) retval = !retval;
- if (retval) {
- ++mymatch.index;
- return next(input, mymatch);
- }
- else return false;
- }
-
- void dump(StringBuffer os) {
- if (negated) os.append('^');
- os.append("[:" + s_nameTable[type] + ":]");
- }
-}
diff --git a/libjava/gnu/regexp/RETokenRange.java b/libjava/gnu/regexp/RETokenRange.java
deleted file mode 100644
index 9ce3be926b9..00000000000
--- a/libjava/gnu/regexp/RETokenRange.java
+++ /dev/null
@@ -1,69 +0,0 @@
-/* gnu/regexp/RETokenRange.java
- Copyright (C) 1998-2001, 2004 Free Software Foundation, Inc.
-
-This file is part of GNU Classpath.
-
-GNU Classpath is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2, or (at your option)
-any later version.
-
-GNU Classpath is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with GNU Classpath; see the file COPYING. If not, write to the
-Free Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA
-02111-1307 USA.
-
-Linking this library statically or dynamically with other modules is
-making a combined work based on this library. Thus, the terms and
-conditions of the GNU General Public License cover the whole
-combination.
-
-As a special exception, the copyright holders of this library give you
-permission to link this library with independent modules to produce an
-executable, regardless of the license terms of these independent
-modules, and to copy and distribute the resulting executable under
-terms of your choice, provided that you also meet, for each linked
-independent module, the terms and conditions of the license of that
-module. An independent module is a module which is not derived from
-or based on this library. If you modify this library, you may extend
-this exception to your version of the library, but you are not
-obligated to do so. If you do not wish to do so, delete this
-exception statement from your version. */
-
-package gnu.regexp;
-
-final class RETokenRange extends REToken {
- private char lo, hi;
- private boolean insens;
-
- RETokenRange(int subIndex, char lo, char hi, boolean ins) {
- super(subIndex);
- this.lo = (insens = ins) ? Character.toLowerCase(lo) : lo;
- this.hi = ins ? Character.toLowerCase(hi) : hi;
- }
-
- int getMinimumLength() {
- return 1;
- }
-
- boolean match(CharIndexed input, REMatch mymatch) {
- char c = input.charAt(mymatch.index);
- if (c == CharIndexed.OUT_OF_BOUNDS) return false;
- if (insens) c = Character.toLowerCase(c);
- if ((c >= lo) && (c <= hi)) {
- ++mymatch.index;
- return next(input, mymatch);
- }
- return false;
- }
-
- void dump(StringBuffer os) {
- os.append(lo).append('-').append(hi);
- }
-}
-
diff --git a/libjava/gnu/regexp/RETokenRepeated.java b/libjava/gnu/regexp/RETokenRepeated.java
deleted file mode 100644
index 8c789271220..00000000000
--- a/libjava/gnu/regexp/RETokenRepeated.java
+++ /dev/null
@@ -1,227 +0,0 @@
-/* gnu/regexp/RETokenRepeated.java
- Copyright (C) 1998-2001, 2004 Free Software Foundation, Inc.
-
-This file is part of GNU Classpath.
-
-GNU Classpath is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2, or (at your option)
-any later version.
-
-GNU Classpath is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with GNU Classpath; see the file COPYING. If not, write to the
-Free Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA
-02111-1307 USA.
-
-Linking this library statically or dynamically with other modules is
-making a combined work based on this library. Thus, the terms and
-conditions of the GNU General Public License cover the whole
-combination.
-
-As a special exception, the copyright holders of this library give you
-permission to link this library with independent modules to produce an
-executable, regardless of the license terms of these independent
-modules, and to copy and distribute the resulting executable under
-terms of your choice, provided that you also meet, for each linked
-independent module, the terms and conditions of the license of that
-module. An independent module is a module which is not derived from
-or based on this library. If you modify this library, you may extend
-this exception to your version of the library, but you are not
-obligated to do so. If you do not wish to do so, delete this
-exception statement from your version. */
-
-
-package gnu.regexp;
-
-import java.util.Vector;
-
-final class RETokenRepeated extends REToken {
- private REToken token;
- private int min,max;
- private boolean stingy;
-
- RETokenRepeated(int subIndex, REToken token, int min, int max) {
- super(subIndex);
- this.token = token;
- this.min = min;
- this.max = max;
- }
-
- /** Sets the minimal matching mode to true. */
- void makeStingy() {
- stingy = true;
- }
-
- /** Queries if this token has minimal matching enabled. */
- boolean isStingy() {
- return stingy;
- }
-
- /**
- * The minimum length of a repeated token is the minimum length
- * of the token multiplied by the minimum number of times it must
- * match.
- */
- int getMinimumLength() {
- return (min * token.getMinimumLength());
- }
-
- // We do need to save every possible point, but the number of clone()
- // invocations here is really a killer for performance on non-stingy
- // repeat operators. I'm open to suggestions...
-
- // Hypothetical question: can you have a RE that matches 1 times,
- // 3 times, 5 times, but not 2 times or 4 times? Does having
- // the subexpression back-reference operator allow that?
-
- boolean match(CharIndexed input, REMatch mymatch) {
- // number of times we've matched so far
- int numRepeats = 0;
-
- // Possible positions for the next repeat to match at
- REMatch newMatch = mymatch;
- REMatch last = null;
- REMatch current;
-
- // Add the '0-repeats' index
- // positions.elementAt(z) == position [] in input after <<z>> matches
- Vector positions = new Vector();
- positions.addElement(newMatch);
-
- // Declare variables used in loop
- REMatch doables;
- REMatch doablesLast;
- REMatch recurrent;
-
- do {
- // Check for stingy match for each possibility.
- if (stingy && (numRepeats >= min)) {
- REMatch result = matchRest(input, newMatch);
- if (result != null) {
- mymatch.assignFrom(result);
- return true;
- }
- }
-
- doables = null;
- doablesLast = null;
-
- // try next repeat at all possible positions
- for (current = newMatch; current != null; current = current.next) {
- recurrent = (REMatch) current.clone();
- if (token.match(input, recurrent)) {
- // add all items in current to doables array
- if (doables == null) {
- doables = recurrent;
- doablesLast = recurrent;
- } else {
- // Order these from longest to shortest
- // Start by assuming longest (more repeats)
- doablesLast.next = recurrent;
- }
- // Find new doablesLast
- while (doablesLast.next != null) {
- doablesLast = doablesLast.next;
- }
- }
- }
- // if none of the possibilities worked out, break out of do/while
- if (doables == null) break;
-
- // reassign where the next repeat can match
- newMatch = doables;
-
- // increment how many repeats we've successfully found
- ++numRepeats;
-
- positions.addElement(newMatch);
- } while (numRepeats < max);
-
- // If there aren't enough repeats, then fail
- if (numRepeats < min) return false;
-
- // We're greedy, but ease off until a true match is found
- int posIndex = positions.size();
-
- // At this point we've either got too many or just the right amount.
- // See if this numRepeats works with the rest of the regexp.
- REMatch allResults = null;
- REMatch allResultsLast = null;
-
- REMatch results = null;
- while (--posIndex >= min) {
- newMatch = (REMatch) positions.elementAt(posIndex);
- results = matchRest(input, newMatch);
- if (results != null) {
- if (allResults == null) {
- allResults = results;
- allResultsLast = results;
- } else {
- // Order these from longest to shortest
- // Start by assuming longest (more repeats)
- allResultsLast.next = results;
- }
- // Find new doablesLast
- while (allResultsLast.next != null) {
- allResultsLast = allResultsLast.next;
- }
- }
- // else did not match rest of the tokens, try again on smaller sample
- }
- if (allResults != null) {
- mymatch.assignFrom(allResults); // does this get all?
- return true;
- }
- // If we fall out, no matches.
- return false;
- }
-
- private REMatch matchRest(CharIndexed input, final REMatch newMatch) {
- REMatch current, single;
- REMatch doneIndex = null;
- REMatch doneIndexLast = null;
- // Test all possible matches for this number of repeats
- for (current = newMatch; current != null; current = current.next) {
- // clone() separates a single match from the chain
- single = (REMatch) current.clone();
- if (next(input, single)) {
- // chain results to doneIndex
- if (doneIndex == null) {
- doneIndex = single;
- doneIndexLast = single;
- } else {
- doneIndexLast.next = single;
- }
- // Find new doneIndexLast
- while (doneIndexLast.next != null) {
- doneIndexLast = doneIndexLast.next;
- }
- }
- }
- return doneIndex;
- }
-
- void dump(StringBuffer os) {
- os.append("(?:");
- token.dumpAll(os);
- os.append(')');
- if ((max == Integer.MAX_VALUE) && (min <= 1))
- os.append( (min == 0) ? '*' : '+' );
- else if ((min == 0) && (max == 1))
- os.append('?');
- else {
- os.append('{').append(min);
- if (max > min) {
- os.append(',');
- if (max != Integer.MAX_VALUE) os.append(max);
- }
- os.append('}');
- }
- if (stingy) os.append('?');
- }
-}
diff --git a/libjava/gnu/regexp/RETokenStart.java b/libjava/gnu/regexp/RETokenStart.java
deleted file mode 100644
index 8adb8c89ce2..00000000000
--- a/libjava/gnu/regexp/RETokenStart.java
+++ /dev/null
@@ -1,87 +0,0 @@
-/* gnu/regexp/RETokenStart.java
- Copyright (C) 1998-2001, 2004 Free Software Foundation, Inc.
-
-This file is part of GNU Classpath.
-
-GNU Classpath is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2, or (at your option)
-any later version.
-
-GNU Classpath is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with GNU Classpath; see the file COPYING. If not, write to the
-Free Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA
-02111-1307 USA.
-
-Linking this library statically or dynamically with other modules is
-making a combined work based on this library. Thus, the terms and
-conditions of the GNU General Public License cover the whole
-combination.
-
-As a special exception, the copyright holders of this library give you
-permission to link this library with independent modules to produce an
-executable, regardless of the license terms of these independent
-modules, and to copy and distribute the resulting executable under
-terms of your choice, provided that you also meet, for each linked
-independent module, the terms and conditions of the license of that
-module. An independent module is a module which is not derived from
-or based on this library. If you modify this library, you may extend
-this exception to your version of the library, but you are not
-obligated to do so. If you do not wish to do so, delete this
-exception statement from your version. */
-
-package gnu.regexp;
-
-class RETokenStart extends REToken {
- private String newline; // matches after a newline
-
- RETokenStart(int subIndex, String newline) {
- super(subIndex);
- this.newline = newline;
- }
-
- boolean match(CharIndexed input, REMatch mymatch) {
- // charAt(index-n) may be unknown on a Reader/InputStream. FIXME
- // Match after a newline if in multiline mode
-
- if (newline != null) {
- int len = newline.length();
- if (mymatch.offset >= len) {
- boolean found = true;
- char z;
- int i = 0; // position in REToken.newline
- char ch = input.charAt(mymatch.index - len);
- do {
- z = newline.charAt(i);
- if (ch != z) {
- found = false;
- break;
- }
- ++i;
- ch = input.charAt(mymatch.index - len + i);
- } while (i < len);
-
- if (found) return next(input, mymatch);
- }
- }
-
- // Don't match at all if REG_NOTBOL is set.
- if ((mymatch.eflags & RE.REG_NOTBOL) > 0) return false;
-
- if ((mymatch.eflags & RE.REG_ANCHORINDEX) > 0)
- return (mymatch.anchor == mymatch.offset) ?
- next(input, mymatch) : false;
- else
- return ((mymatch.index == 0) && (mymatch.offset == 0)) ?
- next(input, mymatch) : false;
- }
-
- void dump(StringBuffer os) {
- os.append('^');
- }
-}
diff --git a/libjava/gnu/regexp/RETokenWordBoundary.java b/libjava/gnu/regexp/RETokenWordBoundary.java
deleted file mode 100644
index 38baaec13d5..00000000000
--- a/libjava/gnu/regexp/RETokenWordBoundary.java
+++ /dev/null
@@ -1,104 +0,0 @@
-/* gnu/regexp/RETokenWordBoundary.java
- Copyright (C) 2001, 2004 Free Software Foundation, Inc.
-
-This file is part of GNU Classpath.
-
-GNU Classpath is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2, or (at your option)
-any later version.
-
-GNU Classpath is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with GNU Classpath; see the file COPYING. If not, write to the
-Free Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA
-02111-1307 USA.
-
-Linking this library statically or dynamically with other modules is
-making a combined work based on this library. Thus, the terms and
-conditions of the GNU General Public License cover the whole
-combination.
-
-As a special exception, the copyright holders of this library give you
-permission to link this library with independent modules to produce an
-executable, regardless of the license terms of these independent
-modules, and to copy and distribute the resulting executable under
-terms of your choice, provided that you also meet, for each linked
-independent module, the terms and conditions of the license of that
-module. An independent module is a module which is not derived from
-or based on this library. If you modify this library, you may extend
-this exception to your version of the library, but you are not
-obligated to do so. If you do not wish to do so, delete this
-exception statement from your version. */
-
-
-package gnu.regexp;
-
-/**
- * Represents a combination lookahead/lookbehind for POSIX [:alnum:].
- */
-final class RETokenWordBoundary extends REToken {
- private boolean negated;
- private int where;
- static final int BEGIN = 1;
- static final int END = 2;
-
- RETokenWordBoundary(int subIndex, int where, boolean negated) {
- super(subIndex);
- this.where = where;
- this.negated = negated;
- }
-
- boolean match(CharIndexed input, REMatch mymatch) {
- // Word boundary means input[index-1] was a word character
- // and input[index] is not, or input[index] is a word character
- // and input[index-1] was not
- // In the string "one two three", these positions match:
- // |o|n|e| |t|w|o| |t|h|r|e|e|
- // ^ ^ ^ ^ ^ ^
- boolean after = false; // is current character a letter or digit?
- boolean before = false; // is previous character a letter or digit?
- char ch;
-
- // TODO: Also check REG_ANCHORINDEX vs. anchor
- if (((mymatch.eflags & RE.REG_ANCHORINDEX) != RE.REG_ANCHORINDEX)
- || (mymatch.offset + mymatch.index > mymatch.anchor)) {
- if ((ch = input.charAt(mymatch.index - 1)) != CharIndexed.OUT_OF_BOUNDS) {
- before = Character.isLetterOrDigit(ch) || (ch == '_');
- }
- }
-
- if ((ch = input.charAt(mymatch.index)) != CharIndexed.OUT_OF_BOUNDS) {
- after = Character.isLetterOrDigit(ch) || (ch == '_');
- }
-
- // if (before) and (!after), we're at end (\>)
- // if (after) and (!before), we're at beginning (\<)
- boolean doNext = false;
-
- if ((where & BEGIN) == BEGIN) {
- doNext = after && !before;
- }
- if ((where & END) == END) {
- doNext ^= before && !after;
- }
-
- if (negated) doNext = !doNext;
-
- return (doNext ? next(input, mymatch) : false);
- }
-
- void dump(StringBuffer os) {
- if (where == (BEGIN | END)) {
- os.append( negated ? "\\B" : "\\b" );
- } else if (where == BEGIN) {
- os.append("\\<");
- } else {
- os.append("\\>");
- }
- }
-}
diff --git a/libjava/gnu/regexp/UncheckedRE.java b/libjava/gnu/regexp/UncheckedRE.java
deleted file mode 100644
index 660466eabbb..00000000000
--- a/libjava/gnu/regexp/UncheckedRE.java
+++ /dev/null
@@ -1,109 +0,0 @@
-/* gnu/regexp/UncheckedRE.java
- Copyright (C) 2001, 2004 Free Software Foundation, Inc.
-
-This file is part of GNU Classpath.
-
-GNU Classpath is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2, or (at your option)
-any later version.
-
-GNU Classpath is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with GNU Classpath; see the file COPYING. If not, write to the
-Free Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA
-02111-1307 USA.
-
-Linking this library statically or dynamically with other modules is
-making a combined work based on this library. Thus, the terms and
-conditions of the GNU General Public License cover the whole
-combination.
-
-As a special exception, the copyright holders of this library give you
-permission to link this library with independent modules to produce an
-executable, regardless of the license terms of these independent
-modules, and to copy and distribute the resulting executable under
-terms of your choice, provided that you also meet, for each linked
-independent module, the terms and conditions of the license of that
-module. An independent module is a module which is not derived from
-or based on this library. If you modify this library, you may extend
-this exception to your version of the library, but you are not
-obligated to do so. If you do not wish to do so, delete this
-exception statement from your version. */
-
-package gnu.regexp;
-
-/**
- * UncheckedRE is a subclass of RE that allows programmers an easier means
- * of programmatically precompiling regular expressions. It is constructed
- * and used in exactly the same manner as an instance of the RE class; the
- * only difference is that its constructors do not throw REException.
- * Instead, if a syntax error is encountered during construction, a
- * RuntimeException will be thrown.
- * <P>
- * Note that this makes UncheckedRE dangerous if constructed with
- * dynamic data. Do not use UncheckedRE unless you are completely sure
- * that all input being passed to it contains valid, well-formed
- * regular expressions for the syntax specified.
- *
- * @author <A HREF="mailto:wes@cacas.org">Wes Biggs</A>
- * @see gnu.regexp.RE
- * @since gnu.regexp 1.1.4
- */
-
-public final class UncheckedRE extends RE {
- /**
- * Constructs a regular expression pattern buffer without any compilation
- * flags set, and using the default syntax (RESyntax.RE_SYNTAX_PERL5).
- *
- * @param pattern A regular expression pattern, in the form of a String,
- * StringBuffer or char[]. Other input types will be converted to
- * strings using the toString() method.
- * @exception RuntimeException The input pattern could not be parsed.
- * @exception NullPointerException The pattern was null.
- */
- public UncheckedRE(Object pattern) {
- this(pattern,0,RESyntax.RE_SYNTAX_PERL5);
- }
-
- /**
- * Constructs a regular expression pattern buffer using the specified
- * compilation flags and the default syntax (RESyntax.RE_SYNTAX_PERL5).
- *
- * @param pattern A regular expression pattern, in the form of a String,
- * StringBuffer, or char[]. Other input types will be converted to
- * strings using the toString() method.
- * @param cflags The logical OR of any combination of the compilation flags in the RE class.
- * @exception RuntimeException The input pattern could not be parsed.
- * @exception NullPointerException The pattern was null.
- */
- public UncheckedRE(Object pattern, int cflags) {
- this(pattern,cflags,RESyntax.RE_SYNTAX_PERL5);
- }
-
- /**
- * Constructs a regular expression pattern buffer using the specified
- * compilation flags and regular expression syntax.
- *
- * @param pattern A regular expression pattern, in the form of a String,
- * StringBuffer, or char[]. Other input types will be converted to
- * strings using the toString() method.
- * @param cflags The logical OR of any combination of the compilation flags in the RE class.
- * @param syntax The type of regular expression syntax to use.
- * @exception RuntimeException The input pattern could not be parsed.
- * @exception NullPointerException The pattern was null.
- */
- public UncheckedRE(Object pattern, int cflags, RESyntax syntax) {
- try {
- initialize(pattern,cflags,syntax,0,0);
- } catch (REException e) {
- throw new RuntimeException(e.getMessage());
- }
- }
-}
-
-
diff --git a/libjava/java/util/natResourceBundle.cc b/libjava/java/util/natResourceBundle.cc
deleted file mode 100644
index 35e90ee23d3..00000000000
--- a/libjava/java/util/natResourceBundle.cc
+++ /dev/null
@@ -1,42 +0,0 @@
-/* Copyright (C) 2002, 2003 Free Software Foundation
-
- This file is part of libgcj.
-
-This software is copyrighted work licensed under the terms of the
-Libgcj License. Please consult the file "LIBGCJ_LICENSE" for
-details. */
-
-// Written by Tom Tromey <tromey@redhat.com>
-
-#include <config.h>
-
-#include <gcj/cni.h>
-#include <jvm.h>
-#include <java/util/ResourceBundle.h>
-#include <java/lang/SecurityManager.h>
-#include <java/lang/ClassLoader.h>
-#include <java/lang/Class.h>
-#include <java/lang/ArrayIndexOutOfBoundsException.h>
-#include <gnu/gcj/runtime/StackTrace.h>
-
-java::lang::ClassLoader *
-java::util::ResourceBundle::getCallingClassLoader ()
-{
- gnu::gcj::runtime::StackTrace *t = new gnu::gcj::runtime::StackTrace(6);
- try
- {
- /* Frame 0 is this method, frame 1 is getBundle, so starting at
- frame 2 we might see the user's class. FIXME: should account
- for reflection, JNI, etc, here. */
- for (int i = 2; ; ++i)
- {
- jclass klass = t->classAt(i);
- if (klass != NULL)
- return klass->getClassLoaderInternal();
- }
- }
- catch (::java::lang::ArrayIndexOutOfBoundsException *e)
- {
- }
- return NULL;
-}
diff --git a/libjava/javax/swing/plaf/basic/BasicProgressBarUI.java b/libjava/javax/swing/plaf/basic/BasicProgressBarUI.java
deleted file mode 100644
index bf5cd0a7aa9..00000000000
--- a/libjava/javax/swing/plaf/basic/BasicProgressBarUI.java
+++ /dev/null
@@ -1,820 +0,0 @@
-/* BasicProgressBarUI.java
- Copyright (C) 2004 Free Software Foundation, Inc.
-
-This file is part of GNU Classpath.
-
-GNU Classpath is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2, or (at your option)
-any later version.
-
-GNU Classpath is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with GNU Classpath; see the file COPYING. If not, write to the
-Free Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA
-02111-1307 USA.
-
-Linking this library statically or dynamically with other modules is
-making a combined work based on this library. Thus, the terms and
-conditions of the GNU General Public License cover the whole
-combination.
-
-As a special exception, the copyright holders of this library give you
-permission to link this library with independent modules to produce an
-executable, regardless of the license terms of these independent
-modules, and to copy and distribute the resulting executable under
-terms of your choice, provided that you also meet, for each linked
-independent module, the terms and conditions of the license of that
-module. An independent module is a module which is not derived from
-or based on this library. If you modify this library, you may extend
-this exception to your version of the library, but you are not
-obligated to do so. If you do not wish to do so, delete this
-exception statement from your version. */
-
-package javax.swing.plaf.basic;
-
-import java.awt.Color;
-import java.awt.Dimension;
-import java.awt.Font;
-import java.awt.FontMetrics;
-import java.awt.Graphics;
-import java.awt.Insets;
-import java.awt.Point;
-import java.awt.Rectangle;
-import java.awt.event.ActionEvent;
-import java.awt.event.ActionListener;
-import java.beans.PropertyChangeEvent;
-import java.beans.PropertyChangeListener;
-import javax.swing.JComponent;
-import javax.swing.JProgressBar;
-import javax.swing.SwingConstants;
-import javax.swing.SwingUtilities;
-import javax.swing.Timer;
-import javax.swing.UIDefaults;
-import javax.swing.UIManager;
-import javax.swing.event.ChangeEvent;
-import javax.swing.event.ChangeListener;
-import javax.swing.plaf.ComponentUI;
-import javax.swing.plaf.ProgressBarUI;
-
-
-/**
- * The Basic Look and Feel UI delegate for the
- * JProgressBar.
- */
-public class BasicProgressBarUI extends ProgressBarUI
-{
- /**
- * A helper class that listens for ChangeEvents
- * from the progressBar's model.
- */
- protected class ChangeHandler implements ChangeListener
- {
- /**
- * Called every time the state of the model changes.
- *
- * @param e The ChangeEvent given by the model.
- */
- public void stateChanged(ChangeEvent e)
- {
- // Nothing to do but repaint.
- progressBar.repaint();
- }
- }
-
- /**
- * This helper class is used to listen for
- * PropertyChangeEvents from the progressBar.
- */
- private class PropertyChangeHandler implements PropertyChangeListener
- {
- /**
- * Called every time the properties of the
- * progressBar change.
- *
- * @param e The PropertyChangeEvent given by the progressBar.
- */
- public void propertyChange(PropertyChangeEvent e)
- {
- // Only need to listen for indeterminate changes.
- // All other things are done on a repaint.
- if (e.getPropertyName().equals(JProgressBar.INDETERMINATE_CHANGED_PROPERTY))
- if (((Boolean) e.getNewValue()).booleanValue())
- startAnimationTimer();
- else
- stopAnimationTimer();
- else
- progressBar.repaint();
- }
- }
-
- /**
- * This helper class is used to listen for
- * the animationTimer's intervals. On every interval,
- * the bouncing box should move.
- */
- private class Animator implements ActionListener
- {
- /**
- * Called every time the animationTimer reaches
- * its interval.
- *
- * @param e The ActionEvent given by the timer.
- */
- public void actionPerformed(ActionEvent e)
- {
- // Incrementing the animation index will cause
- // a repaint.
- incrementAnimationIndex();
- }
- }
-
- /** The timer used to move the bouncing box. */
- private transient Timer animationTimer = new Timer();
-
-
- // The total number of frames must be an even number.
- // The total number of frames is calculated from
- // the cycleTime and repaintInterval given by
- // the basic L&F's defaults.
- //
- // +-----------------------------------------------+
- // | frame0 | frame1 | frame2 | frame 3 | frame 4 |
- // | | frame7 | frame6 | frame 5 | |
- // +-----------------------------------------------+
-
- /** The current animation index. */
- private transient int animationIndex;
-
- /** The total number of frames.*/
- private transient int numFrames;
-
- /** The helper that moves the bouncing box. */
- private transient Animator animation;
-
- /** The helper that listens for property change events. */
- private transient PropertyChangeHandler propertyListener;
-
- /** The Listener for the model. */
- protected ChangeListener changeListener;
-
- /** The progressBar for this UI. */
- protected JProgressBar progressBar;
-
- /** The length of the cell. The cell is the painted part. */
- private transient int cellLength;
-
- /** The gap between cells. */
- private transient int cellSpacing;
-
- /** The color of the text when the bar is not over it.*/
- private transient Color selectionBackground;
-
- /** The color of the text when the bar is over it. */
- private transient Color selectionForeground;
-
- /**
- * Creates a new BasicProgressBarUI object.
- */
- public BasicProgressBarUI()
- {
- super();
- }
-
- /**
- * Creates a new BasicProgressBarUI for the component.
- *
- * @param x The JComponent to create the UI for.
- *
- * @return A new BasicProgressBarUI.
- */
- public static ComponentUI createUI(JComponent x)
- {
- return new BasicProgressBarUI();
- }
-
- /**
- * This method returns the length of the bar (from the minimum)
- * in pixels (or units that the Graphics object draws in) based
- * on the progressBar's getPercentComplete() value.
- *
- * @param b The insets of the progressBar.
- * @param width The width of the progressBar.
- * @param height The height of the progressBar.
- *
- * @return The length of the bar that should be painted in pixels.
- */
- protected int getAmountFull(Insets b, int width, int height)
- {
- double percentDone = progressBar.getPercentComplete();
- if (progressBar.getOrientation() == JProgressBar.HORIZONTAL)
- return (int) (percentDone * (width - b.left - b.right));
- else
- return (int) (percentDone * (height - b.top - b.bottom));
- }
-
- /**
- * The current animation index.
- *
- * @return The current animation index.
- */
- protected int getAnimationIndex()
- {
- return animationIndex;
- }
-
- /**
- * This method returns the size and position of the bouncing box
- * for the current animation index. It stores the values in the
- * given rectangle and returns it. It returns null if no box should
- * be drawn.
- *
- * @param r The bouncing box rectangle.
- *
- * @return The bouncing box rectangle.
- */
- protected Rectangle getBox(Rectangle r)
- {
- if (!progressBar.isIndeterminate())
- return null;
- //numFrames has to be an even number as defined by spec.
- int iterations = numFrames / 2 + 1;
-
- double boxDependent;
- double boxIndependent;
-
- if (progressBar.getOrientation() == JProgressBar.HORIZONTAL)
- {
- Dimension dims = getPreferredInnerHorizontal();
- boxDependent = (double) dims.width / iterations;
- boxIndependent = dims.height;
- }
- else
- {
- Dimension dims = getPreferredInnerVertical();
- boxDependent = (double) dims.height / iterations;
- boxIndependent = dims.width;
- }
-
- Rectangle vr = new Rectangle();
- SwingUtilities.calculateInnerArea(progressBar, vr);
-
- int index = getAnimationIndex();
- if (animationIndex > (numFrames + 1) / 2)
- index = numFrames - getAnimationIndex();
-
- if (progressBar.getOrientation() == JProgressBar.HORIZONTAL)
- {
- r.x = vr.x + (int) (index * boxDependent);
- r.y = vr.y;
- r.width = (int) boxDependent;
- r.height = (int) boxIndependent;
- }
- else
- {
- index++;
- r.x = vr.x;
- r.y = vr.height - (int) (index * boxDependent) + vr.y;
- r.width = (int) boxIndependent;
- r.height = (int) boxDependent;
- }
-
- return r;
- }
-
- /**
- * This method returns the length of the cells.
- *
- * @return The cell length.
- */
- protected int getCellLength()
- {
- return cellLength;
- }
-
- /**
- * This method returns the spacing between cells.
- *
- * @return The cell gap.
- */
- protected int getCellSpacing()
- {
- return cellSpacing;
- }
-
- /**
- * This method returns the maximum size of the JComponent.
- * If it returns null, it is up to the LayoutManager
- * to give it a size.
- *
- * @param c The component to find a maximum size for.
- *
- * @return The maximum size.
- */
- public Dimension getMaximumSize(JComponent c)
- {
- return getPreferredSize(c);
- }
-
- /**
- * This method returns the minimum size of the JComponent.
- * If it returns null, it is up to the LayoutManager to
- * give it a size.
- *
- * @param c The component to find a minimum size for.
- *
- * @return The minimum size.
- */
- public Dimension getMinimumSize(JComponent c)
- {
- return getPreferredSize(c);
- }
-
- /**
- * This method returns the preferred size of the inner
- * rectangle (the bounds without the insets) if the
- * progressBar is horizontal.
- *
- * @return The preferred size of the progressBar minus
- * insets if it's horizontal.
- */
- protected Dimension getPreferredInnerHorizontal()
- {
- Rectangle vr = new Rectangle();
-
- SwingUtilities.calculateInnerArea(progressBar, vr);
-
- return new Dimension(vr.width, vr.height);
- }
-
- /**
- * This method returns the preferred size of the inner
- * rectangle (the bounds without insets) if the
- * progressBar is vertical.
- *
- * @return The preferred size of the progressBar minus
- * insets if it's vertical.
- */
- protected Dimension getPreferredInnerVertical()
- {
- Rectangle vr = new Rectangle();
-
- SwingUtilities.calculateInnerArea(progressBar, vr);
-
- return new Dimension(vr.width, vr.height);
- }
-
- /**
- * This method returns the preferred size of the
- * given JComponent. If it returns null, then it
- * is up to the LayoutManager to give it a size.
- *
- * @param c The component to find the preferred size for.
- *
- * @return The preferred size of the component.
- */
- public Dimension getPreferredSize(JComponent c)
- {
- // The only thing we need to worry about is
- // the text size.
- Graphics g = progressBar.getGraphics();
-
- Insets insets = c.getInsets();
-
- FontMetrics fm = g.getFontMetrics(c.getFont());
-
- int textW = fm.stringWidth(progressBar.getString());
- int textH = fm.getHeight();
-
- g.dispose();
-
- if (progressBar.getOrientation() == JProgressBar.HORIZONTAL)
- {
- if (textH < 20)
- textH = 20;
- if (textW < 200)
- textW = 200;
- }
- else
- {
- if (textH < 200)
- textH = 200;
- if (textW < 20)
- textW = 20;
- }
- textW += insets.left + insets.right;
- textH += insets.top + insets.bottom;
- return new Dimension(textW, textH);
- }
-
- /**
- * This method returns the Color that the text is shown in when the bar is
- * not over the text.
- *
- * @return The color of the text when the bar is not over it.
- */
- protected Color getSelectionBackground()
- {
- return selectionBackground;
- }
-
- /**
- * This method returns the Color that the text is shown in when the bar is
- * over the text.
- *
- * @return The color of the text when the bar is over it.
- */
- protected Color getSelectionForeground()
- {
- return selectionForeground;
- }
-
- /**
- * This method returns the point (the top left of the bounding box)
- * where the text should be painted.
- *
- * @param g The Graphics object to measure FontMetrics with.
- * @param progressString The string to paint.
- * @param x The x coordinate of the overall bounds box.
- * @param y The y coordinate of the overall bounds box.
- * @param width The width of the overall bounds box.
- * @param height The height of the overall bounds box.
- *
- * @return The top left of the bounding box where text should be painted.
- */
- protected Point getStringPlacement(Graphics g, String progressString, int x,
- int y, int width, int height)
- {
- Rectangle tr = new Rectangle();
- Rectangle vr = new Rectangle(x, y, width, height);
- Rectangle ir = new Rectangle();
-
- Font f = g.getFont();
- FontMetrics fm = g.getFontMetrics(f);
-
- SwingUtilities.layoutCompoundLabel(progressBar, fm, progressString, null,
- SwingConstants.CENTER,
- SwingConstants.CENTER,
- SwingConstants.CENTER,
- SwingConstants.CENTER, vr, ir, tr, 0);
- return new Point(tr.x, tr.y);
- }
-
- /**
- * This method increments the animation index.
- */
- public void incrementAnimationIndex()
- {
- animationIndex++;
- //numFrames is like string length, it should be named numFrames or something
- if (animationIndex >= numFrames)
- animationIndex = 0;
- progressBar.repaint();
- }
-
- /**
- * This method paints the progressBar. It delegates its responsibilities
- * to paintDeterminate and paintIndeterminate.
- *
- * @param g The Graphics object to paint with.
- * @param c The JComponent to paint.
- */
- public void paint(Graphics g, JComponent c)
- {
- if (! progressBar.isIndeterminate())
- paintDeterminate(g, c);
- else
- paintIndeterminate(g, c);
-
- if (progressBar.isBorderPainted())
- progressBar.getBorder().paintBorder(progressBar, g, 0, 0,
- progressBar.getWidth(),
- progressBar.getHeight());
- }
-
- /**
- * This method is called if the painting to be done is
- * for a determinate progressBar.
- *
- * @param g The Graphics object to paint with.
- * @param c The JComponent to paint.
- */
- protected void paintDeterminate(Graphics g, JComponent c)
- {
- Color saved = g.getColor();
- int space = getCellSpacing();
- int len = getCellLength();
- int max = progressBar.getMaximum();
- int min = progressBar.getMinimum();
- int value = progressBar.getValue();
-
- Rectangle vr = new Rectangle();
- SwingUtilities.calculateInnerArea(c, vr);
-
- Rectangle or = c.getBounds();
-
- Insets insets = c.getInsets();
-
- int amountFull = getAmountFull(insets, or.width, or.height);
-
- g.setColor(c.getBackground());
- g.fill3DRect(vr.x, vr.y, vr.width, vr.height, false);
-
- if (max != min && len != 0 && value > min)
- {
- int iterations = value / (space + len);
-
- if (progressBar.getOrientation() == JProgressBar.HORIZONTAL)
- {
- double spaceInUnits = space * (double) vr.width / (max - min);
- double lenInUnits = len * (double) vr.width / (max - min);
- double currX = vr.x;
-
- g.setColor(c.getForeground());
- g.fill3DRect(vr.x, vr.y, amountFull, vr.height, true);
-
- g.setColor(c.getBackground());
- if (spaceInUnits != 0)
- {
- for (int i = 0; i < iterations; i++)
- {
- currX += lenInUnits;
- g.fill3DRect((int) currX, vr.y, (int) spaceInUnits,
- vr.height, true);
- currX += spaceInUnits;
- }
- }
- }
- else
- {
- double currY = vr.y;
- double spaceInUnits = space * (double) vr.height / (max - min);
- double lenInUnits = len * (double) vr.height / (max - min);
-
- g.setColor(c.getForeground());
- g.fill3DRect(vr.x, vr.y + vr.height - amountFull, vr.width,
- amountFull, true);
-
- g.setColor(c.getBackground());
-
- if (spaceInUnits != 0)
- {
- for (int i = 0; i < iterations; i++)
- {
- currY -= lenInUnits + spaceInUnits;
- g.fill3DRect(vr.x, (int) currY, vr.width,
- (int) spaceInUnits, true);
- }
- }
- }
- }
-
- if (progressBar.isStringPainted())
- paintString(g, 0, 0, or.width, or.height, amountFull, insets);
- g.setColor(saved);
- }
-
- /**
- * This method is called if the painting to be done is for
- * an indeterminate progressBar.
- *
- * @param g The Graphics object to paint with.
- * @param c The JComponent to paint.
- */
- protected void paintIndeterminate(Graphics g, JComponent c)
- {
- //need to paint the box at it's current position. no text is painted since
- //all we're doing is bouncing back and forth
- Color saved = g.getColor();
- Insets insets = c.getInsets();
-
- Rectangle or = c.getBounds();
- Rectangle vr = new Rectangle();
- SwingUtilities.calculateInnerArea(c, vr);
-
- g.setColor(c.getBackground());
- g.fill3DRect(vr.x, vr.y, vr.width, vr.height, false);
-
- Rectangle box = new Rectangle();
- getBox(box);
-
- g.setColor(c.getForeground());
- g.fill3DRect(box.x, box.y, box.width, box.height, true);
-
- if (progressBar.isStringPainted())
- paintString(g, 0, 0, or.width, or.height,
- getAmountFull(insets, or.width, or.height), insets);
-
- g.setColor(saved);
- }
-
- /**
- * This method paints the string for the progressBar.
- *
- * @param g The Graphics object to paint with.
- * @param x The x coordinate of the progressBar.
- * @param y The y coordinate of the progressBar.
- * @param width The width of the progressBar.
- * @param height The height of the progressBar.
- * @param amountFull The amount of the progressBar that has its bar filled.
- * @param b The insets of the progressBar.
- */
- protected void paintString(Graphics g, int x, int y, int width, int height,
- int amountFull, Insets b)
- {
- // We want to place in the exact center of the bar.
- Point placement = getStringPlacement(g, progressBar.getString(),
- x + b.left, y + b.top,
- width - b.left - b.right,
- height - b.top - b.bottom);
- Color saved = g.getColor();
-
- // FIXME: The Color of the text should use selectionForeground and selectionBackground
- // but that can't be done right now, so we'll use white in the mean time.
- g.setColor(Color.WHITE);
-
- FontMetrics fm = g.getFontMetrics(progressBar.getFont());
-
- g.drawString(progressBar.getString(), placement.x,
- placement.y + fm.getAscent());
-
- g.setColor(saved);
- }
-
- /**
- * This method sets the current animation index. If the index
- * is greater than the number of frames, it resets to 0.
- *
- * @param newValue The new animation index.
- */
- protected void setAnimationIndex(int newValue)
- {
- animationIndex = (newValue <= numFrames) ? newValue : 0;
- progressBar.repaint();
- }
-
- /**
- * This method sets the cell length.
- *
- * @param cellLen The cell length.
- */
- protected void setCellLength(int cellLen)
- {
- cellLength = cellLen;
- }
-
- /**
- * This method sets the cell spacing.
- *
- * @param cellSpace The cell spacing.
- */
- protected void setCellSpacing(int cellSpace)
- {
- cellSpacing = cellSpace;
- }
-
- /**
- * This method starts the animation timer. It is called
- * when the propertyChangeListener detects that the progressBar
- * has changed to indeterminate mode.
- */
- protected void startAnimationTimer()
- {
- if (animationTimer != null)
- animationTimer.start();
- }
-
- /**
- * This method stops the animation timer. It is called when
- * the propertyChangeListener detects that the progressBar
- * has changed to determinate mode.
- */
- protected void stopAnimationTimer()
- {
- if (animationTimer != null)
- animationTimer.stop();
- setAnimationIndex(0);
- }
-
- /**
- * This method changes the settings for the progressBar to
- * the defaults provided by the current Look and Feel.
- */
- protected void installDefaults()
- {
- UIDefaults defaults = UIManager.getLookAndFeelDefaults();
-
- progressBar.setFont(defaults.getFont("ProgressBar.font"));
- progressBar.setForeground(defaults.getColor("ProgressBar.foreground"));
- progressBar.setBackground(defaults.getColor("ProgressBar.background"));
- progressBar.setBorder(defaults.getBorder("ProgressBar.border"));
-
- selectionForeground = defaults.getColor("ProgressBar.selectionForeground");
- selectionBackground = defaults.getColor("ProgressBar.selectionBackground");
- cellLength = defaults.getInt("ProgressBar.cellLength");
- cellSpacing = defaults.getInt("ProgressBar.cellSpacing");
-
- int repaintInterval = defaults.getInt("ProgressBar.repaintInterval");
- int cycleTime = defaults.getInt("ProgressBar.cycleTime");
-
- if (cycleTime % repaintInterval != 0
- && (cycleTime / repaintInterval) % 2 != 0)
- {
- int div = (cycleTime / repaintInterval) + 2;
- div /= 2;
- div *= 2;
- cycleTime = div * repaintInterval;
- }
- setAnimationIndex(0);
- numFrames = cycleTime / repaintInterval;
- animationTimer.setDelay(repaintInterval);
- }
-
- /**
- * The method uninstalls any defaults that were
- * set by the current Look and Feel.
- */
- protected void uninstallDefaults()
- {
- progressBar.setFont(null);
- progressBar.setForeground(null);
- progressBar.setBackground(null);
-
- selectionForeground = null;
- selectionBackground = null;
- }
-
- /**
- * This method registers listeners to all the
- * components that this UI delegate needs to listen to.
- */
- protected void installListeners()
- {
- changeListener = new ChangeHandler();
- propertyListener = new PropertyChangeHandler();
- animation = new Animator();
-
- progressBar.addChangeListener(changeListener);
- progressBar.addPropertyChangeListener(propertyListener);
- animationTimer.addActionListener(animation);
- }
-
- /**
- * This method unregisters listeners to all the
- * components that were listened to.
- */
- protected void uninstallListeners()
- {
- progressBar.removeChangeListener(changeListener);
- progressBar.removePropertyChangeListener(propertyListener);
- animationTimer.removeActionListener(animation);
-
- changeListener = null;
- propertyListener = null;
- animation = null;
- }
-
- /**
- * This method installs the UI for the given JComponent.
- * This includes setting up defaults and listeners as
- * well as initializing any values or objects that
- * the UI may need.
- *
- * @param c The JComponent that is having this UI installed.
- */
- public void installUI(JComponent c)
- {
- super.installUI(c);
- if (c instanceof JProgressBar)
- {
- progressBar = (JProgressBar) c;
-
- animationTimer = new Timer();
- animationTimer.setRepeats(true);
-
- installDefaults();
- installListeners();
- }
- }
-
- /**
- * This method removes the UI for the given JComponent.
- * This includes removing any listeners or defaults
- * that the installUI may have set up.
- *
- * @param c The JComponent that is having this UI uninstalled.
- */
- public void uninstallUI(JComponent c)
- {
- super.uninstallUI(c);
- uninstallListeners();
- uninstallDefaults();
-
- animationTimer = null;
- progressBar = null;
- }
-}
diff --git a/libjava/javax/swing/plaf/basic/BasicSeparatorUI.java b/libjava/javax/swing/plaf/basic/BasicSeparatorUI.java
deleted file mode 100644
index b7df0acb27d..00000000000
--- a/libjava/javax/swing/plaf/basic/BasicSeparatorUI.java
+++ /dev/null
@@ -1,266 +0,0 @@
-/* BasicSeparatorUI.java
- Copyright (C) 2004 Free Software Foundation, Inc.
-
-This file is part of GNU Classpath.
-
-GNU Classpath is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2, or (at your option)
-any later version.
-
-GNU Classpath is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with GNU Classpath; see the file COPYING. If not, write to the
-Free Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA
-02111-1307 USA.
-
-Linking this library statically or dynamically with other modules is
-making a combined work based on this library. Thus, the terms and
-conditions of the GNU General Public License cover the whole
-combination.
-
-As a special exception, the copyright holders of this library give you
-permission to link this library with independent modules to produce an
-executable, regardless of the license terms of these independent
-modules, and to copy and distribute the resulting executable under
-terms of your choice, provided that you also meet, for each linked
-independent module, the terms and conditions of the license of that
-module. An independent module is a module which is not derived from
-or based on this library. If you modify this library, you may extend
-this exception to your version of the library, but you are not
-obligated to do so. If you do not wish to do so, delete this
-exception statement from your version. */
-
-package javax.swing.plaf.basic;
-
-import java.awt.Dimension;
-import java.awt.Color;
-import java.awt.Rectangle;
-import java.awt.Graphics;
-import java.awt.Insets;
-import javax.swing.plaf.ComponentUI;
-import javax.swing.plaf.SeparatorUI;
-import javax.swing.UIDefaults;
-import javax.swing.UIManager;
-import javax.swing.JComponent;
-import javax.swing.JSeparator;
-import javax.swing.SwingUtilities;
-
-/**
- * The Basic L&F UI delegate for JSeparator.
- */
-public class BasicSeparatorUI extends SeparatorUI
-{
- /** The shadow color. */
- protected Color shadow;
-
- /** The highlight color. */
- protected Color highlight;
-
- /**
- * Creates a new UI delegate for the given JComponent.
- *
- * @param c The JComponent to create a delegate for.
- *
- * @return A new BasicSeparatorUI.
- */
- public static ComponentUI createUI(JComponent c)
- {
- return new BasicSeparatorUI();
- }
-
- /**
- * This method installs the UI for the given JComponent.
- * This can include installing defaults, listeners, and
- * initializing any instance data.
- *
- * @param c The JComponent that is having this UI installed.
- */
- public void installUI(JComponent c)
- {
- super.installUI(c);
-
- if (c instanceof JSeparator)
- {
- JSeparator s = (JSeparator) c;
-
- installDefaults(s);
- installListeners(s);
- }
- }
-
- /**
- * Uninstalls the UI for the given JComponent. This
- * method reverses what was done when installing
- * the UI on the JComponent.
- *
- * @param c The JComponent that is having this UI uninstalled.
- */
- public void uninstallUI(JComponent c)
- {
- if (c instanceof JSeparator)
- {
- JSeparator s = (JSeparator) c;
-
- uninstallListeners(s);
- uninstallDefaults(s);
- }
- }
-
- /**
- * This method installs the defaults that are given by
- * the Basic L&F.
- *
- * @param s The JSeparator that is being installed.
- */
- protected void installDefaults(JSeparator s)
- {
- UIDefaults defaults = UIManager.getLookAndFeelDefaults();
-
- shadow = defaults.getColor("Separator.shadow");
- highlight = defaults.getColor("Separator.highlight");
- }
-
- /**
- * This method removes the defaults that were given
- * by the Basic L&F.
- *
- * @param s The JSeparator that is being uninstalled.
- */
- protected void uninstallDefaults(JSeparator s)
- {
- shadow = null;
- highlight = null;
- }
-
- /**
- * This method installs any listeners that need
- * to be attached to the JSeparator or any of its
- * components.
- *
- * @param s The JSeparator that is being installed.
- */
- protected void installListeners(JSeparator s)
- {
- // Separators don't receive events.
- }
-
- /**
- * This method uninstalls any listeners that
- * were installed during the install UI process.
- *
- * @param s The JSeparator that is being uninstalled.
- */
- protected void uninstallListeners(JSeparator s)
- {
- // Separators don't receive events.
- }
-
- /**
- * The separator is made of two lines. The top line will be
- * the highlight color (or left line if it's vertical). The bottom
- * or right line will be the shadow color. The two lines will
- * be centered inside the bounds box. If the separator is horizontal,
- * then it will be vertically centered, or if it's vertical, it will
- * be horizontally centered.
- *
- * @param g The Graphics object to paint with
- * @param c The JComponent to paint.
- */
- public void paint(Graphics g, JComponent c)
- {
- Rectangle r = new Rectangle();
- SwingUtilities.calculateInnerArea(c, r);
- Color saved = g.getColor();
-
- int midAB = r.width / 2 + r.x;
- int midAD = r.height / 2 + r.y;
-
- JSeparator s;
- if (c instanceof JSeparator)
- s = (JSeparator) c;
- else
- return;
-
- if (s.getOrientation() == JSeparator.HORIZONTAL)
- {
- g.setColor(highlight);
- g.drawLine(r.x, midAD, r.x + r.width, midAD);
-
- g.setColor(shadow);
- g.drawLine(r.x, midAD + 1, r.x + r.width, midAD + 1);
- }
- else
- {
- g.setColor(highlight);
- g.drawLine(midAB, r.y, midAB, r.y + r.height);
-
- g.setColor(shadow);
- g.drawLine(midAB + 1, r.y, midAB + 1, r.y + r.height);
- }
- }
-
- /**
- * This method returns the preferred size of the
- * JComponent.
- *
- * @param c The JComponent to measure.
- *
- * @return The preferred size.
- */
- public Dimension getPreferredSize(JComponent c)
- {
- Dimension dims = new Dimension(0, 0);
- Insets insets = c.getInsets();
-
- if (c instanceof JSeparator)
- {
- JSeparator s = (JSeparator) c;
-
- if (s.getOrientation() == JSeparator.HORIZONTAL)
- {
- dims.height = 2;
- dims.width = 40;
- }
- else
- {
- dims.width = 2;
- dims.height = 40;
- }
- }
- dims.width += insets.left + insets.right;
- dims.height += insets.top + insets.bottom;
-
- return dims;
- }
-
- /**
- * This method returns the minimum size of the
- * JComponent.
- *
- * @param c The JComponent to measure.
- *
- * @return The minimum size.
- */
- public Dimension getMinimumSize(JComponent c)
- {
- return getPreferredSize(c);
- }
-
- /**
- * This method returns the maximum size of the
- * JComponent.
- *
- * @param c The JComponent to measure.
- *
- * @return The maximum size.
- */
- public Dimension getMaximumSize(JComponent c)
- {
- return getPreferredSize(c);
- }
-}
diff --git a/libjava/javax/swing/plaf/basic/BasicSliderUI.java b/libjava/javax/swing/plaf/basic/BasicSliderUI.java
deleted file mode 100644
index 2ee481e317d..00000000000
--- a/libjava/javax/swing/plaf/basic/BasicSliderUI.java
+++ /dev/null
@@ -1,2213 +0,0 @@
-/* BasicSliderUI.java
- Copyright (C) 2004 Free Software Foundation, Inc.
-
-This file is part of GNU Classpath.
-
-GNU Classpath is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2, or (at your option)
-any later version.
-
-GNU Classpath is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with GNU Classpath; see the file COPYING. If not, write to the
-Free Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA
-02111-1307 USA.
-
-Linking this library statically or dynamically with other modules is
-making a combined work based on this library. Thus, the terms and
-conditions of the GNU General Public License cover the whole
-combination.
-
-As a special exception, the copyright holders of this library give you
-permission to link this library with independent modules to produce an
-executable, regardless of the license terms of these independent
-modules, and to copy and distribute the resulting executable under
-terms of your choice, provided that you also meet, for each linked
-independent module, the terms and conditions of the license of that
-module. An independent module is a module which is not derived from
-or based on this library. If you modify this library, you may extend
-this exception to your version of the library, but you are not
-obligated to do so. If you do not wish to do so, delete this
-exception statement from your version. */
-
-package javax.swing.plaf.basic;
-
-import java.awt.Color;
-import java.awt.Component;
-import java.awt.ComponentOrientation;
-import java.awt.Container;
-import java.awt.Dimension;
-import java.awt.Graphics;
-import java.awt.Insets;
-import java.awt.Point;
-import java.awt.Polygon;
-import java.awt.Rectangle;
-import java.awt.event.ActionEvent;
-import java.awt.event.ActionListener;
-import java.awt.event.ComponentAdapter;
-import java.awt.event.ComponentEvent;
-import java.awt.event.ComponentListener;
-import java.awt.event.FocusEvent;
-import java.awt.event.FocusListener;
-import java.awt.event.InputEvent;
-import java.awt.event.MouseEvent;
-import java.beans.PropertyChangeEvent;
-import java.beans.PropertyChangeListener;
-import java.util.Dictionary;
-import java.util.Enumeration;
-import javax.swing.JButton;
-import javax.swing.JComponent;
-import javax.swing.JLabel;
-import javax.swing.JSlider;
-import javax.swing.KeyStroke;
-import javax.swing.SwingUtilities;
-import javax.swing.Timer;
-import javax.swing.UIDefaults;
-import javax.swing.UIManager;
-import javax.swing.BoundedRangeModel;
-import javax.swing.event.ChangeEvent;
-import javax.swing.event.ChangeListener;
-import javax.swing.event.MouseInputAdapter;
-import javax.swing.plaf.ComponentUI;
-import javax.swing.plaf.SliderUI;
-
-
-/**
- * <p>
- * BasicSliderUI.java This is the UI delegate in the Basic look and feel that
- * paints JSliders.
- * </p>
- *
- * <p>
- * The UI delegate keeps track of 6 rectangles that place the various parts of
- * the JSlider inside the component.
- * </p>
- *
- * <p>
- * The rectangles are organized as follows:
- * </p>
- * <pre>
- * +-------------------------------------------------------+ <-- focusRect
- * | |
- * | +==+-------------------+==+--------------------+==+<------ contentRect
- * | | | | |<---thumbRect | | |
- * | | | TRACK | | |<--------- trackRect
- * | | +-------------------+==+--------------------+ | |
- * | | | | | |
- * | | | TICKS GO HERE |<-------- tickRect
- * | | | | | |
- * | +==+-------------------------------------------+==+ |
- * | | | | | |
- * | | | | |<----- labelRect
- * | | | LABELS GO HERE | | |
- * | | | | | |
- * | | | | | |
- * | | | | | |
- * | | | | | |
- * | | | | |
- * </pre>
- *
- * <p>
- * The space between the contentRect and the focusRect are the FocusInsets.
- * </p>
- *
- * <p>
- * The space between the focusRect and the component bounds is the insetCache
- * which are the component's insets.
- * </p>
- *
- * <p>
- * The top of the thumb is the top of the contentRect. The trackRect has to be
- * as tall as the thumb.
- * </p>
- *
- * <p>
- * The trackRect and tickRect do not start from the left edge of the
- * focusRect. They are trackBuffer away from each side of the focusRect. This
- * is so that the thumb has room to move.
- * </p>
- *
- * <p>
- * The labelRect does start right against the contentRect's left and right
- * edges and it gets all remaining space.
- * </p>
- */
-public class BasicSliderUI extends SliderUI
-{
- /**
- * Helper class that listens to the {@link JSlider}'s model for changes.
- */
- protected class ChangeHandler implements ChangeListener
- {
- /**
- * Called when the slider's model has been altered. The UI delegate should
- * recalculate any rectangles that are dependent on the model for their
- * positions and repaint.
- *
- * @param e A static {@link ChangeEvent} passed from the model.
- */
- public void stateChanged(ChangeEvent e)
- {
- // Maximum, minimum, and extent values will be taken
- // care of automatically when the slider is repainted.
-
- // Only thing that needs recalculation is the thumb.
- calculateThumbLocation();
- slider.repaint();
- }
- }
-
- /**
- * Helper class that listens for resize events.
- */
- protected class ComponentHandler extends ComponentAdapter
- {
- /**
- * Called when the size of the component changes. The UI delegate should
- * recalculate any rectangles that are dependent on the model for their
- * positions and repaint.
- *
- * @param e A {@link ComponentEvent}.
- */
- public void componentResized(ComponentEvent e)
- {
- calculateGeometry();
-
- slider.revalidate();
- slider.repaint();
- }
- }
-
- /**
- * Helper class that listens for focus events.
- */
- protected class FocusHandler implements FocusListener
- {
- /**
- * Called when the {@link JSlider} has gained focus. It should repaint
- * the slider with the focus drawn.
- *
- * @param e A {@link FocusEvent}.
- */
- public void focusGained(FocusEvent e)
- {
- // FIXME: implement.
- }
-
- /**
- * Called when the {@link JSlider} has lost focus. It should repaint the
- * slider without the focus drawn.
- *
- * @param e A {@link FocusEvent}.
- */
- public void focusLost(FocusEvent e)
- {
- // FIXME: implement.
- }
- }
-
- /**
- * Helper class that listens for changes to the properties of the {@link
- * JSlider}.
- */
- protected class PropertyChangeHandler implements PropertyChangeListener
- {
- /**
- * Called when one of the properties change. The UI should recalculate any
- * rectangles if necessary and repaint.
- *
- * @param e A {@link PropertyChangeEvent}.
- */
- public void propertyChange(PropertyChangeEvent e)
- {
- // Check for orientation changes.
- if (e.getPropertyName().equals(JSlider.ORIENTATION_CHANGED_PROPERTY))
- recalculateIfOrientationChanged();
- else if (e.getPropertyName().equals(JSlider.MODEL_CHANGED_PROPERTY))
- {
- BoundedRangeModel oldModel = (BoundedRangeModel) e.getOldValue();
- oldModel.removeChangeListener(changeListener);
- slider.getModel().addChangeListener(changeListener);
- calculateThumbLocation();
- }
- // elif the componentOrientation changes (this is a bound property,
- // just undocumented) we change leftToRightCache. In Sun's
- // implementation, the LTR cache changes on a repaint. This is strange
- // since there is no need to do so. We could events here and
- // update the cache.
-
- // elif the border/insets change, we recalculateInsets.
- slider.repaint();
- }
- }
-
- /**
- * Helper class that listens to our swing timer. This class is responsible
- * for listening to the timer and moving the thumb in the proper direction
- * every interval.
- */
- protected class ScrollListener implements ActionListener
- {
- /** Indicates which direction the thumb should scroll. */
- private transient int direction;
-
- /** Indicates whether we should scroll in blocks or in units. */
- private transient boolean block;
-
- /**
- * Creates a new ScrollListener object.
- */
- public ScrollListener()
- {
- direction = POSITIVE_SCROLL;
- block = false;
- }
-
- /**
- * Creates a new ScrollListener object.
- *
- * @param dir The direction to scroll in.
- * @param block If movement will be in blocks.
- */
- public ScrollListener(int dir, boolean block)
- {
- direction = dir;
- this.block = block;
- }
-
- /**
- * Called every time the swing timer reaches its interval. If the thumb
- * needs to move, then this method will move the thumb one block or unit
- * in the direction desired. Otherwise, the timer can be stopped.
- *
- * @param e An {@link ActionEvent}.
- */
- public void actionPerformed(ActionEvent e)
- {
- if (! trackListener.shouldScroll(direction))
- {
- scrollTimer.stop();
- return;
- }
-
- if (block)
- scrollByBlock(direction);
- else
- scrollByUnit(direction);
- }
-
- /**
- * Sets the direction to scroll in.
- *
- * @param direction The direction to scroll in.
- */
- public void setDirection(int direction)
- {
- this.direction = direction;
- }
-
- /**
- * Sets whether movement will be in blocks.
- *
- * @param block If movement will be in blocks.
- */
- public void setScrollByBlock(boolean block)
- {
- this.block = block;
- }
- }
-
- /**
- * Helper class that listens for mouse events.
- */
- protected class TrackListener extends MouseInputAdapter
- {
- /** The current X position of the mouse. */
- protected int currentMouseX;
-
- /** The current Y position of the mouse. */
- protected int currentMouseY;
-
- /** The offset between the current slider value
- and the cursor's position. */
- protected int offset;
-
- /**
- * Called when the mouse has been dragged. This should find the mouse's
- * current position and adjust the value of the {@link JSlider}
- * accordingly.
- *
- * @param e A {@link MouseEvent}
- */
- public void mouseDragged(MouseEvent e)
- {
- currentMouseX = e.getX();
- currentMouseY = e.getY();
- if (slider.getValueIsAdjusting())
- {
- int value;
- if (slider.getOrientation() == JSlider.HORIZONTAL)
- value = valueForXPosition(currentMouseX) - offset;
- else
- value = valueForYPosition(currentMouseY) - offset;
-
- slider.setValue(value);
- }
- }
-
- /**
- * Called when the mouse has moved over a component but no buttons have
- * been pressed yet.
- *
- * @param e A {@link MouseEvent}
- */
- public void mouseMoved(MouseEvent e)
- {
- // Don't care that we're moved unless we're dragging.
- }
-
- /**
- * Called when the mouse is pressed. When the press occurs on the thumb
- * itself, the {@link JSlider} should have its value set to where the
- * mouse was pressed. If the press occurs on the track, then the thumb
- * should move one block towards the direction of the mouse.
- *
- * @param e A {@link MouseEvent}
- */
- public void mousePressed(MouseEvent e)
- {
- currentMouseX = e.getX();
- currentMouseY = e.getY();
-
- int value;
- if (slider.getOrientation() == JSlider.HORIZONTAL)
- value = valueForXPosition(currentMouseX);
- else
- value = valueForYPosition(currentMouseY);
-
- if (slider.getSnapToTicks())
- value = findClosestTick(value);
-
- if (value == slider.getValue())
- return;
-
- // If the thumb is hit, then we don't need to set the timers to move it.
- if (!thumbRect.contains(e.getPoint()))
- {
- // The mouse has hit some other part of the slider.
- // The value moves no matter where in the slider you hit.
- if (value > slider.getValue())
- scrollDueToClickInTrack(POSITIVE_SCROLL);
- else
- scrollDueToClickInTrack(NEGATIVE_SCROLL);
- }
- else
- {
- slider.setValueIsAdjusting(true);
- offset = value - slider.getValue();
- }
- }
-
- /**
- * Called when the mouse is released. This should stop the timer that
- * scrolls the thumb.
- *
- * @param e A {@link MouseEvent}
- */
- public void mouseReleased(MouseEvent e)
- {
- currentMouseX = e.getX();
- currentMouseY = e.getY();
-
- if (slider.getValueIsAdjusting())
- {
- slider.setValueIsAdjusting(false);
- if (slider.getSnapToTicks())
- slider.setValue(findClosestTick(slider.getValue()));
- }
- if (scrollTimer != null)
- scrollTimer.stop();
- }
-
- /**
- * Indicates whether the thumb should scroll in the given direction.
- *
- * @param direction The direction to check.
- *
- * @return True if the thumb should move in that direction.
- */
- public boolean shouldScroll(int direction)
- {
- int value;
- if (slider.getOrientation() == JSlider.HORIZONTAL)
- value = valueForXPosition(currentMouseX);
- else
- value = valueForYPosition(currentMouseY);
-
- if (direction == POSITIVE_SCROLL)
- return (value > slider.getValue());
- else
- return (value < slider.getValue());
- }
- }
-
- /** The preferred height of the thumb. */
- private transient int thumbHeight;
-
- /** The preferred width of the thumb. */
- private transient int thumbWidth;
-
- /** The preferred height of the tick rectangle. */
- private transient int tickHeight;
-
- /** Listener for changes from the model. */
- protected ChangeListener changeListener;
-
- /** Listener for changes to the {@link JSlider}. */
- protected PropertyChangeListener propertyChangeListener;
-
- /** Listener for the scrollTimer. */
- protected ScrollListener scrollListener;
-
- /** Listener for component resizing. */
- protected ComponentListener componentListener;
-
- /** Listener for focus handling. */
- protected FocusListener focusListener;
-
- /** Listener for mouse events. */
- protected TrackListener trackListener;
-
- /** The insets between the FocusRectangle and the ContentRectangle. */
- protected Insets focusInsets;
-
- /** The {@link JSlider}'s insets. */
- protected Insets insetCache;
-
- /** Rectangle describing content bounds. See diagram above. */
- protected Rectangle contentRect;
-
- /** Rectangle describing focus bounds. See diagram above. */
- protected Rectangle focusRect;
-
- /** Rectangle describing the thumb's bounds. See diagram above. */
- protected Rectangle thumbRect;
-
- /** Rectangle describing the tick bounds. See diagram above. */
- protected Rectangle tickRect;
-
- /** Rectangle describing the label bounds. See diagram above. */
- protected Rectangle labelRect;
-
- /** Rectangle describing the track bounds. See diagram above. */
- protected Rectangle trackRect;
-
- /** FIXME: use this somewhere. */
- public static final int MAX_SCROLL = 2;
-
- /** FIXME: use this somewhere. */
- public static final int MIN_SCROLL = -2;
-
- /** A constant describing scrolling towards the minimum. */
- public static final int NEGATIVE_SCROLL = -1;
-
- /** A constant describing scrolling towards the maximum. */
- public static final int POSITIVE_SCROLL = 1;
-
- /** The gap between the edges of the contentRect and trackRect. */
- protected int trackBuffer;
-
- /** Whether this slider is actually drawn left to right. */
- protected boolean leftToRightCache;
-
- /** A timer that periodically moves the thumb. */
- protected Timer scrollTimer;
-
- /** A reference to the {@link JSlider} that this UI was created for. */
- protected JSlider slider;
-
- /** The shadow color. */
- private transient Color shadowColor;
-
- /** The highlight color. */
- private transient Color highlightColor;
-
- /** The focus color. */
- private transient Color focusColor;
-
- /**
- * Creates a new Basic look and feel Slider UI.
- *
- * @param b The {@link JSlider} that this UI was created for.
- */
- public BasicSliderUI(JSlider b)
- {
- super();
- }
-
- /**
- * Gets the shadow color to be used for this slider. The shadow color is the
- * color used for drawing the top and left edges of the track.
- *
- * @return The shadow color.
- */
- protected Color getShadowColor()
- {
- return shadowColor;
- }
-
- /**
- * Gets the highlight color to be used for this slider. The highlight color
- * is the color used for drawing the bottom and right edges of the track.
- *
- * @return The highlight color.
- */
- protected Color getHighlightColor()
- {
- return highlightColor;
- }
-
- /**
- * Gets the focus color to be used for this slider. The focus color is the
- * color used for drawing the focus rectangle when the component gains
- * focus.
- *
- * @return The focus color.
- */
- protected Color getFocusColor()
- {
- return focusColor;
- }
-
- /**
- * Factory method to create a BasicSliderUI for the given {@link
- * JComponent}, which should be a {@link JSlider}.
- *
- * @param b The {@link JComponent} a UI is being created for.
- *
- * @return A BasicSliderUI for the {@link JComponent}.
- */
- public static ComponentUI createUI(JComponent b)
- {
- return new BasicSliderUI((JSlider) b);
- }
-
- /**
- * Installs and initializes all fields for this UI delegate. Any properties
- * of the UI that need to be initialized and/or set to defaults will be
- * done now. It will also install any listeners necessary.
- *
- * @param c The {@link JComponent} that is having this UI installed.
- */
- public void installUI(JComponent c)
- {
- super.installUI(c);
- if (c instanceof JSlider)
- {
- slider = (JSlider) c;
-
- focusRect = new Rectangle();
- contentRect = new Rectangle();
- thumbRect = new Rectangle();
- trackRect = new Rectangle();
- tickRect = new Rectangle();
- labelRect = new Rectangle();
-
- insetCache = slider.getInsets();
- leftToRightCache = ! slider.getInverted();
-
- scrollTimer = new Timer();
- scrollTimer.setDelay(200);
- scrollTimer.setRepeats(true);
-
- installDefaults(slider);
- installListeners(slider);
- installKeyboardActions(slider);
-
- calculateFocusRect();
-
- calculateContentRect();
- calculateThumbSize();
- calculateTrackBuffer();
- calculateTrackRect();
- calculateThumbLocation();
-
- calculateTickRect();
- calculateLabelRect();
- }
- }
-
- /**
- * Performs the opposite of installUI. Any properties or resources that need
- * to be cleaned up will be done now. It will also uninstall any listeners
- * it has. In addition, any properties of this UI will be nulled.
- *
- * @param c The {@link JComponent} that is having this UI uninstalled.
- */
- public void uninstallUI(JComponent c)
- {
- super.uninstallUI(c);
-
- uninstallKeyboardActions(slider);
- uninstallListeners(slider);
-
- scrollTimer = null;
-
- focusRect = null;
- contentRect = null;
- thumbRect = null;
- trackRect = null;
- tickRect = null;
- labelRect = null;
-
- focusInsets = null;
- }
-
- /**
- * Initializes any default properties that this UI has from the defaults for
- * the Basic look and feel.
- *
- * @param slider The {@link JSlider} that is having this UI installed.
- */
- protected void installDefaults(JSlider slider)
- {
- UIDefaults defaults = UIManager.getLookAndFeelDefaults();
-
- slider.setForeground(defaults.getColor("Slider.foreground"));
- slider.setBackground(defaults.getColor("Slider.background"));
- shadowColor = defaults.getColor("Slider.shadow");
- highlightColor = defaults.getColor("Slider.highlight");
- focusColor = defaults.getColor("Slider.focus");
- slider.setBorder(defaults.getBorder("Slider.border"));
-
- thumbHeight = defaults.getInt("Slider.thumbHeight");
- thumbWidth = defaults.getInt("Slider.thumbWidth");
- tickHeight = defaults.getInt("Slider.tickHeight");
-
- focusInsets = defaults.getInsets("Slider.focusInsets");
- }
-
- /**
- * Creates a new {@link TrackListener}.
- *
- * @param slider The {@link JSlider} that this {@link TrackListener} is
- * created for.
- *
- * @return A new {@link TrackListener}.
- */
- protected TrackListener createTrackListener(JSlider slider)
- {
- return new TrackListener();
- }
-
- /**
- * Creates a new {@link ChangeListener}.
- *
- * @param slider The {@link JSlider} that this {@link ChangeListener} is
- * created for.
- *
- * @return A new {@link ChangeListener}.
- */
- protected ChangeListener createChangeListener(JSlider slider)
- {
- return new ChangeHandler();
- }
-
- /**
- * Creates a new {@link ComponentListener}.
- *
- * @param slider The {@link JSlider} that this {@link ComponentListener} is
- * created for.
- *
- * @return A new {@link ComponentListener}.
- */
- protected ComponentListener createComponentListener(JSlider slider)
- {
- return new ComponentHandler();
- }
-
- /**
- * Creates a new {@link FocusListener}.
- *
- * @param slider The {@link JSlider} that this {@link FocusListener} is
- * created for.
- *
- * @return A new {@link FocusListener}.
- */
- protected FocusListener createFocusListener(JSlider slider)
- {
- return new FocusHandler();
- }
-
- /**
- * Creates a new {@link ScrollListener}.
- *
- * @param slider The {@link JSlider} that this {@link ScrollListener} is
- * created for.
- *
- * @return A new {@link ScrollListener}.
- */
- protected ScrollListener createScrollListener(JSlider slider)
- {
- return new ScrollListener();
- }
-
- /**
- * Creates a new {@link PropertyChangeListener}.
- *
- * @param slider The {@link JSlider} that this {@link
- * PropertyChangeListener} is created for.
- *
- * @return A new {@link PropertyChangeListener}.
- */
- protected PropertyChangeListener createPropertyChangeListener(JSlider slider)
- {
- return new PropertyChangeHandler();
- }
-
- /**
- * Creates and registers all the listeners for this UI delegate. This
- * includes creating the ScrollListener and registering it to the timer.
- *
- * @param slider The {@link JSlider} is having listeners installed.
- */
- protected void installListeners(JSlider slider)
- {
- propertyChangeListener = createPropertyChangeListener(slider);
- componentListener = createComponentListener(slider);
- trackListener = createTrackListener(slider);
- focusListener = createFocusListener(slider);
- changeListener = createChangeListener(slider);
- scrollListener = createScrollListener(slider);
-
- slider.addPropertyChangeListener(propertyChangeListener);
- slider.addComponentListener(componentListener);
- slider.addMouseListener(trackListener);
- slider.addMouseMotionListener(trackListener);
- slider.addFocusListener(focusListener);
- slider.getModel().addChangeListener(changeListener);
-
- scrollTimer.addActionListener(scrollListener);
- }
-
- /**
- * Unregisters all the listeners that this UI delegate was using. In
- * addition, it will also null any listeners that it was using.
- *
- * @param slider The {@link JSlider} that is having listeners removed.
- */
- protected void uninstallListeners(JSlider slider)
- {
- slider.removePropertyChangeListener(propertyChangeListener);
- slider.removeComponentListener(componentListener);
- slider.removeMouseListener(trackListener);
- slider.removeMouseMotionListener(trackListener);
- slider.removeFocusListener(focusListener);
- slider.getModel().removeChangeListener(changeListener);
-
- scrollTimer.removeActionListener(scrollListener);
-
- propertyChangeListener = null;
- componentListener = null;
- trackListener = null;
- focusListener = null;
- changeListener = null;
- scrollListener = null;
- }
-
- /**
- * Installs any keyboard actions. The list of keys that need to be bound are
- * listed in Basic look and feel's defaults.
- *
- * @param slider The {@link JSlider} that is having keyboard actions
- * installed.
- */
- protected void installKeyboardActions(JSlider slider)
- {
- // FIXME: implement.
- }
-
- /**
- * Uninstalls any keyboard actions. The list of keys used are listed in
- * Basic look and feel's defaults.
- *
- * @param slider The {@link JSlider} that is having keyboard actions
- * uninstalled.
- */
- protected void uninstallKeyboardActions(JSlider slider)
- {
- // FIXME: implement.
- }
-
- /* XXX: This is all after experimentation with SUN's implementation.
-
- PreferredHorizontalSize seems to be 200x21.
- PreferredVerticalSize seems to be 21x200.
-
- MinimumHorizontalSize seems to be 36x21.
- MinimumVerticalSize seems to be 21x36.
-
- PreferredSize seems to be 200x63. Or Components.getBounds?
-
- MinimumSize seems to be 36x63.
-
- MaximumSize seems to be 32767x63.
- */
-
- /**
- * This method returns the preferred size when the slider is
- * horizontally oriented.
- *
- * @return The dimensions of the preferred horizontal size.
- */
- public Dimension getPreferredHorizontalSize()
- {
- Insets insets = slider.getInsets();
-
- // The width should cover all the labels (which are usually the
- // deciding factor of the width)
- int width = getWidthOfWidestLabel() * (slider.getLabelTable() == null ?
- 0 : slider.getLabelTable().size());
-
- // If there are not enough labels.
- // This number is pretty much arbitrary, but it looks nice.
- if (width < 200)
- width = 200;
-
- // We can only draw inside of the focusRectangle, so we have to
- // pad it with insets.
- width += insets.left + insets.right + focusInsets.left +
- focusInsets.right;
-
- // Height is determined by the thumb, the ticks and the labels.
- int height = thumbHeight;
-
- if (slider.getPaintTicks() && slider.getMajorTickSpacing() > 0 ||
- slider.getMinorTickSpacing() > 0)
- height += tickHeight;
-
- if (slider.getPaintLabels())
- height += getHeightOfTallestLabel();
-
- height += insets.top + insets.bottom + focusInsets.top +
- focusInsets.bottom;
-
- return new Dimension(width, height);
- }
-
- /**
- * This method returns the preferred size when the slider is
- * vertically oriented.
- *
- * @return The dimensions of the preferred vertical size.
- */
- public Dimension getPreferredVerticalSize()
- {
- Insets insets = slider.getInsets();
-
- int height = getHeightOfTallestLabel() * (slider.getLabelTable() == null ?
- 0 : slider.getLabelTable().size());
-
- if (height < 200)
- height = 200;
-
- height += insets.top + insets.bottom + focusInsets.top +
- focusInsets.bottom;
-
- int width = thumbHeight;
-
- if (slider.getPaintTicks() && slider.getMajorTickSpacing() > 0 ||
- slider.getMinorTickSpacing() > 0)
- width += tickHeight;
-
- if (slider.getPaintLabels())
- width += getWidthOfWidestLabel();
-
- width += insets.left + insets.right + focusInsets.left +
- focusInsets.right;
-
- return new Dimension(width, height);
- }
-
- /**
- * This method returns the minimum size when the slider is
- * horizontally oriented.
- *
- * @return The dimensions of the minimum horizontal size.
- */
- public Dimension getMinimumHorizontalSize()
- {
- return getPreferredHorizontalSize();
- }
-
- /**
- * This method returns the minimum size of the slider when it
- * is vertically oriented.
- *
- * @return The dimensions of the minimum vertical size.
- */
- public Dimension getMinimumVerticalSize()
- {
- return getPreferredVerticalSize();
- }
-
- /**
- * This method returns the preferred size of the component. If it returns
- * null, then it is up to the Layout Manager to give the {@link JComponent}
- * a size.
- *
- * @param c The {@link JComponent} to find the preferred size for.
- *
- * @return The dimensions of the preferred size.
- */
- public Dimension getPreferredSize(JComponent c)
- {
- if (slider.getOrientation() == JSlider.HORIZONTAL)
- return getPreferredHorizontalSize();
- else
- return getPreferredVerticalSize();
- }
-
- /**
- * This method returns the minimum size for this {@link JSlider} for this
- * look and feel. If it returns null, then it is up to the Layout Manager
- * to give the {@link JComponent} a size.
- *
- * @param c The {@link JComponent} to find the minimum size for.
- *
- * @return The dimensions of the minimum size.
- */
- public Dimension getMinimumSize(JComponent c)
- {
- if (slider.getOrientation() == JSlider.HORIZONTAL)
- return getPreferredHorizontalSize();
- else
- return getPreferredVerticalSize();
- }
-
- /**
- * This method returns the maximum size for this {@link JSlider} for this
- * look and feel. If it returns null, then it is up to the Layout Manager
- * to give the {@link JComponent} a size.
- *
- * @param c The {@link JComponent} to find a maximum size for.
- *
- * @return The dimensions of the maximum size.
- */
- public Dimension getMaximumSize(JComponent c)
- {
- if (slider.getOrientation() == JSlider.HORIZONTAL)
- return getPreferredHorizontalSize();
- else
- return getPreferredVerticalSize();
- }
-
- /**
- * This method calculates all the sizes of the rectangles by delegating
- * to the helper methods calculateXXXRect.
- */
- protected void calculateGeometry()
- {
- calculateFocusRect();
- calculateContentRect();
- calculateThumbSize();
- calculateTrackBuffer();
- calculateTrackRect();
- calculateTickRect();
- calculateLabelRect();
- calculateThumbLocation();
- }
-
- /**
- * This method calculates the size and position of the focusRect. This
- * method does not need to be called if the orientation changes.
- */
- protected void calculateFocusRect()
- {
- insetCache = slider.getInsets();
- focusRect = SwingUtilities.calculateInnerArea(slider, focusRect);
-
- if (focusRect.width < 0)
- focusRect.width = 0;
- if (focusRect.height < 0)
- focusRect.height = 0;
- }
-
- /**
- * This method calculates the size but not the position of the thumbRect. It
- * must take into account the orientation of the slider.
- */
- protected void calculateThumbSize()
- {
- if (slider.getOrientation() == JSlider.HORIZONTAL)
- {
- if (thumbWidth > contentRect.width)
- thumbRect.width = contentRect.width / 4;
- else
- thumbRect.width = thumbWidth;
- if (thumbHeight > contentRect.height)
- thumbRect.height = contentRect.height;
- else
- thumbRect.height = thumbHeight;
- }
- else
- {
- // The thumb gets flipped when inverted, so thumbWidth
- // actually is the height and vice versa.
- if (thumbWidth > contentRect.height)
- thumbRect.height = contentRect.height / 4;
- else
- thumbRect.height = thumbWidth;
- if (thumbHeight > contentRect.width)
- thumbRect.width = contentRect.width;
- else
- thumbRect.width = thumbHeight;
- }
- }
-
- /**
- * This method calculates the size and position of the contentRect. This
- * method does not need to be called if the orientation changes.
- */
- protected void calculateContentRect()
- {
- contentRect.x = focusRect.x + focusInsets.left;
- contentRect.y = focusRect.y + focusInsets.top;
- contentRect.width = focusRect.width - focusInsets.left - focusInsets.right;
- contentRect.height = focusRect.height - focusInsets.top
- - focusInsets.bottom;
-
- if (contentRect.width < 0)
- contentRect.width = 0;
- if (contentRect.height < 0)
- contentRect.height = 0;
- }
-
- /**
- * Calculates the position of the thumbRect based on the current value of
- * the slider. It must take into account the orientation of the slider.
- */
- protected void calculateThumbLocation()
- {
- int value = slider.getValue();
-
- if (slider.getOrientation() == JSlider.HORIZONTAL)
- {
- thumbRect.x = xPositionForValue(value) - thumbRect.width / 2;
- thumbRect.y = contentRect.y;
- }
- else
- {
- thumbRect.x = contentRect.x;
- thumbRect.y = yPositionForValue(value) - thumbRect.height / 2;
- }
- }
-
- /**
- * Calculates the gap size between the left edge of the contentRect and the
- * left edge of the trackRect.
- */
- protected void calculateTrackBuffer()
- {
- if (slider.getOrientation() == JSlider.HORIZONTAL)
- trackBuffer = thumbRect.width;
- else
- trackBuffer = thumbRect.height;
- }
-
- /**
- * This method returns the size of the thumbRect.
- *
- * @return The dimensions of the thumb.
- */
- protected Dimension getThumbSize()
- {
- // This is really just the bounds box for the thumb.
- // The thumb will actually be pointed (like a rectangle + triangle at bottom)
- return thumbRect.getSize();
- }
-
- /**
- * Calculates the size and position of the trackRect. It must take into
- * account the orientation of the slider.
- */
- protected void calculateTrackRect()
- {
- if (slider.getOrientation() == JSlider.HORIZONTAL)
- {
- trackRect.x = contentRect.x + trackBuffer;
- trackRect.y = contentRect.y;
- trackRect.width = contentRect.width - 2 * trackBuffer;
- trackRect.height = thumbRect.height;
- }
- else
- {
- trackRect.x = contentRect.x;
- trackRect.y = contentRect.y + trackBuffer;
- trackRect.width = thumbRect.width;
- trackRect.height = contentRect.height - 2 * trackBuffer;
- }
- }
-
- /**
- * This method returns the height of the tick area box if the slider is
- * horizontal and the width of the tick area box is the slider is vertical.
- * It not necessarily how long the ticks will be. If a gap between the edge
- * of tick box and the actual tick is desired, then that will need to be
- * handled in the tick painting methods.
- *
- * @return The height (or width if the slider is vertical) of the tick
- * rectangle.
- */
- protected int getTickLength()
- {
- return tickHeight;
- }
-
- /**
- * This method calculates the size and position of the tickRect. It must
- * take into account the orientation of the slider.
- */
- protected void calculateTickRect()
- {
- if (slider.getOrientation() == JSlider.HORIZONTAL)
- {
- tickRect.x = trackRect.x;
- tickRect.y = trackRect.y + trackRect.height;
- tickRect.width = trackRect.width;
- tickRect.height = getTickLength();
-
- if (tickRect.y + tickRect.height > contentRect.y + contentRect.height)
- tickRect.height = contentRect.y + contentRect.height - tickRect.y;
- }
- else
- {
- tickRect.x = trackRect.x + trackRect.width;
- tickRect.y = trackRect.y;
- tickRect.width = getTickLength();
- tickRect.height = trackRect.height;
-
- if (tickRect.x + tickRect.width > contentRect.x + contentRect.width)
- tickRect.width = contentRect.x + contentRect.width - tickRect.x;
- }
- }
-
- /**
- * This method calculates the size and position of the labelRect. It must
- * take into account the orientation of the slider.
- */
- protected void calculateLabelRect()
- {
- if (slider.getOrientation() == JSlider.HORIZONTAL)
- {
- labelRect.x = contentRect.x;
- labelRect.y = tickRect.y + tickRect.height;
- labelRect.width = contentRect.width;
- labelRect.height = contentRect.height - labelRect.y;
- }
- else
- {
- labelRect.x = tickRect.x + tickRect.width;
- labelRect.y = contentRect.y;
- labelRect.width = contentRect.width - labelRect.x;
- labelRect.height = contentRect.height;
- }
- }
-
- /**
- * This method returns the width of the widest label in the slider's label
- * table.
- *
- * @return The width of the widest label or 0 if no label table exists.
- */
- protected int getWidthOfWidestLabel()
- {
- int widest = 0;
- Component label;
-
- if (slider.getLabelTable() == null)
- return 0;
-
- for (Enumeration list = slider.getLabelTable().elements();
- list.hasMoreElements();)
- {
- Object comp = list.nextElement();
- if (! (comp instanceof Component))
- continue;
- label = (Component) comp;
- if (label.getWidth() > widest)
- widest = label.getWidth();
- }
- return widest;
- }
-
- /**
- * This method returns the height of the tallest label in the slider's label
- * table.
- *
- * @return The height of the tallest label or 0 if no label table exists.
- */
- protected int getHeightOfTallestLabel()
- {
- int tallest = 0;
- Component label;
-
- if (slider.getLabelTable() == null)
- return 0;
-
- for (Enumeration list = slider.getLabelTable().elements();
- list.hasMoreElements();)
- {
- Object comp = list.nextElement();
- if (! (comp instanceof Component))
- continue;
- label = (Component) comp;
- if (label.getHeight() > tallest)
- tallest = label.getHeight();
- }
- return tallest;
- }
-
- /**
- * This method returns the width of the label whose key has the highest
- * value.
- *
- * @return The width of the high value label or 0 if no label table exists.
- */
- protected int getWidthOfHighValueLabel()
- {
- Component highValueLabel = getHighestValueLabel();
- if (highValueLabel != null)
- return highValueLabel.getWidth();
- else
- return 0;
- }
-
- /**
- * This method returns the width of the label whose key has the lowest
- * value.
- *
- * @return The width of the low value label or 0 if no label table exists.
- */
- protected int getWidthOfLowValueLabel()
- {
- Component lowValueLabel = getLowestValueLabel();
- if (lowValueLabel != null)
- return lowValueLabel.getWidth();
- else
- return 0;
- }
-
- /**
- * This method returns the height of the label whose key has the highest
- * value.
- *
- * @return The height of the high value label or 0 if no label table exists.
- */
- protected int getHeightOfHighValueLabel()
- {
- Component highValueLabel = getHighestValueLabel();
- if (highValueLabel != null)
- return highValueLabel.getHeight();
- else
- return 0;
- }
-
- /**
- * This method returns the height of the label whose key has the lowest
- * value.
- *
- * @return The height of the low value label or 0 if no label table exists.
- */
- protected int getHeightOfLowValueLabel()
- {
- Component lowValueLabel = getLowestValueLabel();
- if (lowValueLabel != null)
- return lowValueLabel.getHeight();
- else
- return 0;
- }
-
- /**
- * This method returns whether the slider is to be drawn inverted.
- *
- * @return True is the slider is to be drawn inverted.
- */
- protected boolean drawInverted()
- {
- return ! (slider.getInverted() ^ leftToRightCache);
- }
-
- /**
- * This method returns the label whose key has the lowest value.
- *
- * @return The low value label or null if no label table exists.
- */
- protected Component getLowestValueLabel()
- {
- Integer key = new Integer(Integer.MAX_VALUE);
- Integer tmpKey;
- Dictionary labelTable = slider.getLabelTable();
-
- if (labelTable == null)
- return null;
-
- for (Enumeration list = labelTable.keys(); list.hasMoreElements();)
- {
- Object value = list.nextElement();
- if (! (value instanceof Integer))
- continue;
- tmpKey = (Integer) value;
- if (tmpKey.intValue() < key.intValue())
- key = tmpKey;
- }
- Object comp = labelTable.get(key);
- if (! (comp instanceof Component))
- return null;
- return (Component) comp;
- }
-
- /**
- * This method returns the label whose key has the highest value.
- *
- * @return The high value label or null if no label table exists.
- */
- protected Component getHighestValueLabel()
- {
- Integer key = new Integer(Integer.MIN_VALUE);
- Integer tmpKey;
- Dictionary labelTable = slider.getLabelTable();
-
- if (labelTable == null)
- return null;
-
- for (Enumeration list = labelTable.keys(); list.hasMoreElements();)
- {
- Object value = list.nextElement();
- if (! (value instanceof Integer))
- continue;
- tmpKey = (Integer) value;
- if (tmpKey.intValue() > key.intValue())
- key = tmpKey;
- }
- Object comp = labelTable.get(key);
- if (! (comp instanceof Component))
- return null;
- return (Component) comp;
- }
-
- /**
- * This method is used to paint the {@link JSlider}. It delegates all its
- * duties to the various paint methods like paintTicks(), paintTrack(),
- * paintThumb(), etc.
- *
- * @param g The {@link Graphics} object to paint with.
- * @param c The {@link JComponent} that is being painted.
- */
- public void paint(Graphics g, JComponent c)
- {
- // FIXME: Move this to propertyChangeEvent handler, when we get those.
- leftToRightCache = slider.getComponentOrientation() != ComponentOrientation.RIGHT_TO_LEFT;
- // FIXME: This next line is only here because the above line is here.
- calculateThumbLocation();
-
- if (slider.getPaintTrack())
- paintTrack(g);
- if (slider.getPaintTicks())
- paintTicks(g);
- if (slider.getPaintLabels())
- paintLabels(g);
-
- //FIXME: Paint focus.
- paintThumb(g);
- }
-
- /**
- * This method recalculates any rectangles that need to be recalculated
- * after the insets of the component have changed.
- */
- protected void recalculateIfInsetsChanged()
- {
- // Examining a test program shows that either Sun calls private
- // methods that we don't know about, or these don't do anything.
- calculateFocusRect();
-
- calculateContentRect();
- calculateThumbSize();
- calculateTrackBuffer();
- calculateTrackRect();
- calculateThumbLocation();
-
- calculateTickRect();
- calculateLabelRect();
- }
-
- /**
- * This method recalculates any rectangles that need to be recalculated
- * after the orientation of the slider changes.
- */
- protected void recalculateIfOrientationChanged()
- {
- // Examining a test program shows that either Sun calls private
- // methods that we don't know about, or these don't do anything.
- calculateThumbSize();
- calculateTrackBuffer();
- calculateTrackRect();
- calculateThumbLocation();
-
- calculateTickRect();
- calculateLabelRect();
- }
-
- /**
- * This method is called during a repaint if the slider has focus. It draws
- * an outline of the focusRect using the color returned by
- * getFocusColor().
- *
- * @param g The {@link Graphics} object to draw with.
- */
- public void paintFocus(Graphics g)
- {
- Color saved_color = g.getColor();
-
- g.setColor(getFocusColor());
-
- g.drawRect(focusRect.x, focusRect.y, focusRect.width, focusRect.height);
-
- g.setColor(saved_color);
- }
-
- /**
- * <p>
- * This method is called during a repaint if the track is to be drawn. It
- * draws a 3D rectangle to represent the track. The track is not the size
- * of the trackRect. The top and left edges of the track should be outlined
- * with the shadow color. The bottom and right edges should be outlined
- * with the highlight color.
- * </p>
- * <pre>
- * a---d
- * | |
- * | | a------------------------d
- * | | | |
- * | | b------------------------c
- * | |
- * | |
- * b---c
- * </pre>
- *
- * <p>
- * The b-a-d path needs to be drawn with the shadow color and the b-c-d path
- * needs to be drawn with the highlight color.
- * </p>
- *
- * @param g The {@link Graphics} object to draw with.
- */
- public void paintTrack(Graphics g)
- {
- Color saved_color = g.getColor();
- int width;
- int height;
-
- Point a = new Point(trackRect.x, trackRect.y);
- Point b = new Point(a);
- Point c = new Point(a);
- Point d = new Point(a);
-
- Polygon high;
- Polygon shadow;
-
- if (slider.getOrientation() == JSlider.HORIZONTAL)
- {
- width = trackRect.width;
- height = (thumbRect.height / 4 == 0) ? 1 : thumbRect.height / 4;
-
- a.translate(0, (trackRect.height / 2) - (height / 2));
- b.translate(0, (trackRect.height / 2) + (height / 2));
- c.translate(trackRect.width, (trackRect.height / 2) + (height / 2));
- d.translate(trackRect.width, (trackRect.height / 2) - (height / 2));
- }
- else
- {
- width = (thumbRect.width / 4 == 0) ? 1 : thumbRect.width / 4;
- height = trackRect.height;
-
- a.translate((trackRect.width / 2) - (width / 2), 0);
- b.translate((trackRect.width / 2) - (width / 2), trackRect.height);
- c.translate((trackRect.width / 2) + (width / 2), trackRect.height);
- d.translate((trackRect.width / 2) + (width / 2), 0);
- }
- high = new Polygon(new int[] { b.x, c.x, d.x },
- new int[] { b.y, c.y, d.y }, 3);
- shadow = new Polygon(new int[] { b.x, a.x, d.x },
- new int[] { b.y, a.y, d.y }, 3);
-
- g.setColor(getHighlightColor());
- g.drawPolygon(high);
- g.setColor(getShadowColor());
- g.drawPolygon(shadow);
-
- g.setColor(Color.GRAY);
- g.fillRect(a.x + 1, a.y + 1, width - 2, height - 2);
- g.setColor(saved_color);
- }
-
- /**
- * This method is called during a repaint if the ticks are to be drawn. This
- * method must still verify that the majorTickSpacing and minorTickSpacing
- * are greater than zero before drawing the ticks.
- *
- * @param g The {@link Graphics} object to draw with.
- */
- public void paintTicks(Graphics g)
- {
- int max = slider.getMaximum();
- int min = slider.getMinimum();
- int majorSpace = slider.getMajorTickSpacing();
- int minorSpace = slider.getMinorTickSpacing();
-
- if (majorSpace > 0)
- {
- if (slider.getOrientation() == JSlider.HORIZONTAL)
- {
- double loc = tickRect.x;
- double increment = (max == min) ? 0
- : majorSpace * (double) tickRect.width / (max
- - min);
- if (drawInverted())
- {
- loc += tickRect.width;
- increment *= -1;
- }
- for (int i = min; i <= max; i += majorSpace)
- {
- paintMajorTickForHorizSlider(g, tickRect, (int) loc);
- loc += increment;
- }
- }
- else
- {
- double loc = tickRect.height + tickRect.y;
- double increment = (max == min) ? 0
- : -majorSpace * (double) tickRect.height / (max
- - min);
- if (drawInverted())
- {
- loc = tickRect.y;
- increment *= -1;
- }
- for (int i = min; i <= max; i += majorSpace)
- {
- paintMajorTickForVertSlider(g, tickRect, (int) loc);
- loc += increment;
- }
- }
- }
- if (minorSpace > 0)
- {
- if (slider.getOrientation() == JSlider.HORIZONTAL)
- {
- double loc = tickRect.x;
- double increment = (max == min) ? 0
- : minorSpace * (double) tickRect.width / (max
- - min);
- if (drawInverted())
- {
- loc += tickRect.width;
- increment *= -1;
- }
- for (int i = min; i <= max; i += minorSpace)
- {
- paintMinorTickForHorizSlider(g, tickRect, (int) loc);
- loc += increment;
- }
- }
- else
- {
- double loc = tickRect.height + tickRect.y;
- double increment = (max == min) ? 0
- : -minorSpace * (double) tickRect.height / (max
- - min);
- if (drawInverted())
- {
- loc = tickRect.y;
- increment *= -1;
- }
- for (int i = min; i <= max; i += minorSpace)
- {
- paintMinorTickForVertSlider(g, tickRect, (int) loc);
- loc += increment;
- }
- }
- }
- }
-
- /* Minor ticks start at 1/4 of the height (or width) of the tickRect and extend
- to 1/2 of the tickRect.
-
- Major ticks start at 1/4 of the height and extend to 3/4.
- */
-
- /**
- * This method paints a minor tick for a horizontal slider at the given x
- * value. x represents the x coordinate to paint at.
- *
- * @param g The {@link Graphics} object to draw with.
- * @param tickBounds The tickRect rectangle.
- * @param x The x coordinate to draw the tick at.
- */
- protected void paintMinorTickForHorizSlider(Graphics g,
- Rectangle tickBounds, int x)
- {
- int y = tickRect.y + tickRect.height / 4;
-
- g.drawLine(x, y, x, y + tickRect.height / 4);
- }
-
- /**
- * This method paints a major tick for a horizontal slider at the given x
- * value. x represents the x coordinate to paint at.
- *
- * @param g The {@link Graphics} object to draw with.
- * @param tickBounds The tickRect rectangle.
- * @param x The x coordinate to draw the tick at.
- */
- protected void paintMajorTickForHorizSlider(Graphics g,
- Rectangle tickBounds, int x)
- {
- int y = tickRect.y + tickRect.height / 4;
-
- g.drawLine(x, y, x, y + tickRect.height / 2);
- }
-
- /**
- * This method paints a minor tick for a vertical slider at the given y
- * value. y represents the y coordinate to paint at.
- *
- * @param g The {@link Graphics} object to draw with.
- * @param tickBounds The tickRect rectangle.
- * @param y The y coordinate to draw the tick at.
- */
- protected void paintMinorTickForVertSlider(Graphics g, Rectangle tickBounds,
- int y)
- {
- int x = tickRect.x + tickRect.width / 4;
-
- g.drawLine(x, y, x + tickRect.width / 4, y);
- }
-
- /**
- * This method paints a major tick for a vertical slider at the given y
- * value. y represents the y coordinate to paint at.
- *
- * @param g The {@link Graphics} object to draw with.
- * @param tickBounds The tickRect rectangle.
- * @param y The y coordinate to draw the tick at.
- */
- protected void paintMajorTickForVertSlider(Graphics g, Rectangle tickBounds,
- int y)
- {
- int x = tickRect.x + tickRect.width / 4;
-
- g.drawLine(x, y, x + tickRect.width / 2, y);
- }
-
- /**
- * This method paints all the labels from the slider's label table. This
- * method must make sure that the label table is not null before painting
- * the labels. Each entry in the label table is a (integer, component)
- * pair. Every label is painted at the value of the integer.
- *
- * @param g The {@link Graphics} object to draw with.
- */
- public void paintLabels(Graphics g)
- {
- if (slider.getLabelTable() != null)
- {
- Dictionary table = slider.getLabelTable();
- Integer tmpKey;
- Object key;
- Object element;
- Component label;
- if (slider.getOrientation() == JSlider.HORIZONTAL)
- {
- for (Enumeration list = table.keys(); list.hasMoreElements();)
- {
- key = list.nextElement();
- if (! (key instanceof Integer))
- continue;
- tmpKey = (Integer) key;
- element = table.get(tmpKey);
- // We won't paint them if they're not
- // JLabels so continue anyway
- if (! (element instanceof JLabel))
- continue;
- label = (Component) element;
- paintHorizontalLabel(g, tmpKey.intValue(), label);
- }
- }
- else
- {
- for (Enumeration list = table.keys(); list.hasMoreElements();)
- {
- key = list.nextElement();
- if (! (key instanceof Integer))
- continue;
- tmpKey = (Integer) key;
- element = table.get(tmpKey);
- // We won't paint them if they're not
- // JLabels so continue anyway
- if (! (element instanceof JLabel))
- continue;
- label = (Component) element;
- paintVerticalLabel(g, tmpKey.intValue(), label);
- }
- }
- }
- }
-
- /**
- * This method paints the label on the horizontal slider at the value
- * specified. The value is not a coordinate. It is a value within the range
- * of the slider. If the value is not within the range of the slider, this
- * method will do nothing. This method should not paint outside the
- * boundaries of the labelRect.
- *
- * @param g The {@link Graphics} object to draw with.
- * @param value The value to paint at.
- * @param label The label to paint.
- */
- protected void paintHorizontalLabel(Graphics g, int value, Component label)
- {
- // This relies on clipping working properly or we'll end up
- // painting all over the place. If our preferred size is ignored, then
- // the labels may not fit inside the slider's bounds. Rather than mucking
- // with font sizes and possible icon sizes, we'll set the bounds for
- // the label and let it get clipped.
-
- Dimension dim = label.getPreferredSize();
- int w = (int) dim.getWidth();
- int h = (int) dim.getHeight();
-
- int max = slider.getMaximum();
- int min = slider.getMinimum();
-
- if (value > max || value < min)
- return;
-
- // value
- // |
- // ------------
- // | |
- // | |
- // | |
- // The label must move w/2 to the right to fit directly under the value.
-
-
- int xpos = xPositionForValue(value) - w / 2;
- int ypos = labelRect.y;
-
- // We want to center the label around the xPositionForValue
- // So we use xpos - w / 2. However, if value is min and the label
- // is large, we run the risk of going out of bounds. So we bring it back
- // to 0 if it becomes negative.
- if (xpos < 0)
- xpos = 0;
-
- // If the label + starting x position is greater than
- // the x space in the label rectangle, we reset it to the largest
- // amount possible in the rectangle. This means ugliness.
- if (xpos + w > labelRect.x + labelRect.width)
- w = labelRect.x + labelRect.width - xpos;
-
- // If the label is too tall. We reset it to the height of the label
- // rectangle.
- if (h > labelRect.height)
- h = labelRect.height;
-
- label.setBounds(xpos, ypos, w, h);
- javax.swing.SwingUtilities.paintComponent(g, label, null, label.getBounds());
- }
-
- /**
- * This method paints the label on the vertical slider at the value
- * specified. The value is not a coordinate. It is a value within the range
- * of the slider. If the value is not within the range of the slider, this
- * method will do nothing. This method should not paint outside the
- * boundaries of the labelRect.
- *
- * @param g The {@link Graphics} object to draw with.
- * @param value The value to paint at.
- * @param label The label to paint.
- */
- protected void paintVerticalLabel(Graphics g, int value, Component label)
- {
- Dimension dim = label.getPreferredSize();
- int w = (int) dim.getWidth();
- int h = (int) dim.getHeight();
-
- int max = slider.getMaximum();
- int min = slider.getMinimum();
-
- if (value > max || value < min)
- return;
-
- int xpos = labelRect.x;
- int ypos = yPositionForValue(value) - h / 2;
-
- if (ypos < 0)
- ypos = 0;
-
- if (ypos + h > labelRect.y + labelRect.height)
- h = labelRect.y + labelRect.height - ypos;
-
- if (w > labelRect.width)
- w = labelRect.width;
-
- label.setBounds(xpos, ypos, w, h);
- javax.swing.SwingUtilities.paintComponent(g, label, null, label.getBounds());
- }
-
- /**
- * <p>
- * This method paints a thumb. There are two types of thumb:
- * </p>
- * <pre>
- * Vertical Horizontal
- * a---b a-----b
- * | | | \
- * e c | c
- * \ / | /
- * d e-----d
- * </pre>
- *
- * <p>
- * In the case of vertical thumbs, we highlight the path b-a-e-d and shadow
- * the path b-c-d. In the case of horizontal thumbs, we highlight the path
- * c-b-a-e and shadow the path c-d-e. In both cases we fill the path
- * a-b-c-d-e before shadows and highlights are drawn.
- * </p>
- *
- * @param g The graphics object to paint with
- */
- public void paintThumb(Graphics g)
- {
- Color saved_color = g.getColor();
-
- Polygon thumb = new Polygon();
-
- Point a = new Point(thumbRect.x, thumbRect.y);
- Point b = new Point(a);
- Point c = new Point(a);
- Point d = new Point(a);
- Point e = new Point(a);
-
- Polygon bright;
- Polygon dark;
- Polygon all;
-
- // This will be in X-dimension if the slider is inverted and y if it isn't.
- int turnPoint;
-
- if (slider.getOrientation() == JSlider.HORIZONTAL)
- {
- turnPoint = thumbRect.height * 3 / 4;
-
- b.translate(thumbRect.width, 0);
- c.translate(thumbRect.width, turnPoint);
- d.translate(thumbRect.width / 2, thumbRect.height);
- e.translate(0, turnPoint);
-
- bright = new Polygon(new int[] { b.x, a.x, e.x, d.x },
- new int[] { b.y, a.y, e.y, d.y }, 4);
-
- dark = new Polygon(new int[] { b.x, c.x, d.x },
- new int[] { b.y, c.y, d.y }, 3);
- all = new Polygon(new int[] { a.x + 1, b.x, c.x, d.x, e.x + 1 },
- new int[] { a.y + 1, b.y + 1, c.y, d.y + 1, e.y }, 5);
- }
- else
- {
- turnPoint = thumbRect.width * 3 / 4;
-
- b.translate(turnPoint, 0);
- c.translate(thumbRect.width, thumbRect.height / 2);
- d.translate(turnPoint, thumbRect.height);
- e.translate(0, thumbRect.height);
-
- bright = new Polygon(new int[] { c.x, b.x, a.x, e.x },
- new int[] { c.y, b.y, a.y, e.y }, 4);
-
- dark = new Polygon(new int[] { c.x, d.x, e.x + 1 },
- new int[] { c.y, d.y, e.y }, 3);
-
- all = new Polygon(new int[] { a.x + 1, b.x, c.x - 1, d.x, e.x + 1 },
- new int[] { a.y + 1, b.y + 1, c.y, d.y, e.y }, 5);
- }
-
- g.setColor(Color.WHITE);
- g.drawPolygon(bright);
-
- g.setColor(Color.BLACK);
- g.drawPolygon(dark);
-
- g.setColor(Color.GRAY);
- g.fillPolygon(all);
-
- g.setColor(saved_color);
- }
-
- /**
- * This method sets the position of the thumbRect.
- *
- * @param x The new x position.
- * @param y The new y position.
- */
- public void setThumbLocation(int x, int y)
- {
- thumbRect.x = x;
- thumbRect.y = y;
- }
-
- /**
- * This method is used to move the thumb one block in the direction
- * specified. If the slider snaps to ticks, this method is responsible for
- * snapping it to a tick after the thumb has been moved.
- *
- * @param direction The direction to move in.
- */
- public void scrollByBlock(int direction)
- {
- // The direction is -1 for backwards and 1 for forwards.
- int unit = direction * (slider.getMaximum() - slider.getMinimum()) / 10;
-
- int moveTo = slider.getValue() + unit;
-
- if (slider.getSnapToTicks())
- moveTo = findClosestTick(moveTo);
-
- slider.setValue(moveTo);
- }
-
- /**
- * This method is used to move the thumb one unit in the direction
- * specified. If the slider snaps to ticks, this method is responsible for
- * snapping it to a tick after the thumb has been moved.
- *
- * @param direction The direction to move in.
- */
- public void scrollByUnit(int direction)
- {
- // The direction is -1 for backwards and 1 for forwards.
- int moveTo = slider.getValue() + direction;
-
- if (slider.getSnapToTicks())
- moveTo = findClosestTick(moveTo);
-
- slider.setValue(moveTo);
- }
-
- /**
- * This method is called when there has been a click in the track and the
- * thumb needs to be scrolled on regular intervals. This method is only
- * responsible for starting the timer and not for stopping it.
- *
- * @param dir The direction to move in.
- */
- protected void scrollDueToClickInTrack(int dir)
- {
- scrollTimer.stop();
-
- scrollListener.setDirection(dir);
- scrollListener.setScrollByBlock(true);
-
- scrollTimer.start();
- }
-
- /**
- * This method returns the X coordinate for the value passed in.
- *
- * @param value The value to calculate an x coordinate for.
- *
- * @return The x coordinate for the value.
- */
- protected int xPositionForValue(int value)
- {
- int min = slider.getMinimum();
- int max = slider.getMaximum();
- int extent = slider.getExtent();
- int len = trackRect.width;
-
- int xPos = (max == min) ? 0 : (value - min) * len / (max - min);
-
- if (! drawInverted())
- xPos += trackRect.x;
- else
- {
- xPos = trackRect.width - xPos;
- xPos += trackRect.x;
- }
- return xPos;
- }
-
- /**
- * This method returns the y coordinate for the value passed in.
- *
- * @param value The value to calculate a y coordinate for.
- *
- * @return The y coordinate for the value.
- */
- protected int yPositionForValue(int value)
- {
- int min = slider.getMinimum();
- int max = slider.getMaximum();
- int extent = slider.getExtent();
- int len = trackRect.height;
-
- int yPos = (max == min) ? 0 : (value - min) * len / (max - min);
-
- if (! drawInverted())
- {
- yPos = trackRect.height - yPos;
- yPos += trackRect.y;
- }
- else
- yPos += trackRect.y;
- return yPos;
- }
-
- /**
- * This method returns the value in the slider's range given the y
- * coordinate. If the value is out of range, it will return the closest
- * legal value.
- *
- * @param yPos The y coordinate to calculate a value for.
- *
- * @return The value for the y coordinate.
- */
- public int valueForYPosition(int yPos)
- {
- int min = slider.getMinimum();
- int max = slider.getMaximum();
- int len = trackRect.height;
-
- int value;
-
- // If the length is 0, you shouldn't be able to even see where the slider is.
- // This really shouldn't ever happen, but just in case, we'll return the middle.
- if (len == 0)
- return ((max - min) / 2);
-
- if (! drawInverted())
- value = ((len - (yPos - trackRect.y)) * (max - min) / len + min);
- else
- value = ((yPos - trackRect.y) * (max - min) / len + min);
-
- // If this isn't a legal value, then we'll have to move to one now.
- if (value > max)
- value = max;
- else if (value < min)
- value = min;
- return value;
- }
-
- /**
- * This method returns the value in the slider's range given the x
- * coordinate. If the value is out of range, it will return the closest
- * legal value.
- *
- * @param xPos The x coordinate to calculate a value for.
- *
- * @return The value for the x coordinate.
- */
- public int valueForXPosition(int xPos)
- {
- int min = slider.getMinimum();
- int max = slider.getMaximum();
- int len = trackRect.width;
-
- int value;
-
- // If the length is 0, you shouldn't be able to even see where the slider is.
- // This really shouldn't ever happen, but just in case, we'll return the middle.
- if (len == 0)
- return ((max - min) / 2);
-
- if (! drawInverted())
- value = ((xPos - trackRect.x) * (max - min) / len + min);
- else
- value = ((len - (xPos - trackRect.x)) * (max - min) / len + min);
-
- // If this isn't a legal value, then we'll have to move to one now.
- if (value > max)
- value = max;
- else if (value < min)
- value = min;
- return value;
- }
-
- /**
- * This method finds the closest value that has a tick associated with it.
- *
- * @param value The value to search from.
- *
- * @return The closest value that has a tick associated with it.
- */
- private int findClosestTick(int value)
- {
- int min = slider.getMinimum();
- int max = slider.getMaximum();
- int majorSpace = slider.getMajorTickSpacing();
- int minorSpace = slider.getMinorTickSpacing();
-
- // The default value to return is value + minor or
- // value + major.
- // Initializing at min - value leaves us with a default
- // return value of min, which always has tick marks
- // (if ticks are painted).
- int minor = min - value;
- int major = min - value;
-
- // If there are no major tick marks or minor tick marks
- // e.g. snap is set to true but no ticks are set, then
- // we can just return the value.
- if (majorSpace <= 0 && minorSpace <= 0)
- return value;
-
- // First check the major ticks.
- if (majorSpace > 0)
- {
- int lowerBound = (value - min) / majorSpace;
- int majLower = majorSpace * lowerBound + min;
- int majHigher = majorSpace * (lowerBound + 1) + min;
-
- if (majHigher <= max && majHigher - value <= value - majLower)
- major = majHigher - value;
- else
- major = majLower - value;
- }
-
- if (minorSpace > 0)
- {
- int lowerBound = value / minorSpace;
- int minLower = minorSpace * lowerBound;
- int minHigher = minorSpace * (lowerBound + 1);
-
- if (minHigher <= max && minHigher - value <= value - minLower)
- minor = minHigher - value;
- else
- minor = minLower - value;
- }
-
- // Give preference to minor ticks
- if (Math.abs(minor) > Math.abs(major))
- return value + major;
- else
- return value + minor;
- }
-}
diff --git a/libstdc++-v3/config/allocator/bitmap_allocator_base.h b/libstdc++-v3/config/allocator/bitmap_allocator_base.h
deleted file mode 100644
index bf84ae06d7f..00000000000
--- a/libstdc++-v3/config/allocator/bitmap_allocator_base.h
+++ /dev/null
@@ -1,37 +0,0 @@
-// Base to std::allocator -*- C++ -*-
-
-// Copyright (C) 2004 Free Software Foundation, Inc.
-//
-// This file is part of the GNU ISO C++ Library. This library is free
-// software; you can redistribute it and/or modify it under the
-// terms of the GNU General Public License as published by the
-// Free Software Foundation; either version 2, or (at your option)
-// any later version.
-
-// This library is distributed in the hope that it will be useful,
-// but WITHOUT ANY WARRANTY; without even the implied warranty of
-// MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-// GNU General Public License for more details.
-
-// You should have received a copy of the GNU General Public License along
-// with this library; see the file COPYING. If not, write to the Free
-// Software Foundation, 59 Temple Place - Suite 330, Boston, MA 02111-1307,
-// USA.
-
-// As a special exception, you may use this file as part of a free software
-// library without restriction. Specifically, if other files instantiate
-// templates or use macros or inline functions from this file, or you compile
-// this file and link it with other files to produce an executable, this
-// file does not by itself cause the resulting executable to be covered by
-// the GNU General Public License. This exception does not however
-// invalidate any other reasons why the executable file might be covered by
-// the GNU General Public License.
-
-#ifndef _CXX_ALLOCATOR_H
-#define _CXX_ALLOCATOR_H 1
-
-// Define bitmap_allocator as the base class to std::allocator.
-#include <ext/bitmap_allocator.h>
-#define ___glibcxx_base_allocator __gnu_cxx::bitmap_allocator
-
-#endif
diff --git a/libstdc++-v3/config/allocator/malloc_allocator_base.h b/libstdc++-v3/config/allocator/malloc_allocator_base.h
deleted file mode 100644
index 4a82ec362c5..00000000000
--- a/libstdc++-v3/config/allocator/malloc_allocator_base.h
+++ /dev/null
@@ -1,37 +0,0 @@
-// Base to std::allocator -*- C++ -*-
-
-// Copyright (C) 2004 Free Software Foundation, Inc.
-//
-// This file is part of the GNU ISO C++ Library. This library is free
-// software; you can redistribute it and/or modify it under the
-// terms of the GNU General Public License as published by the
-// Free Software Foundation; either version 2, or (at your option)
-// any later version.
-
-// This library is distributed in the hope that it will be useful,
-// but WITHOUT ANY WARRANTY; without even the implied warranty of
-// MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-// GNU General Public License for more details.
-
-// You should have received a copy of the GNU General Public License along
-// with this library; see the file COPYING. If not, write to the Free
-// Software Foundation, 59 Temple Place - Suite 330, Boston, MA 02111-1307,
-// USA.
-
-// As a special exception, you may use this file as part of a free software
-// library without restriction. Specifically, if other files instantiate
-// templates or use macros or inline functions from this file, or you compile
-// this file and link it with other files to produce an executable, this
-// file does not by itself cause the resulting executable to be covered by
-// the GNU General Public License. This exception does not however
-// invalidate any other reasons why the executable file might be covered by
-// the GNU General Public License.
-
-#ifndef _CXX_ALLOCATOR_H
-#define _CXX_ALLOCATOR_H 1
-
-// Define new_allocator as the base class to std::allocator.
-#include <ext/malloc_allocator.h>
-#define ___glibcxx_base_allocator __gnu_cxx::malloc_allocator
-
-#endif
diff --git a/libstdc++-v3/config/allocator/mt_allocator_base.h b/libstdc++-v3/config/allocator/mt_allocator_base.h
deleted file mode 100644
index 52b4421a439..00000000000
--- a/libstdc++-v3/config/allocator/mt_allocator_base.h
+++ /dev/null
@@ -1,37 +0,0 @@
-// Base to std::allocator -*- C++ -*-
-
-// Copyright (C) 2004 Free Software Foundation, Inc.
-//
-// This file is part of the GNU ISO C++ Library. This library is free
-// software; you can redistribute it and/or modify it under the
-// terms of the GNU General Public License as published by the
-// Free Software Foundation; either version 2, or (at your option)
-// any later version.
-
-// This library is distributed in the hope that it will be useful,
-// but WITHOUT ANY WARRANTY; without even the implied warranty of
-// MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-// GNU General Public License for more details.
-
-// You should have received a copy of the GNU General Public License along
-// with this library; see the file COPYING. If not, write to the Free
-// Software Foundation, 59 Temple Place - Suite 330, Boston, MA 02111-1307,
-// USA.
-
-// As a special exception, you may use this file as part of a free software
-// library without restriction. Specifically, if other files instantiate
-// templates or use macros or inline functions from this file, or you compile
-// this file and link it with other files to produce an executable, this
-// file does not by itself cause the resulting executable to be covered by
-// the GNU General Public License. This exception does not however
-// invalidate any other reasons why the executable file might be covered by
-// the GNU General Public License.
-
-#ifndef _CXX_ALLOCATOR_H
-#define _CXX_ALLOCATOR_H 1
-
-// Define mt_allocator as the base class to std::allocator.
-#include <ext/mt_allocator.h>
-#define ___glibcxx_base_allocator __gnu_cxx::__mt_alloc
-
-#endif
diff --git a/libstdc++-v3/config/allocator/new_allocator_base.h b/libstdc++-v3/config/allocator/new_allocator_base.h
deleted file mode 100644
index 442f89cc535..00000000000
--- a/libstdc++-v3/config/allocator/new_allocator_base.h
+++ /dev/null
@@ -1,37 +0,0 @@
-// Base to std::allocator -*- C++ -*-
-
-// Copyright (C) 2004 Free Software Foundation, Inc.
-//
-// This file is part of the GNU ISO C++ Library. This library is free
-// software; you can redistribute it and/or modify it under the
-// terms of the GNU General Public License as published by the
-// Free Software Foundation; either version 2, or (at your option)
-// any later version.
-
-// This library is distributed in the hope that it will be useful,
-// but WITHOUT ANY WARRANTY; without even the implied warranty of
-// MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-// GNU General Public License for more details.
-
-// You should have received a copy of the GNU General Public License along
-// with this library; see the file COPYING. If not, write to the Free
-// Software Foundation, 59 Temple Place - Suite 330, Boston, MA 02111-1307,
-// USA.
-
-// As a special exception, you may use this file as part of a free software
-// library without restriction. Specifically, if other files instantiate
-// templates or use macros or inline functions from this file, or you compile
-// this file and link it with other files to produce an executable, this
-// file does not by itself cause the resulting executable to be covered by
-// the GNU General Public License. This exception does not however
-// invalidate any other reasons why the executable file might be covered by
-// the GNU General Public License.
-
-#ifndef _CXX_ALLOCATOR_H
-#define _CXX_ALLOCATOR_H 1
-
-// Define new_allocator as the base class to std::allocator.
-#include <ext/new_allocator.h>
-#define ___glibcxx_base_allocator __gnu_cxx::new_allocator
-
-#endif
diff --git a/libstdc++-v3/config/os/bsd/darwin/ctype_base.h b/libstdc++-v3/config/os/bsd/darwin/ctype_base.h
new file mode 100644
index 00000000000..66f59010649
--- /dev/null
+++ b/libstdc++-v3/config/os/bsd/darwin/ctype_base.h
@@ -0,0 +1,77 @@
+// APPLE LOCAL file darwin-specific headers
+// Locale support -*- C++ -*-
+
+// Copyright (C) 2000 Free Software Foundation, Inc.
+//
+// This file is part of the GNU ISO C++ Library. This library is free
+// software; you can redistribute it and/or modify it under the
+// terms of the GNU General Public License as published by the
+// Free Software Foundation; either version 2, or (at your option)
+// any later version.
+
+// This library is distributed in the hope that it will be useful,
+// but WITHOUT ANY WARRANTY; without even the implied warranty of
+// MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+// GNU General Public License for more details.
+
+// You should have received a copy of the GNU General Public License along
+// with this library; see the file COPYING. If not, write to the Free
+// Software Foundation, 59 Temple Place - Suite 330, Boston, MA 02111-1307,
+// USA.
+
+// As a special exception, you may use this file as part of a free software
+// library without restriction. Specifically, if other files instantiate
+// templates or use macros or inline functions from this file, or you compile
+// this file and link it with other files to produce an executable, this
+// file does not by itself cause the resulting executable to be covered by
+// the GNU General Public License. This exception does not however
+// invalidate any other reasons why the executable file might be covered by
+// the GNU General Public License.
+
+//
+// ISO C++ 14882: 22.1 Locales
+//
+
+// Information as gleaned from /usr/include/ctype.h on FreeBSD 3.4,
+// 4.0 and all versions of the CVS managed file at:
+// :pserver:anoncvs@anoncvs.freebsd.org:/home/ncvs/src/include/ctype.h
+
+ struct ctype_base
+ {
+ // Non-standard typedefs.
+ typedef const int* __to_type;
+
+ // NB: Offsets into ctype<char>::_M_table force a particular size
+ // on the mask type. Because of this, we don't use an enum.
+ typedef unsigned long mask;
+#ifdef _CTYPE_S
+ // FreeBSD 4.0 uses this style of define.
+ static const mask upper = _CTYPE_U;
+ static const mask lower = _CTYPE_L;
+ static const mask alpha = _CTYPE_A;
+ static const mask digit = _CTYPE_D;
+ static const mask xdigit = _CTYPE_X;
+ static const mask space = _CTYPE_S;
+ static const mask print = _CTYPE_R;
+ static const mask graph = _CTYPE_G;
+ static const mask cntrl = _CTYPE_C;
+ static const mask punct = _CTYPE_P;
+ static const mask alnum = _CTYPE_A | _CTYPE_D;
+#else
+ // Older versions, including Free BSD 3.4, use this style of define.
+ static const mask upper = _U;
+ static const mask lower = _L;
+ static const mask alpha = _A;
+ static const mask digit = _D;
+ static const mask xdigit = _X;
+ static const mask space = _S;
+ static const mask print = _R;
+ static const mask graph = _G;
+ static const mask cntrl = _C;
+ static const mask punct = _P;
+ static const mask alnum = _A | _D;
+#endif
+ };
+
+
+
diff --git a/libstdc++-v3/config/os/bsd/darwin/ctype_inline.h b/libstdc++-v3/config/os/bsd/darwin/ctype_inline.h
new file mode 100644
index 00000000000..ea8e93539f3
--- /dev/null
+++ b/libstdc++-v3/config/os/bsd/darwin/ctype_inline.h
@@ -0,0 +1,95 @@
+// APPLE LOCAL file darwin-specific headers
+// Locale support -*- C++ -*-
+
+// Copyright (C) 2000 Free Software Foundation, Inc.
+//
+// This file is part of the GNU ISO C++ Library. This library is free
+// software; you can redistribute it and/or modify it under the
+// terms of the GNU General Public License as published by the
+// Free Software Foundation; either version 2, or (at your option)
+// any later version.
+
+// This library is distributed in the hope that it will be useful,
+// but WITHOUT ANY WARRANTY; without even the implied warranty of
+// MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+// GNU General Public License for more details.
+
+// You should have received a copy of the GNU General Public License along
+// with this library; see the file COPYING. If not, write to the Free
+// Software Foundation, 59 Temple Place - Suite 330, Boston, MA 02111-1307,
+// USA.
+
+// As a special exception, you may use this file as part of a free software
+// library without restriction. Specifically, if other files instantiate
+// templates or use macros or inline functions from this file, or you compile
+// this file and link it with other files to produce an executable, this
+// file does not by itself cause the resulting executable to be covered by
+// the GNU General Public License. This exception does not however
+// invalidate any other reasons why the executable file might be covered by
+// the GNU General Public License.
+
+//
+// ISO C++ 14882: 22.1 Locales
+//
+
+// ctype bits to be inlined go here. Non-inlinable (ie virtual do_*)
+// functions go in ctype.cc
+
+ bool
+ ctype<char>::
+ is(mask __m, char __c) const
+ {
+ return __istype(__c, __m);
+ }
+
+ const char*
+ ctype<char>::
+ is(const char* __low, const char* __high, mask* __vec) const
+ {
+ for (;__low < __high; ++__vec, ++__low)
+ {
+#if defined (_CTYPE_S) || defined (__istype)
+ *__vec = __maskrune (*__low, upper | lower | alpha | digit | xdigit
+ | space | print | graph | cntrl | punct | alnum);
+#else
+ mask __m = 0;
+ if (this->is(upper, *__low)) __m |= upper;
+ if (this->is(lower, *__low)) __m |= lower;
+ if (this->is(alpha, *__low)) __m |= alpha;
+ if (this->is(digit, *__low)) __m |= digit;
+ if (this->is(xdigit, *__low)) __m |= xdigit;
+ if (this->is(space, *__low)) __m |= space;
+ if (this->is(print, *__low)) __m |= print;
+ if (this->is(graph, *__low)) __m |= graph;
+ if (this->is(cntrl, *__low)) __m |= cntrl;
+ if (this->is(punct, *__low)) __m |= punct;
+ // Do not include explicit line for alnum mask since it is a
+ // pure composite of masks on FreeBSD.
+ *__vec = __m;
+#endif
+ }
+ return __high;
+ }
+
+ const char*
+ ctype<char>::
+ scan_is(mask __m, const char* __low, const char* __high) const
+ {
+ while (__low < __high && !this->is(__m, *__low))
+ ++__low;
+ return __low;
+ }
+
+ const char*
+ ctype<char>::
+ scan_not(mask __m, const char* __low, const char* __high) const
+ {
+ while (__low < __high && this->is(__m, *__low) != 0)
+ ++__low;
+ return __low;
+ }
+
+
+
+
+
diff --git a/libstdc++-v3/config/os/bsd/darwin/ctype_noninline.h b/libstdc++-v3/config/os/bsd/darwin/ctype_noninline.h
new file mode 100644
index 00000000000..34bbe5cb2c7
--- /dev/null
+++ b/libstdc++-v3/config/os/bsd/darwin/ctype_noninline.h
@@ -0,0 +1,82 @@
+// APPLE LOCAL file darwin-specific headers
+// Locale support -*- C++ -*-
+
+// Copyright (C) 2000, 2001, 2002 Free Software Foundation, Inc.
+//
+// This file is part of the GNU ISO C++ Library. This library is free
+// software; you can redistribute it and/or modify it under the
+// terms of the GNU General Public License as published by the
+// Free Software Foundation; either version 2, or (at your option)
+// any later version.
+
+// This library is distributed in the hope that it will be useful,
+// but WITHOUT ANY WARRANTY; without even the implied warranty of
+// MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+// GNU General Public License for more details.
+
+// You should have received a copy of the GNU General Public License along
+// with this library; see the file COPYING. If not, write to the Free
+// Software Foundation, 59 Temple Place - Suite 330, Boston, MA 02111-1307,
+// USA.
+
+// As a special exception, you may use this file as part of a free software
+// library without restriction. Specifically, if other files instantiate
+// templates or use macros or inline functions from this file, or you compile
+// this file and link it with other files to produce an executable, this
+// file does not by itself cause the resulting executable to be covered by
+// the GNU General Public License. This exception does not however
+// invalidate any other reasons why the executable file might be covered by
+// the GNU General Public License.
+
+//
+// ISO C++ 14882: 22.1 Locales
+//
+
+// Information as gleaned from /usr/include/ctype.h
+
+ const ctype_base::mask*
+ ctype<char>::classic_table() throw()
+ { return 0; }
+
+ ctype<char>::ctype(__c_locale, const mask* __table, bool __del,
+ size_t __refs)
+ : __ctype_abstract_base<char>(__refs), _M_del(__table != 0 && __del),
+ _M_toupper(NULL), _M_tolower(NULL),
+ _M_table(__table ? __table : classic_table())
+ { }
+
+ ctype<char>::ctype(const mask* __table, bool __del, size_t __refs)
+ : __ctype_abstract_base<char>(__refs), _M_del(__table != 0 && __del),
+ _M_toupper(NULL), _M_tolower(NULL),
+ _M_table(__table ? __table : classic_table())
+ { }
+
+ char
+ ctype<char>::do_toupper(char __c) const
+ { return ::toupper((int) __c); }
+
+ const char*
+ ctype<char>::do_toupper(char* __low, const char* __high) const
+ {
+ while (__low < __high)
+ {
+ *__low = ::toupper((int) *__low);
+ ++__low;
+ }
+ return __high;
+ }
+
+ char
+ ctype<char>::do_tolower(char __c) const
+ { return ::tolower((int) __c); }
+
+ const char*
+ ctype<char>::do_tolower(char* __low, const char* __high) const
+ {
+ while (__low < __high)
+ {
+ *__low = ::tolower((int) *__low);
+ ++__low;
+ }
+ return __high;
+ }
diff --git a/libstdc++-v3/config/os/bsd/darwin/os_defines.h b/libstdc++-v3/config/os/bsd/darwin/os_defines.h
new file mode 100644
index 00000000000..6a006e30217
--- /dev/null
+++ b/libstdc++-v3/config/os/bsd/darwin/os_defines.h
@@ -0,0 +1,161 @@
+// APPLE LOCAL file darwin-specific headers
+// Specific definitions for BSD -*- C++ -*-
+
+// Copyright (C) 2000 Free Software Foundation, Inc.
+//
+// This file is part of the GNU ISO C++ Library. This library is free
+// software; you can redistribute it and/or modify it under the
+// terms of the GNU General Public License as published by the
+// Free Software Foundation; either version 2, or (at your option)
+// any later version.
+
+// This library is distributed in the hope that it will be useful,
+// but WITHOUT ANY WARRANTY; without even the implied warranty of
+// MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+// GNU General Public License for more details.
+
+// You should have received a copy of the GNU General Public License along
+// with this library; see the file COPYING. If not, write to the Free
+// Software Foundation, 59 Temple Place - Suite 330, Boston, MA 02111-1307,
+// USA.
+
+// As a special exception, you may use this file as part of a free software
+// library without restriction. Specifically, if other files instantiate
+// templates or use macros or inline functions from this file, or you compile
+// this file and link it with other files to produce an executable, this
+// file does not by itself cause the resulting executable to be covered by
+// the GNU General Public License. This exception does not however
+// invalidate any other reasons why the executable file might be covered by
+// the GNU General Public License.
+
+
+#ifndef _GLIBCPP_OS_DEFINES
+#define _GLIBCPP_OS_DEFINES 1
+
+// System-specific #define, typedefs, corrections, etc, go here. This
+// file will come before all others.
+
+#define __glibcpp_long_double_bits __glibcpp_double_bits
+
+#define _GLIBCPP_AVOID_FSEEK 1
+
+/* APPLE LOCAL begin keymgr */
+/* Copyright (C) 1989, 92-97, 1998, Free Software Foundation, Inc.
+
+This file is part of GNU CC.
+
+GNU CC is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2, or (at your option)
+any later version.
+
+GNU CC is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+GNU General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with GNU CC; see the file COPYING. If not, write to
+the Free Software Foundation, 59 Temple Place - Suite 330,
+Boston, MA 02111-1307, USA. */
+
+
+/*
+ * This file added by Apple Computer Inc. for its OS X
+ * environment.
+ */
+
+#ifndef __KEYMGR_H
+#define __KEYMGR_H
+
+#ifdef __cplusplus
+extern "C" {
+#endif
+
+
+
+/*
+ * keymgr - Create and maintain process-wide global data known to
+ * all threads across all dynamic libraries.
+ *
+ */
+
+typedef enum node_kinds {
+ NODE_THREAD_SPECIFIC_DATA=1,
+ NODE_PROCESSWIDE_PTR=2,
+ NODE_LAST_KIND
+ } TnodeKind ;
+
+/*
+ * These enum members are bits or combination of bits.
+ */
+
+typedef enum node_mode {
+ NM_ALLOW_RECURSION=1,
+ NM_RECURSION_ILLEGAL=2,
+ NM_ENHANCED_LOCKING=3,
+ NM_LOCKED=4
+ } TnodeMode ;
+
+
+
+extern void * _keymgr_get_per_thread_data(unsigned int key) ;
+extern void _keymgr_set_per_thread_data(unsigned int key, void *keydata) ;
+extern void *_keymgr_get_and_lock_processwide_ptr(unsigned int key) ;
+extern void _keymgr_set_and_unlock_processwide_ptr(unsigned int key, void *ptr) ;
+extern void _keymgr_unlock_processwide_ptr(unsigned int key) ;
+extern void _keymgr_set_lockmode_processwide_ptr(unsigned int key, unsigned int mode) ;
+extern unsigned int _keymgr_get_lockmode_processwide_ptr(unsigned int key) ;
+extern int _keymgr_get_lock_count_processwide_ptr(unsigned int key) ;
+
+#ifndef NULL
+#define NULL (0)
+#endif
+
+/*
+ * Keys currently in use:
+ */
+
+#define KEYMGR_EH_CONTEXT_KEY 1 /*stores handle for root pointer of exception context node.*/
+
+#define KEYMGR_NEW_HANLDER_KEY 2 /*store handle for new handler pointer.*/
+
+#define KEYMGR_UNEXPECTED_HANDLER_KEY 3 /*store handle for unexpected exception pointer.*/
+
+#define KEYMGR_TERMINATE_HANDLER_KEY 4 /*store handle for terminate handler pointer. */
+
+#define KEYMGR_MODE_BITS 5 /*stores handle for runtime mode bits.*/
+
+#define KEYMGR_IO_LIST 6 /*Root pointer to the list of open streams.*/
+
+#define KEYMGR_IO_STDIN 7 /*GNU stdin.*/
+
+#define KEYMGR_IO_STDOUT 8 /*GNU stdout.*/
+
+#define KEYMGR_IO_STDERR 9 /*GNU stderr.*/
+
+#define KEYMGR_IO_REFCNT 10 /*How many plugins/main program currently using streams.*/
+
+#define KEYMGR_IO_MODE_BITS 11 /*Flags controlling the behavior of C++ I/O.*/
+
+#define KEYMGR_ZOE_IMAGE_LIST 12 /*Head pointer for list of per image dwarf2 unwind sections.*/
+
+
+
+/*
+ * Other important data.
+ */
+
+#define KEYMGR_API_REV_MAJOR 2 /*Major revision number of the keymgr API.*/
+#define KEYMGR_API_REV_MINOR 1 /*Minor revision number of the keymgr API.*/
+
+
+
+#ifdef __cplusplus
+}
+#endif
+
+#endif /* __KEYMGR_H */
+/* APPLE LOCAL end keymgr */
+
+#endif /* _GLIBCPP_OS_DEFINES */
diff --git a/libstdc++-v3/docs/html/ext/ballocator_doc.txt b/libstdc++-v3/docs/html/ext/ballocator_doc.txt
deleted file mode 100644
index 2173b618f4f..00000000000
--- a/libstdc++-v3/docs/html/ext/ballocator_doc.txt
+++ /dev/null
@@ -1,374 +0,0 @@
- BITMAPPED ALLOCATOR
- ===================
-
-2004-03-11 Dhruv Matani <dhruvbird@HotPOP.com>
-
----------------------------------------------------------------------
-
-As this name suggests, this allocator uses a bit-map to keep track of
-the used and unused memory locations for it's book-keeping purposes.
-
-This allocator will make use of 1 single bit to keep track of whether
-it has been allocated or not. A bit 1 indicates free, while 0
-indicates allocated. This has been done so that you can easily check a
-collection of bits for a free block. This kind of Bitmapped strategy
-works best for single object allocations, and with the STL type
-parameterized allocators, we do not need to choose any size for the
-block which will be represented by a single bit. This will be the size
-of the parameter around which the allocator has been
-parameterized. Thus, close to optimal performance will result. Hence,
-this should be used for node based containers which call the allocate
-function with an argument of 1.
-
-The bitmapped allocator's internal pool is exponentially
-growing. Meaning that internally, the blocks acquired from the Free
-List Store will double every time the bitmapped allocator runs out of
-memory.
-
---------------------------------------------------------------------
-
-The macro __GTHREADS decides whether to use Mutex Protection around
-every allocation/deallocation. The state of the macro is picked up
-automatically from the gthr abstration layer.
-
-----------------------------------------------------------------------
-
-What is the Free List Store?
-----------------------------
-
-The Free List Store (referred to as FLS for the remaining part of this
-document) is the Global memory pool that is shared by all instances of
-the bitmapped allocator instantiated for any type. This maintains a
-sorted order of all free memory blocks given back to it by the
-bitmapped allocator, and is also responsible for giving memory to the
-bitmapped allocator when it asks for more.
-
-Internally, there is a Free List threshold which indicates the Maximum
-number of free lists that the FLS can hold internally
-(cache). Currently, this value is set at 64. So, if there are more
-than 64 free lists coming in, then some of them will be given back to
-the OS using operator delete so that at any given time the Free List's
-size does not exceed 64 entries. This is done because a Binary Search
-is used to locate an entry in a free list when a request for memory
-comes along. Thus, the run-time complexity of the search would go up
-given an increasing size, for 64 entries however, lg(64) == 6
-comparisons are enough to locate the correct free list if it exists.
-
-Suppose the free list size has reached it's threshold, then the
-largest block from among those in the list and the new block will be
-selected and given back to the OS. This is done because it reduces
-external fragmentation, and allows the OS to use the larger blocks
-later in an orderly fashion, possibly merging them later. Also, on
-some systems, large blocks are obtained via calls to mmap, so giving
-them back to free system resources becomes most important.
-
-The function _S_should_i_give decides the policy that determines
-whether the current block of memory should be given to the allocator
-for the request that it has made. That's because we may not always
-have exact fits for the memory size that the allocator requests. We do
-this mainly to prevent external fragmentation at the cost of a little
-internal fragmentation. Now, the value of this internal fragmentation
-has to be decided by this function. I can see 3 possibilities right
-now. Please add more as and when you find better strategies.
-
-1. Equal size check. Return true only when the 2 blocks are of equal
- size.
-
-2. Difference Threshold: Return true only when the _block_size is
- greater than or equal to the _required_size, and if the _BS is >
- _RS by a difference of less than some THRESHOLD value, then return
- true, else return false.
-
-3. Percentage Threshold. Return true only when the _block_size is
- greater than or equal to the _required_size, and if the _BS is >
- _RS by a percentage of less than some THRESHOLD value, then return
- true, else return false.
-
-Currently, (3) is being used with a value of 36% Maximum wastage per
-Super Block.
-
---------------------------------------------------------------------
-
-1) What is a super block? Why is it needed?
-
- A super block is the block of memory acquired from the FLS from
- which the bitmap allocator carves out memory for single objects and
- satisfies the user's requests. These super blocks come in sizes that
- are powers of 2 and multiples of 32 (_Bits_Per_Block). Yes both at
- the same time! That's because the next super block acquired will be
- 2 times the previous one, and also all super blocks have to be
- multiples of the _Bits_Per_Block value.
-
-2) How does it interact with the free list store?
-
- The super block is contained in the FLS, and the FLS is responsible
- for getting / returning Super Bocks to and from the OS using
- operator new as defined by the C++ standard.
-
----------------------------------------------------------------------
-
-How does the allocate function Work?
-------------------------------------
-
-The allocate function is specialized for single object allocation
-ONLY. Thus, ONLY if n == 1, will the bitmap_allocator's specialized
-algorithm be used. Otherwise, the request is satisfied directly by
-calling operator new.
-
-Suppose n == 1, then the allocator does the following:
-
-1. Checks to see whether the a free block exists somewhere in a region
- of memory close to the last satisfied request. If so, then that
- block is marked as allocated in the bit map and given to the
- user. If not, then (2) is executed.
-
-2. Is there a free block anywhere after the current block right upto
- the end of the memory that we have? If so, that block is found, and
- the same procedure is applied as above, and returned to the
- user. If not, then (3) is executed.
-
-3. Is there any block in whatever region of memory that we own free?
- This is done by checking (a) The use count for each super block,
- and if that fails then (b) The individual bit-maps for each super
- block. Note: Here we are never touching any of the memory that the
- user will be given, and we are confining all memory accesses to a
- small region of memory! This helps reduce cache misses. If this
- succeeds then we apply the same procedure on that bit-map as (1),
- and return that block of memory to the user. However, if this
- process fails, then we resort to (4).
-
-4. This process involves Refilling the internal exponentially growing
- memory pool. The said effect is achieved by calling _S_refill_pool
- which does the following:
- (a). Gets more memory from the Global Free List of the
- Required size.
- (b). Adjusts the size for the next call to itself.
- (c). Writes the appropriate headers in the bit-maps.
- (d). Sets the use count for that super-block just allocated
- to 0 (zero).
- (e). All of the above accounts to maintaining the basic
- invariant for the allocator. If the invariant is
- maintained, we are sure that all is well.
- Now, the same process is applied on the newly acquired free blocks,
- which are dispatched accordingly.
-
-Thus, you can clearly see that the allocate function is nothing but a
-combination of the next-fit and first-fit algorithm optimized ONLY for
-single object allocations.
-
-
--------------------------------------------------------------------------
-
-How does the deallocate function work?
---------------------------------------
-
-The deallocate function again is specialized for single objects ONLY.
-For all n belonging to > 1, the operator delete is called without
-further ado, and the deallocate function returns.
-
-However for n == 1, a series of steps are performed:
-
-1. We first need to locate that super-block which holds the memory
- location given to us by the user. For that purpose, we maintain a
- static variable _S_last_dealloc_index, which holds the index into
- the vector of block pairs which indicates the index of the last
- super-block from which memory was freed. We use this strategy in
- the hope that the user will deallocate memory in a region close to
- what he/she deallocated the last time around. If the check for
- belongs_to succeeds, then we determine the bit-map for the given
- pointer, and locate the index into that bit-map, and mark that bit
- as free by setting it.
-
-2. If the _S_last_dealloc_index does not point to the memory block
- that we're looking for, then we do a linear search on the block
- stored in the vector of Block Pairs. This vector in code is called
- _S_mem_blocks. When the corresponding super-block is found, we
- apply the same procedure as we did for (1) to mark the block as
- free in the bit-map.
-
-Now, whenever a block is freed, the use count of that particular super
-block goes down by 1. When this use count hits 0, we remove that super
-block from the list of all valid super blocks stored in the
-vector. While doing this, we also make sure that the basic invariant
-is maintained by making sure that _S_last_request and
-_S_last_dealloc_index point to valid locations within the vector.
-
---------------------------------------------------------------------
-
-
-Data Layout for a Super Block:
-==============================
-
-Each Super Block will be of some size that is a multiple of the number
-of Bits Per Block. Typically, this value is chosen as Bits_Per_Byte X
-sizeof(unsigned int). On an X86 system, this gives the figure
-8 X 4 = 32. Thus, each Super Block will be of size 32 X Some_Value.
-This Some_Value is sizeof(value_type). For now, let it be called 'K'.
-Thus, finally, Super Block size is 32 X K bytes.
-
-This value of 32 has been chosen because each unsigned int has 32-bits
-and Maximum use of these can be made with such a figure.
-
-Consider a block of size 32 ints.
-In memory, it would look like this:
-
----------------------------------------------------------------------
-| 136 | 0 | 4294967295 | Data-> Space for 32-ints |
----------------------------------------------------------------------
-
-The first Columns represents the size of the Block in bytes as seen by
-the Bitmap Allocator. Internally, a global free list is used to keep
-track of the free blocks used and given back by the bitmap
-allocator. It is this Free List Store that is responsible for writing
-and managing this information. Actually the number of bytes allocated
-in this case would be: 4 + 4 + 4 + 32*4 = 140 bytes, but the first 4
-bytes are an addition by the Free List Store, so the Bitmap Allocator
-sees only 136 bytes. These first 4 bytes about which the bitmapped
-allocator is not aware hold the value 136.
-
-What do the remaining values represent?
----------------------------------------
-
-The 2nd 4 in the expression is the sizeof(unsigned int) because the
-Bitmapped Allocator maintains a used count for each Super Block, which
-is initially set to 0 (as indicated in the diagram). This is
-incremented every time a block is removed from this super block
-(allocated), and decremented whenever it is given back. So, when the
-used count falls to 0, the whole super block will be given back to the
-Free List Store.
-
-The value 4294967295 represents the integer corresponding to the
-bit representation of all bits set: 11111111111111111111111111111111.
-
-The 3rd 4 is size of the bitmap itself, which is the size of 32-bits,
-which is 4-bytes, or 1 X sizeof(unsigned int).
-
-
---------------------------------------------------------------------
-
-Another issue would be whether to keep the all bitmaps in a separate
-area in memory, or to keep them near the actual blocks that will be
-given out or allocated for the client. After some testing, I've
-decided to keep these bitmaps close to the actual blocks. this will
-help in 2 ways.
-
-1. Constant time access for the bitmap themselves, since no kind of
- look up will be needed to find the correct bitmap list or it's
- equivalent.
-
-2. And also this would preserve the cache as far as possible.
-
-So in effect, this kind of an allocator might prove beneficial from a
-purely cache point of view. But this allocator has been made to try
-and roll out the defects of the node_allocator, wherein the nodes get
-skewed about in memory, if they are not returned in the exact reverse
-order or in the same order in which they were allocated. Also, the
-new_allocator's book keeping overhead is too much for small objects
-and single object allocations, though it preserves the locality of
-blocks very well when they are returned back to the allocator.
-
--------------------------------------------------------------------
-
-Expected overhead per block would be 1 bit in memory. Also, once
-the address of the free list has been found, the cost for
-allocation/deallocation would be negligible, and is supposed to be
-constant time. For these very reasons, it is very important to
-minimize the linear time costs, which include finding a free list
-with a free block while allocating, and finding the corresponding
-free list for a block while deallocating. Therefore, I have decided
-that the growth of the internal pool for this allocator will be
-exponential as compared to linear for node_allocator. There, linear
-time works well, because we are mainly concerned with speed of
-allocation/deallocation and memory consumption, whereas here, the
-allocation/deallocation part does have some linear/logarithmic
-complexity components in it. Thus, to try and minimize them would
-be a good thing to do at the cost of a little bit of memory.
-
-Another thing to be noted is the the pool size will double every time
-the internal pool gets exhausted, and all the free blocks have been
-given away. The initial size of the pool would be sizeof(unsigned
-int)*8 which is the number of bits in an integer, which can fit
-exactly in a CPU register. Hence, the term given is exponential growth
-of the internal pool.
-
----------------------------------------------------------------------
-
-After reading all this, you may still have a few questions about the
-internal working of this allocator, like my friend had!
-
-Well here are the exact questions that he posed:
-
-1) The "Data Layout" section is cryptic. I have no idea of what you
- are trying to say. Layout of what? The free-list? Each bitmap? The
- Super Block?
-
- The layout of a Super Block of a given size. In the example, a super
- block of size 32 X 1 is taken. The general formula for calculating
- the size of a super block is 32*sizeof(value_type)*2^n, where n
- ranges from 0 to 32 for 32-bit systems.
-
-2) And since I just mentioned the term `each bitmap', what in the
- world is meant by it? What does each bitmap manage? How does it
- relate to the super block? Is the Super Block a bitmap as well?
-
- Good question! Each bitmap is part of a Super Block which is made up
- of 3 parts as I have mentioned earlier. Re-iterating, 1. The use
- count, 2. The bit-map for that Super Block. 3. The actual memory
- that will be eventually given to the user. Each bitmap is a multiple
- of 32 in size. If there are 32*(2^3) blocks of single objects to be
- given, there will be '32*(2^3)' bits present. Each 32 bits managing
- the allocated / free status for 32 blocks. Since each unsigned int
- contains 32-bits, one unsigned int can manage upto 32 blocks'
- status. Each bit-map is made up of a number of unsigned ints, whose
- exact number for a super-block of a given size I have just
- mentioned.
-
-3) How do the allocate and deallocate functions work in regard to
- bitmaps?
-
- The allocate and deallocate functions manipulate the bitmaps and have
- nothing to do with the memory that is given to the user. As I have
- earlier mentioned, a 1 in the bitmap's bit field indicates free,
- while a 0 indicates allocated. This lets us check 32 bits at a time
- to check whether there is at lease one free block in those 32 blocks
- by testing for equality with (0). Now, the allocate function will
- given a memory block find the corresponding bit in the bitmap, and
- will reset it (ie. make it re-set (0)). And when the deallocate
- function is called, it will again set that bit after locating it to
- indicate that that particular block corresponding to this bit in the
- bit-map is not being used by anyone, and may be used to satisfy
- future requests.
-
-----------------------------------------------------------------------
-
-(Tech-Stuff, Please stay out if you are not interested in the
-selection of certain constants. This has nothing to do with the
-algorithm per-se, only with some vales that must be chosen correctly
-to ensure that the allocator performs well in a real word scenario,
-and maintains a good balance between the memory consumption and the
-allocation/deallocation speed).
-
-The formula for calculating the maximum wastage as a percentage:
-
-(32 X k + 1) / (2 X (32 X k + 1 + 32 X c)) X 100.
-
-Where,
- k => The constant overhead per node. eg. for list, it is 8
- bytes, and for map it is 12 bytes.
- c => The size of the base type on which the map/list is
- instantiated. Thus, suppose the the type1 is int and type2 is
- double, they are related by the relation sizeof(double) ==
- 2*sizeof(int). Thus, all types must have this double size
- relation for this formula to work properly.
-
-Plugging-in: For List: k = 8 and c = 4 (int and double), we get:
-33.376%
-
-For map/multimap: k = 12, and c = 4 (int and double), we get:
-37.524%
-
-Thus, knowing these values, and based on the sizeof(value_type), we
-may create a function that returns the Max_Wastage_Percentage for us
-to use.
-
-
diff --git a/libstdc++-v3/include/c_std/std_cctype.h b/libstdc++-v3/include/c_std/std_cctype.h
index 65a4214657c..b6151c308f4 100644
--- a/libstdc++-v3/include/c_std/std_cctype.h
+++ b/libstdc++-v3/include/c_std/std_cctype.h
@@ -63,6 +63,27 @@
#undef tolower
#undef toupper
+/* APPLE LOCAL begin supply missing ctype.h decls 2001-07-11 sts */
+/* These are supposed be in ctype.h like the standard says! We need
+ this until Darwin ctype.h gets fixed and/or GCC has a fixincludes
+ to supply these if they're missing. */
+#if defined(__APPLE__) && defined(__MACH__)
+extern "C" {
+extern int isalnum(int c);
+extern int isalpha(int c);
+extern int iscntrl(int c);
+extern int isdigit(int c);
+extern int isgraph(int c);
+extern int islower(int c);
+extern int isprint(int c);
+extern int ispunct(int c);
+extern int isspace(int c);
+extern int isupper(int c);
+extern int isxdigit(int c);
+}
+#endif
+/* APPLE LOCAL end supply missing ctype.h decls 2001-07-11 sts */
+
namespace std
{
using ::isalnum;
diff --git a/libstdc++-v3/libsupc++/eh_alloc.cc b/libstdc++-v3/libsupc++/eh_alloc.cc
index f4ba9701d2c..ba6719aac33 100644
--- a/libstdc++-v3/libsupc++/eh_alloc.cc
+++ b/libstdc++-v3/libsupc++/eh_alloc.cc
@@ -64,6 +64,14 @@ using namespace __cxxabiv1;
# define EMERGENCY_OBJ_COUNT 4
#endif
+/* APPLE LOCAL begin reduce emergency buffer size */
+/* 256 bytes is more than large enough for an std::bad_alloc object */
+#undef EMERGENCY_OBJ_SIZE
+#undef EMERGENCY_OBJ_COUNT
+#define EMERGENCY_OBJ_SIZE 256
+#define EMERGENCY_OBJ_COUNT 2
+/* APPLE LOCAL end reduce emergency buffer size */
+
#if INT_MAX == 32767 || EMERGENCY_OBJ_COUNT <= 32
typedef unsigned int bitmask_type;
#else
diff --git a/libstdc++-v3/libsupc++/eh_terminate.cc b/libstdc++-v3/libsupc++/eh_terminate.cc
index bf9d74db116..e8c30c470e4 100644
--- a/libstdc++-v3/libsupc++/eh_terminate.cc
+++ b/libstdc++-v3/libsupc++/eh_terminate.cc
@@ -34,6 +34,12 @@
#include "unwind-cxx.h"
#include "exception_defines.h"
+/* APPLE LOCAL begin keymgr */
+#if defined(APPLE_KEYMGR) && ! defined(APPLE_KERNEL_EXTENSION) && ! defined(LIBCC_KEXT)
+#include "bits/os_defines.h"
+#endif
+/* APPLE LOCAL end keymgr */
+
using namespace __cxxabiv1;
void
@@ -50,7 +56,19 @@ __cxxabiv1::__terminate (std::terminate_handler handler)
void
std::terminate ()
{
+ /* APPLE LOCAL begin keymgr */
+#if defined(APPLE_KEYMGR) && ! defined(APPLE_KERNEL_EXTENSION) && ! defined(LIBCC_KEXT)
+ /*
+ * If the Key Manager has a terminate function assigned to this thread, invoke that fn.
+ * If not (KeyMgr has 0), use whatever is initialized into my local static pointer (above).
+ */
+ std::terminate_handler __keymgr_terminate_func = (std::terminate_handler)
+ _keymgr_get_per_thread_data (KEYMGR_TERMINATE_HANDLER_KEY);
+ if (__keymgr_terminate_func)
+ __terminate_handler = __keymgr_terminate_func;
+#endif /* APPLE_KEYMGR */
__terminate (__terminate_handler);
+ /* APPLE LOCAL end keymgr */
}
void
@@ -63,13 +81,32 @@ __cxxabiv1::__unexpected (std::unexpected_handler handler)
void
std::unexpected ()
{
+ /* APPLE LOCAL begin keymgr */
+#if defined(APPLE_KEYMGR) && ! defined(APPLE_KERNEL_EXTENSION) && ! defined(LIBCC_KEXT)
+ /* Similar to terminate case above. */
+ std::unexpected_handler __keymgr_unexpected_func = (std::unexpected_handler)
+ _keymgr_get_per_thread_data (KEYMGR_UNEXPECTED_HANDLER_KEY);
+ if (__keymgr_unexpected_func)
+ __unexpected_handler = __keymgr_unexpected_func;
+#endif /* APPLE_KEYMGR */
+ /* APPLE LOCAL end keymgr */
__unexpected (__unexpected_handler);
}
std::terminate_handler
std::set_terminate (std::terminate_handler func) throw()
{
+ /* APPLE LOCAL begin keymgr */
+#if defined(APPLE_KEYMGR) && ! defined(APPLE_KERNEL_EXTENSION) && ! defined(LIBCC_KEXT)
+ std::terminate_handler old =
+ (std::terminate_handler) _keymgr_get_per_thread_data (KEYMGR_TERMINATE_HANDLER_KEY);
+ _keymgr_set_per_thread_data (KEYMGR_TERMINATE_HANDLER_KEY, (void *) func) ;
+ if ( ! old)
+ old = __terminate_handler;
+#else
std::terminate_handler old = __terminate_handler;
+#endif /* APPLE_KEYMGR */
+ /* APPLE LOCAL end keymgr */
__terminate_handler = func;
return old;
}
@@ -77,7 +114,17 @@ std::set_terminate (std::terminate_handler func) throw()
std::unexpected_handler
std::set_unexpected (std::unexpected_handler func) throw()
{
+ /* APPLE LOCAL begin keymgr */
+#if defined(APPLE_KEYMGR) && ! defined(APPLE_KERNEL_EXTENSION) && ! defined(LIBCC_KEXT)
+ std::unexpected_handler old =
+ (std::unexpected_handler) _keymgr_get_per_thread_data (KEYMGR_UNEXPECTED_HANDLER_KEY);
+ _keymgr_set_per_thread_data (KEYMGR_UNEXPECTED_HANDLER_KEY, (void *) func);
+ if ( ! old)
+ old = __unexpected_handler;
+#else
std::unexpected_handler old = __unexpected_handler;
+#endif /* APPLE_KEYMGR */
+ /* APPLE LOCAL end keymgr */
__unexpected_handler = func;
return old;
}
diff --git a/libstdc++-v3/libsupc++/new_handler.cc b/libstdc++-v3/libsupc++/new_handler.cc
index 2f9f6bd3579..bffb3d80a63 100644
--- a/libstdc++-v3/libsupc++/new_handler.cc
+++ b/libstdc++-v3/libsupc++/new_handler.cc
@@ -31,6 +31,12 @@
#include "new"
+/* APPLE LOCAL begin keymgr */
+#if defined APPLE_KEYMGR && ! defined(LIBCC_KEXT) && ! defined(APPLE_KERNEL_EXTENSION)
+#include "bits/os_defines.h"
+#endif
+/* APPLE LOCAL end keymgr */
+
const std::nothrow_t std::nothrow = { };
using std::new_handler;
@@ -39,9 +45,19 @@ new_handler __new_handler;
new_handler
std::set_new_handler (new_handler handler) throw()
{
+#if defined(APPLE_KEYMGR) && ! defined(APPLE_KERNEL_EXTENSION) && ! defined(LIBCC_KEXT)
+ new_handler prev_handler =
+ (new_handler) _keymgr_get_per_thread_data (KEYMGR_NEW_HANLDER_KEY);
+ if ( ! prev_handler)
+ prev_handler = __new_handler;
+ _keymgr_set_per_thread_data (KEYMGR_NEW_HANLDER_KEY, (void *) handler);
+#else /* ! APPLE_KEYMGR */
new_handler prev_handler = __new_handler;
+#endif /* APPLE_KEYMGR */
__new_handler = handler;
return prev_handler;
}
+#if !defined(LIBCC_KEXT)
std::bad_alloc::~bad_alloc() throw() { }
+#endif
diff --git a/libstdc++-v3/libsupc++/new_op.cc b/libstdc++-v3/libsupc++/new_op.cc
index 29eac93ecf0..10f65c10adc 100644
--- a/libstdc++-v3/libsupc++/new_op.cc
+++ b/libstdc++-v3/libsupc++/new_op.cc
@@ -28,12 +28,27 @@
// the GNU General Public License.
#include "new"
+/* APPLE LOCAL begin libcc_kext */
+#ifdef LIBCC_KEXT
+extern "C" {
+extern void *malloc (size_t);
+extern int panic ();
+}
+#define ABORT() panic ()
+#else
#include <cstdlib>
+#define ABORT() std::abort ()
+#endif
+/* APPLE LOCAL end libcc_kext */
#include <exception_defines.h>
using std::new_handler;
using std::bad_alloc;
+/* APPLE LOCAL libcc_kext */
+#ifndef LIBCC_KEXT
using std::malloc;
+/* APPLE LOCAL libcc_kext */
+#endif
extern new_handler __new_handler;
@@ -48,12 +63,21 @@ operator new (std::size_t sz) throw (std::bad_alloc)
p = (void *) malloc (sz);
while (p == 0)
{
+ /* APPLE LOCAL begin keymgr */
+#if defined(APPLE_KEYMGR) && ! defined(APPLE_KERNEL_EXTENSION) && ! defined(LIBCC_KEXT)
+ /* Ask Key Manager for new_handler; if provided (!=0), use it, else use local version. */
+ new_handler handler =
+ (new_handler) _keymgr_get_per_thread_data (KEYMGR_NEW_HANLDER_KEY);
+#else /* ! APPLE_KEYMGR */
new_handler handler = __new_handler;
+#endif /* APPLE_KEYMGR */
+ /* APPLE LOCAL end keymgr */
if (! handler)
#ifdef __EXCEPTIONS
throw bad_alloc();
#else
- std::abort();
+ /* APPLE LOCAL libcc_kext */
+ ABORT();
#endif
handler ();
p = (void *) malloc (sz);
diff --git a/libstdc++-v3/libsupc++/new_opnt.cc b/libstdc++-v3/libsupc++/new_opnt.cc
index 4d7a5087c14..6406a50086c 100644
--- a/libstdc++-v3/libsupc++/new_opnt.cc
+++ b/libstdc++-v3/libsupc++/new_opnt.cc
@@ -30,6 +30,12 @@
#include "new"
#include <exception_defines.h>
+/* APPLE LOCAL begin keymgr */
+#if defined APPLE_KEYMGR && ! defined(LIBCC_KEXT) && ! defined(APPLE_KERNEL_EXTENSION)
+#include "bits/os_defines.h"
+#endif /* APPLE_KEYMGR */
+/* APPLE LOCAL end keymgr */
+
using std::new_handler;
using std::bad_alloc;
@@ -47,7 +53,14 @@ operator new (std::size_t sz, const std::nothrow_t&) throw()
p = (void *) malloc (sz);
while (p == 0)
{
+ /* APPLE LOCAL begin keymgr */
+#if defined(APPLE_KEYMGR) && ! defined(APPLE_KERNEL_EXTENSION) && ! defined(LIBCC_KEXT)
+ new_handler handler =
+ (new_handler) _keymgr_get_per_thread_data (KEYMGR_NEW_HANLDER_KEY);
+#else /* ! APPLE_KEYMGR */
new_handler handler = __new_handler;
+#endif /* APPLE_KEYMGR */
+ /* APPLE LOCAL end keymgr */
if (! handler)
return 0;
try
diff --git a/libstdc++-v3/libsupc++/pure.cc b/libstdc++-v3/libsupc++/pure.cc
index 66ccb7d12dd..fb31d54c2ca 100644
--- a/libstdc++-v3/libsupc++/pure.cc
+++ b/libstdc++-v3/libsupc++/pure.cc
@@ -27,8 +27,12 @@
// invalidate any other reasons why the executable file might be covered by
// the GNU General Public License.
+/* APPLE LOCAL begin libcc_kext */
+#ifndef LIBCC_KEXT /* Kludge: easier than identifying correct -Ipath, and unnecessary for kext */
#include <bits/c++config.h>
#include "unwind-cxx.h"
+#endif
+/* APPLE LOCAL end libcc_kext */
#ifdef _GLIBCXX_HAVE_UNISTD_H
# include <unistd.h>
@@ -46,6 +50,14 @@
extern "C" void
__cxa_pure_virtual (void)
{
+
+/* APPLE LOCAL begin libcc_kext */
+#ifndef LIBCC_KEXT
writestr ("pure virtual method called\n");
std::terminate ();
+#else
+ extern void panic (void);
+ panic ();
+#endif
+/* APPLE LOCAL end libcc_kext */
}
diff --git a/libstdc++-v3/src/functexcept.cc b/libstdc++-v3/src/functexcept.cc
index fb158a61242..fb041effbce 100644
--- a/libstdc++-v3/src/functexcept.cc
+++ b/libstdc++-v3/src/functexcept.cc
@@ -94,9 +94,15 @@ namespace std
__throw_underflow_error(const char* __s)
{ throw underflow_error(_(__s)); }
+ /* APPLE LOCAL begin make libstdc++ more fine-grained */
+ /* This function now lives in ios.cc, so that we can avoid dragging in all
+ of IOS when some other function in this file is called. */
+#ifndef APPLE_KEYMGR
void
__throw_ios_failure(const char* __s)
{ throw ios_base::failure(_(__s)); }
+#endif /* APPLE_KEYMGR */
+ /* APPLE LOCAL end make libstdc++ more fine-grained */
#else
void
__throw_bad_exception(void)
diff --git a/libstdc++-v3/src/ios.cc b/libstdc++-v3/src/ios.cc
index 0dfa482d9bb..0aeb4d2ef61 100644
--- a/libstdc++-v3/src/ios.cc
+++ b/libstdc++-v3/src/ios.cc
@@ -222,4 +222,15 @@ namespace std
}
_M_callbacks = 0;
}
+
+ /* APPLE LOCAL begin make libstdc++ more fine-grained */
+#ifdef APPLE_KEYMGR
+ /* This function used to live in functexcept.cc, but now lives here to
+ avoid dragging in all of IOS when some other function in functexcept.cc
+ is called. */
+ void
+ __throw_ios_failure(const char* __s)
+ { throw ios_base::failure(__s); }
+#endif /* APPLE_KEYMGR */
+ /* APPLE LOCAL end make libstdc++ more fine-grained */
} // namespace std
diff --git a/libstdc++-v3/testsuite/20_util/allocator/14176.cc b/libstdc++-v3/testsuite/20_util/allocator/14176.cc
deleted file mode 100644
index cb8a2f5c4bf..00000000000
--- a/libstdc++-v3/testsuite/20_util/allocator/14176.cc
+++ /dev/null
@@ -1,42 +0,0 @@
-// Copyright (C) 2004 Free Software Foundation, Inc.
-//
-// This file is part of the GNU ISO C++ Library. This library is free
-// software; you can redistribute it and/or modify it under the
-// terms of the GNU General Public License as published by the
-// Free Software Foundation; either version 2, or (at your option)
-// any later version.
-
-// This library is distributed in the hope that it will be useful,
-// but WITHOUT ANY WARRANTY; without even the implied warranty of
-// MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-// GNU General Public License for more details.
-
-// You should have received a copy of the GNU General Public License along
-// with this library; see the file COPYING. If not, write to the Free
-// Software Foundation, 59 Temple Place - Suite 330, Boston, MA 02111-1307,
-// USA.
-
-// 20.4.1.1 allocator members
-
-#include <memory>
-#include <testsuite_hooks.h>
-
-// libstdc++/14176
-void test02()
-{
- unsigned int len = 0;
- std::allocator<int> a;
- int* p = a.allocate(len);
- a.deallocate(p, len);
-}
-
-#if !__GXX_WEAK__ && _MT_ALLOCATOR_H
-// Explicitly instantiate for systems with no COMDAT or weak support.
-template class __gnu_cxx::__mt_alloc<int>;
-#endif
-
-int main()
-{
- test02();
- return 0;
-}
diff --git a/libstdc++-v3/testsuite/22_locale/locale/cons/12658_thread.cc b/libstdc++-v3/testsuite/22_locale/locale/cons/12658_thread.cc
deleted file mode 100644
index 3a89d371f62..00000000000
--- a/libstdc++-v3/testsuite/22_locale/locale/cons/12658_thread.cc
+++ /dev/null
@@ -1,67 +0,0 @@
-// { dg-do run { target *-*-freebsd* *-*-netbsd* *-*-linux* *-*-solaris* *-*-cygwin *-*-darwin* alpha*-*-osf* } }
-// { dg-options "-pthread" { target *-*-freebsd* *-*-netbsd* *-*-linux* alpha*-*-osf* } }
-// { dg-options "-pthreads" { target *-*-solaris* } }
-
-// Copyright (C) 2004 Free Software Foundation
-//
-// This file is part of the GNU ISO C++ Library. This library is free
-// software; you can redistribute it and/or modify it under the
-// terms of the GNU General Public License as published by the
-// Free Software Foundation; either version 2, or (at your option)
-// any later version.
-
-// This library is distributed in the hope that it will be useful,
-// but WITHOUT ANY WARRANTY; without even the implied warranty of
-// MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-// GNU General Public License for more details.
-
-// You should have received a copy of the GNU General Public License along
-// with this library; see the file COPYING. If not, write to the Free
-// Software Foundation, 59 Temple Place - Suite 330, Boston, MA 02111-1307,
-// USA.
-
-// 22.1.1.2 locale constructors and destructors [lib.locale.cons]
-
-#include <locale>
-#include <pthread.h>
-
-const int max_thread_count = 20;
-//const int max_loop_count = 1000000; // orig value
-const int max_loop_count = 100000;
-const int max_locales = 10;
-
-void* thread_main(void*)
-{
- try
- {
- std::locale loc_c = std::locale::classic();
- std::locale loc[max_locales];
- for (int j = 0; j < max_locales; ++j)
- loc[j] = std::locale(j % 2 ? "en_US" : "fr_FR");
-
- for (int i = 0; i < max_loop_count; ++i)
- {
- int k = i % max_locales;
- loc[k] = std::locale::global(loc[k]);
-
- if (i % 37 == 0)
- loc[k] = loc[k].combine<std::ctype<char> >(loc_c);
- }
- }
- catch (...) { }
- return 0;
-}
-
-int
-main()
-{
- pthread_t tid[max_thread_count];
-
- for (int i = 0; i < max_thread_count; i++)
- pthread_create (&tid[i], NULL, thread_main, 0);
-
- for (int i = 0; i < max_thread_count; i++)
- pthread_join (tid[i], NULL);
-
- return 0;
-}
diff --git a/libstdc++-v3/testsuite/22_locale/money_get/get/char/17.cc b/libstdc++-v3/testsuite/22_locale/money_get/get/char/17.cc
deleted file mode 100644
index 5216b414aae..00000000000
--- a/libstdc++-v3/testsuite/22_locale/money_get/get/char/17.cc
+++ /dev/null
@@ -1,71 +0,0 @@
-// 2004-03-08 Paolo Carlini <pcarlini@suse.de>
-
-// Copyright (C) 2004 Free Software Foundation
-//
-// This file is part of the GNU ISO C++ Library. This library is free
-// software; you can redistribute it and/or modify it under the
-// terms of the GNU General Public License as published by the
-// Free Software Foundation; either version 2, or (at your option)
-// any later version.
-
-// This library is distributed in the hope that it will be useful,
-// but WITHOUT ANY WARRANTY; without even the implied warranty of
-// MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-// GNU General Public License for more details.
-
-// You should have received a copy of the GNU General Public License along
-// with this library; see the file COPYING. If not, write to the Free
-// Software Foundation, 59 Temple Place - Suite 330, Boston, MA 02111-1307,
-// USA.
-
-// 22.2.6.1.1 money_get members
-
-#include <locale>
-#include <sstream>
-#include <testsuite_hooks.h>
-
-// 22.2.6.3, p2: "The value _space_ indicates that at least one space
-// is required at that position."
-void test01()
-{
- using namespace std;
- typedef istreambuf_iterator<char> iterator_type;
-
- bool test __attribute__((unused)) = true;
-
- // basic construction
- locale loc_c = locale::classic();
- locale loc_de = __gnu_test::try_named_locale("de_DE@euro");
- VERIFY( loc_c != loc_de );
-
- iterator_type end, end02;
- istringstream iss;
- iss.imbue(loc_de);
- // cache the money_get facet
- const money_get<char>& mon_get =
- use_facet<money_get<char> >(iss.getloc());
-
- iss.str("7.200.000.000,00");
- iterator_type is_it01(iss);
- string result1;
- ios_base::iostate err01 = ios_base::goodbit;
- mon_get.get(is_it01, end, true, iss, err01, result1);
- VERIFY( err01 == (ios_base::failbit | ios_base::eofbit) );
-
- // now try with showbase, to get currency symbol in format
- iss.setf(ios_base::showbase);
-
- iss.str("7.200.000.000,00EUR ");
- iterator_type is_it02(iss);
- string result2;
- ios_base::iostate err02 = ios_base::goodbit;
- end02 = mon_get.get(is_it02, end, true, iss, err02, result2);
- VERIFY( err02 == ios_base::failbit );
- VERIFY( *end02 == 'E' );
-}
-
-int main()
-{
- test01();
- return 0;
-}
diff --git a/libstdc++-v3/testsuite/22_locale/money_get/get/char/18.cc b/libstdc++-v3/testsuite/22_locale/money_get/get/char/18.cc
deleted file mode 100644
index 3da65de43d1..00000000000
--- a/libstdc++-v3/testsuite/22_locale/money_get/get/char/18.cc
+++ /dev/null
@@ -1,69 +0,0 @@
-// 2004-03-15 Paolo Carlini <pcarlini@suse.de>
-
-// Copyright (C) 2004 Free Software Foundation
-//
-// This file is part of the GNU ISO C++ Library. This library is free
-// software; you can redistribute it and/or modify it under the
-// terms of the GNU General Public License as published by the
-// Free Software Foundation; either version 2, or (at your option)
-// any later version.
-
-// This library is distributed in the hope that it will be useful,
-// but WITHOUT ANY WARRANTY; without even the implied warranty of
-// MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-// GNU General Public License for more details.
-
-// You should have received a copy of the GNU General Public License along
-// with this library; see the file COPYING. If not, write to the Free
-// Software Foundation, 59 Temple Place - Suite 330, Boston, MA 02111-1307,
-// USA.
-
-// 22.2.6.1.1 money_get members
-
-#include <locale>
-#include <sstream>
-#include <testsuite_hooks.h>
-
-// If (str.flags() & str.showbase) is false, the currency symbol is optional,
-// but, if found, must be consumed entirely.
-void test01()
-{
- using namespace std;
- typedef istreambuf_iterator<char> iterator_type;
-
- bool test __attribute__((unused)) = true;
-
- // basic construction
- locale loc_c = locale::classic();
- locale loc_hk = __gnu_test::try_named_locale("en_HK");
- VERIFY( loc_c != loc_hk );
-
- iterator_type end, end01, end02;
- istringstream iss;
- iss.imbue(loc_hk);
- // cache the money_get facet
- const money_get<char>& mon_get =
- use_facet<money_get<char> >(iss.getloc());
-
- iss.str("HK7,200,000,000.00");
- iterator_type is_it01(iss);
- string result01;
- ios_base::iostate err01 = ios_base::goodbit;
- end01 = mon_get.get(is_it01, end, false, iss, err01, result01);
- VERIFY( err01 == ios_base::failbit );
- VERIFY( *end01 == '7' );
-
- iss.str("(HK100,000,000,000.00)");
- iterator_type is_it02(iss);
- string result02;
- ios_base::iostate err02 = ios_base::goodbit;
- end02 = mon_get.get(is_it02, end, true, iss, err02, result02);
- VERIFY( err02 == ios_base::failbit );
- VERIFY( *end02 == '1' );
-}
-
-int main()
-{
- test01();
- return 0;
-}
diff --git a/libstdc++-v3/testsuite/22_locale/money_get/get/char/19.cc b/libstdc++-v3/testsuite/22_locale/money_get/get/char/19.cc
deleted file mode 100644
index 5d9dea2be1e..00000000000
--- a/libstdc++-v3/testsuite/22_locale/money_get/get/char/19.cc
+++ /dev/null
@@ -1,125 +0,0 @@
-// 2004-03-15 Paolo Carlini <pcarlini@suse.de>
-
-// Copyright (C) 2004 Free Software Foundation
-//
-// This file is part of the GNU ISO C++ Library. This library is free
-// software; you can redistribute it and/or modify it under the
-// terms of the GNU General Public License as published by the
-// Free Software Foundation; either version 2, or (at your option)
-// any later version.
-
-// This library is distributed in the hope that it will be useful,
-// but WITHOUT ANY WARRANTY; without even the implied warranty of
-// MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-// GNU General Public License for more details.
-
-// You should have received a copy of the GNU General Public License along
-// with this library; see the file COPYING. If not, write to the Free
-// Software Foundation, 59 Temple Place - Suite 330, Boston, MA 02111-1307,
-// USA.
-
-// 22.2.6.1.1 money_get members
-
-#include <locale>
-#include <sstream>
-#include <testsuite_hooks.h>
-
-struct My_money_io_01 : public std::moneypunct<char, false>
-{
- std::string do_curr_symbol() const { return "$"; }
- std::string do_positive_sign() const { return ""; }
- std::string do_negative_sign() const { return ""; }
-
- pattern do_neg_format() const
- {
- pattern pat = { { value, symbol, none, sign } };
- return pat;
- }
-};
-
-struct My_money_io_02 : public std::moneypunct<char, false>
-{
- std::string do_curr_symbol() const { return "%"; }
- std::string do_positive_sign() const { return ""; }
- std::string do_negative_sign() const { return "-"; }
-
- pattern do_neg_format() const
- {
- pattern pat = { { value, symbol, sign, none } };
- return pat;
- }
-};
-
-struct My_money_io_03 : public std::moneypunct<char, false>
-{
- std::string do_curr_symbol() const { return "&"; }
- std::string do_positive_sign() const { return ""; }
- std::string do_negative_sign() const { return ""; }
-
- pattern do_neg_format() const
- {
- pattern pat = { { value, space, symbol, sign } };
- return pat;
- }
-};
-
-// When both do_positive_sign and do_negative_sign return an empty
-// string, patterns of the forms { value, symbol, none, sign },
-// { value, symbol, sign, none } and { X, Y, symbol, sign } imply
-// that the symbol is not consumed since no other characters are
-// needed to complete the format.
-void test01()
-{
- using namespace std;
- typedef istreambuf_iterator<char> iterator_type;
-
- bool test __attribute__((unused)) = true;
-
- // basic construction
- locale loc_01(locale::classic(), new My_money_io_01);
- locale loc_02(locale::classic(), new My_money_io_02);
- locale loc_03(locale::classic(), new My_money_io_03);
-
- iterator_type end, end01, end02, end03;
- istringstream iss_01, iss_02, iss_03;
- iss_01.imbue(loc_01);
- iss_02.imbue(loc_02);
- iss_03.imbue(loc_03);
- // cache the money_get facet
- const money_get<char>& mon_get_01 =
- use_facet<money_get<char> >(iss_01.getloc());
- const money_get<char>& mon_get_02 =
- use_facet<money_get<char> >(iss_02.getloc());
- const money_get<char>& mon_get_03 =
- use_facet<money_get<char> >(iss_03.getloc());
-
- iss_01.str("10$");
- iterator_type is_it01(iss_01);
- string result01;
- ios_base::iostate err01 = ios_base::goodbit;
- end01 = mon_get_01.get(is_it01, end, false, iss_01, err01, result01);
- VERIFY( err01 == ios_base::goodbit );
- VERIFY( *end01 == '$' );
-
- iss_02.str("50%");
- iterator_type is_it02(iss_02);
- string result02;
- ios_base::iostate err02 = ios_base::goodbit;
- end02 = mon_get_02.get(is_it02, end, false, iss_02, err02, result02);
- VERIFY( err02 == ios_base::goodbit );
- VERIFY( *end02 == '%' );
-
- iss_03.str("7 &");
- iterator_type is_it03(iss_03);
- string result03;
- ios_base::iostate err03 = ios_base::goodbit;
- end03 = mon_get_03.get(is_it03, end, false, iss_03, err03, result03);
- VERIFY( err03 == ios_base::goodbit );
- VERIFY( *end03 == '&' );
-}
-
-int main()
-{
- test01();
- return 0;
-}
diff --git a/libstdc++-v3/testsuite/22_locale/money_get/get/wchar_t/17.cc b/libstdc++-v3/testsuite/22_locale/money_get/get/wchar_t/17.cc
deleted file mode 100644
index e8affd81bb8..00000000000
--- a/libstdc++-v3/testsuite/22_locale/money_get/get/wchar_t/17.cc
+++ /dev/null
@@ -1,71 +0,0 @@
-// 2004-03-08 Paolo Carlini <pcarlini@suse.de>
-
-// Copyright (C) 2004 Free Software Foundation
-//
-// This file is part of the GNU ISO C++ Library. This library is free
-// software; you can redistribute it and/or modify it under the
-// terms of the GNU General Public License as published by the
-// Free Software Foundation; either version 2, or (at your option)
-// any later version.
-
-// This library is distributed in the hope that it will be useful,
-// but WITHOUT ANY WARRANTY; without even the implied warranty of
-// MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-// GNU General Public License for more details.
-
-// You should have received a copy of the GNU General Public License along
-// with this library; see the file COPYING. If not, write to the Free
-// Software Foundation, 59 Temple Place - Suite 330, Boston, MA 02111-1307,
-// USA.
-
-// 22.2.6.1.1 money_get members
-
-#include <locale>
-#include <sstream>
-#include <testsuite_hooks.h>
-
-// 22.2.6.3, p2: "The value _space_ indicates that at least one space
-// is required at that position."
-void test01()
-{
- using namespace std;
- typedef istreambuf_iterator<wchar_t> iterator_type;
-
- bool test __attribute__((unused)) = true;
-
- // basic construction
- locale loc_c = locale::classic();
- locale loc_de = __gnu_test::try_named_locale("de_DE@euro");
- VERIFY( loc_c != loc_de );
-
- iterator_type end, end02;
- wistringstream iss;
- iss.imbue(loc_de);
- // cache the money_get facet
- const money_get<wchar_t>& mon_get =
- use_facet<money_get<wchar_t> >(iss.getloc());
-
- iss.str(L"7.200.000.000,00");
- iterator_type is_it01(iss);
- wstring result1;
- ios_base::iostate err01 = ios_base::goodbit;
- mon_get.get(is_it01, end, true, iss, err01, result1);
- VERIFY( err01 == (ios_base::failbit | ios_base::eofbit) );
-
- // now try with showbase, to get currency symbol in format
- iss.setf(ios_base::showbase);
-
- iss.str(L"7.200.000.000,00EUR ");
- iterator_type is_it02(iss);
- wstring result2;
- ios_base::iostate err02 = ios_base::goodbit;
- end02 = mon_get.get(is_it02, end, true, iss, err02, result2);
- VERIFY( err02 == ios_base::failbit );
- VERIFY( *end02 == L'E' );
-}
-
-int main()
-{
- test01();
- return 0;
-}
diff --git a/libstdc++-v3/testsuite/22_locale/money_get/get/wchar_t/18.cc b/libstdc++-v3/testsuite/22_locale/money_get/get/wchar_t/18.cc
deleted file mode 100644
index 285de236276..00000000000
--- a/libstdc++-v3/testsuite/22_locale/money_get/get/wchar_t/18.cc
+++ /dev/null
@@ -1,69 +0,0 @@
-// 2004-03-15 Paolo Carlini <pcarlini@suse.de>
-
-// Copyright (C) 2004 Free Software Foundation
-//
-// This file is part of the GNU ISO C++ Library. This library is free
-// software; you can redistribute it and/or modify it under the
-// terms of the GNU General Public License as published by the
-// Free Software Foundation; either version 2, or (at your option)
-// any later version.
-
-// This library is distributed in the hope that it will be useful,
-// but WITHOUT ANY WARRANTY; without even the implied warranty of
-// MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-// GNU General Public License for more details.
-
-// You should have received a copy of the GNU General Public License along
-// with this library; see the file COPYING. If not, write to the Free
-// Software Foundation, 59 Temple Place - Suite 330, Boston, MA 02111-1307,
-// USA.
-
-// 22.2.6.1.1 money_get members
-
-#include <locale>
-#include <sstream>
-#include <testsuite_hooks.h>
-
-// If (str.flags() & str.showbase) is false, the currency symbol is optional,
-// but, if found, must be consumed entirely.
-void test01()
-{
- using namespace std;
- typedef istreambuf_iterator<wchar_t> iterator_type;
-
- bool test __attribute__((unused)) = true;
-
- // basic construction
- locale loc_c = locale::classic();
- locale loc_hk = __gnu_test::try_named_locale("en_HK");
- VERIFY( loc_c != loc_hk );
-
- iterator_type end, end01, end02;
- wistringstream iss;
- iss.imbue(loc_hk);
- // cache the money_get facet
- const money_get<wchar_t>& mon_get =
- use_facet<money_get<wchar_t> >(iss.getloc());
-
- iss.str(L"HK7,200,000,000.00");
- iterator_type is_it01(iss);
- wstring result01;
- ios_base::iostate err01 = ios_base::goodbit;
- end01 = mon_get.get(is_it01, end, false, iss, err01, result01);
- VERIFY( err01 == ios_base::failbit );
- VERIFY( *end01 == L'7' );
-
- iss.str(L"(HK100,000,000,000.00)");
- iterator_type is_it02(iss);
- wstring result02;
- ios_base::iostate err02 = ios_base::goodbit;
- end02 = mon_get.get(is_it02, end, true, iss, err02, result02);
- VERIFY( err02 == ios_base::failbit );
- VERIFY( *end02 == L'1' );
-}
-
-int main()
-{
- test01();
- return 0;
-}
diff --git a/libstdc++-v3/testsuite/22_locale/money_get/get/wchar_t/19.cc b/libstdc++-v3/testsuite/22_locale/money_get/get/wchar_t/19.cc
deleted file mode 100644
index 93c63e6ea29..00000000000
--- a/libstdc++-v3/testsuite/22_locale/money_get/get/wchar_t/19.cc
+++ /dev/null
@@ -1,125 +0,0 @@
-// 2004-03-15 Paolo Carlini <pcarlini@suse.de>
-
-// Copyright (C) 2004 Free Software Foundation
-//
-// This file is part of the GNU ISO C++ Library. This library is free
-// software; you can redistribute it and/or modify it under the
-// terms of the GNU General Public License as published by the
-// Free Software Foundation; either version 2, or (at your option)
-// any later version.
-
-// This library is distributed in the hope that it will be useful,
-// but WITHOUT ANY WARRANTY; without even the implied warranty of
-// MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-// GNU General Public License for more details.
-
-// You should have received a copy of the GNU General Public License along
-// with this library; see the file COPYING. If not, write to the Free
-// Software Foundation, 59 Temple Place - Suite 330, Boston, MA 02111-1307,
-// USA.
-
-// 22.2.6.1.1 money_get members
-
-#include <locale>
-#include <sstream>
-#include <testsuite_hooks.h>
-
-struct My_money_io_01 : public std::moneypunct<wchar_t, false>
-{
- std::wstring do_curr_symbol() const { return L"$"; }
- std::wstring do_positive_sign() const { return L""; }
- std::wstring do_negative_sign() const { return L""; }
-
- pattern do_neg_format() const
- {
- pattern pat = { { value, symbol, none, sign } };
- return pat;
- }
-};
-
-struct My_money_io_02 : public std::moneypunct<wchar_t, false>
-{
- std::wstring do_curr_symbol() const { return L"%"; }
- std::wstring do_positive_sign() const { return L""; }
- std::wstring do_negative_sign() const { return L"-"; }
-
- pattern do_neg_format() const
- {
- pattern pat = { { value, symbol, sign, none } };
- return pat;
- }
-};
-
-struct My_money_io_03 : public std::moneypunct<wchar_t, false>
-{
- std::wstring do_curr_symbol() const { return L"&"; }
- std::wstring do_positive_sign() const { return L""; }
- std::wstring do_negative_sign() const { return L""; }
-
- pattern do_neg_format() const
- {
- pattern pat = { { value, space, symbol, sign } };
- return pat;
- }
-};
-
-// When both do_positive_sign and do_negative_sign return an empty
-// string, patterns of the forms { value, symbol, none, sign },
-// { value, symbol, sign, none } and { X, Y, symbol, sign } imply
-// that the symbol is not consumed since no other characters are
-// needed to complete the format.
-void test01()
-{
- using namespace std;
- typedef istreambuf_iterator<wchar_t> iterator_type;
-
- bool test __attribute__((unused)) = true;
-
- // basic construction
- locale loc_01(locale::classic(), new My_money_io_01);
- locale loc_02(locale::classic(), new My_money_io_02);
- locale loc_03(locale::classic(), new My_money_io_03);
-
- iterator_type end, end01, end02, end03;
- wistringstream iss_01, iss_02, iss_03;
- iss_01.imbue(loc_01);
- iss_02.imbue(loc_02);
- iss_03.imbue(loc_03);
- // cache the money_get facet
- const money_get<wchar_t>& mon_get_01 =
- use_facet<money_get<wchar_t> >(iss_01.getloc());
- const money_get<wchar_t>& mon_get_02 =
- use_facet<money_get<wchar_t> >(iss_02.getloc());
- const money_get<wchar_t>& mon_get_03 =
- use_facet<money_get<wchar_t> >(iss_03.getloc());
-
- iss_01.str(L"10$");
- iterator_type is_it01(iss_01);
- wstring result01;
- ios_base::iostate err01 = ios_base::goodbit;
- end01 = mon_get_01.get(is_it01, end, false, iss_01, err01, result01);
- VERIFY( err01 == ios_base::goodbit );
- VERIFY( *end01 == L'$' );
-
- iss_02.str(L"50%");
- iterator_type is_it02(iss_02);
- wstring result02;
- ios_base::iostate err02 = ios_base::goodbit;
- end02 = mon_get_02.get(is_it02, end, false, iss_02, err02, result02);
- VERIFY( err02 == ios_base::goodbit );
- VERIFY( *end02 == L'%' );
-
- iss_03.str(L"7 &");
- iterator_type is_it03(iss_03);
- wstring result03;
- ios_base::iostate err03 = ios_base::goodbit;
- end03 = mon_get_03.get(is_it03, end, false, iss_03, err03, result03);
- VERIFY( err03 == ios_base::goodbit );
- VERIFY( *end03 == L'&' );
-}
-
-int main()
-{
- test01();
- return 0;
-}
diff --git a/libstdc++-v3/testsuite/23_containers/deque/modifiers/swap.cc b/libstdc++-v3/testsuite/23_containers/deque/modifiers/swap.cc
deleted file mode 100644
index 43dc6867d3d..00000000000
--- a/libstdc++-v3/testsuite/23_containers/deque/modifiers/swap.cc
+++ /dev/null
@@ -1,68 +0,0 @@
-// Copyright (C) 2004 Free Software Foundation
-//
-// This file is part of the GNU ISO C++ Library. This library is free
-// software; you can redistribute it and/or modify it under the
-// terms of the GNU General Public License as published by the
-// Free Software Foundation; either version 2, or (at your option)
-// any later version.
-
-// This library is distributed in the hope that it will be useful,
-// but WITHOUT ANY WARRANTY; without even the implied warranty of
-// MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-// GNU General Public License for more details.
-
-// You should have received a copy of the GNU General Public License along
-// with this library; see the file COPYING. If not, write to the Free
-// Software Foundation, 59 Temple Place - Suite 330, Boston, MA 02111-1307,
-// USA.
-
-#include <deque>
-#include <testsuite_hooks.h>
-
-struct T { int i; };
-
-int swap_calls;
-
-namespace std
-{
- template<>
- void
- deque<T, allocator<T> >::swap(deque<T, allocator<T> >&)
- { ++swap_calls; }
-}
-
-// Should use deque specialization for swap.
-void test01()
-{
- bool test __attribute__((unused)) = true;
- std::deque<T> A;
- std::deque<T> B;
- swap_calls = 0;
- std::swap(A, B);
- VERIFY(1 == swap_calls);
-}
-
-// Should use deque specialization for swap.
-void test02()
-{
- bool test __attribute__((unused)) = true;
- using namespace std;
- deque<T> A;
- deque<T> B;
- swap_calls = 0;
- swap(A, B);
- VERIFY(1 == swap_calls);
-}
-
-#if !__GXX_WEAK__ && _MT_ALLOCATOR_H
-template class __gnu_cxx::__mt_alloc<T>;
-template class __gnu_cxx::__mt_alloc<T*>;
-#endif
-
-// See c++/13658 for background info.
-int main()
-{
- test01();
- test02();
- return 0;
-}
diff --git a/libstdc++-v3/testsuite/23_containers/list/modifiers/swap.cc b/libstdc++-v3/testsuite/23_containers/list/modifiers/swap.cc
deleted file mode 100644
index a51d1263fb4..00000000000
--- a/libstdc++-v3/testsuite/23_containers/list/modifiers/swap.cc
+++ /dev/null
@@ -1,67 +0,0 @@
-// Copyright (C) 2004 Free Software Foundation
-//
-// This file is part of the GNU ISO C++ Library. This library is free
-// software; you can redistribute it and/or modify it under the
-// terms of the GNU General Public License as published by the
-// Free Software Foundation; either version 2, or (at your option)
-// any later version.
-
-// This library is distributed in the hope that it will be useful,
-// but WITHOUT ANY WARRANTY; without even the implied warranty of
-// MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-// GNU General Public License for more details.
-
-// You should have received a copy of the GNU General Public License along
-// with this library; see the file COPYING. If not, write to the Free
-// Software Foundation, 59 Temple Place - Suite 330, Boston, MA 02111-1307,
-// USA.
-
-#include <list>
-#include <testsuite_hooks.h>
-
-struct T { int i; };
-
-int swap_calls;
-
-namespace std
-{
- template<>
- void
- list<T, allocator<T> >::swap(list<T, allocator<T> >&)
- { ++swap_calls; }
-}
-
-// Should use list specialization for swap.
-void test01()
-{
- bool test __attribute__((unused)) = true;
- std::list<T> A;
- std::list<T> B;
- swap_calls = 0;
- std::swap(A, B);
- VERIFY(1 == swap_calls);
-}
-
-// Should use list specialization for swap.
-void test02()
-{
- bool test __attribute__((unused)) = true;
- using namespace std;
- list<T> A;
- list<T> B;
- swap_calls = 0;
- swap(A, B);
- VERIFY(1 == swap_calls);
-}
-
-#if !__GXX_WEAK__ && _MT_ALLOCATOR_H
-template class __gnu_cxx::__mt_alloc<std::_List_node<T> >;
-#endif
-
-// See c++/13658 for background info.
-int main()
-{
- test01();
- test02();
- return 0;
-}
diff --git a/libstdc++-v3/testsuite/23_containers/map/modifiers/swap.cc b/libstdc++-v3/testsuite/23_containers/map/modifiers/swap.cc
deleted file mode 100644
index 1afde71dd8a..00000000000
--- a/libstdc++-v3/testsuite/23_containers/map/modifiers/swap.cc
+++ /dev/null
@@ -1,67 +0,0 @@
-// Copyright (C) 2004 Free Software Foundation
-//
-// This file is part of the GNU ISO C++ Library. This library is free
-// software; you can redistribute it and/or modify it under the
-// terms of the GNU General Public License as published by the
-// Free Software Foundation; either version 2, or (at your option)
-// any later version.
-
-// This library is distributed in the hope that it will be useful,
-// but WITHOUT ANY WARRANTY; without even the implied warranty of
-// MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-// GNU General Public License for more details.
-
-// You should have received a copy of the GNU General Public License along
-// with this library; see the file COPYING. If not, write to the Free
-// Software Foundation, 59 Temple Place - Suite 330, Boston, MA 02111-1307,
-// USA.
-
-#include <map>
-#include <testsuite_hooks.h>
-
-struct T { int i; };
-
-int swap_calls;
-
-namespace std
-{
- template<>
- void
- map<T, int>::swap(map<T, int>&)
- { ++swap_calls; }
-}
-
-// Should use map specialization for swap.
-void test01()
-{
- bool test __attribute__((unused)) = true;
- std::map<T, int> A;
- std::map<T, int> B;
- swap_calls = 0;
- std::swap(A, B);
- VERIFY(1 == swap_calls);
-}
-
-// Should use map specialization for swap.
-void test02()
-{
- bool test __attribute__((unused)) = true;
- using namespace std;
- map<T, int> A;
- map<T, int> B;
- swap_calls = 0;
- swap(A, B);
- VERIFY(1 == swap_calls);
-}
-
-#if !__GXX_WEAK__ && _MT_ALLOCATOR_H
-template class __gnu_cxx::__mt_alloc<std::_Rb_tree_node<std::pair<T const, int> > >;
-#endif
-
-// See c++/13658 for background info.
-int main()
-{
- test01();
- test02();
- return 0;
-}
diff --git a/libstdc++-v3/testsuite/23_containers/multimap/modifiers/swap.cc b/libstdc++-v3/testsuite/23_containers/multimap/modifiers/swap.cc
deleted file mode 100644
index 2e87dff1632..00000000000
--- a/libstdc++-v3/testsuite/23_containers/multimap/modifiers/swap.cc
+++ /dev/null
@@ -1,67 +0,0 @@
-// Copyright (C) 2004 Free Software Foundation
-//
-// This file is part of the GNU ISO C++ Library. This library is free
-// software; you can redistribute it and/or modify it under the
-// terms of the GNU General Public License as published by the
-// Free Software Foundation; either version 2, or (at your option)
-// any later version.
-
-// This library is distributed in the hope that it will be useful,
-// but WITHOUT ANY WARRANTY; without even the implied warranty of
-// MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-// GNU General Public License for more details.
-
-// You should have received a copy of the GNU General Public License along
-// with this library; see the file COPYING. If not, write to the Free
-// Software Foundation, 59 Temple Place - Suite 330, Boston, MA 02111-1307,
-// USA.
-
-#include <map>
-#include <testsuite_hooks.h>
-
-struct T { int i; };
-
-int swap_calls;
-
-namespace std
-{
- template<>
- void
- multimap<T, int>::swap(multimap<T, int>&)
- { ++swap_calls; }
-}
-
-// Should use multimap specialization for swap.
-void test01()
-{
- bool test __attribute__((unused)) = true;
- std::multimap<T, int> A;
- std::multimap<T, int> B;
- swap_calls = 0;
- std::swap(A, B);
- VERIFY(1 == swap_calls);
-}
-
-// Should use multimap specialization for swap.
-void test02()
-{
- bool test __attribute__((unused)) = true;
- using namespace std;
- multimap<T, int> A;
- multimap<T, int> B;
- swap_calls = 0;
- swap(A, B);
- VERIFY(1 == swap_calls);
-}
-
-#if !__GXX_WEAK__ && _MT_ALLOCATOR_H
-template class __gnu_cxx::__mt_alloc<std::_Rb_tree_node<std::pair<T const, int> > >;
-#endif
-
-// See c++/13658 for background info.
-int main()
-{
- test01();
- test02();
- return 0;
-}
diff --git a/libstdc++-v3/testsuite/23_containers/multiset/modifiers/swap.cc b/libstdc++-v3/testsuite/23_containers/multiset/modifiers/swap.cc
deleted file mode 100644
index b9632cb88ae..00000000000
--- a/libstdc++-v3/testsuite/23_containers/multiset/modifiers/swap.cc
+++ /dev/null
@@ -1,67 +0,0 @@
-// Copyright (C) 2004 Free Software Foundation
-//
-// This file is part of the GNU ISO C++ Library. This library is free
-// software; you can redistribute it and/or modify it under the
-// terms of the GNU General Public License as published by the
-// Free Software Foundation; either version 2, or (at your option)
-// any later version.
-
-// This library is distributed in the hope that it will be useful,
-// but WITHOUT ANY WARRANTY; without even the implied warranty of
-// MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-// GNU General Public License for more details.
-
-// You should have received a copy of the GNU General Public License along
-// with this library; see the file COPYING. If not, write to the Free
-// Software Foundation, 59 Temple Place - Suite 330, Boston, MA 02111-1307,
-// USA.
-
-#include <set>
-#include <testsuite_hooks.h>
-
-struct T { int i; };
-
-int swap_calls;
-
-namespace std
-{
- template<>
- void
- multiset<T>::swap(multiset<T>&)
- { ++swap_calls; }
-}
-
-// Should use multiset specialization for swap.
-void test01()
-{
- bool test __attribute__((unused)) = true;
- std::multiset<T> A;
- std::multiset<T> B;
- swap_calls = 0;
- std::swap(A, B);
- VERIFY(1 == swap_calls);
-}
-
-// Should use multiset specialization for swap.
-void test02()
-{
- bool test __attribute__((unused)) = true;
- using namespace std;
- multiset<T> A;
- multiset<T> B;
- swap_calls = 0;
- swap(A, B);
- VERIFY(1 == swap_calls);
-}
-
-#if !__GXX_WEAK__ && _MT_ALLOCATOR_H
-template class __gnu_cxx::__mt_alloc<std::_Rb_tree_node<T> >;
-#endif
-
-// See c++/13658 for background info.
-int main()
-{
- test01();
- test02();
- return 0;
-}
diff --git a/libstdc++-v3/testsuite/23_containers/set/modifiers/swap.cc b/libstdc++-v3/testsuite/23_containers/set/modifiers/swap.cc
deleted file mode 100644
index dcc69c99b3a..00000000000
--- a/libstdc++-v3/testsuite/23_containers/set/modifiers/swap.cc
+++ /dev/null
@@ -1,67 +0,0 @@
-// Copyright (C) 2004 Free Software Foundation
-//
-// This file is part of the GNU ISO C++ Library. This library is free
-// software; you can redistribute it and/or modify it under the
-// terms of the GNU General Public License as published by the
-// Free Software Foundation; either version 2, or (at your option)
-// any later version.
-
-// This library is distributed in the hope that it will be useful,
-// but WITHOUT ANY WARRANTY; without even the implied warranty of
-// MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-// GNU General Public License for more details.
-
-// You should have received a copy of the GNU General Public License along
-// with this library; see the file COPYING. If not, write to the Free
-// Software Foundation, 59 Temple Place - Suite 330, Boston, MA 02111-1307,
-// USA.
-
-#include <set>
-#include <testsuite_hooks.h>
-
-struct T { int i; };
-
-int swap_calls;
-
-namespace std
-{
- template<>
- void
- set<T>::swap(set<T>&)
- { ++swap_calls; }
-}
-
-// Should use set specialization for swap.
-void test01()
-{
- bool test __attribute__((unused)) = true;
- std::set<T> A;
- std::set<T> B;
- swap_calls = 0;
- std::swap(A, B);
- VERIFY(1 == swap_calls);
-}
-
-// Should use set specialization for swap.
-void test02()
-{
- bool test __attribute__((unused)) = true;
- using namespace std;
- set<T> A;
- set<T> B;
- swap_calls = 0;
- swap(A, B);
- VERIFY(1 == swap_calls);
-}
-
-#if !__GXX_WEAK__ && _MT_ALLOCATOR_H
-template class __gnu_cxx::__mt_alloc<std::_Rb_tree_node<T> >;
-#endif
-
-// See c++/13658 for background info.
-int main()
-{
- test01();
- test02();
- return 0;
-}
diff --git a/libstdc++-v3/testsuite/23_containers/vector/modifiers/swap.cc b/libstdc++-v3/testsuite/23_containers/vector/modifiers/swap.cc
deleted file mode 100644
index 4e49635bc22..00000000000
--- a/libstdc++-v3/testsuite/23_containers/vector/modifiers/swap.cc
+++ /dev/null
@@ -1,67 +0,0 @@
-// Copyright (C) 2004 Free Software Foundation
-//
-// This file is part of the GNU ISO C++ Library. This library is free
-// software; you can redistribute it and/or modify it under the
-// terms of the GNU General Public License as published by the
-// Free Software Foundation; either version 2, or (at your option)
-// any later version.
-
-// This library is distributed in the hope that it will be useful,
-// but WITHOUT ANY WARRANTY; without even the implied warranty of
-// MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-// GNU General Public License for more details.
-
-// You should have received a copy of the GNU General Public License along
-// with this library; see the file COPYING. If not, write to the Free
-// Software Foundation, 59 Temple Place - Suite 330, Boston, MA 02111-1307,
-// USA.
-
-#include <vector>
-#include <testsuite_hooks.h>
-
-struct T { int i; };
-
-int swap_calls;
-
-namespace std
-{
- template<>
- void
- vector<T, allocator<T> >::swap(vector<T, allocator<T> >&)
- { ++swap_calls; }
-}
-
-// Should use vector specialization for swap.
-void test01()
-{
- bool test __attribute__((unused)) = true;
- std::vector<T> A;
- std::vector<T> B;
- swap_calls = 0;
- std::swap(A, B);
- VERIFY(1 == swap_calls);
-}
-
-// Should use vector specialization for swap.
-void test02()
-{
- bool test __attribute__((unused)) = true;
- using namespace std;
- vector<T> A;
- vector<T> B;
- swap_calls = 0;
- swap(A, B);
- VERIFY(1 == swap_calls);
-}
-
-#if !__GXX_WEAK__ && _MT_ALLOCATOR_H
-template class __gnu_cxx::__mt_alloc<T>;
-#endif
-
-// See c++/13658 for background info.
-int main()
-{
- test01();
- test02();
- return 0;
-}
diff --git a/libstdc++-v3/testsuite/26_numerics/cmath/overloads.cc b/libstdc++-v3/testsuite/26_numerics/cmath/overloads.cc
deleted file mode 100644
index 4d41a9640b4..00000000000
--- a/libstdc++-v3/testsuite/26_numerics/cmath/overloads.cc
+++ /dev/null
@@ -1,27 +0,0 @@
-// PR 3181
-// Origin: pete@toyon.com
-
-#include <cmath>
-
-int main()
-{
- int i = -1;
- int j = 9;
- double ans;
- ans = std::acos(i);
- ans = std::asin(i);
- ans = std::atan(i);
- ans = std::atan2(i, j);
- ans = std::cos(i);
- ans = std::cosh(i);
- ans = std::exp(i);
- ans = std::fabs(i);
- ans = std::floor(i);
- ans = std::log(i);
- ans = std::log10(i);
- ans = std::sqrt(i);
- ans = std::sin(i);
- ans = std::sinh(j);
- ans = std::tan(i);
- ans = std::tanh(i);
-}
diff --git a/libstdc++-v3/testsuite/26_numerics/complex/13450.cc b/libstdc++-v3/testsuite/26_numerics/complex/13450.cc
deleted file mode 100644
index 50f4bad3b93..00000000000
--- a/libstdc++-v3/testsuite/26_numerics/complex/13450.cc
+++ /dev/null
@@ -1,75 +0,0 @@
-// Copyright (C) 2004 Free Software Foundation
-//
-// This file is part of the GNU ISO C++ Library. This library is free
-// software; you can redistribute it and/or modify it under the
-// terms of the GNU General Public License as published by the
-// Free Software Foundation; either version 2, or (at your option)
-// any later version.
-
-// This library is distributed in the hope that it will be useful,
-// but WITHOUT ANY WARRANTY; without even the implied warranty of
-// MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-// GNU General Public License for more details.
-
-// You should have received a copy of the GNU General Public License along
-// with this library; see the file COPYING. If not, write to the Free
-// Software Foundation, 59 Temple Place - Suite 330, Boston, MA 02111-1307,
-// USA.
-
-// 26.2.8 complex transcendentals
-
-#include <complex>
-#include <limits>
-#include <testsuite_hooks.h>
-
-template<typename T>
- void test01_do(T a, T b)
- {
- using namespace std;
- bool test __attribute__((unused)) = true;
- typedef complex<T> cplx;
-
- T eps = numeric_limits<T>::epsilon() * 100;
-
- cplx ref = pow(cplx(a, T()), cplx(b, T()));
- cplx res1 = pow(a, cplx(b, T()));
- cplx res2 = pow(cplx(a, T()), b);
-
- VERIFY( abs(ref - res1) < eps );
- VERIFY( abs(ref - res2) < eps );
- VERIFY( abs(res1 - res2) < eps );
- }
-
-// libstdc++/13450
-void test01()
-{
- float f1 = -1.0f;
- float f2 = 0.5f;
- test01_do(f1, f2);
-
- f1 = -3.2f;
- f2 = 1.4f;
- test01_do(f1, f2);
-
- double d1 = -1.0;
- double d2 = 0.5;
- test01_do(d1, d2);
-
- d1 = -3.2;
- d2 = 1.4;
- test01_do(d1, d2);
-
- long double ld1 = -1.0l;
- long double ld2 = 0.5l;
- test01_do(ld1, ld2);
-
- ld1 = -3.2l;
- ld2 = 1.4l;
- test01_do(ld1, ld2);
-}
-
-int main()
-{
- test01();
- return 0;
-}
diff --git a/libstdc++-v3/testsuite/26_numerics/complex/pow.cc b/libstdc++-v3/testsuite/26_numerics/complex/pow.cc
deleted file mode 100644
index 58d0fc5909b..00000000000
--- a/libstdc++-v3/testsuite/26_numerics/complex/pow.cc
+++ /dev/null
@@ -1,14 +0,0 @@
-// PR libbstdc++/10689
-// Origin: Daniel.Levine@jhuaph.edu
-
-#include <complex>
-#include <testsuite_hooks.h>
-
-int main()
-{
- std::complex<double> z;
-
- VERIFY( pow(z, 1.0/3.0) == 0.0 );
-
- return 0;
-}
diff --git a/libstdc++-v3/testsuite/26_numerics/valarray_subset_assignment.cc b/libstdc++-v3/testsuite/26_numerics/valarray_subset_assignment.cc
deleted file mode 100644
index 9298bfb046f..00000000000
--- a/libstdc++-v3/testsuite/26_numerics/valarray_subset_assignment.cc
+++ /dev/null
@@ -1,88 +0,0 @@
-// 2004-01-03 Jerry Quinn <jlquinn@optonline.net>
-
-// Copyright (C) 2004 Free Software Foundation, Inc.
-//
-// This file is part of the GNU ISO C++ Library. This library is free
-// software; you can redistribute it and/or modify it under the
-// terms of the GNU General Public License as published by the
-// Free Software Foundation; either version 2, or (at your option)
-// any later version.
-
-// This library is distributed in the hope that it will be useful,
-// but WITHOUT ANY WARRANTY; without even the implied warranty of
-// MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-// GNU General Public License for more details.
-
-// You should have received a copy of the GNU General Public License along
-// with this library; see the file COPYING. If not, write to the Free
-// Software Foundation, 59 Temple Place - Suite 330, Boston, MA 02111-1307,
-// USA.
-
-// As a special exception, you may use this file as part of a free software
-// library without restriction. Specifically, if other files instantiate
-// templates or use macros or inline functions from this file, or you compile
-// this file and link it with other files to produce an executable, this
-// file does not by itself cause the resulting executable to be covered by
-// the GNU General Public License. This exception does not however
-// invalidate any other reasons why the executable file might be covered by
-// the GNU General Public License.
-
-// PR 3247
-
-// This is DR-253. Test for accessible assignment-operators.
-#include <valarray>
-#include <testsuite_hooks.h>
-
-bool check_array(std::valarray<double>& a, double b[])
-{
- for (int i=0; i < a.size(); i++)
- if (a[i] != b[i]) return false;
- return true;
-}
-
-int main()
-{
- double dvar = 1.0;
- std::valarray<double> val_d(10); // 0 1 2 3 4 5 6 7 8 9
- std::valarray<double> val_d1(10); // 10 9 8 7 6 5 4 3 2 1
-
- for (int i=0; i< 10; i++) { val_d[i] = 10; val_d1[i] = i; }
- std::valarray<double> val_c(val_d);
- std::valarray<double> val_f(val_d);
- std::valarray<double> val_g(val_d);
-
- std::slice slc(1, 3, 3); // 1 4 7
- val_d[slc] = val_d1[slc];
-
- double ans1[10] = {10, 1, 10, 10, 4, 10, 10, 7, 10, 10};
- VERIFY(check_array(val_d, ans1));
-
- std::valarray<std::size_t> val_size(2);
- std::valarray<std::size_t> val_stride(2);
- val_size[0] = 2; val_size[1] = 3;
- val_stride[0] = 4; val_stride[1] = 1;
-
- std::gslice gslc(1, val_size, val_stride);
- val_c[gslc] = val_d1[gslc];
-
- double ans2[10] = {10, 1, 2, 3, 10, 5, 6, 7, 10, 10};
- VERIFY(check_array(val_c, ans2));
-
- std::valarray<bool> val_b(false, 10);
- val_b[2] = val_b[6] = val_b[9] = true;
- val_f[val_b] = val_d1[val_b];
-
- double ans3[10] = {10, 10, 2, 10, 10, 10, 6, 10, 10, 9};
- VERIFY(check_array(val_f, ans3));
-
- size_t addr[] = {1, 2, 3, 4, 5};
- size_t addr1[] = {2, 7, 1, 9, 4};
- std::valarray<std::size_t> val_indirect(addr, 5);
- std::valarray<std::size_t> val_indirect1(addr1, 5);
- val_g[val_indirect] = val_d1[val_indirect1];
-
- double ans4[10] = {10, 2, 7, 1, 9, 4, 10, 10, 10, 10};
- VERIFY(check_array(val_g, ans4));
-
- return 0;
-};
diff --git a/ltconfig b/ltconfig
index 0d97409d799..c1c903fa6e3 100755
--- a/ltconfig
+++ b/ltconfig
@@ -625,7 +625,8 @@ old_postuninstall_cmds=
if test -n "$RANLIB"; then
old_archive_cmds="$old_archive_cmds~\$RANLIB \$oldlib"
- old_postinstall_cmds="\$RANLIB \$oldlib~$old_postinstall_cmds"
+ # APPLE LOCAL begin handle ~ in pathnames 2002-01-14 sts
+ old_postinstall_cmds="\$RANLIB \$oldlib@$old_postinstall_cmds"
fi
# Source the script associated with the $tagname tag configuration.
diff --git a/ltmain.sh b/ltmain.sh
index c1ef9974d0e..fe0d022b07b 100644
--- a/ltmain.sh
+++ b/ltmain.sh
@@ -495,11 +495,34 @@ if test -z "$show_help"; then
# Only attempt this if the compiler in the base compile
# command doesn't match the default compiler.
if test -n "$available_tags" && test -z "$tagname"; then
+ # APPLE LOCAL begin handle ~ in pathnames 2002-01-14 sts
+ # Since CC may have args with shell metachars in them, add
+ # doublequotes to args so it looks the same as $base_compile.
+ qCC=
+ for argu in $CC; do
+ case $argu in
+ # Double-quote args containing other shell metacharacters.
+ # Many Bourne shells cannot handle close brackets correctly
+ # in scan sets, so we specify it separately.
+ *[\[\~\#\^\&\*\(\)\{\}\|\;\<\>\?\'\ \ ]*|*]*|"")
+ argu="\"$argu\""
+ ;;
+ esac
+ # Add the previous argument to qCC.
+ if test -z "$qCC"; then
+ qCC="$argu"
+ else
+ qCC="$qCC $argu"
+ fi
+ done
+ # APPLE LOCAL end handle ~ in pathnames 2002-01-14 sts
case $base_compile in
- "$CC "*) ;;
+ # APPLE LOCAL handle ~ in pathnames 2002-01-14 sts
+ "$qCC "*) ;;
# Blanks in the command may have been stripped by the calling shell,
# but not from the CC environment variable when ltconfig was run.
- "`$echo $CC` "*) ;;
+ # APPLE LOCAL handle ~ in pathnames 2002-01-14 sts
+ "`$echo $qCC` "*) ;;
*)
for z in $available_tags; do
if grep "^### BEGIN LIBTOOL TAG CONFIG: $z$" < "$0" > /dev/null; then
@@ -4913,7 +4936,8 @@ relink_command=\"$relink_command\""
# Do each command in the postinstall commands.
eval cmds=\"$old_postinstall_cmds\"
- IFS="${IFS= }"; save_ifs="$IFS"; IFS='~'
+ # APPLE LOCAL begin handle ~ in pathnames 2002-01-14 sts
+ IFS="${IFS= }"; save_ifs="$IFS"; IFS='@'
for cmd in $cmds; do
IFS="$save_ifs"
$show "$cmd"
diff --git a/maintainer-scripts/import-prune b/maintainer-scripts/import-prune
new file mode 100755
index 00000000000..66424e5f0d1
--- /dev/null
+++ b/maintainer-scripts/import-prune
@@ -0,0 +1,24 @@
+#!/bin/sh
+# APPLE LOCAL file maintenance
+# Use in directory to prune, argument is corresponding mainline source dir.
+# Output is list of commands to execute; save into file and review before
+# executing.
+
+diff -r --exclude CVS --exclude '*~' --exclude '*.#*' --brief $1 . \
+ | grep '^Only in \.' \
+ | sed -e 's,Only in \([^:]*\): \(.*\)$,\1/\2,' \
+ | sed -e 's,\./,,g' > /tmp/prunes
+
+for fname in `cat /tmp/prunes`; do
+ if head -3 $fname |grep -q 'APPLE *LOCAL' || test -d $fname; then :
+ echo "# keeping $fname"
+ else
+ echo "rm $fname; cvs remove $fname"
+ fi
+done
+
+
+
+
+
+
diff --git a/maintainer-scripts/local-summary b/maintainer-scripts/local-summary
new file mode 100755
index 00000000000..a3a518d4af1
--- /dev/null
+++ b/maintainer-scripts/local-summary
@@ -0,0 +1,60 @@
+#!/bin/sh
+# APPLE LOCAL file maintenance
+
+root="."
+uniq_options=""
+show_file=no
+
+while :
+do
+ case $# in
+ 0)
+ break
+ ;;
+ esac
+ option=$1
+ shift
+ case $option in
+ -c)
+ uniq_options="-c"
+ ;;
+ -f)
+ show_file=yes
+ ;;
+ *)
+ root=$option
+ ;;
+ esac
+done
+
+if [ $show_file == no ]; then
+ grep 'APPLE[^_]LOCAL' -r $root | sed -e 's/.*APPLE/APPLE/' >/tmp/rawlocals
+else
+ grep -n 'APPLE[^_]LOCAL' -r $root | sed -e 's/\(.*:[0-9]*:\).*APPLE/\1 APPLE/' >/tmp/rawlocals
+fi
+
+sed < /tmp/rawlocals \
+ -e 's/LOCAL[: ] /LOCAL /' \
+ -e 's/LOCAL *begin/LOCAL/' \
+ -e '/LOCAL *end/d' \
+ -e '/APPLE LOCAL"/d' \
+ -e 's/LOCAL *file/LOCAL/' \
+ -e 's/APPLE[ ]LOCAL[ ]*//' \
+ -e 's,\*/.*$,,g' \
+ -e 's/ dpatel//' \
+ -e 's/ ff//' \
+ -e 's/ ilr//' \
+ -e 's/ matt//' \
+ -e 's/ --matt//' \
+ -e 's/ sts//' \
+ -e 's/ turly//' \
+ -e 's/ tur//' \
+ -e 's/ zll//' \
+ -e 's/ 200[12]-..-..//' \
+ -e 's/ 200[12]-.-..//' \
+ -e 's/ 200[12][0-9][0-9][0-9][0-9]//' \
+ -e 's,[ */"\\]*$,,g' | \
+ sort | uniq $uniq_options
+
+
+
diff --git a/maintainer-scripts/local-untested b/maintainer-scripts/local-untested
new file mode 100755
index 00000000000..f7953192fba
--- /dev/null
+++ b/maintainer-scripts/local-untested
@@ -0,0 +1,9 @@
+#!/bin/sh
+# APPLE LOCAL file maintenance
+# Use from the toplevel directory.
+
+maintainer-scripts/local-summary gcc >/tmp/locals1
+maintainer-scripts/local-summary gcc/testsuite >/tmp/locals2
+
+diff -u /tmp/locals1 /tmp/locals2 | grep '^-' | sed -e 's/^-//'
+
diff --git a/man-pages/README b/man-pages/README
new file mode 100644
index 00000000000..61156ca88a8
--- /dev/null
+++ b/man-pages/README
@@ -0,0 +1,4 @@
+APPLE LOCAL file man pages
+
+This directory is a holder for preformatted man pages for Darwin gcc3.
+Eventually these should be generated during the build process.
diff --git a/man-pages/cpp3.1 b/man-pages/cpp3.1
new file mode 100644
index 00000000000..3ead6db6993
--- /dev/null
+++ b/man-pages/cpp3.1
@@ -0,0 +1,821 @@
+.\" Automatically generated by Pod::Man version 1.15
+.\" Wed Jun 19 19:36:25 2002
+.\"
+.\" Standard preamble:
+.\" ======================================================================
+.de Sh \" Subsection heading
+.br
+.if t .Sp
+.ne 5
+.PP
+\fB\\$1\fR
+.PP
+..
+.de Sp \" Vertical space (when we can't use .PP)
+.if t .sp .5v
+.if n .sp
+..
+.de Ip \" List item
+.br
+.ie \\n(.$>=3 .ne \\$3
+.el .ne 3
+.IP "\\$1" \\$2
+..
+.de Vb \" Begin verbatim text
+.ft CW
+.nf
+.ne \\$1
+..
+.de Ve \" End verbatim text
+.ft R
+
+.fi
+..
+.\" Set up some character translations and predefined strings. \*(-- will
+.\" give an unbreakable dash, \*(PI will give pi, \*(L" will give a left
+.\" double quote, and \*(R" will give a right double quote. | will give a
+.\" real vertical bar. \*(C+ will give a nicer C++. Capital omega is used
+.\" to do unbreakable dashes and therefore won't be available. \*(C` and
+.\" \*(C' expand to `' in nroff, nothing in troff, for use with C<>
+.tr \(*W-|\(bv\*(Tr
+.ds C+ C\v'-.1v'\h'-1p'\s-2+\h'-1p'+\s0\v'.1v'\h'-1p'
+.ie n \{\
+. ds -- \(*W-
+. ds PI pi
+. if (\n(.H=4u)&(1m=24u) .ds -- \(*W\h'-12u'\(*W\h'-12u'-\" diablo 10 pitch
+. if (\n(.H=4u)&(1m=20u) .ds -- \(*W\h'-12u'\(*W\h'-8u'-\" diablo 12 pitch
+. ds L" ""
+. ds R" ""
+. ds C` ""
+. ds C' ""
+'br\}
+.el\{\
+. ds -- \|\(em\|
+. ds PI \(*p
+. ds L" ``
+. ds R" ''
+'br\}
+.\"
+.\" If the F register is turned on, we'll generate index entries on stderr
+.\" for titles (.TH), headers (.SH), subsections (.Sh), items (.Ip), and
+.\" index entries marked with X<> in POD. Of course, you'll have to process
+.\" the output yourself in some meaningful fashion.
+.if \nF \{\
+. de IX
+. tm Index:\\$1\t\\n%\t"\\$2"
+..
+. nr % 0
+. rr F
+.\}
+.\"
+.\" For nroff, turn off justification. Always turn off hyphenation; it
+.\" makes way too many mistakes in technical documents.
+.hy 0
+.if n .na
+.\"
+.\" Accent mark definitions (@(#)ms.acc 1.5 88/02/08 SMI; from UCB 4.2).
+.\" Fear. Run. Save yourself. No user-serviceable parts.
+.bd B 3
+. \" fudge factors for nroff and troff
+.if n \{\
+. ds #H 0
+. ds #V .8m
+. ds #F .3m
+. ds #[ \f1
+. ds #] \fP
+.\}
+.if t \{\
+. ds #H ((1u-(\\\\n(.fu%2u))*.13m)
+. ds #V .6m
+. ds #F 0
+. ds #[ \&
+. ds #] \&
+.\}
+. \" simple accents for nroff and troff
+.if n \{\
+. ds ' \&
+. ds ` \&
+. ds ^ \&
+. ds , \&
+. ds ~ ~
+. ds /
+.\}
+.if t \{\
+. ds ' \\k:\h'-(\\n(.wu*8/10-\*(#H)'\'\h"|\\n:u"
+. ds ` \\k:\h'-(\\n(.wu*8/10-\*(#H)'\`\h'|\\n:u'
+. ds ^ \\k:\h'-(\\n(.wu*10/11-\*(#H)'^\h'|\\n:u'
+. ds , \\k:\h'-(\\n(.wu*8/10)',\h'|\\n:u'
+. ds ~ \\k:\h'-(\\n(.wu-\*(#H-.1m)'~\h'|\\n:u'
+. ds / \\k:\h'-(\\n(.wu*8/10-\*(#H)'\z\(sl\h'|\\n:u'
+.\}
+. \" troff and (daisy-wheel) nroff accents
+.ds : \\k:\h'-(\\n(.wu*8/10-\*(#H+.1m+\*(#F)'\v'-\*(#V'\z.\h'.2m+\*(#F'.\h'|\\n:u'\v'\*(#V'
+.ds 8 \h'\*(#H'\(*b\h'-\*(#H'
+.ds o \\k:\h'-(\\n(.wu+\w'\(de'u-\*(#H)/2u'\v'-.3n'\*(#[\z\(de\v'.3n'\h'|\\n:u'\*(#]
+.ds d- \h'\*(#H'\(pd\h'-\w'~'u'\v'-.25m'\f2\(hy\fP\v'.25m'\h'-\*(#H'
+.ds D- D\\k:\h'-\w'D'u'\v'-.11m'\z\(hy\v'.11m'\h'|\\n:u'
+.ds th \*(#[\v'.3m'\s+1I\s-1\v'-.3m'\h'-(\w'I'u*2/3)'\s-1o\s+1\*(#]
+.ds Th \*(#[\s+2I\s-2\h'-\w'I'u*3/5'\v'-.3m'o\v'.3m'\*(#]
+.ds ae a\h'-(\w'a'u*4/10)'e
+.ds Ae A\h'-(\w'A'u*4/10)'E
+. \" corrections for vroff
+.if v .ds ~ \\k:\h'-(\\n(.wu*9/10-\*(#H)'\s-2\u~\d\s+2\h'|\\n:u'
+.if v .ds ^ \\k:\h'-(\\n(.wu*10/11-\*(#H)'\v'-.4m'^\v'.4m'\h'|\\n:u'
+. \" for low resolution devices (crt and lpr)
+.if \n(.H>23 .if \n(.V>19 \
+\{\
+. ds : e
+. ds 8 ss
+. ds o a
+. ds d- d\h'-1'\(ga
+. ds D- D\h'-1'\(hy
+. ds th \o'bp'
+. ds Th \o'LP'
+. ds ae ae
+. ds Ae AE
+.\}
+.rm #[ #] #H #V #F C
+.\" ======================================================================
+.\"
+.IX Title "CPP 1"
+.TH CPP 1 "gcc-3.1" "2002-06-19" "GNU"
+.UC
+.SH "NAME"
+cpp \- The C Preprocessor
+.SH "SYNOPSIS"
+.IX Header "SYNOPSIS"
+cpp [\fB\-D\fR\fImacro\fR[=\fIdefn\fR]...] [\fB\-U\fR\fImacro\fR]
+ [\fB\-I\fR\fIdir\fR...] [\fB\-W\fR\fIwarn\fR...]
+ [\fB\-M\fR|\fB\-MM\fR] [\fB\-MG\fR] [\fB\-MF\fR \fIfilename\fR]
+ [\fB\-MP\fR] [\fB\-MQ\fR \fItarget\fR...] [\fB\-MT\fR \fItarget\fR...]
+ [\fB\-x\fR \fIlanguage\fR] [\fB\-std=\fR\fIstandard\fR]
+ \fIinfile\fR \fIoutfile\fR
+.PP
+Only the most useful options are listed here; see below for the remainder.
+.SH "DESCRIPTION"
+.IX Header "DESCRIPTION"
+The C preprocessor, often known as \fIcpp\fR, is a \fImacro processor\fR
+that is used automatically by the C compiler to transform your program
+before compilation. It is called a macro processor because it allows
+you to define \fImacros\fR, which are brief abbreviations for longer
+constructs.
+.PP
+The C preprocessor is intended to be used only with C, \*(C+, and
+Objective-C source code. In the past, it has been abused as a general
+text processor. It will choke on input which does not obey C's lexical
+rules. For example, apostrophes will be interpreted as the beginning of
+character constants, and cause errors. Also, you cannot rely on it
+preserving characteristics of the input which are not significant to
+C-family languages. If a Makefile is preprocessed, all the hard tabs
+will be removed, and the Makefile will not work.
+.PP
+Having said that, you can often get away with using cpp on things which
+are not C. Other Algol-ish programming languages are often safe
+(Pascal, Ada, etc.) So is assembly, with caution. \fB\-traditional\fR
+mode preserves more white space, and is otherwise more permissive. Many
+of the problems can be avoided by writing C or \*(C+ style comments
+instead of native language comments, and keeping macros simple.
+.PP
+Wherever possible, you should use a preprocessor geared to the language
+you are writing in. Modern versions of the \s-1GNU\s0 assembler have macro
+facilities. Most high level programming languages have their own
+conditional compilation and inclusion mechanism. If all else fails,
+try a true general text processor, such as \s-1GNU\s0 M4.
+.PP
+C preprocessors vary in some details. This manual discusses the \s-1GNU\s0 C
+preprocessor, which provides a small superset of the features of \s-1ISO\s0
+Standard C. In its default mode, the \s-1GNU\s0 C preprocessor does not do a
+few things required by the standard. These are features which are
+rarely, if ever, used, and may cause surprising changes to the meaning
+of a program which does not expect them. To get strict \s-1ISO\s0 Standard C,
+you should use the \fB\-std=c89\fR or \fB\-std=c99\fR options, depending
+on which version of the standard you want. To get all the mandatory
+diagnostics, you must also use \fB\-pedantic\fR.
+.SH "OPTIONS"
+.IX Header "OPTIONS"
+The C preprocessor expects two file names as arguments, \fIinfile\fR and
+\&\fIoutfile\fR. The preprocessor reads \fIinfile\fR together with any
+other files it specifies with \fB#include\fR. All the output generated
+by the combined input files is written in \fIoutfile\fR.
+.PP
+Either \fIinfile\fR or \fIoutfile\fR may be \fB-\fR, which as
+\&\fIinfile\fR means to read from standard input and as \fIoutfile\fR
+means to write to standard output. Also, if either file is omitted, it
+means the same as if \fB-\fR had been specified for that file.
+.PP
+Unless otherwise noted, or the option ends in \fB=\fR, all options
+which take an argument may have that argument appear either immediately
+after the option, or with a space between option and argument:
+\&\fB\-Ifoo\fR and \fB\-I foo\fR have the same effect.
+.PP
+Many options have multi-letter names; therefore multiple single-letter
+options may \fInot\fR be grouped: \fB\-dM\fR is very different from
+\&\fB\-d\ \-M\fR.
+.Ip "\fB\-D\fR \fIname\fR" 4
+.IX Item "-D name"
+Predefine \fIname\fR as a macro, with definition \f(CW\*(C`1\*(C'\fR.
+.Ip "\fB\-D\fR \fIname\fR\fB=\fR\fIdefinition\fR" 4
+.IX Item "-D name=definition"
+Predefine \fIname\fR as a macro, with definition \fIdefinition\fR.
+There are no restrictions on the contents of \fIdefinition\fR, but if
+you are invoking the preprocessor from a shell or shell-like program you
+may need to use the shell's quoting syntax to protect characters such as
+spaces that have a meaning in the shell syntax.
+.Sp
+If you wish to define a function-like macro on the command line, write
+its argument list with surrounding parentheses before the equals sign
+(if any). Parentheses are meaningful to most shells, so you will need
+to quote the option. With \fBsh\fR and \fBcsh\fR,
+\&\fB\-D'\fR\fIname\fR\fB(\fR\fIargs...\fR\fB)=\fR\fIdefinition\fR\fB'\fR works.
+.Sp
+\&\fB\-D\fR and \fB\-U\fR options are processed in the order they
+are given on the command line. All \fB\-imacros\fR \fIfile\fR and
+\&\fB\-include\fR \fIfile\fR options are processed after all
+\&\fB\-D\fR and \fB\-U\fR options.
+.Ip "\fB\-U\fR \fIname\fR" 4
+.IX Item "-U name"
+Cancel any previous definition of \fIname\fR, either built in or
+provided with a \fB\-D\fR option.
+.Ip "\fB\-undef\fR" 4
+.IX Item "-undef"
+Do not predefine any system-specific macros. The common predefined
+macros remain defined.
+.Ip "\fB\-I\fR \fIdir\fR" 4
+.IX Item "-I dir"
+Add the directory \fIdir\fR to the list of directories to be searched
+for header files.
+.Sp
+Directories named by \fB\-I\fR are searched before the standard
+system include directories.
+.Sp
+It is dangerous to specify a standard system include directory in an
+\&\fB\-I\fR option. This defeats the special treatment of system
+headers
+\&. It can also defeat the repairs to buggy system headers which \s-1GCC\s0
+makes when it is installed.
+.Ip "\fB\-o\fR \fIfile\fR" 4
+.IX Item "-o file"
+Write output to \fIfile\fR. This is the same as specifying \fIfile\fR
+as the second non-option argument to \fBcpp\fR. \fBgcc\fR has a
+different interpretation of a second non-option argument, so you must
+use \fB\-o\fR to specify the output file.
+.Ip "\fB\-Wall\fR" 4
+.IX Item "-Wall"
+Turns on all optional warnings which are desirable for normal code. At
+present this is \fB\-Wcomment\fR and \fB\-Wtrigraphs\fR. Note that
+many of the preprocessor's warnings are on by default and have no
+options to control them.
+.Ip "\fB\-Wcomment\fR" 4
+.IX Item "-Wcomment"
+.PD 0
+.Ip "\fB\-Wcomments\fR" 4
+.IX Item "-Wcomments"
+.PD
+Warn whenever a comment-start sequence \fB/*\fR appears in a \fB/*\fR
+comment, or whenever a backslash-newline appears in a \fB//\fR comment.
+(Both forms have the same effect.)
+.Ip "\fB\-Wtrigraphs\fR" 4
+.IX Item "-Wtrigraphs"
+Warn if any trigraphs are encountered. This option used to take effect
+only if \fB\-trigraphs\fR was also specified, but now works
+independently. Warnings are not given for trigraphs within comments, as
+they do not affect the meaning of the program.
+.Ip "\fB\-Wtraditional\fR" 4
+.IX Item "-Wtraditional"
+Warn about certain constructs that behave differently in traditional and
+\&\s-1ISO\s0 C. Also warn about \s-1ISO\s0 C constructs that have no traditional C
+equivalent, and problematic constructs which should be avoided.
+.Ip "\fB\-Wimport\fR" 4
+.IX Item "-Wimport"
+Warn the first time \fB#import\fR is used.
+.Ip "\fB\-Wundef\fR" 4
+.IX Item "-Wundef"
+Warn whenever an identifier which is not a macro is encountered in an
+\&\fB#if\fR directive, outside of \fBdefined\fR. Such identifiers are
+replaced with zero.
+.Ip "\fB\-Werror\fR" 4
+.IX Item "-Werror"
+Make all warnings into hard errors. Source code which triggers warnings
+will be rejected.
+.Ip "\fB\-Wsystem-headers\fR" 4
+.IX Item "-Wsystem-headers"
+Issue warnings for code in system headers. These are normally unhelpful
+in finding bugs in your own code, therefore suppressed. If you are
+responsible for the system library, you may want to see them.
+.Ip "\fB\-w\fR" 4
+.IX Item "-w"
+Suppress all warnings, including those which \s-1GNU\s0 \s-1CPP\s0 issues by default.
+.Ip "\fB\-pedantic\fR" 4
+.IX Item "-pedantic"
+Issue all the mandatory diagnostics listed in the C standard. Some of
+them are left out by default, since they trigger frequently on harmless
+code.
+.Ip "\fB\-pedantic-errors\fR" 4
+.IX Item "-pedantic-errors"
+Issue all the mandatory diagnostics, and make all mandatory diagnostics
+into errors. This includes mandatory diagnostics that \s-1GCC\s0 issues
+without \fB\-pedantic\fR but treats as warnings.
+.Ip "\fB\-M\fR" 4
+.IX Item "-M"
+Instead of outputting the result of preprocessing, output a rule
+suitable for \fBmake\fR describing the dependencies of the main
+source file. The preprocessor outputs one \fBmake\fR rule containing
+the object file name for that source file, a colon, and the names of all
+the included files, including those coming from \fB\-include\fR or
+\&\fB\-imacros\fR command line options.
+.Sp
+Unless specified explicitly (with \fB\-MT\fR or \fB\-MQ\fR), the
+object file name consists of the basename of the source file with any
+suffix replaced with object file suffix. If there are many included
+files then the rule is split into several lines using \fB\e\fR\-newline.
+The rule has no commands.
+.Sp
+This option does not suppress the preprocessor's debug output, such as
+\&\fB\-dM\fR. To avoid mixing such debug output with the dependency
+rules you should explicitly specify the dependency output file with
+\&\fB\-MF\fR, or use an environment variable like
+\&\fB\s-1DEPENDENCIES_OUTPUT\s0\fR. Debug output
+will still be sent to the regular output stream as normal.
+.Sp
+Passing \fB\-M\fR to the driver implies \fB\-E\fR.
+.Ip "\fB\-MM\fR" 4
+.IX Item "-MM"
+Like \fB\-M\fR but do not mention header files that are found in
+system header directories, nor header files that are included,
+directly or indirectly, from such a header.
+.Sp
+This implies that the choice of angle brackets or double quotes in an
+\&\fB#include\fR directive does not in itself determine whether that
+header will appear in \fB\-MM\fR dependency output. This is a
+slight change in semantics from \s-1GCC\s0 versions 3.0 and earlier.
+.Ip "\fB\-MF\fR \fIfile\fR" 4
+.IX Item "-MF file"
+@anchor{\-MF}
+When used with \fB\-M\fR or \fB\-MM\fR, specifies a
+file to write the dependencies to. If no \fB\-MF\fR switch is given
+the preprocessor sends the rules to the same place it would have sent
+preprocessed output.
+.Sp
+When used with the driver options \fB\-MD\fR or \fB\-MMD\fR,
+\&\fB\-MF\fR overrides the default dependency output file.
+.Ip "\fB\-dependency-file\fR" 4
+.IX Item "-dependency-file"
+Like \fB\-MF\fR. (\s-1APPLE\s0 \s-1ONLY\s0)
+.Ip "\fB\-MG\fR" 4
+.IX Item "-MG"
+When used with \fB\-M\fR or \fB\-MM\fR, \fB\-MG\fR says to treat missing
+header files as generated files and assume they live in the same
+directory as the source file. It suppresses preprocessed output, as a
+missing header file is ordinarily an error.
+.Sp
+This feature is used in automatic updating of makefiles.
+.Ip "\fB\-MP\fR" 4
+.IX Item "-MP"
+This option instructs \s-1CPP\s0 to add a phony target for each dependency
+other than the main file, causing each to depend on nothing. These
+dummy rules work around errors \fBmake\fR gives if you remove header
+files without updating the \fIMakefile\fR to match.
+.Sp
+This is typical output:
+.Sp
+.Vb 1
+\& test.o: test.c test.h
+.Ve
+.Vb 1
+\& test.h:
+.Ve
+.Ip "\fB\-MT\fR \fItarget\fR" 4
+.IX Item "-MT target"
+Change the target of the rule emitted by dependency generation. By
+default \s-1CPP\s0 takes the name of the main input file, including any path,
+deletes any file suffix such as \fB.c\fR, and appends the platform's
+usual object suffix. The result is the target.
+.Sp
+An \fB\-MT\fR option will set the target to be exactly the string you
+specify. If you want multiple targets, you can specify them as a single
+argument to \fB\-MT\fR, or use multiple \fB\-MT\fR options.
+.Sp
+For example, \fB\-MT\ '$(objpfx)foo.o'\fR might give
+.Sp
+.Vb 1
+\& $(objpfx)foo.o: foo.c
+.Ve
+.Ip "\fB\-MQ\fR \fItarget\fR" 4
+.IX Item "-MQ target"
+Same as \fB\-MT\fR, but it quotes any characters which are special to
+Make. \fB\-MQ\ '$(objpfx)foo.o'\fR gives
+.Sp
+.Vb 1
+\& $$(objpfx)foo.o: foo.c
+.Ve
+The default target is automatically quoted, as if it were given with
+\&\fB\-MQ\fR.
+.Ip "\fB\-MD\fR" 4
+.IX Item "-MD"
+\&\fB\-MD\fR is equivalent to \fB\-M \-MF\fR \fIfile\fR, except that
+\&\fB\-E\fR is not implied. The driver determines \fIfile\fR based on
+whether an \fB\-o\fR option is given. If it is, the driver uses its
+argument but with a suffix of \fI.d\fR, otherwise it take the
+basename of the input file and applies a \fI.d\fR suffix.
+.Sp
+If \fB\-MD\fR is used in conjunction with \fB\-E\fR, any
+\&\fB\-o\fR switch is understood to specify the dependency output file
+(but \f(CW@pxref\fR{\-MF}), but if used without \fB\-E\fR, each \fB\-o\fR
+is understood to specify a target object file.
+.Sp
+Since \fB\-E\fR is not implied, \fB\-MD\fR can be used to generate
+a dependency output file as a side-effect of the compilation process.
+.Ip "\fB\-MMD\fR" 4
+.IX Item "-MMD"
+Like \fB\-MD\fR except mention only user header files, not system
+\&\-header files.
+.Ip "\fB\-x c\fR" 4
+.IX Item "-x c"
+.PD 0
+.Ip "\fB\-x c++\fR" 4
+.IX Item "-x c++"
+.Ip "\fB\-x objective-c\fR" 4
+.IX Item "-x objective-c"
+.Ip "\fB\-x objective-c++\fR" 4
+.IX Item "-x objective-c++"
+.Ip "\fB\-x assembler-with-cpp\fR" 4
+.IX Item "-x assembler-with-cpp"
+.PD
+Specify the source language: C, \*(C+, Objective-C, Objective-\*(C+, or assembly. This has
+nothing to do with standards conformance or extensions; it merely
+selects which base syntax to expect. If you give none of these options,
+cpp will deduce the language from the extension of the source file:
+\&\fB.c\fR, \fB.cc\fR, \fB.m\fR, \fB.mm\fR, or \fB.S\fR. Some other common
+extensions for \*(C+ and assembly are also recognized. If cpp does not
+recognize the extension, it will treat the file as C; this is the most
+generic mode.
+.Sp
+\&\fBNote:\fR Previous versions of cpp accepted a \fB\-lang\fR option
+which selected both the language and the standards conformance level.
+This option has been removed, because it conflicts with the \fB\-l\fR
+option.
+.Ip "\fB\-std=\fR\fIstandard\fR" 4
+.IX Item "-std=standard"
+.PD 0
+.Ip "\fB\-ansi\fR" 4
+.IX Item "-ansi"
+.PD
+Specify the standard to which the code should conform. Currently cpp
+only knows about the standards for C; other language standards will be
+added in the future.
+.Sp
+\&\fIstandard\fR
+may be one of:
+.RS 4
+.if n .Ip "\f(CW""""iso9899:1990""""\fR" 4
+.el .Ip "\f(CWiso9899:1990\fR" 4
+.IX Item "iso9899:1990"
+.PD 0
+.if n .Ip "\f(CW""""c89""""\fR" 4
+.el .Ip "\f(CWc89\fR" 4
+.IX Item "c89"
+.PD
+The \s-1ISO\s0 C standard from 1990. \fBc89\fR is the customary shorthand for
+this version of the standard.
+.Sp
+The \fB\-ansi\fR option is equivalent to \fB\-std=c89\fR.
+.if n .Ip "\f(CW""""iso9899:199409""""\fR" 4
+.el .Ip "\f(CWiso9899:199409\fR" 4
+.IX Item "iso9899:199409"
+The 1990 C standard, as amended in 1994.
+.if n .Ip "\f(CW""""iso9899:1999""""\fR" 4
+.el .Ip "\f(CWiso9899:1999\fR" 4
+.IX Item "iso9899:1999"
+.PD 0
+.if n .Ip "\f(CW""""c99""""\fR" 4
+.el .Ip "\f(CWc99\fR" 4
+.IX Item "c99"
+.if n .Ip "\f(CW""""iso9899:199x""""\fR" 4
+.el .Ip "\f(CWiso9899:199x\fR" 4
+.IX Item "iso9899:199x"
+.if n .Ip "\f(CW""""c9x""""\fR" 4
+.el .Ip "\f(CWc9x\fR" 4
+.IX Item "c9x"
+.PD
+The revised \s-1ISO\s0 C standard, published in December 1999. Before
+publication, this was known as C9X.
+.if n .Ip "\f(CW""""gnu89""""\fR" 4
+.el .Ip "\f(CWgnu89\fR" 4
+.IX Item "gnu89"
+The 1990 C standard plus \s-1GNU\s0 extensions. This is the default.
+.if n .Ip "\f(CW""""gnu99""""\fR" 4
+.el .Ip "\f(CWgnu99\fR" 4
+.IX Item "gnu99"
+.PD 0
+.if n .Ip "\f(CW""""gnu9x""""\fR" 4
+.el .Ip "\f(CWgnu9x\fR" 4
+.IX Item "gnu9x"
+.PD
+The 1999 C standard plus \s-1GNU\s0 extensions.
+.RE
+.RS 4
+.RE
+.Ip "\fB\-I-\fR" 4
+.IX Item "-I-"
+Split the include path. Any directories specified with \fB\-I\fR
+options before \fB\-I-\fR are searched only for headers requested with
+\&\f(CW\*(C`#include\ "\f(CIfile\f(CW"\*(C'\fR; they are not searched for
+\&\f(CW\*(C`#include\ <\f(CIfile\f(CW>\*(C'\fR. If additional directories are
+specified with \fB\-I\fR options after the \fB\-I-\fR, those
+directories are searched for all \fB#include\fR directives.
+.Sp
+In addition, \fB\-I-\fR inhibits the use of the directory of the current
+file directory as the first search directory for \f(CW\*(C`#include\ "\f(CIfile\f(CW"\*(C'\fR.
+.Ip "\fB\-nostdinc\fR" 4
+.IX Item "-nostdinc"
+Do not search the standard system directories for header files.
+Only the directories you have specified with \fB\-I\fR options
+(and the directory of the current file, if appropriate) are searched.
+.Ip "\fB\-nostdinc++\fR" 4
+.IX Item "-nostdinc++"
+Do not search for header files in the \*(C+\-specific standard directories,
+but do still search the other standard directories. (This option is
+used when building the \*(C+ library.)
+.Ip "\fB\-include\fR \fIfile\fR" 4
+.IX Item "-include file"
+Process \fIfile\fR as if \f(CW\*(C`#include "file"\*(C'\fR appeared as the first
+line of the primary source file. However, the first directory searched
+for \fIfile\fR is the preprocessor's working directory \fIinstead of\fR
+the directory containing the main source file. If not found there, it
+is searched for in the remainder of the \f(CW\*(C`#include "..."\*(C'\fR search
+chain as normal.
+.Sp
+If multiple \fB\-include\fR options are given, the files are included
+in the order they appear on the command line.
+.Ip "\fB\-imacros\fR \fIfile\fR" 4
+.IX Item "-imacros file"
+Exactly like \fB\-include\fR, except that any output produced by
+scanning \fIfile\fR is thrown away. Macros it defines remain defined.
+This allows you to acquire all the macros from a header without also
+processing its declarations.
+.Sp
+All files specified by \fB\-imacros\fR are processed before all files
+specified by \fB\-include\fR.
+.Ip "\fB\-idirafter\fR \fIdir\fR" 4
+.IX Item "-idirafter dir"
+Search \fIdir\fR for header files, but do it \fIafter\fR all
+directories specified with \fB\-I\fR and the standard system directories
+have been exhausted. \fIdir\fR is treated as a system include directory.
+.Ip "\fB\-iprefix\fR \fIprefix\fR" 4
+.IX Item "-iprefix prefix"
+Specify \fIprefix\fR as the prefix for subsequent \fB\-iwithprefix\fR
+options. If the prefix represents a directory, you should include the
+final \fB/\fR.
+.Ip "\fB\-iwithprefix\fR \fIdir\fR" 4
+.IX Item "-iwithprefix dir"
+.PD 0
+.Ip "\fB\-iwithprefixbefore\fR \fIdir\fR" 4
+.IX Item "-iwithprefixbefore dir"
+.PD
+Append \fIdir\fR to the prefix specified previously with
+\&\fB\-iprefix\fR, and add the resulting directory to the include search
+path. \fB\-iwithprefixbefore\fR puts it in the same place \fB\-I\fR
+would; \fB\-iwithprefix\fR puts it where \fB\-idirafter\fR would.
+.Sp
+Use of these options is discouraged.
+.Ip "\fB\-isystem\fR \fIdir\fR" 4
+.IX Item "-isystem dir"
+Search \fIdir\fR for header files, after all directories specified by
+\&\fB\-I\fR but before the standard system directories. Mark it
+as a system directory, so that it gets the same special treatment as
+is applied to the standard system directories.
+.Ip "\fB\-fpreprocessed\fR" 4
+.IX Item "-fpreprocessed"
+Indicate to the preprocessor that the input file has already been
+preprocessed. This suppresses things like macro expansion, trigraph
+conversion, escaped newline splicing, and processing of most directives.
+The preprocessor still recognizes and removes comments, so that you can
+pass a file preprocessed with \fB\-C\fR to the compiler without
+problems. In this mode the integrated preprocessor is little more than
+a tokenizer for the front ends.
+.Sp
+\&\fB\-fpreprocessed\fR is implicit if the input file has one of the
+extensions \fB.i\fR, \fB.ii\fR or \fB.mi\fR. These are the
+extensions that \s-1GCC\s0 uses for preprocessed files created by
+\&\fB\-save-temps\fR.
+.Ip "\fB\-ftabstop=\fR\fIwidth\fR" 4
+.IX Item "-ftabstop=width"
+Set the distance between tab stops. This helps the preprocessor report
+correct column numbers in warnings or errors, even if tabs appear on the
+line. If the value is less than 1 or greater than 100, the option is
+ignored. The default is 8.
+.Ip "\fB\-fno-show-column\fR" 4
+.IX Item "-fno-show-column"
+Do not print column numbers in diagnostics. This may be necessary if
+diagnostics are being scanned by a program that does not understand the
+column numbers, such as \fBdejagnu\fR.
+.Ip "\fB\-A\fR \fIpredicate\fR\fB=\fR\fIanswer\fR" 4
+.IX Item "-A predicate=answer"
+Make an assertion with the predicate \fIpredicate\fR and answer
+\&\fIanswer\fR. This form is preferred to the older form \fB\-A\fR
+\&\fIpredicate\fR\fB(\fR\fIanswer\fR\fB)\fR, which is still supported, because
+it does not use shell special characters.
+.Ip "\fB\-A -\fR\fIpredicate\fR\fB=\fR\fIanswer\fR" 4
+.IX Item "-A -predicate=answer"
+Cancel an assertion with the predicate \fIpredicate\fR and answer
+\&\fIanswer\fR.
+.Ip "\fB\-A-\fR" 4
+.IX Item "-A-"
+Cancel all predefined assertions and all assertions preceding it on
+the command line. Also, undefine all predefined macros and all
+macros preceding it on the command line. (This is a historical wart and
+may change in the future.)
+.Ip "\fB\-dCHARS\fR" 4
+.IX Item "-dCHARS"
+\&\fI\s-1CHARS\s0\fR is a sequence of one or more of the following characters,
+and must not be preceded by a space. Other characters are interpreted
+by the compiler proper, or reserved for future versions of \s-1GCC\s0, and so
+are silently ignored. If you specify characters whose behavior
+conflicts, the result is undefined.
+.RS 4
+.Ip "\fBM\fR" 4
+.IX Item "M"
+Instead of the normal output, generate a list of \fB#define\fR
+directives for all the macros defined during the execution of the
+preprocessor, including predefined macros. This gives you a way of
+finding out what is predefined in your version of the preprocessor.
+Assuming you have no file \fIfoo.h\fR, the command
+.Sp
+.Vb 1
+\& touch foo.h; cpp -dM foo.h
+.Ve
+will show all the predefined macros.
+.Ip "\fBD\fR" 4
+.IX Item "D"
+Like \fBM\fR except in two respects: it does \fInot\fR include the
+predefined macros, and it outputs \fIboth\fR the \fB#define\fR
+directives and the result of preprocessing. Both kinds of output go to
+the standard output file.
+.Ip "\fBN\fR" 4
+.IX Item "N"
+Like \fBD\fR, but emit only the macro names, not their expansions.
+.Ip "\fBI\fR" 4
+.IX Item "I"
+Output \fB#include\fR directives in addition to the result of
+preprocessing.
+.RE
+.RS 4
+.RE
+.Ip "\fB\-P\fR" 4
+.IX Item "-P"
+Inhibit generation of linemarkers in the output from the preprocessor.
+This might be useful when running the preprocessor on something that is
+not C code, and will be sent to a program which might be confused by the
+linemarkers.
+.Ip "\fB\-C\fR" 4
+.IX Item "-C"
+Do not discard comments. All comments are passed through to the output
+file, except for comments in processed directives, which are deleted
+along with the directive.
+.Sp
+You should be prepared for side effects when using \fB\-C\fR; it
+causes the preprocessor to treat comments as tokens in their own right.
+For example, comments appearing at the start of what would be a
+directive line have the effect of turning that line into an ordinary
+source line, since the first token on the line is no longer a \fB#\fR.
+.Ip "\fB\-gcc\fR" 4
+.IX Item "-gcc"
+Define the macros _\|_GNUC_\|_, _\|_GNUC_MINOR_\|_ and
+_\|_GNUC_PATCHLEVEL_\|_. These are defined automatically when you use
+\&\fBgcc \-E\fR; you can turn them off in that case with
+\&\fB\-no-gcc\fR.
+.Ip "\fB\-traditional\fR" 4
+.IX Item "-traditional"
+Try to imitate the behavior of old-fashioned C, as opposed to \s-1ISO\s0
+C.
+.Ip "\fB\-trigraphs\fR" 4
+.IX Item "-trigraphs"
+Process trigraph sequences.
+.Ip "\fB\-remap\fR" 4
+.IX Item "-remap"
+Enable special code to work around file systems which only permit very
+short file names, such as \s-1MS-DOS\s0.
+.Ip "\fB\-$\fR" 4
+.IX Item "-$"
+Forbid the use of \fB$\fR in identifiers. The C standard allows
+implementations to define extra characters that can appear in
+identifiers. By default \s-1GNU\s0 \s-1CPP\s0 permits \fB$\fR, a common extension.
+.Ip "\fB\-h\fR" 4
+.IX Item "-h"
+.PD 0
+.Ip "\fB\*(--help\fR" 4
+.IX Item "help"
+.Ip "\fB\*(--target-help\fR" 4
+.IX Item "target-help"
+.PD
+Print text describing all the command line options instead of
+preprocessing anything.
+.Ip "\fB\-v\fR" 4
+.IX Item "-v"
+Verbose mode. Print out \s-1GNU\s0 \s-1CPP\s0's version number at the beginning of
+execution, and report the final form of the include path.
+.Ip "\fB\-H\fR" 4
+.IX Item "-H"
+Print the name of each header file used, in addition to other normal
+activities. Each name is indented to show how deep in the
+\&\fB#include\fR stack it is.
+.Ip "\fB\-version\fR" 4
+.IX Item "-version"
+.PD 0
+.Ip "\fB\*(--version\fR" 4
+.IX Item "version"
+.PD
+Print out \s-1GNU\s0 \s-1CPP\s0's version number. With one dash, proceed to
+preprocess as normal. With two dashes, exit immediately.
+.SH "ENVIRONMENT"
+.IX Header "ENVIRONMENT"
+This section describes the environment variables that affect how \s-1CPP\s0
+operates. You can use them to specify directories or prefixes to use
+when searching for include files, or to control dependency output.
+.PP
+Note that you can also specify places to search using options such as
+\&\fB\-I\fR, and control dependency output with options like
+\&\fB\-M\fR. These take precedence over
+environment variables, which in turn take precedence over the
+configuration of \s-1GCC\s0.
+.Ip "\fB\s-1CPATH\s0\fR" 4
+.IX Item "CPATH"
+.PD 0
+.Ip "\fBC_INCLUDE_PATH\fR" 4
+.IX Item "C_INCLUDE_PATH"
+.Ip "\fB\s-1CPLUS_INCLUDE_PATH\s0\fR" 4
+.IX Item "CPLUS_INCLUDE_PATH"
+.Ip "\fB\s-1OBJC_INCLUDE_PATH\s0\fR" 4
+.IX Item "OBJC_INCLUDE_PATH"
+.PD
+Each variable's value is a list of directories separated by a special
+character, much like \fB\s-1PATH\s0\fR, in which to look for header files.
+The special character, \f(CW\*(C`PATH_SEPARATOR\*(C'\fR, is target-dependent and
+determined at \s-1GCC\s0 build time. For Windows-based targets it is a
+semicolon, and for almost all other targets it is a colon.
+.Sp
+\&\fB\s-1CPATH\s0\fR specifies a list of directories to be searched as if
+specified with \fB\-I\fR, but after any paths given with \fB\-I\fR
+options on the command line. The environment variable is used
+regardless of which language is being preprocessed.
+.Sp
+The remaining environment variables apply only when preprocessing the
+particular language indicated. Each specifies a list of directories
+to be searched as if specified with \fB\-isystem\fR, but after any
+paths given with \fB\-isystem\fR options on the command line.
+.Sp
+See also \f(CW@ref\fR{Search Path}.
+.Ip "\fB\s-1DEPENDENCIES_OUTPUT\s0\fR" 4
+.IX Item "DEPENDENCIES_OUTPUT"
+@anchor{\s-1DEPENDENCIES_OUTPUT\s0}
+If this variable is set, its value specifies how to output
+dependencies for Make based on the non-system header files processed
+by the compiler. System header files are ignored in the dependency
+output.
+.Sp
+The value of \fB\s-1DEPENDENCIES_OUTPUT\s0\fR can be just a file name, in
+which case the Make rules are written to that file, guessing the target
+name from the source file name. Or the value can have the form
+\&\fIfile\fR\fB \fR\fItarget\fR, in which case the rules are written to
+file \fIfile\fR using \fItarget\fR as the target name.
+.Sp
+In other words, this environment variable is equivalent to combining
+the options \fB\-MM\fR and \fB\-MF\fR,
+with an optional \fB\-MT\fR switch too.
+.Ip "\fB\s-1SUNPRO_DEPENDENCIES\s0\fR" 4
+.IX Item "SUNPRO_DEPENDENCIES"
+This variable is the same as the environment variable
+\&\fB\s-1DEPENDENCIES_OUTPUT\s0\fR, except that
+system header files are not ignored, so it implies \fB\-M\fR rather
+than \fB\-MM\fR.
+.SH "SEE ALSO"
+.IX Header "SEE ALSO"
+\&\fIgpl\fR\|(7), \fIgfdl\fR\|(7), \fIfsf-funding\fR\|(7),
+\&\fIgcc\fR\|(1), \fIas\fR\|(1), \fIld\fR\|(1), and the Info entries for \fIcpp\fR, \fIgcc\fR, and
+\&\fIbinutils\fR.
+.SH "COPYRIGHT"
+.IX Header "COPYRIGHT"
+Copyright (c) 1987, 1989, 1991, 1992, 1993, 1994, 1995, 1996,
+1997, 1998, 1999, 2000, 2001
+Free Software Foundation, Inc.
+.PP
+Permission is granted to copy, distribute and/or modify this document
+under the terms of the \s-1GNU\s0 Free Documentation License, Version 1.1 or
+any later version published by the Free Software Foundation. A copy of
+the license is included in the
+man page \fIgfdl\fR\|(7).
+This manual contains no Invariant Sections. The Front-Cover Texts are
+(a) (see below), and the Back-Cover Texts are (b) (see below).
+.PP
+(a) The \s-1FSF\s0's Front-Cover Text is:
+.PP
+.Vb 1
+\& A GNU Manual
+.Ve
+(b) The \s-1FSF\s0's Back-Cover Text is:
+.PP
+.Vb 3
+\& You have freedom to copy and modify this GNU Manual, like GNU
+\& software. Copies published by the Free Software Foundation raise
+\& funds for GNU development.
+.Ve
diff --git a/man-pages/gcc3.1 b/man-pages/gcc3.1
new file mode 100644
index 00000000000..35d83929541
--- /dev/null
+++ b/man-pages/gcc3.1
@@ -0,0 +1,5764 @@
+.\" Automatically generated by Pod::Man version 1.15
+.\" Wed Jun 19 19:36:28 2002
+.\"
+.\" Standard preamble:
+.\" ======================================================================
+.de Sh \" Subsection heading
+.br
+.if t .Sp
+.ne 5
+.PP
+\fB\\$1\fR
+.PP
+..
+.de Sp \" Vertical space (when we can't use .PP)
+.if t .sp .5v
+.if n .sp
+..
+.de Ip \" List item
+.br
+.ie \\n(.$>=3 .ne \\$3
+.el .ne 3
+.IP "\\$1" \\$2
+..
+.de Vb \" Begin verbatim text
+.ft CW
+.nf
+.ne \\$1
+..
+.de Ve \" End verbatim text
+.ft R
+
+.fi
+..
+.\" Set up some character translations and predefined strings. \*(-- will
+.\" give an unbreakable dash, \*(PI will give pi, \*(L" will give a left
+.\" double quote, and \*(R" will give a right double quote. | will give a
+.\" real vertical bar. \*(C+ will give a nicer C++. Capital omega is used
+.\" to do unbreakable dashes and therefore won't be available. \*(C` and
+.\" \*(C' expand to `' in nroff, nothing in troff, for use with C<>
+.tr \(*W-|\(bv\*(Tr
+.ds C+ C\v'-.1v'\h'-1p'\s-2+\h'-1p'+\s0\v'.1v'\h'-1p'
+.ie n \{\
+. ds -- \(*W-
+. ds PI pi
+. if (\n(.H=4u)&(1m=24u) .ds -- \(*W\h'-12u'\(*W\h'-12u'-\" diablo 10 pitch
+. if (\n(.H=4u)&(1m=20u) .ds -- \(*W\h'-12u'\(*W\h'-8u'-\" diablo 12 pitch
+. ds L" ""
+. ds R" ""
+. ds C` ""
+. ds C' ""
+'br\}
+.el\{\
+. ds -- \|\(em\|
+. ds PI \(*p
+. ds L" ``
+. ds R" ''
+'br\}
+.\"
+.\" If the F register is turned on, we'll generate index entries on stderr
+.\" for titles (.TH), headers (.SH), subsections (.Sh), items (.Ip), and
+.\" index entries marked with X<> in POD. Of course, you'll have to process
+.\" the output yourself in some meaningful fashion.
+.if \nF \{\
+. de IX
+. tm Index:\\$1\t\\n%\t"\\$2"
+..
+. nr % 0
+. rr F
+.\}
+.\"
+.\" For nroff, turn off justification. Always turn off hyphenation; it
+.\" makes way too many mistakes in technical documents.
+.hy 0
+.if n .na
+.\"
+.\" Accent mark definitions (@(#)ms.acc 1.5 88/02/08 SMI; from UCB 4.2).
+.\" Fear. Run. Save yourself. No user-serviceable parts.
+.bd B 3
+. \" fudge factors for nroff and troff
+.if n \{\
+. ds #H 0
+. ds #V .8m
+. ds #F .3m
+. ds #[ \f1
+. ds #] \fP
+.\}
+.if t \{\
+. ds #H ((1u-(\\\\n(.fu%2u))*.13m)
+. ds #V .6m
+. ds #F 0
+. ds #[ \&
+. ds #] \&
+.\}
+. \" simple accents for nroff and troff
+.if n \{\
+. ds ' \&
+. ds ` \&
+. ds ^ \&
+. ds , \&
+. ds ~ ~
+. ds /
+.\}
+.if t \{\
+. ds ' \\k:\h'-(\\n(.wu*8/10-\*(#H)'\'\h"|\\n:u"
+. ds ` \\k:\h'-(\\n(.wu*8/10-\*(#H)'\`\h'|\\n:u'
+. ds ^ \\k:\h'-(\\n(.wu*10/11-\*(#H)'^\h'|\\n:u'
+. ds , \\k:\h'-(\\n(.wu*8/10)',\h'|\\n:u'
+. ds ~ \\k:\h'-(\\n(.wu-\*(#H-.1m)'~\h'|\\n:u'
+. ds / \\k:\h'-(\\n(.wu*8/10-\*(#H)'\z\(sl\h'|\\n:u'
+.\}
+. \" troff and (daisy-wheel) nroff accents
+.ds : \\k:\h'-(\\n(.wu*8/10-\*(#H+.1m+\*(#F)'\v'-\*(#V'\z.\h'.2m+\*(#F'.\h'|\\n:u'\v'\*(#V'
+.ds 8 \h'\*(#H'\(*b\h'-\*(#H'
+.ds o \\k:\h'-(\\n(.wu+\w'\(de'u-\*(#H)/2u'\v'-.3n'\*(#[\z\(de\v'.3n'\h'|\\n:u'\*(#]
+.ds d- \h'\*(#H'\(pd\h'-\w'~'u'\v'-.25m'\f2\(hy\fP\v'.25m'\h'-\*(#H'
+.ds D- D\\k:\h'-\w'D'u'\v'-.11m'\z\(hy\v'.11m'\h'|\\n:u'
+.ds th \*(#[\v'.3m'\s+1I\s-1\v'-.3m'\h'-(\w'I'u*2/3)'\s-1o\s+1\*(#]
+.ds Th \*(#[\s+2I\s-2\h'-\w'I'u*3/5'\v'-.3m'o\v'.3m'\*(#]
+.ds ae a\h'-(\w'a'u*4/10)'e
+.ds Ae A\h'-(\w'A'u*4/10)'E
+. \" corrections for vroff
+.if v .ds ~ \\k:\h'-(\\n(.wu*9/10-\*(#H)'\s-2\u~\d\s+2\h'|\\n:u'
+.if v .ds ^ \\k:\h'-(\\n(.wu*10/11-\*(#H)'\v'-.4m'^\v'.4m'\h'|\\n:u'
+. \" for low resolution devices (crt and lpr)
+.if \n(.H>23 .if \n(.V>19 \
+\{\
+. ds : e
+. ds 8 ss
+. ds o a
+. ds d- d\h'-1'\(ga
+. ds D- D\h'-1'\(hy
+. ds th \o'bp'
+. ds Th \o'LP'
+. ds ae ae
+. ds Ae AE
+.\}
+.rm #[ #] #H #V #F C
+.\" ======================================================================
+.\"
+.IX Title "GCC 1"
+.TH GCC 1 "gcc-3.1" "2002-06-19" "GNU"
+.UC
+.SH "NAME"
+gcc \- \s-1GNU\s0 project C and \*(C+ compiler
+.SH "SYNOPSIS"
+.IX Header "SYNOPSIS"
+gcc [\fB\-c\fR|\fB\-S\fR|\fB\-E\fR] [\fB\-std=\fR\fIstandard\fR]
+ [\fB\-g\fR] [\fB\-pg\fR] [\fB\-O\fR\fIlevel\fR]
+ [\fB\-W\fR\fIwarn\fR...] [\fB\-pedantic\fR]
+ [\fB\-I\fR\fIdir\fR...] [\fB\-L\fR\fIdir\fR...]
+ [\fB\-D\fR\fImacro\fR[=\fIdefn\fR]...] [\fB\-U\fR\fImacro\fR]
+ [\fB\-f\fR\fIoption\fR...] [\fB\-m\fR\fImachine-option\fR...]
+ [\fB\-o\fR \fIoutfile\fR] \fIinfile\fR...
+.PP
+Only the most useful options are listed here; see below for the
+remainder. \fBg++\fR accepts mostly the same options as \fBgcc\fR.
+.PP
+In Apple's version of \s-1GCC\s0, both \fBcc\fR and \fBgcc\fR are actually
+symbolic links to \fBgcc3\fR, while \fBc++\fR and \fBg++\fR are links
+to \fBg++3\fR.
+.PP
+Note that Apple's \s-1GCC\s0 includes a number of extensions to standard \s-1GCC\s0
+(flagged below with ``\s-1APPLE\s0 \s-1ONLY\s0''), and that not all generic \s-1GCC\s0
+options are available or supported on Darwin / Mac \s-1OS\s0 X. In particular,
+Apple does not currently support the compilation of Fortran, Ada, or
+Java, although there are third parties who have made these work.
+.SH "DESCRIPTION"
+.IX Header "DESCRIPTION"
+When you invoke \s-1GCC\s0, it normally does preprocessing, compilation,
+assembly and linking. The ``overall options'' allow you to stop this
+process at an intermediate stage. For example, the \fB\-c\fR option
+says not to run the linker. Then the output consists of object files
+output by the assembler.
+.PP
+Other options are passed on to one stage of processing. Some options
+control the preprocessor and others the compiler itself. Yet other
+options control the assembler and linker; most of these are not
+documented here, since you rarely need to use any of them.
+.PP
+Most of the command line options that you can use with \s-1GCC\s0 are useful
+for C programs; when an option is only useful with another language
+(usually \*(C+), the explanation says so explicitly. If the description
+for a particular option does not mention a source language, you can use
+that option with all supported languages.
+.PP
+The \fBgcc\fR program accepts options and file names as operands. Many
+options have multi-letter names; therefore multiple single-letter options
+may \fInot\fR be grouped: \fB\-dr\fR is very different from \fB\-d\ \-r\fR.
+.PP
+You can mix options and other arguments. For the most part, the order
+you use doesn't matter. Order does matter when you use several options
+of the same kind; for example, if you specify \fB\-L\fR more than once,
+the directories are searched in the order specified.
+.PP
+Many options have long names starting with \fB\-f\fR or with
+\&\fB\-W\fR\-\-\-for example, \fB\-fforce-mem\fR,
+\&\fB\-fstrength-reduce\fR, \fB\-Wformat\fR and so on. Most of
+these have both positive and negative forms; the negative form of
+\&\fB\-ffoo\fR would be \fB\-fno-foo\fR. This manual documents
+only one of these two forms, whichever one is not the default.
+.SH "OPTIONS"
+.IX Header "OPTIONS"
+.Sh "Option Summary"
+.IX Subsection "Option Summary"
+Here is a summary of all the options, grouped by type. Explanations are
+in the following sections.
+.Ip "\fIOverall Options\fR" 4
+.IX Item "Overall Options"
+\&\fB\-c \-S \-E \-o\fR \fIfile\fR \fB\-pipe \-pass-exit-codes \-x\fR \fIlanguage\fR
+\&\fB\-ObjC (\s-1APPLE\s0 \s-1ONLY\s0) \-ObjC++ (\s-1APPLE\s0 \s-1ONLY\s0)
+\&\-arch\fR \fIarch\fR \fB(\s-1APPLE\s0 \s-1ONLY\s0)
+\&\-v \-### \-\-target-help \-\-help\fR
+.Ip "\fIC Language Options\fR" 4
+.IX Item "C Language Options"
+\&\fB\-ansi \-std=\fR\fIstandard\fR \fB\-aux-info\fR \fIfilename\fR
+\&\fB\-faltivec (\s-1APPLE\s0 \s-1ONLY\s0)
+\&\-fno-asm \-fno-builtin \-fno-builtin-\fR\fIfunction\fR
+\&\fB\-fhosted \-ffreestanding
+\&\-trigraphs \-no-integrated-cpp \-traditional \-traditional-cpp
+\&\-fallow-single-precision \-fcond-mismatch
+\&\-fconstant-cfstrings (\s-1APPLE\s0 \s-1ONLY\s0)
+\&\-fsigned-bitfields \-fsigned-char
+\&\-funsigned-bitfields \-funsigned-char
+\&\-fwritable-strings \-fshort-wchar
+\&\-fpascal-strings (\s-1APPLE\s0 \s-1ONLY\s0)
+\&\-fcoalesce (\s-1APPLE\s0 \s-1ONLY\s0) \-fweak-coalesced (\s-1APPLE\s0 \s-1ONLY\s0)
+\&\-Wno-#warnings (\s-1APPLE\s0 \s-1ONLY\s0)
+\&\-Wextra-tokens (\s-1APPLE\s0 \s-1ONLY\s0)
+\&\-Wpragma-once (\s-1APPLE\s0 \s-1ONLY\s0)
+\&\-Wnewline-eof (\s-1APPLE\s0 \s-1ONLY\s0)
+\&\-Wno-altivec-long-deprecated (\s-1APPLE\s0 \s-1ONLY\s0)\fR
+.Ip "\fI\*(C+ Language Options\fR" 4
+.IX Item " Language Options"
+\&\fB\-fno-access-control \-fcheck-new \-fconserve-space
+\&\-fno-const-strings \-fdollars-in-identifiers
+\&\-fno-elide-constructors
+\&\-fno-enforce-eh-specs \-fexternal-templates
+\&\-falt-external-templates
+\&\-ffor-scope \-fno-for-scope \-fno-gnu-keywords
+\&\-fno-implicit-templates
+\&\-fno-implicit-inline-templates
+\&\-fno-implement-inlines
+\&\-findirect-virtual-calls (\s-1APPLE\s0 \s-1ONLY\s0)
+\&\-fapple-kext (\s-1APPLE\s0 \s-1ONLY\s0)
+\&\-fcoalesce-templates (\s-1APPLE\s0 \s-1ONLY\s0)
+\&\-fms-extensions
+\&\-fno-nonansi-builtins \-fno-operator-names
+\&\-fno-optional-diags \-fpermissive
+\&\-frepo \-fno-rtti \-fstats \-ftemplate-depth-\fR\fIn\fR
+\&\fB\-fuse-cxa-atexit \-fvtable-gc \-fno-weak \-nostdinc++
+\&\-fno-default-inline \-Wctor-dtor-privacy
+\&\-Wnon-virtual-dtor \-Wreorder
+\&\-Weffc++ \-Wno-deprecated
+\&\-Wno-non-template-friend \-Wold-style-cast
+\&\-Woverloaded-virtual \-Wno-pmf-conversions
+\&\-Wsign-promo \-Wsynth\fR
+.Ip "\fIObjective-C Language Options\fR" 4
+.IX Item "Objective-C Language Options"
+\&\fB\-fconstant-string-class=\fR\fIclass-name\fR
+\&\fB\-fgnu-runtime \-fnext-runtime \-gen-decls
+\&\-Wno-protocol \-Wselector\fR
+.Ip "\fILanguage Independent Options\fR" 4
+.IX Item "Language Independent Options"
+\&\fB\-fmessage-length=\fR\fIn\fR
+\&\fB\-fdiagnostics-show-location=\fR[\fBonce\fR|\fBevery-line\fR]
+.Ip "\fIWarning Options\fR" 4
+.IX Item "Warning Options"
+\&\fB\-fsyntax-only \-pedantic \-pedantic-errors
+\&\-w \-W \-Wall \-Waggregate-return
+\&\-Wcast-align \-Wcast-qual \-Wchar-subscripts \-Wcomment
+\&\-Wconversion \-Wno-deprecated-declarations
+\&\-Wdisabled-optimization \-Wdiv-by-zero \-Werror
+\&\-Wfloat-equal \-Wformat \-Wformat=2
+\&\-Wformat-nonliteral \-Wformat-security
+\&\-Wimplicit \-Wimplicit-int
+\&\-Wimplicit-function-declaration
+\&\-Werror-implicit-function-declaration
+\&\-Wimport \-Winline
+\&\-Wlarger-than-\fR\fIlen\fR
+\&\fB\-Wno-long-double (\s-1APPLE\s0 \s-1ONLY\s0)
+\&\-Wlong-long
+\&\-Wmain \-Wmissing-braces \-Wmissing-declarations
+\&\-Wmissing-format-attribute \-Wmissing-noreturn
+\&\-Wmost (\s-1APPLE\s0 \s-1ONLY\s0)
+\&\-Wmultichar \-Wno-format-extra-args \-Wno-format-y2k
+\&\-Wno-import \-Wpacked \-Wpadded
+\&\-Wparentheses \-Wpointer-arith \-Wredundant-decls
+\&\-Wreturn-type \-Wsequence-point \-Wshadow
+\&\-Wsign-compare \-Wswitch \-Wsystem-headers
+\&\-Wtrigraphs \-Wundef \-Wuninitialized
+\&\-Wunknown-pragmas \-Wunreachable-code
+\&\-Wunused \-Wunused-function \-Wunused-label \-Wunused-parameter
+\&\-Wunused-value \-Wunused-variable \-Wwrite-strings\fR
+.Ip "\fIC-only Warning Options\fR" 4
+.IX Item "C-only Warning Options"
+\&\fB\-Wbad-function-cast \-Wmissing-prototypes \-Wnested-externs
+\&\-Wstrict-prototypes \-Wtraditional\fR
+.Ip "\fIDebugging Options\fR" 4
+.IX Item "Debugging Options"
+\&\fB\-d\fR\fIletters\fR \fB\-dumpspecs \-dumpmachine \-dumpversion
+\&\-fdump-unnumbered \-fdump-translation-unit\fR[\fB-\fR\fIn\fR]
+\&\fB\-fdump-class-hierarchy\fR[\fB-\fR\fIn\fR]
+\&\fB\-fdump-tree-original\fR[\fB-\fR\fIn\fR] \fB\-fdump-tree-optimized\fR[\fB-\fR\fIn\fR]
+\&\fB\-fdump-tree-inlined\fR[\fB-\fR\fIn\fR]
+\&\fB\-fmem-report \-fpretend-float
+\&\-fprofile-arcs \-ftest-coverage \-ftime-report
+\&\-g \-g\fR\fIlevel\fR \fB\-gcoff \-gdwarf \-gdwarf-1 \-gdwarf-1+ \-gdwarf-2
+\&\-ggdb \-gstabs \-gstabs+ \-gvms \-gxcoff \-gxcoff+
+\&\-p \-pg \-print-file-name=\fR\fIlibrary\fR \fB\-print-libgcc-file-name
+\&\-print-multi-directory \-print-multi-lib
+\&\-print-prog-name=\fR\fIprogram\fR \fB\-print-search-dirs \-Q
+\&\-save-temps \-time\fR
+.Ip "\fIOptimization Options\fR" 4
+.IX Item "Optimization Options"
+\&\fB\-falign-functions=\fR\fIn\fR \fB\-falign-jumps=\fR\fIn\fR
+\&\fB\-falign-labels=\fR\fIn\fR \fB\-falign-loops=\fR\fIn\fR
+\&\fB\-fbranch-probabilities \-fcaller-saves \-fcprop-registers
+\&\-fcse-follow-jumps \-fcse-skip-blocks \-fdata-sections
+\&\-fdelayed-branch \-fdelete-null-pointer-checks
+\&\-fexpensive-optimizations \-ffast-math \-ffloat-store
+\&\-fforce-addr \-fforce-mem \-ffunction-sections
+\&\-fgcse \-fgcse-lm \-fgcse-sm
+\&\-finline-functions \-finline-limit=\fR\fIn\fR \fB\-fkeep-inline-functions
+\&\-fkeep-static-consts \-fmerge-constants \-fmerge-all-constants
+\&\-fmove-all-movables \-fno-default-inline \-fno-defer-pop
+\&\-fno-function-cse \-fno-guess-branch-probability
+\&\-fno-inline \-fno-math-errno \-fno-peephole \-fno-peephole2
+\&\-funsafe-math-optimizations \-fno-trapping-math
+\&\-fomit-frame-pointer \-foptimize-register-move
+\&\-foptimize-sibling-calls \-fprefetch-loop-arrays
+\&\-freduce-all-givs \-fregmove \-frename-registers
+\&\-frerun-cse-after-loop \-frerun-loop-opt
+\&\-fschedule-insns \-fschedule-insns2
+\&\-fsingle-precision-constant \-fssa \-fssa-ccp \-fssa-dce
+\&\-fstrength-reduce \-fstrict-aliasing \-fthread-jumps \-ftrapv
+\&\-funroll-all-loops \-funroll-loops
+\&\-\-param\fR \fIname\fR\fB=\fR\fIvalue\fR
+\&\fB\-O \-O0 \-O1 \-O2 \-O3 \-Os\fR
+.Ip "\fIPreprocessor Options\fR" 4
+.IX Item "Preprocessor Options"
+\&\fB\-$ \-A\fR\fIquestion\fR\fB=\fR\fIanswer\fR \fB\-A-\fR\fIquestion\fR[\fB=\fR\fIanswer\fR]
+\&\fB\-C \-dD \-dI \-dM \-dN
+\&\-D\fR\fImacro\fR[\fB=\fR\fIdefn\fR] \fB\-E \-H
+\&\-idirafter\fR \fIdir\fR
+\&\fB\-include\fR \fIfile\fR \fB\-imacros\fR \fIfile\fR
+\&\fB\-iprefix\fR \fIfile\fR \fB\-iwithprefix\fR \fIdir\fR
+\&\fB\-iwithprefixbefore\fR \fIdir\fR \fB\-isystem\fR \fIdir\fR
+\&\fB\-M \-MM \-MF \-MG \-MP \-MQ \-MT \-nostdinc \-P \-remap
+\&\-dependency-file (\s-1APPLE\s0 \s-1ONLY\s0)
+\&\-\-dump-pch\fR \fIname\fR \fB(\s-1APPLE\s0 \s-1ONLY\s0) \-\-load-pch\fR \fIname\fR \fB(\s-1APPLE\s0 \s-1ONLY\s0)
+\&\-trigraphs \-undef \-U\fR\fImacro\fR \fB\-Wp,\fR\fIoption\fR
+.Ip "\fIAssembler Option\fR" 4
+.IX Item "Assembler Option"
+\&\fB\-Wa,\fR\fIoption\fR
+.Ip "\fILinker Options\fR" 4
+.IX Item "Linker Options"
+\&\fB
+\&\fR\fIobject-file-name\fR \fB\-l\fR\fIlibrary\fR
+\&\fB\-nostartfiles \-nodefaultlibs \-nostdlib \-no-c++filt (\s-1APPLE\s0 \s-1ONLY\s0)
+\&\-s \-static \-static-libgcc \-shared \-shared-libgcc \-symbolic
+\&\-Wl,\fR\fIoption\fR \fB\-Xlinker\fR \fIoption\fR
+\&\fB\-u\fR \fIsymbol\fR
+.Ip "\fIDirectory Options\fR" 4
+.IX Item "Directory Options"
+\&\fB\-B\fR\fIprefix\fR \fB\-I\fR\fIdir\fR \fB\-I-
+\&\-F\fR\fIdir\fR \fB(\s-1APPLE\s0 \s-1ONLY\s0)
+\&\-L\fR\fIdir\fR \fB\-specs=\fR\fIfile\fR
+.Ip "\fITarget Options\fR" 4
+.IX Item "Target Options"
+\&\fB\-b\fR \fImachine\fR \fB\-V\fR \fIversion\fR
+.Ip "\fIMachine Dependent Options\fR" 4
+.IX Item "Machine Dependent Options"
+\&\fI\s-1RS/6000\s0 and PowerPC Options\fR
+.Sp
+\&\fB\-mcpu=\fR\fIcpu-type\fR
+\&\fB\-mtune=\fR\fIcpu-type\fR
+\&\fB\-mpower \-mno-power \-mpower2 \-mno-power2
+\&\-mpowerpc \-mpowerpc64 \-mno-powerpc
+\&\-maltivec \-mno-altivec
+\&\-mpowerpc-gpopt \-mno-powerpc-gpopt
+\&\-mpowerpc-gfxopt \-mno-powerpc-gfxopt
+\&\-mnew-mnemonics \-mold-mnemonics
+\&\-mfull-toc \-mminimal-toc \-mno-fp-in-toc \-mno-sum-in-toc
+\&\-m64 \-m32 \-mxl-call \-mno-xl-call \-mpe
+\&\-malign-mac68k (\s-1APPLE\s0 \s-1ONLY\s0)
+\&\-malign-power (\s-1APPLE\s0 \s-1ONLY\s0)
+\&\-malign-natural (\s-1APPLE\s0 \s-1ONLY\s0)
+\&\-msoft-float \-mhard-float \-mmultiple \-mno-multiple
+\&\-mstring \-mno-string \-mupdate \-mno-update
+\&\-mfused-madd \-mno-fused-madd \-mbit-align \-mno-bit-align
+\&\-mstrict-align \-mno-strict-align \-mrelocatable
+\&\-mno-relocatable \-mrelocatable-lib \-mno-relocatable-lib
+\&\-mtoc \-mno-toc \-mlittle \-mlittle-endian \-mbig \-mbig-endian
+\&\-mdynamic-no-pic (\s-1APPLE\s0 \s-1ONLY\s0)
+\&\-mlong-branch (\s-1APPLE\s0 \s-1ONLY\s0)
+\&\-mcall-aix \-mcall-sysv \-mcall-netbsd
+\&\-maix-struct-return \-msvr4\-struct-return
+\&\-mabi=altivec \-mabi=no-altivec
+\&\-mprototype \-mno-prototype
+\&\-msim \-mmvme \-mads \-myellowknife \-memb \-msdata
+\&\-msdata=\fR\fIopt\fR \fB\-mvxworks \-G\fR \fInum\fR \fB\-pthread\fR
+.Sp
+\&\fIi386 and x86\-64 Options\fR
+.Sp
+\&\fB\-mcpu=\fR\fIcpu-type\fR \fB\-march=\fR\fIcpu-type\fR \fB\-mfpmath=\fR\fIunit\fR
+\&\fB\-masm=\fR\fIdialect\fR \fB\-mno-fancy-math-387
+\&\-mno-fp-ret-in-387 \-msoft-float \-msvr3\-shlib
+\&\-mno-wide-multiply \-mrtd \-malign-double
+\&\-mpreferred-stack-boundary=\fR\fInum\fR
+\&\fB\-mmmx \-msse \-msse2 \-msse-math \-m3dnow
+\&\-mthreads \-mno-align-stringops \-minline-all-stringops
+\&\-mpush-args \-maccumulate-outgoing-args \-m128bit-long-double
+\&\-m96bit-long-double \-mregparm=\fR\fInum\fR \fB\-momit-leaf-frame-pointer
+\&\-mno-red-zone
+\&\-m32 \-m64\fR
+.Ip "\fICode Generation Options\fR" 4
+.IX Item "Code Generation Options"
+\&\fB\-fcall-saved-\fR\fIreg\fR \fB\-fcall-used-\fR\fIreg\fR
+\&\fB\-ffixed-\fR\fIreg\fR \fB\-fexceptions
+\&\-fnon-call-exceptions \-funwind-tables
+\&\-fasynchronous-unwind-tables
+\&\-finhibit-size-directive \-finstrument-functions
+\&\-fno-common \-fno-ident \-fno-gnu-linker
+\&\-fpcc-struct-return \-fpic \-fPIC
+\&\-freg-struct-return \-fshared-data \-fshort-enums
+\&\-fshort-double \-fvolatile
+\&\-fvolatile-global \-fvolatile-static
+\&\-fverbose-asm \-fpack-struct \-fstack-check
+\&\-fstack-limit-register=\fR\fIreg\fR \fB\-fstack-limit-symbol=\fR\fIsym\fR
+\&\fB\-fargument-alias \-fargument-noalias
+\&\-fargument-noalias-global \-fleading-underscore\fR
+.Sh "Options Controlling the Kind of Output"
+.IX Subsection "Options Controlling the Kind of Output"
+Compilation can involve up to four stages: preprocessing, compilation
+proper, assembly and linking, always in that order. The first three
+stages apply to an individual source file, and end by producing an
+object file; linking combines all the object files (those newly
+compiled, and those specified as input) into an executable file.
+.PP
+For any given input file, the file name suffix determines what kind of
+compilation is done:
+.Ip "\fIfile\fR\fB.c\fR" 4
+.IX Item "file.c"
+C source code which must be preprocessed.
+.Ip "\fIfile\fR\fB.i\fR" 4
+.IX Item "file.i"
+C source code which should not be preprocessed.
+.Ip "\fIfile\fR\fB.ii\fR" 4
+.IX Item "file.ii"
+\&\*(C+ source code which should not be preprocessed.
+.Ip "\fIfile\fR\fB.m\fR" 4
+.IX Item "file.m"
+Objective-C source code. Note that you must link with the library
+\&\fIlibobjc.a\fR to make an Objective-C program work.
+.Ip "\fIfile\fR\fB.mi\fR" 4
+.IX Item "file.mi"
+Objective-C source code which should not be preprocessed.
+.Ip "\fIfile\fR\fB.h\fR" 4
+.IX Item "file.h"
+C header file (not to be compiled or linked).
+.Ip "\fIfile\fR\fB.cc\fR" 4
+.IX Item "file.cc"
+.PD 0
+.Ip "\fIfile\fR\fB.cp\fR" 4
+.IX Item "file.cp"
+.Ip "\fIfile\fR\fB.cxx\fR" 4
+.IX Item "file.cxx"
+.Ip "\fIfile\fR\fB.cpp\fR" 4
+.IX Item "file.cpp"
+.Ip "\fIfile\fR\fB.c++\fR" 4
+.IX Item "file.c++"
+.Ip "\fIfile\fR\fB.C\fR" 4
+.IX Item "file.C"
+.PD
+\&\*(C+ source code which must be preprocessed. Note that in \fB.cxx\fR,
+the last two letters must both be literally \fBx\fR. Likewise,
+\&\fB.C\fR refers to a literal capital C.
+.Ip "\fIfile\fR\fB.mm\fR" 4
+.IX Item "file.mm"
+.PD 0
+.Ip "\fIfile\fR\fB.M\fR" 4
+.IX Item "file.M"
+.PD
+Objective-\*(C+ source code which must be preprocessed. (\s-1APPLE\s0 \s-1ONLY\s0)
+.Ip "\fIfile\fR\fB.mii\fR" 4
+.IX Item "file.mii"
+Objective-\*(C+ source code which should not be preprocessed. (\s-1APPLE\s0 \s-1ONLY\s0)
+.Ip "\fIfile\fR\fB.f\fR" 4
+.IX Item "file.f"
+.PD 0
+.Ip "\fIfile\fR\fB.for\fR" 4
+.IX Item "file.for"
+.Ip "\fIfile\fR\fB.FOR\fR" 4
+.IX Item "file.FOR"
+.PD
+Fortran source code which should not be preprocessed.
+.Ip "\fIfile\fR\fB.F\fR" 4
+.IX Item "file.F"
+.PD 0
+.Ip "\fIfile\fR\fB.fpp\fR" 4
+.IX Item "file.fpp"
+.Ip "\fIfile\fR\fB.FPP\fR" 4
+.IX Item "file.FPP"
+.PD
+Fortran source code which must be preprocessed (with the traditional
+preprocessor).
+.Ip "\fIfile\fR\fB.r\fR" 4
+.IX Item "file.r"
+Fortran source code which must be preprocessed with a \s-1RATFOR\s0
+preprocessor (not included with \s-1GCC\s0).
+.Ip "\fIfile\fR\fB.ads\fR" 4
+.IX Item "file.ads"
+Ada source code file which contains a library unit declaration (a
+declaration of a package, subprogram, or generic, or a generic
+instantiation), or a library unit renaming declaration (a package,
+generic, or subprogram renaming declaration). Such files are also
+called \fIspecs\fR.
+.Ip "\fIfile\fR\fB.adb\fR" 4
+.IX Item "file.adb"
+Ada source code file containing a library unit body (a subprogram or
+package body). Such files are also called \fIbodies\fR.
+.Ip "\fIfile\fR\fB.s\fR" 4
+.IX Item "file.s"
+Assembler code. Apple's version of \s-1GCC\s0 runs the preprocessor
+on these files as well as those ending in \fB.S\fR.
+.Ip "\fIfile\fR\fB.S\fR" 4
+.IX Item "file.S"
+Assembler code which must be preprocessed.
+.Ip "\fIother\fR" 4
+.IX Item "other"
+An object file to be fed straight into linking.
+Any file name with no recognized suffix is treated this way.
+.PP
+You can specify the input language explicitly with the \fB\-x\fR option:
+.Ip "\fB\-x\fR \fIlanguage\fR" 4
+.IX Item "-x language"
+Specify explicitly the \fIlanguage\fR for the following input files
+(rather than letting the compiler choose a default based on the file
+name suffix). This option applies to all following input files until
+the next \fB\-x\fR option. Possible values for \fIlanguage\fR are:
+.Sp
+.Vb 8
+\& c c-header cpp-output
+\& c++ c++-cpp-output
+\& objective-c objc-cpp-output
+\& objective-c++ (APPLE ONLY)
+\& assembler assembler-with-cpp
+\& ada
+\& f77 f77-cpp-input ratfor
+\& java
+.Ve
+.Ip "\fB\-x none\fR" 4
+.IX Item "-x none"
+Turn off any specification of a language, so that subsequent files are
+handled according to their file name suffixes (as they are if \fB\-x\fR
+has not been used at all).
+.Ip "\fB\-ObjC\fR" 4
+.IX Item "-ObjC"
+.PD 0
+.Ip "\fB\-ObjC++\fR" 4
+.IX Item "-ObjC++"
+.PD
+These are similar in effect to \fB\-x objective-c\fR and \fB\-x
+objective-c++\fR, but affect only the choice of compiler for files already
+identified as source files. (\s-1APPLE\s0 \s-1ONLY\s0)
+.Ip "\fB\-arch\fR \fIarch\fR" 4
+.IX Item "-arch arch"
+Compile for the specified target architecture \fIarch\fR. The allowable
+values are \fBi386\fR and \fBppc\fR. Multiple options work, and
+direct the compiler to produce ``fat'' binaries including object code
+for each architecture specified with \fB\-arch\fR. This option only
+works if assembler and libraries are available for each architecture
+specified. (\s-1APPLE\s0 \s-1ONLY\s0)
+.Ip "\fB\-pass-exit-codes\fR" 4
+.IX Item "-pass-exit-codes"
+Normally the \fBgcc\fR program will exit with the code of 1 if any
+phase of the compiler returns a non-success return code. If you specify
+\&\fB\-pass-exit-codes\fR, the \fBgcc\fR program will instead return with
+numerically highest error produced by any phase that returned an error
+indication.
+.PP
+If you only want some of the stages of compilation, you can use
+\&\fB\-x\fR (or filename suffixes) to tell \fBgcc\fR where to start, and
+one of the options \fB\-c\fR, \fB\-S\fR, or \fB\-E\fR to say where
+\&\fBgcc\fR is to stop. Note that some combinations (for example,
+\&\fB\-x cpp-output \-E\fR) instruct \fBgcc\fR to do nothing at all.
+.Ip "\fB\-c\fR" 4
+.IX Item "-c"
+Compile or assemble the source files, but do not link. The linking
+stage simply is not done. The ultimate output is in the form of an
+object file for each source file.
+.Sp
+By default, the object file name for a source file is made by replacing
+the suffix \fB.c\fR, \fB.i\fR, \fB.s\fR, etc., with \fB.o\fR.
+.Sp
+Unrecognized input files, not requiring compilation or assembly, are
+ignored.
+.Ip "\fB\-S\fR" 4
+.IX Item "-S"
+Stop after the stage of compilation proper; do not assemble. The output
+is in the form of an assembler code file for each non-assembler input
+file specified.
+.Sp
+By default, the assembler file name for a source file is made by
+replacing the suffix \fB.c\fR, \fB.i\fR, etc., with \fB.s\fR.
+.Sp
+Input files that don't require compilation are ignored.
+.Ip "\fB\-E\fR" 4
+.IX Item "-E"
+Stop after the preprocessing stage; do not run the compiler proper. The
+output is in the form of preprocessed source code, which is sent to the
+standard output.
+.Sp
+Input files which don't require preprocessing are ignored.
+.Ip "\fB\-o\fR \fIfile\fR" 4
+.IX Item "-o file"
+Place output in file \fIfile\fR. This applies regardless to whatever
+sort of output is being produced, whether it be an executable file,
+an object file, an assembler file or preprocessed C code.
+.Sp
+Since only one output file can be specified, it does not make sense to
+use \fB\-o\fR when compiling more than one input file, unless you are
+producing an executable file as output.
+.Sp
+If \fB\-o\fR is not specified, the default is to put an executable file
+in \fIa.out\fR, the object file for \fI\fIsource\fI.\fIsuffix\fI\fR in
+\&\fI\fIsource\fI.o\fR, its assembler file in \fI\fIsource\fI.s\fR, and
+all preprocessed C source on standard output.
+.Ip "\fB\-v\fR" 4
+.IX Item "-v"
+Print (on standard error output) the commands executed to run the stages
+of compilation. Also print the version number of the compiler driver
+program and of the preprocessor and the compiler proper.
+.Ip "\fB\-###\fR" 4
+.IX Item "-###"
+Like \fB\-v\fR except the commands are not executed and all command
+arguments are quoted. This is useful for shell scripts to capture the
+driver-generated command lines.
+.Ip "\fB\-pipe\fR" 4
+.IX Item "-pipe"
+Use pipes rather than temporary files for communication between the
+various stages of compilation. This fails to work on some systems where
+the assembler is unable to read from a pipe; but the \s-1GNU\s0 assembler has
+no trouble.
+.Ip "\fB\*(--help\fR" 4
+.IX Item "help"
+Print (on the standard output) a description of the command line options
+understood by \fBgcc\fR. If the \fB\-v\fR option is also specified
+then \fB\*(--help\fR will also be passed on to the various processes
+invoked by \fBgcc\fR, so that they can display the command line options
+they accept. If the \fB\-W\fR option is also specified then command
+line options which have no documentation associated with them will also
+be displayed.
+.Ip "\fB\*(--target-help\fR" 4
+.IX Item "target-help"
+Print (on the standard output) a description of target specific command
+line options for each tool.
+.Sh "Compiling \*(C+ Programs"
+.IX Subsection "Compiling Programs"
+\&\*(C+ source files conventionally use one of the suffixes \fB.C\fR,
+\&\fB.cc\fR, \fB.cpp\fR, \fB.c++\fR, \fB.cp\fR, or \fB.cxx\fR;
+preprocessed \*(C+ files use the suffix \fB.ii\fR. \s-1GCC\s0 recognizes
+files with these names and compiles them as \*(C+ programs even if you
+call the compiler the same way as for compiling C programs (usually with
+the name \fBgcc\fR).
+.PP
+However, \*(C+ programs often require class libraries as well as a
+compiler that understands the \*(C+ language\-\-\-and under some
+circumstances, you might want to compile programs from standard input,
+or otherwise without a suffix that flags them as \*(C+ programs.
+\&\fBg++\fR is a program that calls \s-1GCC\s0 with the default language
+set to \*(C+, and automatically specifies linking against the \*(C+
+library. On many systems, \fBg++\fR is also
+installed with the name \fBc++\fR.
+.PP
+When you compile \*(C+ programs, you may specify many of the same
+command-line options that you use for compiling programs in any
+language; or command-line options meaningful for C and related
+languages; or options that are meaningful only for \*(C+ programs.
+.Sh "Options Controlling C Dialect"
+.IX Subsection "Options Controlling C Dialect"
+The following options control the dialect of C (or languages derived
+from C, such as \*(C+ and Objective-C) that the compiler accepts:
+.Ip "\fB\-ansi\fR" 4
+.IX Item "-ansi"
+In C mode, support all \s-1ISO\s0 C89 programs. In \*(C+ mode,
+remove \s-1GNU\s0 extensions that conflict with \s-1ISO\s0 \*(C+.
+.Sp
+This turns off certain features of \s-1GCC\s0 that are incompatible with \s-1ISO\s0
+C89 (when compiling C code), or of standard \*(C+ (when compiling \*(C+ code),
+such as the \f(CW\*(C`asm\*(C'\fR and \f(CW\*(C`typeof\*(C'\fR keywords, and
+predefined macros such as \f(CW\*(C`unix\*(C'\fR and \f(CW\*(C`vax\*(C'\fR that identify the
+type of system you are using. It also enables the undesirable and
+rarely used \s-1ISO\s0 trigraph feature. For the C compiler,
+it disables recognition of \*(C+ style \fB//\fR comments as well as
+the \f(CW\*(C`inline\*(C'\fR keyword.
+.Sp
+The alternate keywords \f(CW\*(C`_\|_asm_\|_\*(C'\fR, \f(CW\*(C`_\|_extension_\|_\*(C'\fR,
+\&\f(CW\*(C`_\|_inline_\|_\*(C'\fR and \f(CW\*(C`_\|_typeof_\|_\*(C'\fR continue to work despite
+\&\fB\-ansi\fR. You would not want to use them in an \s-1ISO\s0 C program, of
+course, but it is useful to put them in header files that might be included
+in compilations done with \fB\-ansi\fR. Alternate predefined macros
+such as \f(CW\*(C`_\|_unix_\|_\*(C'\fR and \f(CW\*(C`_\|_vax_\|_\*(C'\fR are also available, with or
+without \fB\-ansi\fR.
+.Sp
+The \fB\-ansi\fR option does not cause non-ISO programs to be
+rejected gratuitously. For that, \fB\-pedantic\fR is required in
+addition to \fB\-ansi\fR.
+.Sp
+The macro \f(CW\*(C`_\|_STRICT_ANSI_\|_\*(C'\fR is predefined when the \fB\-ansi\fR
+option is used. Some header files may notice this macro and refrain
+from declaring certain functions or defining certain macros that the
+\&\s-1ISO\s0 standard doesn't call for; this is to avoid interfering with any
+programs that might use these names for other things.
+.Sp
+Functions which would normally be built in but do not have semantics
+defined by \s-1ISO\s0 C (such as \f(CW\*(C`alloca\*(C'\fR and \f(CW\*(C`ffs\*(C'\fR) are not built-in
+functions with \fB\-ansi\fR is used.
+.Ip "\fB\-std=\fR" 4
+.IX Item "-std="
+Determine the language standard. This option is currently only
+supported when compiling C. A value for this option must be provided;
+possible values are
+.RS 4
+.Ip "\fBc89\fR" 4
+.IX Item "c89"
+.PD 0
+.Ip "\fBiso9899:1990\fR" 4
+.IX Item "iso9899:1990"
+.PD
+\&\s-1ISO\s0 C89 (same as \fB\-ansi\fR).
+.Ip "\fBiso9899:199409\fR" 4
+.IX Item "iso9899:199409"
+\&\s-1ISO\s0 C89 as modified in amendment 1.
+.Ip "\fBc99\fR" 4
+.IX Item "c99"
+.PD 0
+.Ip "\fBc9x\fR" 4
+.IX Item "c9x"
+.Ip "\fBiso9899:1999\fR" 4
+.IX Item "iso9899:1999"
+.Ip "\fBiso9899:199x\fR" 4
+.IX Item "iso9899:199x"
+.PD
+\&\s-1ISO\s0 C99. Note that this standard is not yet fully supported; see
+<\fBhttp://gcc.gnu.org/gcc-3.1/c99status.html\fR> for more information. The
+names \fBc9x\fR and \fBiso9899:199x\fR are deprecated.
+.Ip "\fBgnu89\fR" 4
+.IX Item "gnu89"
+Default, \s-1ISO\s0 C89 plus \s-1GNU\s0 extensions (including some C99 features).
+.Ip "\fBgnu99\fR" 4
+.IX Item "gnu99"
+.PD 0
+.Ip "\fBgnu9x\fR" 4
+.IX Item "gnu9x"
+.PD
+\&\s-1ISO\s0 C99 plus \s-1GNU\s0 extensions. When \s-1ISO\s0 C99 is fully implemented in \s-1GCC\s0,
+this will become the default. The name \fBgnu9x\fR is deprecated.
+.RE
+.RS 4
+.Sp
+Even when this option is not specified, you can still use some of the
+features of newer standards in so far as they do not conflict with
+previous C standards. For example, you may use \f(CW\*(C`_\|_restrict_\|_\*(C'\fR even
+when \fB\-std=c99\fR is not specified.
+.Sp
+The \fB\-std\fR options specifying some version of \s-1ISO\s0 C have the same
+effects as \fB\-ansi\fR, except that features that were not in \s-1ISO\s0 C89
+but are in the specified version (for example, \fB//\fR comments and
+the \f(CW\*(C`inline\*(C'\fR keyword in \s-1ISO\s0 C99) are not disabled.
+.RE
+.Ip "\fB\-aux-info\fR \fIfilename\fR" 4
+.IX Item "-aux-info filename"
+Output to the given filename prototyped declarations for all functions
+declared and/or defined in a translation unit, including those in header
+files. This option is silently ignored in any language other than C.
+.Sp
+Besides declarations, the file indicates, in comments, the origin of
+each declaration (source file and line), whether the declaration was
+implicit, prototyped or unprototyped (\fBI\fR, \fBN\fR for new or
+\&\fBO\fR for old, respectively, in the first character after the line
+number and the colon), and whether it came from a declaration or a
+definition (\fBC\fR or \fBF\fR, respectively, in the following
+character). In the case of function definitions, a K&R-style list of
+arguments followed by their declarations is also provided, inside
+comments, after the declaration.
+.Ip "\fB\-faltivec\fR" 4
+.IX Item "-faltivec"
+Enable the AltiVec language extensions, as defined in Motorola's AltiVec
+\&\s-1PIM\s0. This includes the recognition of \f(CW\*(C`vector\*(C'\fR and \f(CW\*(C`pixel\*(C'\fR as
+(context-dependent) keywords, the definition of built-in functions such
+as \f(CW\*(C`vec_add\*(C'\fR, and other extensions. Note that unlike the option
+\&\fB\-maltivec\fR, the extensions do not require the inclusion of any
+special header files. (\s-1APPLE\s0 \s-1ONLY\s0)
+.Ip "\fB\-fno-asm\fR" 4
+.IX Item "-fno-asm"
+Do not recognize \f(CW\*(C`asm\*(C'\fR, \f(CW\*(C`inline\*(C'\fR or \f(CW\*(C`typeof\*(C'\fR as a
+keyword, so that code can use these words as identifiers. You can use
+the keywords \f(CW\*(C`_\|_asm_\|_\*(C'\fR, \f(CW\*(C`_\|_inline_\|_\*(C'\fR and \f(CW\*(C`_\|_typeof_\|_\*(C'\fR
+instead. \fB\-ansi\fR implies \fB\-fno-asm\fR.
+.Sp
+In \*(C+, this switch only affects the \f(CW\*(C`typeof\*(C'\fR keyword, since
+\&\f(CW\*(C`asm\*(C'\fR and \f(CW\*(C`inline\*(C'\fR are standard keywords. You may want to
+use the \fB\-fno-gnu-keywords\fR flag instead, which has the same
+effect. In C99 mode (\fB\-std=c99\fR or \fB\-std=gnu99\fR), this
+switch only affects the \f(CW\*(C`asm\*(C'\fR and \f(CW\*(C`typeof\*(C'\fR keywords, since
+\&\f(CW\*(C`inline\*(C'\fR is a standard keyword in \s-1ISO\s0 C99.
+.Ip "\fB\-fno-builtin\fR" 4
+.IX Item "-fno-builtin"
+.PD 0
+.Ip "\fB\-fno-builtin-\fR\fIfunction\fR\fB \fR(C and Objective-C only)" 4
+.IX Item "-fno-builtin-function (C and Objective-C only)"
+.PD
+Don't recognize built-in functions that do not begin with
+\&\fB_\|_builtin_\fR as prefix.
+.Sp
+\&\s-1GCC\s0 normally generates special code to handle certain built-in functions
+more efficiently; for instance, calls to \f(CW\*(C`alloca\*(C'\fR may become single
+instructions that adjust the stack directly, and calls to \f(CW\*(C`memcpy\*(C'\fR
+may become inline copy loops. The resulting code is often both smaller
+and faster, but since the function calls no longer appear as such, you
+cannot set a breakpoint on those calls, nor can you change the behavior
+of the functions by linking with a different library.
+.Sp
+In \*(C+, \fB\-fno-builtin\fR is always in effect. The \fB\-fbuiltin\fR
+option has no effect. Therefore, in \*(C+, the only way to get the
+optimization benefits of built-in functions is to call the function
+using the \fB_\|_builtin_\fR prefix. The \s-1GNU\s0 \*(C+ Standard Library uses
+built-in functions to implement many functions (like
+\&\f(CW\*(C`std::strchr\*(C'\fR), so that you automatically get efficient code.
+.Sp
+With the \fB\-fno-builtin-\fR\fIfunction\fR option, not available
+when compiling \*(C+, only the built-in function \fIfunction\fR is
+disabled. \fIfunction\fR must not begin with \fB_\|_builtin_\fR. If a
+function is named this is not built-in in this version of \s-1GCC\s0, this
+option is ignored. There is no corresponding
+\&\fB\-fbuiltin-\fR\fIfunction\fR option; if you wish to enable
+built-in functions selectively when using \fB\-fno-builtin\fR or
+\&\fB\-ffreestanding\fR, you may define macros such as:
+.Sp
+.Vb 2
+\& #define abs(n) __builtin_abs ((n))
+\& #define strcpy(d, s) __builtin_strcpy ((d), (s))
+.Ve
+.Ip "\fB\-fhosted\fR" 4
+.IX Item "-fhosted"
+Assert that compilation takes place in a hosted environment. This implies
+\&\fB\-fbuiltin\fR. A hosted environment is one in which the
+entire standard library is available, and in which \f(CW\*(C`main\*(C'\fR has a return
+type of \f(CW\*(C`int\*(C'\fR. Examples are nearly everything except a kernel.
+This is equivalent to \fB\-fno-freestanding\fR.
+.Ip "\fB\-ffreestanding\fR" 4
+.IX Item "-ffreestanding"
+Assert that compilation takes place in a freestanding environment. This
+implies \fB\-fno-builtin\fR. A freestanding environment
+is one in which the standard library may not exist, and program startup may
+not necessarily be at \f(CW\*(C`main\*(C'\fR. The most obvious example is an \s-1OS\s0 kernel.
+This is equivalent to \fB\-fno-hosted\fR.
+.Ip "\fB\-trigraphs\fR" 4
+.IX Item "-trigraphs"
+Support \s-1ISO\s0 C trigraphs. The \fB\-ansi\fR option (and \fB\-std\fR
+options for strict \s-1ISO\s0 C conformance) implies \fB\-trigraphs\fR.
+.Ip "\fB\-no-integrated-cpp\fR" 4
+.IX Item "-no-integrated-cpp"
+Invoke the external cpp during compilation. The default is to use the
+integrated cpp (internal cpp). This option also allows a
+user-supplied cpp via the \fB\-B\fR option. This flag is applicable
+in both C and \*(C+ modes.
+.Sp
+We do not guarantee to retain this option in future, and we may change
+its semantics.
+.Ip "\fB\*(--dump-pch\fR \fIname\fR" 4
+.IX Item "dump-pch name"
+Dump the state of the compiler into a directory named \fIname\fR, after
+processing all the other arguments. This is useful for creating
+precompiled headers. (\s-1APPLE\s0 \s-1ONLY\s0)
+.Ip "\fB\*(--load-pch\fR \fIname\fR" 4
+.IX Item "load-pch name"
+Restore the state of the compiler from the directory \fIname\fR before
+processing the other arguments. The net effect is similar to
+\&\fB\-include\fR, but it happens much more quickly. (\s-1APPLE\s0 \s-1ONLY\s0)
+.Sp
+So for instance if the file \fImyprefix.c\fR #includes various
+headers that are useful to all files in your program, you can do
+.Sp
+.Vb 5
+\& gcc --dump-pch foo -c myprefix.c
+\& gcc --load-pch foo myfile1.c
+\& gcc --load-pch foo myfile2.c
+\& gcc --load-pch foo myfile2.c
+\& ...
+.Ve
+.Ip "\fB\-traditional\fR" 4
+.IX Item "-traditional"
+Attempt to support some aspects of traditional C compilers.
+Specifically:
+.RS 4
+.Ip "\(bu" 4
+All \f(CW\*(C`extern\*(C'\fR declarations take effect globally even if they
+are written inside of a function definition. This includes implicit
+declarations of functions.
+.Ip "\(bu" 4
+The newer keywords \f(CW\*(C`typeof\*(C'\fR, \f(CW\*(C`inline\*(C'\fR, \f(CW\*(C`signed\*(C'\fR, \f(CW\*(C`const\*(C'\fR
+and \f(CW\*(C`volatile\*(C'\fR are not recognized. (You can still use the
+alternative keywords such as \f(CW\*(C`_\|_typeof_\|_\*(C'\fR, \f(CW\*(C`_\|_inline_\|_\*(C'\fR, and
+so on.)
+.Ip "\(bu" 4
+Comparisons between pointers and integers are always allowed.
+.Ip "\(bu" 4
+Integer types \f(CW\*(C`unsigned short\*(C'\fR and \f(CW\*(C`unsigned char\*(C'\fR promote
+to \f(CW\*(C`unsigned int\*(C'\fR.
+.Ip "\(bu" 4
+Out-of-range floating point literals are not an error.
+.Ip "\(bu" 4
+Certain constructs which \s-1ISO\s0 regards as a single invalid preprocessing
+number, such as \fB0xe-0xd\fR, are treated as expressions instead.
+.Ip "\(bu" 4
+String ``constants'' are not necessarily constant; they are stored in
+writable space, and identical looking constants are allocated
+separately. (This is the same as the effect of
+\&\fB\-fwritable-strings\fR.)
+.Ip "\(bu" 4
+All automatic variables not declared \f(CW\*(C`register\*(C'\fR are preserved by
+\&\f(CW\*(C`longjmp\*(C'\fR. Ordinarily, \s-1GNU\s0 C follows \s-1ISO\s0 C: automatic variables
+not declared \f(CW\*(C`volatile\*(C'\fR may be clobbered.
+.Ip "\(bu" 4
+The character escape sequences \fB\ex\fR and \fB\ea\fR evaluate as the
+literal characters \fBx\fR and \fBa\fR respectively. Without
+\&\fB\-traditional\fR, \fB\ex\fR is a prefix for the hexadecimal
+representation of a character, and \fB\ea\fR produces a bell.
+.RE
+.RS 4
+.Sp
+This option is deprecated and may be removed.
+.Sp
+You may wish to use \fB\-fno-builtin\fR as well as \fB\-traditional\fR
+if your program uses names that are normally \s-1GNU\s0 C built-in functions for
+other purposes of its own.
+.Sp
+You cannot use \fB\-traditional\fR if you include any header files that
+rely on \s-1ISO\s0 C features. Some vendors are starting to ship systems with
+\&\s-1ISO\s0 C header files and you cannot use \fB\-traditional\fR on such
+systems to compile files that include any system headers.
+.Sp
+The \fB\-traditional\fR option also enables \fB\-traditional-cpp\fR.
+.RE
+.Ip "\fB\-fcond-mismatch\fR" 4
+.IX Item "-fcond-mismatch"
+Allow conditional expressions with mismatched types in the second and
+third arguments. The value of such an expression is void. This option
+is not supported for \*(C+.
+.Ip "\fB\-funsigned-char\fR" 4
+.IX Item "-funsigned-char"
+Let the type \f(CW\*(C`char\*(C'\fR be unsigned, like \f(CW\*(C`unsigned char\*(C'\fR.
+.Sp
+Each kind of machine has a default for what \f(CW\*(C`char\*(C'\fR should
+be. It is either like \f(CW\*(C`unsigned char\*(C'\fR by default or like
+\&\f(CW\*(C`signed char\*(C'\fR by default.
+.Sp
+Ideally, a portable program should always use \f(CW\*(C`signed char\*(C'\fR or
+\&\f(CW\*(C`unsigned char\*(C'\fR when it depends on the signedness of an object.
+But many programs have been written to use plain \f(CW\*(C`char\*(C'\fR and
+expect it to be signed, or expect it to be unsigned, depending on the
+machines they were written for. This option, and its inverse, let you
+make such a program work with the opposite default.
+.Sp
+The type \f(CW\*(C`char\*(C'\fR is always a distinct type from each of
+\&\f(CW\*(C`signed char\*(C'\fR or \f(CW\*(C`unsigned char\*(C'\fR, even though its behavior
+is always just like one of those two.
+.Ip "\fB\-fsigned-char\fR" 4
+.IX Item "-fsigned-char"
+Let the type \f(CW\*(C`char\*(C'\fR be signed, like \f(CW\*(C`signed char\*(C'\fR.
+.Sp
+Note that this is equivalent to \fB\-fno-unsigned-char\fR, which is
+the negative form of \fB\-funsigned-char\fR. Likewise, the option
+\&\fB\-fno-signed-char\fR is equivalent to \fB\-funsigned-char\fR.
+.Ip "\fB\-fsigned-bitfields\fR" 4
+.IX Item "-fsigned-bitfields"
+.PD 0
+.Ip "\fB\-funsigned-bitfields\fR" 4
+.IX Item "-funsigned-bitfields"
+.Ip "\fB\-fno-signed-bitfields\fR" 4
+.IX Item "-fno-signed-bitfields"
+.Ip "\fB\-fno-unsigned-bitfields\fR" 4
+.IX Item "-fno-unsigned-bitfields"
+.PD
+These options control whether a bit-field is signed or unsigned, when the
+declaration does not use either \f(CW\*(C`signed\*(C'\fR or \f(CW\*(C`unsigned\*(C'\fR. By
+default, such a bit-field is signed, because this is consistent: the
+basic integer types such as \f(CW\*(C`int\*(C'\fR are signed types.
+.Sp
+However, when \fB\-traditional\fR is used, bit-fields are all unsigned
+no matter what.
+.Ip "\fB\-fwritable-strings\fR" 4
+.IX Item "-fwritable-strings"
+Store string constants in the writable data segment and don't uniquize
+them. This is for compatibility with old programs which assume they can
+write into string constants. The option \fB\-traditional\fR also has
+this effect.
+.Sp
+Writing into string constants is a very bad idea; ``constants'' should
+be constant.
+.Ip "\fB\-fconstant-cfstrings\fR" 4
+.IX Item "-fconstant-cfstrings"
+Enable the automatic creation of a CoreFoundation-type constant string
+whenever a special builtin \f(CW\*(C`_\|_builtin_\|_CFStringMakeConstantString\*(C'\fR
+is called on a literal string. (\s-1APPLE\s0 \s-1ONLY\s0)
+.Ip "\fB\-fallow-single-precision\fR" 4
+.IX Item "-fallow-single-precision"
+Do not promote single precision math operations to double precision,
+even when compiling with \fB\-traditional\fR.
+.Sp
+Traditional K&R C promotes all floating point operations to double
+precision, regardless of the sizes of the operands. On the
+architecture for which you are compiling, single precision may be faster
+than double precision. If you must use \fB\-traditional\fR, but want
+to use single precision operations when the operands are single
+precision, use this option. This option has no effect when compiling
+with \s-1ISO\s0 or \s-1GNU\s0 C conventions (the default).
+.Ip "\fB\-fshort-wchar\fR" 4
+.IX Item "-fshort-wchar"
+Override the underlying type for \fBwchar_t\fR to be \fBshort
+unsigned int\fR instead of the default for the target. This option is
+useful for building programs to run under \s-1WINE\s0.
+.Ip "\fB\-fpascal-strings\fR" 4
+.IX Item "-fpascal-strings"
+Allow Pascal-style string literals to be constructed. (\s-1APPLE\s0 \s-1ONLY\s0)
+.Ip "\fB\-fcoalesce\fR" 4
+.IX Item "-fcoalesce"
+Coalesce duplicated functions and data. The linker will discard all
+but one, saving space. Enabled by default. (\s-1APPLE\s0 \s-1ONLY\s0)
+.Ip "\fB\-fweak-coalesced\fR" 4
+.IX Item "-fweak-coalesced"
+Use the new \s-1OS\s0 X \*(L"weak_definitions\*(R" section attribute for coalesced items.
+A single \*(L"normal\*(R" definition will be chosen by the linker over any number
+of weakly-coalesced ones. (\s-1APPLE\s0 \s-1ONLY\s0)
+.Sh "Options Controlling \*(C+ Dialect"
+.IX Subsection "Options Controlling Dialect"
+This section describes the command-line options that are only meaningful
+for \*(C+ programs; but you can also use most of the \s-1GNU\s0 compiler options
+regardless of what language your program is in. For example, you
+might compile a file \f(CW\*(C`firstClass.C\*(C'\fR like this:
+.PP
+.Vb 1
+\& g++ -g -frepo -O -c firstClass.C
+.Ve
+In this example, only \fB\-frepo\fR is an option meant
+only for \*(C+ programs; you can use the other options with any
+language supported by \s-1GCC\s0.
+.PP
+Here is a list of options that are \fIonly\fR for compiling \*(C+ programs:
+.Ip "\fB\-fno-access-control\fR" 4
+.IX Item "-fno-access-control"
+Turn off all access checking. This switch is mainly useful for working
+around bugs in the access control code.
+.Ip "\fB\-fcheck-new\fR" 4
+.IX Item "-fcheck-new"
+Check that the pointer returned by \f(CW\*(C`operator new\*(C'\fR is non-null
+before attempting to modify the storage allocated. The current Working
+Paper requires that \f(CW\*(C`operator new\*(C'\fR never return a null pointer, so
+this check is normally unnecessary.
+.Sp
+An alternative to using this option is to specify that your
+\&\f(CW\*(C`operator new\*(C'\fR does not throw any exceptions; if you declare it
+\&\fB\f(BIthrow()\fB\fR, G++ will check the return value. See also \fBnew
+(nothrow)\fR.
+.Ip "\fB\-fconserve-space\fR" 4
+.IX Item "-fconserve-space"
+Put uninitialized or runtime-initialized global variables into the
+common segment, as C does. This saves space in the executable at the
+cost of not diagnosing duplicate definitions. If you compile with this
+flag and your program mysteriously crashes after \f(CW\*(C`main()\*(C'\fR has
+completed, you may have an object that is being destroyed twice because
+two definitions were merged.
+.Sp
+This option is no longer useful on most targets, now that support has
+been added for putting variables into \s-1BSS\s0 without making them common.
+.Ip "\fB\-fno-const-strings\fR" 4
+.IX Item "-fno-const-strings"
+Give string constants type \f(CW\*(C`char *\*(C'\fR instead of type \f(CW\*(C`const
+char *\*(C'\fR. By default, G++ uses type \f(CW\*(C`const char *\*(C'\fR as required by
+the standard. Even if you use \fB\-fno-const-strings\fR, you cannot
+actually modify the value of a string constant, unless you also use
+\&\fB\-fwritable-strings\fR.
+.Sp
+This option might be removed in a future release of G++. For maximum
+portability, you should structure your code so that it works with
+string constants that have type \f(CW\*(C`const char *\*(C'\fR.
+.Ip "\fB\-fdollars-in-identifiers\fR" 4
+.IX Item "-fdollars-in-identifiers"
+Accept \fB$\fR in identifiers. You can also explicitly prohibit use of
+\&\fB$\fR with the option \fB\-fno-dollars-in-identifiers\fR. (\s-1GNU\s0 C allows
+\&\fB$\fR by default on most target systems, but there are a few exceptions.)
+Traditional C allowed the character \fB$\fR to form part of
+identifiers. However, \s-1ISO\s0 C and \*(C+ forbid \fB$\fR in identifiers.
+.Ip "\fB\-fno-elide-constructors\fR" 4
+.IX Item "-fno-elide-constructors"
+The \*(C+ standard allows an implementation to omit creating a temporary
+which is only used to initialize another object of the same type.
+Specifying this option disables that optimization, and forces G++ to
+call the copy constructor in all cases.
+.Ip "\fB\-fno-enforce-eh-specs\fR" 4
+.IX Item "-fno-enforce-eh-specs"
+Don't check for violation of exception specifications at runtime. This
+option violates the \*(C+ standard, but may be useful for reducing code
+size in production builds, much like defining \fB\s-1NDEBUG\s0\fR. The compiler
+will still optimize based on the exception specifications.
+.Ip "\fB\-fexternal-templates\fR" 4
+.IX Item "-fexternal-templates"
+Cause \fB#pragma interface\fR and \fBimplementation\fR to apply to
+template instantiation; template instances are emitted or not according
+to the location of the template definition.
+.Sp
+This option is deprecated.
+.Ip "\fB\-falt-external-templates\fR" 4
+.IX Item "-falt-external-templates"
+Similar to \fB\-fexternal-templates\fR, but template instances are
+emitted or not according to the place where they are first instantiated.
+.Sp
+This option is deprecated.
+.Ip "\fB\-ffor-scope\fR" 4
+.IX Item "-ffor-scope"
+.PD 0
+.Ip "\fB\-fno-for-scope\fR" 4
+.IX Item "-fno-for-scope"
+.PD
+If \fB\-ffor-scope\fR is specified, the scope of variables declared in
+a \fIfor-init-statement\fR is limited to the \fBfor\fR loop itself,
+as specified by the \*(C+ standard.
+If \fB\-fno-for-scope\fR is specified, the scope of variables declared in
+a \fIfor-init-statement\fR extends to the end of the enclosing scope,
+as was the case in old versions of G++, and other (traditional)
+implementations of \*(C+.
+.Sp
+The default if neither flag is given to follow the standard,
+but to allow and give a warning for old-style code that would
+otherwise be invalid, or have different behavior.
+.Ip "\fB\-fno-gnu-keywords\fR" 4
+.IX Item "-fno-gnu-keywords"
+Do not recognize \f(CW\*(C`typeof\*(C'\fR as a keyword, so that code can use this
+word as an identifier. You can use the keyword \f(CW\*(C`_\|_typeof_\|_\*(C'\fR instead.
+\&\fB\-ansi\fR implies \fB\-fno-gnu-keywords\fR.
+.Ip "\fB\-fno-implicit-templates\fR" 4
+.IX Item "-fno-implicit-templates"
+Never emit code for non-inline templates which are instantiated
+implicitly (i.e. by use); only emit code for explicit instantiations.
+.Ip "\fB\-fno-implicit-inline-templates\fR" 4
+.IX Item "-fno-implicit-inline-templates"
+Don't emit code for implicit instantiations of inline templates, either.
+The default is to handle inlines differently so that compiles with and
+without optimization will need the same set of explicit instantiations.
+.Ip "\fB\-fno-implement-inlines\fR" 4
+.IX Item "-fno-implement-inlines"
+To save space, do not emit out-of-line copies of inline functions
+controlled by \fB#pragma implementation\fR. This will cause linker
+errors if these functions are not inlined everywhere they are called.
+.Ip "\fB\-findirect-virtual-calls\fR" 4
+.IX Item "-findirect-virtual-calls"
+Do not make direct calls to virtual functions; instead, always
+go through the vtable. (\s-1APPLE\s0 \s-1ONLY\s0)
+.Ip "\fB\-fapple-kext\fR" 4
+.IX Item "-fapple-kext"
+Alter vtables, destructors, and other implementation details to more
+closely resemble the \s-1GCC\s0 2.95 \s-1ABI\s0. This is to make kernel extensions
+loadable by Darwin kernels built using older compilers, and is required
+to build any Darwin kernel extension. (\s-1APPLE\s0 \s-1ONLY\s0)
+.Ip "\fB\-fcoalesce-templates\fR" 4
+.IX Item "-fcoalesce-templates"
+Mark instantiated templates as \*(L"coalesced\*(R": the linker will discard
+all but one, thus saving space. (\s-1APPLE\s0 \s-1ONLY\s0)
+.Ip "\fB\-fms-extensions\fR" 4
+.IX Item "-fms-extensions"
+Disable pedantic warnings about constructs used in \s-1MFC\s0, such as implicit
+int and getting a pointer to member function via non-standard syntax.
+.Ip "\fB\-fno-nonansi-builtins\fR" 4
+.IX Item "-fno-nonansi-builtins"
+Disable built-in declarations of functions that are not mandated by
+\&\s-1ANSI/ISO\s0 C. These include \f(CW\*(C`ffs\*(C'\fR, \f(CW\*(C`alloca\*(C'\fR, \f(CW\*(C`_exit\*(C'\fR,
+\&\f(CW\*(C`index\*(C'\fR, \f(CW\*(C`bzero\*(C'\fR, \f(CW\*(C`conjf\*(C'\fR, and other related functions.
+.Ip "\fB\-fno-operator-names\fR" 4
+.IX Item "-fno-operator-names"
+Do not treat the operator name keywords \f(CW\*(C`and\*(C'\fR, \f(CW\*(C`bitand\*(C'\fR,
+\&\f(CW\*(C`bitor\*(C'\fR, \f(CW\*(C`compl\*(C'\fR, \f(CW\*(C`not\*(C'\fR, \f(CW\*(C`or\*(C'\fR and \f(CW\*(C`xor\*(C'\fR as
+synonyms as keywords.
+.Ip "\fB\-fno-optional-diags\fR" 4
+.IX Item "-fno-optional-diags"
+Disable diagnostics that the standard says a compiler does not need to
+issue. Currently, the only such diagnostic issued by G++ is the one for
+a name having multiple meanings within a class.
+.Ip "\fB\-fpermissive\fR" 4
+.IX Item "-fpermissive"
+Downgrade messages about nonconformant code from errors to warnings. By
+default, G++ effectively sets \fB\-pedantic-errors\fR without
+\&\fB\-pedantic\fR; this option reverses that. This behavior and this
+option are superseded by \fB\-pedantic\fR, which works as it does for \s-1GNU\s0 C.
+.Ip "\fB\-frepo\fR" 4
+.IX Item "-frepo"
+Enable automatic template instantiation at link time. This option also
+implies \fB\-fno-implicit-templates\fR.
+.Ip "\fB\-fno-rtti\fR" 4
+.IX Item "-fno-rtti"
+Disable generation of information about every class with virtual
+functions for use by the \*(C+ runtime type identification features
+(\fBdynamic_cast\fR and \fBtypeid\fR). If you don't use those parts
+of the language, you can save some space by using this flag. Note that
+exception handling uses the same information, but it will generate it as
+needed.
+.Ip "\fB\-fstats\fR" 4
+.IX Item "-fstats"
+Emit statistics about front-end processing at the end of the compilation.
+This information is generally only useful to the G++ development team.
+.Ip "\fB\-ftemplate-depth-\fR\fIn\fR" 4
+.IX Item "-ftemplate-depth-n"
+Set the maximum instantiation depth for template classes to \fIn\fR.
+A limit on the template instantiation depth is needed to detect
+endless recursions during template class instantiation. \s-1ANSI/ISO\s0 \*(C+
+conforming programs must not rely on a maximum depth greater than 17.
+.Ip "\fB\-fuse-cxa-atexit\fR" 4
+.IX Item "-fuse-cxa-atexit"
+Register destructors for objects with static storage duration with the
+\&\f(CW\*(C`_\|_cxa_atexit\*(C'\fR function rather than the \f(CW\*(C`atexit\*(C'\fR function.
+This option is required for fully standards-compliant handling of static
+destructors, but will only work if your C library supports
+\&\f(CW\*(C`_\|_cxa_atexit\*(C'\fR.
+This option is not supported on Mac \s-1OS\s0 X.
+.Ip "\fB\-fvtable-gc\fR" 4
+.IX Item "-fvtable-gc"
+Emit special relocations for vtables and virtual function references
+so that the linker can identify unused virtual functions and zero out
+vtable slots that refer to them. This is most useful with
+\&\fB\-ffunction-sections\fR and \fB\-Wl,\-\-gc-sections\fR, in order to
+also discard the functions themselves.
+.Sp
+This optimization requires \s-1GNU\s0 as and \s-1GNU\s0 ld. Not all systems support
+this option. \fB\-Wl,\-\-gc-sections\fR is ignored without \fB\-static\fR.
+.Ip "\fB\-fno-weak\fR" 4
+.IX Item "-fno-weak"
+Do not use weak symbol support, even if it is provided by the linker.
+By default, G++ will use weak symbols if they are available. This
+option exists only for testing, and should not be used by end-users;
+it will result in inferior code and has no benefits. This option may
+be removed in a future release of G++.
+.Ip "\fB\-nostdinc++\fR" 4
+.IX Item "-nostdinc++"
+Do not search for header files in the standard directories specific to
+\&\*(C+, but do still search the other standard directories. (This option
+is used when building the \*(C+ library.)
+.PP
+In addition, these optimization, warning, and code generation options
+have meanings only for \*(C+ programs:
+.Ip "\fB\-fno-default-inline\fR" 4
+.IX Item "-fno-default-inline"
+Do not assume \fBinline\fR for functions defined inside a class scope.
+ Note that these
+functions will have linkage like inline functions; they just won't be
+inlined by default.
+.Ip "\fB\-Wctor-dtor-privacy\fR (\*(C+ only)" 4
+.IX Item "-Wctor-dtor-privacy ( only)"
+Warn when a class seems unusable, because all the constructors or
+destructors in a class are private and the class has no friends or
+public static member functions.
+.Ip "\fB\-Wnon-virtual-dtor\fR (\*(C+ only)" 4
+.IX Item "-Wnon-virtual-dtor ( only)"
+Warn when a class declares a non-virtual destructor that should probably
+be virtual, because it looks like the class will be used polymorphically.
+.Ip "\fB\-Wreorder\fR (\*(C+ only)" 4
+.IX Item "-Wreorder ( only)"
+Warn when the order of member initializers given in the code does not
+match the order in which they must be executed. For instance:
+.Sp
+.Vb 5
+\& struct A {
+\& int i;
+\& int j;
+\& A(): j (0), i (1) { }
+\& };
+.Ve
+Here the compiler will warn that the member initializers for \fBi\fR
+and \fBj\fR will be rearranged to match the declaration order of the
+members.
+.PP
+The following \fB\-W...\fR options are not affected by \fB\-Wall\fR.
+.Ip "\fB\-Weffc++\fR (\*(C+ only)" 4
+.IX Item "-Weffc++ ( only)"
+Warn about violations of the following style guidelines from Scott Meyers'
+\&\fIEffective \*(C+\fR book:
+.RS 4
+.Ip "\(bu" 4
+Item 11: Define a copy constructor and an assignment operator for classes
+with dynamically allocated memory.
+.Ip "\(bu" 4
+Item 12: Prefer initialization to assignment in constructors.
+.Ip "\(bu" 4
+Item 14: Make destructors virtual in base classes.
+.Ip "\(bu" 4
+Item 15: Have \f(CW\*(C`operator=\*(C'\fR return a reference to \f(CW\*(C`*this\*(C'\fR.
+.Ip "\(bu" 4
+Item 23: Don't try to return a reference when you must return an object.
+.RE
+.RS 4
+.Sp
+and about violations of the following style guidelines from Scott Meyers'
+\&\fIMore Effective \*(C+\fR book:
+.RS 4
+.RE
+.Ip "\(bu" 4
+Item 6: Distinguish between prefix and postfix forms of increment and
+decrement operators.
+.Ip "\(bu" 4
+Item 7: Never overload \f(CW\*(C`&&\*(C'\fR, \f(CW\*(C`||\*(C'\fR, or \f(CW\*(C`,\*(C'\fR.
+.RE
+.RS 4
+.Sp
+If you use this option, you should be aware that the standard library
+headers do not obey all of these guidelines; you can use \fBgrep \-v\fR
+to filter out those warnings.
+.RE
+.Ip "\fB\-Wno-deprecated\fR (\*(C+ only)" 4
+.IX Item "-Wno-deprecated ( only)"
+Do not warn about usage of deprecated features.
+.Ip "\fB\-Wno-non-template-friend\fR (\*(C+ only)" 4
+.IX Item "-Wno-non-template-friend ( only)"
+Disable warnings when non-templatized friend functions are declared
+within a template. With the advent of explicit template specification
+support in G++, if the name of the friend is an unqualified-id (i.e.,
+\&\fBfriend foo(int)\fR), the \*(C+ language specification demands that the
+friend declare or define an ordinary, nontemplate function. (Section
+14.5.3). Before G++ implemented explicit specification, unqualified-ids
+could be interpreted as a particular specialization of a templatized
+function. Because this non-conforming behavior is no longer the default
+behavior for G++, \fB\-Wnon-template-friend\fR allows the compiler to
+check existing code for potential trouble spots, and is on by default.
+This new compiler behavior can be turned off with
+\&\fB\-Wno-non-template-friend\fR which keeps the conformant compiler code
+but disables the helpful warning.
+.Ip "\fB\-Wold-style-cast\fR (\*(C+ only)" 4
+.IX Item "-Wold-style-cast ( only)"
+Warn if an old-style (C-style) cast to a non-void type is used within
+a \*(C+ program. The new-style casts (\fBstatic_cast\fR,
+\&\fBreinterpret_cast\fR, and \fBconst_cast\fR) are less vulnerable to
+unintended effects, and much easier to grep for.
+.Ip "\fB\-Woverloaded-virtual\fR (\*(C+ only)" 4
+.IX Item "-Woverloaded-virtual ( only)"
+Warn when a function declaration hides virtual functions from a
+base class. For example, in:
+.Sp
+.Vb 3
+\& struct A {
+\& virtual void f();
+\& };
+.Ve
+.Vb 3
+\& struct B: public A {
+\& void f(int);
+\& };
+.Ve
+the \f(CW\*(C`A\*(C'\fR class version of \f(CW\*(C`f\*(C'\fR is hidden in \f(CW\*(C`B\*(C'\fR, and code
+like this:
+.Sp
+.Vb 2
+\& B* b;
+\& b->f();
+.Ve
+will fail to compile.
+.Ip "\fB\-Wno-pmf-conversions\fR (\*(C+ only)" 4
+.IX Item "-Wno-pmf-conversions ( only)"
+Disable the diagnostic for converting a bound pointer to member function
+to a plain pointer.
+.Ip "\fB\-Wsign-promo\fR (\*(C+ only)" 4
+.IX Item "-Wsign-promo ( only)"
+Warn when overload resolution chooses a promotion from unsigned or
+enumeral type to a signed type over a conversion to an unsigned type of
+the same size. Previous versions of G++ would try to preserve
+unsignedness, but the standard mandates the current behavior.
+.Ip "\fB\-Wsynth\fR (\*(C+ only)" 4
+.IX Item "-Wsynth ( only)"
+Warn when G++'s synthesis behavior does not match that of cfront. For
+instance:
+.Sp
+.Vb 4
+\& struct A {
+\& operator int ();
+\& A& operator = (int);
+\& };
+.Ve
+.Vb 5
+\& main ()
+\& {
+\& A a,b;
+\& a = b;
+\& }
+.Ve
+In this example, G++ will synthesize a default \fBA& operator =
+(const A&);\fR, while cfront will use the user-defined \fBoperator =\fR.
+.Sh "Options Controlling Objective-C Dialect"
+.IX Subsection "Options Controlling Objective-C Dialect"
+This section describes the command-line options that are only meaningful
+for Objective-C programs; but you can also use most of the \s-1GNU\s0 compiler
+options regardless of what language your program is in. For example,
+you might compile a file \f(CW\*(C`some_class.m\*(C'\fR like this:
+.PP
+.Vb 1
+\& gcc -g -fgnu-runtime -O -c some_class.m
+.Ve
+In this example, only \fB\-fgnu-runtime\fR is an option meant only for
+Objective-C programs; you can use the other options with any language
+supported by \s-1GCC\s0.
+.PP
+Here is a list of options that are \fIonly\fR for compiling Objective-C
+programs:
+.Ip "\fB\-fconstant-string-class=\fR\fIclass-name\fR" 4
+.IX Item "-fconstant-string-class=class-name"
+Use \fIclass-name\fR as the name of the class to instantiate for each
+literal string specified with the syntax \f(CW\*(C`@"..."\*(C'\fR. The default
+class name is \f(CW\*(C`NXConstantString\*(C'\fR.
+.Ip "\fB\-fgnu-runtime\fR" 4
+.IX Item "-fgnu-runtime"
+Generate object code compatible with the standard \s-1GNU\s0 Objective-C
+runtime. This is the default for most types of systems.
+.Ip "\fB\-fnext-runtime\fR" 4
+.IX Item "-fnext-runtime"
+Generate output compatible with the NeXT runtime. This is the default
+for NeXT-based systems, including Darwin and Mac \s-1OS\s0 X.
+.Ip "\fB\-gen-decls\fR" 4
+.IX Item "-gen-decls"
+Dump interface declarations for all classes seen in the source file to a
+file named \fI\fIsourcename\fI.decl\fR.
+.Ip "\fB\-Wno-protocol\fR" 4
+.IX Item "-Wno-protocol"
+Do not warn if methods required by a protocol are not implemented
+in the class adopting it.
+.Ip "\fB\-Wselector\fR" 4
+.IX Item "-Wselector"
+Warn if a selector has multiple methods of different types defined.
+.Sh "Options to Control Diagnostic Messages Formatting"
+.IX Subsection "Options to Control Diagnostic Messages Formatting"
+Traditionally, diagnostic messages have been formatted irrespective of
+the output device's aspect (e.g. its width, ...). The options described
+below can be used to control the diagnostic messages formatting
+algorithm, e.g. how many characters per line, how often source location
+information should be reported. Right now, only the \*(C+ front end can
+honor these options. However it is expected, in the near future, that
+the remaining front ends would be able to digest them correctly.
+.Ip "\fB\-fmessage-length=\fR\fIn\fR" 4
+.IX Item "-fmessage-length=n"
+Try to format error messages so that they fit on lines of about \fIn\fR
+characters. The default is 72 characters for \fBg++\fR and 0 for the rest of
+the front ends supported by \s-1GCC\s0. If \fIn\fR is zero, then no
+line-wrapping will be done; each error message will appear on a single
+line.
+.Ip "\fB\-fdiagnostics-show-location=once\fR" 4
+.IX Item "-fdiagnostics-show-location=once"
+Only meaningful in line-wrapping mode. Instructs the diagnostic messages
+reporter to emit \fIonce\fR source location information; that is, in
+case the message is too long to fit on a single physical line and has to
+be wrapped, the source location won't be emitted (as prefix) again,
+over and over, in subsequent continuation lines. This is the default
+behavior.
+.Ip "\fB\-fdiagnostics-show-location=every-line\fR" 4
+.IX Item "-fdiagnostics-show-location=every-line"
+Only meaningful in line-wrapping mode. Instructs the diagnostic
+messages reporter to emit the same source location information (as
+prefix) for physical lines that result from the process of breaking
+a message which is too long to fit on a single line.
+.Sh "Options to Request or Suppress Warnings"
+.IX Subsection "Options to Request or Suppress Warnings"
+Warnings are diagnostic messages that report constructions which
+are not inherently erroneous but which are risky or suggest there
+may have been an error.
+.PP
+You can request many specific warnings with options beginning \fB\-W\fR,
+for example \fB\-Wimplicit\fR to request warnings on implicit
+declarations. Each of these specific warning options also has a
+negative form beginning \fB\-Wno-\fR to turn off warnings;
+for example, \fB\-Wno-implicit\fR. This manual lists only one of the
+two forms, whichever is not the default.
+.PP
+The following options control the amount and kinds of warnings produced
+by \s-1GCC\s0; for further, language-specific options also refer to
+\&\f(CW@ref\fR{\*(C+ Dialect Options} and \f(CW@ref\fR{Objective-C Dialect Options}.
+.Ip "\fB\-fsyntax-only\fR" 4
+.IX Item "-fsyntax-only"
+Check the code for syntax errors, but don't do anything beyond that.
+.Ip "\fB\-pedantic\fR" 4
+.IX Item "-pedantic"
+Issue all the warnings demanded by strict \s-1ISO\s0 C and \s-1ISO\s0 \*(C+;
+reject all programs that use forbidden extensions, and some other
+programs that do not follow \s-1ISO\s0 C and \s-1ISO\s0 \*(C+. For \s-1ISO\s0 C, follows the
+version of the \s-1ISO\s0 C standard specified by any \fB\-std\fR option used.
+.Sp
+Valid \s-1ISO\s0 C and \s-1ISO\s0 \*(C+ programs should compile properly with or without
+this option (though a rare few will require \fB\-ansi\fR or a
+\&\fB\-std\fR option specifying the required version of \s-1ISO\s0 C). However,
+without this option, certain \s-1GNU\s0 extensions and traditional C and \*(C+
+features are supported as well. With this option, they are rejected.
+.Sp
+\&\fB\-pedantic\fR does not cause warning messages for use of the
+alternate keywords whose names begin and end with \fB_\|_\fR. Pedantic
+warnings are also disabled in the expression that follows
+\&\f(CW\*(C`_\|_extension_\|_\*(C'\fR. However, only system header files should use
+these escape routes; application programs should avoid them.
+.Sp
+Some users try to use \fB\-pedantic\fR to check programs for strict \s-1ISO\s0
+C conformance. They soon find that it does not do quite what they want:
+it finds some non-ISO practices, but not all\-\-\-only those for which
+\&\s-1ISO\s0 C \fIrequires\fR a diagnostic, and some others for which
+diagnostics have been added.
+.Sp
+A feature to report any failure to conform to \s-1ISO\s0 C might be useful in
+some instances, but would require considerable additional work and would
+be quite different from \fB\-pedantic\fR. We don't have plans to
+support such a feature in the near future.
+.Sp
+Where the standard specified with \fB\-std\fR represents a \s-1GNU\s0
+extended dialect of C, such as \fBgnu89\fR or \fBgnu99\fR, there is a
+corresponding \fIbase standard\fR, the version of \s-1ISO\s0 C on which the \s-1GNU\s0
+extended dialect is based. Warnings from \fB\-pedantic\fR are given
+where they are required by the base standard. (It would not make sense
+for such warnings to be given only for features not in the specified \s-1GNU\s0
+C dialect, since by definition the \s-1GNU\s0 dialects of C include all
+features the compiler supports with the given option, and there would be
+nothing to warn about.)
+.Ip "\fB\-pedantic-errors\fR" 4
+.IX Item "-pedantic-errors"
+Like \fB\-pedantic\fR, except that errors are produced rather than
+warnings.
+.Ip "\fB\-w\fR" 4
+.IX Item "-w"
+Inhibit all warning messages.
+.Ip "\fB\-Wno-import\fR" 4
+.IX Item "-Wno-import"
+Inhibit warning messages about the use of \fB#import\fR.
+.Ip "\fB\-Wno-#warnings\fR" 4
+.IX Item "-Wno-#warnings"
+Inhibit warning messages issued by \fB#warning\fR.
+.Ip "\fB\-Wpragma-once\fR" 4
+.IX Item "-Wpragma-once"
+Warn about the use of \fB#pragma once\fR. (\s-1APPLE\s0 \s-1ONLY\s0)
+.Ip "\fB\-Wextra-tokens\fR" 4
+.IX Item "-Wextra-tokens"
+Warn about extra tokens at the end of prepreprocessor directives. (\s-1APPLE\s0 \s-1ONLY\s0)
+.Ip "\fB\-Wnewline-eof\fR" 4
+.IX Item "-Wnewline-eof"
+Warn about files missing a newline at the end of the file. (\s-1APPLE\s0 \s-1ONLY\s0)
+.Ip "\fB\-Wno-altivec-long-deprecated\fR" 4
+.IX Item "-Wno-altivec-long-deprecated"
+Do not warn about the use of the deprecated 'long' keyword in
+AltiVec data types. (\s-1APPLE\s0 \s-1ONLY\s0)
+.Ip "\fB\-Wchar-subscripts\fR" 4
+.IX Item "-Wchar-subscripts"
+Warn if an array subscript has type \f(CW\*(C`char\*(C'\fR. This is a common cause
+of error, as programmers often forget that this type is signed on some
+machines.
+.Ip "\fB\-Wcomment\fR" 4
+.IX Item "-Wcomment"
+Warn whenever a comment-start sequence \fB/*\fR appears in a \fB/*\fR
+comment, or whenever a Backslash-Newline appears in a \fB//\fR comment.
+.Ip "\fB\-Wformat\fR" 4
+.IX Item "-Wformat"
+Check calls to \f(CW\*(C`printf\*(C'\fR and \f(CW\*(C`scanf\*(C'\fR, etc., to make sure that
+the arguments supplied have types appropriate to the format string
+specified, and that the conversions specified in the format string make
+sense. This includes standard functions, and others specified by format
+attributes, in the \f(CW\*(C`printf\*(C'\fR,
+\&\f(CW\*(C`scanf\*(C'\fR, \f(CW\*(C`strftime\*(C'\fR and \f(CW\*(C`strfmon\*(C'\fR (an X/Open extension,
+not in the C standard) families.
+.Sp
+The formats are checked against the format features supported by \s-1GNU\s0
+libc version 2.2. These include all \s-1ISO\s0 C89 and C99 features, as well
+as features from the Single Unix Specification and some \s-1BSD\s0 and \s-1GNU\s0
+extensions. Other library implementations may not support all these
+features; \s-1GCC\s0 does not support warning about features that go beyond a
+particular library's limitations. However, if \fB\-pedantic\fR is used
+with \fB\-Wformat\fR, warnings will be given about format features not
+in the selected standard version (but not for \f(CW\*(C`strfmon\*(C'\fR formats,
+since those are not in any version of the C standard).
+.Sp
+\&\fB\-Wformat\fR is included in \fB\-Wall\fR. For more control over some
+aspects of format checking, the options \fB\-Wno-format-y2k\fR,
+\&\fB\-Wno-format-extra-args\fR, \fB\-Wformat-nonliteral\fR,
+\&\fB\-Wformat-security\fR and \fB\-Wformat=2\fR are available, but are
+not included in \fB\-Wall\fR.
+.Ip "\fB\-Wno-format-y2k\fR" 4
+.IX Item "-Wno-format-y2k"
+If \fB\-Wformat\fR is specified, do not warn about \f(CW\*(C`strftime\*(C'\fR
+formats which may yield only a two-digit year.
+.Ip "\fB\-Wno-format-extra-args\fR" 4
+.IX Item "-Wno-format-extra-args"
+If \fB\-Wformat\fR is specified, do not warn about excess arguments to a
+\&\f(CW\*(C`printf\*(C'\fR or \f(CW\*(C`scanf\*(C'\fR format function. The C standard specifies
+that such arguments are ignored.
+.Sp
+Where the unused arguments lie between used arguments that are
+specified with \fB$\fR operand number specifications, normally
+warnings are still given, since the implementation could not know what
+type to pass to \f(CW\*(C`va_arg\*(C'\fR to skip the unused arguments. However,
+in the case of \f(CW\*(C`scanf\*(C'\fR formats, this option will suppress the
+warning if the unused arguments are all pointers, since the Single
+Unix Specification says that such unused arguments are allowed.
+.Ip "\fB\-Wformat-nonliteral\fR" 4
+.IX Item "-Wformat-nonliteral"
+If \fB\-Wformat\fR is specified, also warn if the format string is not a
+string literal and so cannot be checked, unless the format function
+takes its format arguments as a \f(CW\*(C`va_list\*(C'\fR.
+.Ip "\fB\-Wformat-security\fR" 4
+.IX Item "-Wformat-security"
+If \fB\-Wformat\fR is specified, also warn about uses of format
+functions that represent possible security problems. At present, this
+warns about calls to \f(CW\*(C`printf\*(C'\fR and \f(CW\*(C`scanf\*(C'\fR functions where the
+format string is not a string literal and there are no format arguments,
+as in \f(CW\*(C`printf (foo);\*(C'\fR. This may be a security hole if the format
+string came from untrusted input and contains \fB%n\fR. (This is
+currently a subset of what \fB\-Wformat-nonliteral\fR warns about, but
+in future warnings may be added to \fB\-Wformat-security\fR that are not
+included in \fB\-Wformat-nonliteral\fR.)
+.Ip "\fB\-Wformat=2\fR" 4
+.IX Item "-Wformat=2"
+Enable \fB\-Wformat\fR plus format checks not included in
+\&\fB\-Wformat\fR. Currently equivalent to \fB\-Wformat
+\&\-Wformat-nonliteral \-Wformat-security\fR.
+.Ip "\fB\-Wimplicit-int\fR" 4
+.IX Item "-Wimplicit-int"
+Warn when a declaration does not specify a type.
+.Ip "\fB\-Wimplicit-function-declaration\fR" 4
+.IX Item "-Wimplicit-function-declaration"
+.PD 0
+.Ip "\fB\-Werror-implicit-function-declaration\fR" 4
+.IX Item "-Werror-implicit-function-declaration"
+.PD
+Give a warning (or error) whenever a function is used before being
+declared.
+.Ip "\fB\-Wimplicit\fR" 4
+.IX Item "-Wimplicit"
+Same as \fB\-Wimplicit-int\fR and \fB\-Wimplicit-function-declaration\fR.
+.Ip "\fB\-Wmain\fR" 4
+.IX Item "-Wmain"
+Warn if the type of \fBmain\fR is suspicious. \fBmain\fR should be a
+function with external linkage, returning int, taking either zero
+arguments, two, or three arguments of appropriate types.
+.Ip "\fB\-Wmissing-braces\fR" 4
+.IX Item "-Wmissing-braces"
+Warn if an aggregate or union initializer is not fully bracketed. In
+the following example, the initializer for \fBa\fR is not fully
+bracketed, but that for \fBb\fR is fully bracketed.
+.Sp
+.Vb 2
+\& int a[2][2] = { 0, 1, 2, 3 };
+\& int b[2][2] = { { 0, 1 }, { 2, 3 } };
+.Ve
+.Ip "\fB\-Wparentheses\fR" 4
+.IX Item "-Wparentheses"
+Warn if parentheses are omitted in certain contexts, such
+as when there is an assignment in a context where a truth value
+is expected, or when operators are nested whose precedence people
+often get confused about.
+.Sp
+Also warn about constructions where there may be confusion to which
+\&\f(CW\*(C`if\*(C'\fR statement an \f(CW\*(C`else\*(C'\fR branch belongs. Here is an example of
+such a case:
+.Sp
+.Vb 7
+\& {
+\& if (a)
+\& if (b)
+\& foo ();
+\& else
+\& bar ();
+\& }
+.Ve
+In C, every \f(CW\*(C`else\*(C'\fR branch belongs to the innermost possible \f(CW\*(C`if\*(C'\fR
+statement, which in this example is \f(CW\*(C`if (b)\*(C'\fR. This is often not
+what the programmer expected, as illustrated in the above example by
+indentation the programmer chose. When there is the potential for this
+confusion, \s-1GCC\s0 will issue a warning when this flag is specified.
+To eliminate the warning, add explicit braces around the innermost
+\&\f(CW\*(C`if\*(C'\fR statement so there is no way the \f(CW\*(C`else\*(C'\fR could belong to
+the enclosing \f(CW\*(C`if\*(C'\fR. The resulting code would look like this:
+.Sp
+.Vb 9
+\& {
+\& if (a)
+\& {
+\& if (b)
+\& foo ();
+\& else
+\& bar ();
+\& }
+\& }
+.Ve
+.Ip "\fB\-Wsequence-point\fR" 4
+.IX Item "-Wsequence-point"
+Warn about code that may have undefined semantics because of violations
+of sequence point rules in the C standard.
+.Sp
+The C standard defines the order in which expressions in a C program are
+evaluated in terms of \fIsequence points\fR, which represent a partial
+ordering between the execution of parts of the program: those executed
+before the sequence point, and those executed after it. These occur
+after the evaluation of a full expression (one which is not part of a
+larger expression), after the evaluation of the first operand of a
+\&\f(CW\*(C`&&\*(C'\fR, \f(CW\*(C`||\*(C'\fR, \f(CW\*(C`? :\*(C'\fR or \f(CW\*(C`,\*(C'\fR (comma) operator, before a
+function is called (but after the evaluation of its arguments and the
+expression denoting the called function), and in certain other places.
+Other than as expressed by the sequence point rules, the order of
+evaluation of subexpressions of an expression is not specified. All
+these rules describe only a partial order rather than a total order,
+since, for example, if two functions are called within one expression
+with no sequence point between them, the order in which the functions
+are called is not specified. However, the standards committee have
+ruled that function calls do not overlap.
+.Sp
+It is not specified when between sequence points modifications to the
+values of objects take effect. Programs whose behavior depends on this
+have undefined behavior; the C standard specifies that ``Between the
+previous and next sequence point an object shall have its stored value
+modified at most once by the evaluation of an expression. Furthermore,
+the prior value shall be read only to determine the value to be
+stored.''. If a program breaks these rules, the results on any
+particular implementation are entirely unpredictable.
+.Sp
+Examples of code with undefined behavior are \f(CW\*(C`a = a++;\*(C'\fR, \f(CW\*(C`a[n]
+= b[n++]\*(C'\fR and \f(CW\*(C`a[i++] = i;\*(C'\fR. Some more complicated cases are not
+diagnosed by this option, and it may give an occasional false positive
+result, but in general it has been found fairly effective at detecting
+this sort of problem in programs.
+.Sp
+The present implementation of this option only works for C programs. A
+future implementation may also work for \*(C+ programs.
+.Sp
+The C standard is worded confusingly, therefore there is some debate
+over the precise meaning of the sequence point rules in subtle cases.
+Links to discussions of the problem, including proposed formal
+definitions, may be found on our readings page, at
+<\fBhttp://gcc.gnu.org/readings.html\fR>.
+.Ip "\fB\-Wreturn-type\fR" 4
+.IX Item "-Wreturn-type"
+Warn whenever a function is defined with a return-type that defaults to
+\&\f(CW\*(C`int\*(C'\fR. Also warn about any \f(CW\*(C`return\*(C'\fR statement with no
+return-value in a function whose return-type is not \f(CW\*(C`void\*(C'\fR.
+.Sp
+For \*(C+, a function without return type always produces a diagnostic
+message, even when \fB\-Wno-return-type\fR is specified. The only
+exceptions are \fBmain\fR and functions defined in system headers.
+.Ip "\fB\-Wswitch\fR" 4
+.IX Item "-Wswitch"
+Warn whenever a \f(CW\*(C`switch\*(C'\fR statement has an index of enumeral type
+and lacks a \f(CW\*(C`case\*(C'\fR for one or more of the named codes of that
+enumeration. (The presence of a \f(CW\*(C`default\*(C'\fR label prevents this
+warning.) \f(CW\*(C`case\*(C'\fR labels outside the enumeration range also
+provoke warnings when this option is used.
+.Ip "\fB\-Wtrigraphs\fR" 4
+.IX Item "-Wtrigraphs"
+Warn if any trigraphs are encountered that might change the meaning of
+the program (trigraphs within comments are not warned about).
+.Ip "\fB\-Wunused-function\fR" 4
+.IX Item "-Wunused-function"
+Warn whenever a static function is declared but not defined or a
+non\e-inline static function is unused.
+.Ip "\fB\-Wunused-label\fR" 4
+.IX Item "-Wunused-label"
+Warn whenever a label is declared but not used.
+.Sp
+To suppress this warning use the \fBunused\fR attribute.
+.Ip "\fB\-Wunused-parameter\fR" 4
+.IX Item "-Wunused-parameter"
+Warn whenever a function parameter is unused aside from its declaration.
+.Sp
+To suppress this warning use the \fBunused\fR attribute.
+.Ip "\fB\-Wunused-variable\fR" 4
+.IX Item "-Wunused-variable"
+Warn whenever a local variable or non-constant static variable is unused
+aside from its declaration
+.Sp
+To suppress this warning use the \fBunused\fR attribute.
+.Ip "\fB\-Wunused-value\fR" 4
+.IX Item "-Wunused-value"
+Warn whenever a statement computes a result that is explicitly not used.
+.Sp
+To suppress this warning cast the expression to \fBvoid\fR.
+.Ip "\fB\-Wunused\fR" 4
+.IX Item "-Wunused"
+All all the above \fB\-Wunused\fR options combined.
+.Sp
+In order to get a warning about an unused function parameter, you must
+either specify \fB\-W \-Wunused\fR or separately specify
+\&\fB\-Wunused-parameter\fR.
+.Ip "\fB\-Wuninitialized\fR" 4
+.IX Item "-Wuninitialized"
+Warn if an automatic variable is used without first being initialized or
+if a variable may be clobbered by a \f(CW\*(C`setjmp\*(C'\fR call.
+.Sp
+These warnings are possible only in optimizing compilation,
+because they require data flow information that is computed only
+when optimizing. If you don't specify \fB\-O\fR, you simply won't
+get these warnings.
+.Sp
+These warnings occur only for variables that are candidates for
+register allocation. Therefore, they do not occur for a variable that
+is declared \f(CW\*(C`volatile\*(C'\fR, or whose address is taken, or whose size
+is other than 1, 2, 4 or 8 bytes. Also, they do not occur for
+structures, unions or arrays, even when they are in registers.
+.Sp
+Note that there may be no warning about a variable that is used only
+to compute a value that itself is never used, because such
+computations may be deleted by data flow analysis before the warnings
+are printed.
+.Sp
+These warnings are made optional because \s-1GCC\s0 is not smart
+enough to see all the reasons why the code might be correct
+despite appearing to have an error. Here is one example of how
+this can happen:
+.Sp
+.Vb 12
+\& {
+\& int x;
+\& switch (y)
+\& {
+\& case 1: x = 1;
+\& break;
+\& case 2: x = 4;
+\& break;
+\& case 3: x = 5;
+\& }
+\& foo (x);
+\& }
+.Ve
+If the value of \f(CW\*(C`y\*(C'\fR is always 1, 2 or 3, then \f(CW\*(C`x\*(C'\fR is
+always initialized, but \s-1GCC\s0 doesn't know this. Here is
+another common case:
+.Sp
+.Vb 6
+\& {
+\& int save_y;
+\& if (change_y) save_y = y, y = new_y;
+\& ...
+\& if (change_y) y = save_y;
+\& }
+.Ve
+This has no bug because \f(CW\*(C`save_y\*(C'\fR is used only if it is set.
+.Sp
+This option also warns when a non-volatile automatic variable might be
+changed by a call to \f(CW\*(C`longjmp\*(C'\fR. These warnings as well are possible
+only in optimizing compilation.
+.Sp
+The compiler sees only the calls to \f(CW\*(C`setjmp\*(C'\fR. It cannot know
+where \f(CW\*(C`longjmp\*(C'\fR will be called; in fact, a signal handler could
+call it at any point in the code. As a result, you may get a warning
+even when there is in fact no problem because \f(CW\*(C`longjmp\*(C'\fR cannot
+in fact be called at the place which would cause a problem.
+.Sp
+Some spurious warnings can be avoided if you declare all the functions
+you use that never return as \f(CW\*(C`noreturn\*(C'\fR.
+.Ip "\fB\-Wreorder\fR (\*(C+ only)" 4
+.IX Item "-Wreorder ( only)"
+Warn when the order of member initializers given in the code does not
+match the order in which they must be executed. For instance:
+.Ip "\fB\-Wunknown-pragmas\fR" 4
+.IX Item "-Wunknown-pragmas"
+Warn when a #pragma directive is encountered which is not understood by
+\&\s-1GCC\s0. If this command line option is used, warnings will even be issued
+for unknown pragmas in system header files. This is not the case if
+the warnings were only enabled by the \fB\-Wall\fR command line option.
+.Ip "\fB\-Wall\fR" 4
+.IX Item "-Wall"
+All of the above \fB\-W\fR options combined. This enables all the
+warnings about constructions that some users consider questionable, and
+that are easy to avoid (or modify to prevent the warning), even in
+conjunction with macros.
+.Ip "\fB\-Wmost\fR" 4
+.IX Item "-Wmost"
+This is equivalent to \-Wall \-Wno-parentheses. (\s-1APPLE\s0 \s-1ONLY\s0)
+.Ip "\fB\-Wdiv-by-zero\fR" 4
+.IX Item "-Wdiv-by-zero"
+Warn about compile-time integer division by zero. This is default. To
+inhibit the warning messages, use \fB\-Wno-div-by-zero\fR. Floating
+point division by zero is not warned about, as it can be a legitimate
+way of obtaining infinities and NaNs.
+.Ip "\fB\-Wmultichar\fR" 4
+.IX Item "-Wmultichar"
+Warn if a multicharacter constant (\fB'\s-1FOOF\s0'\fR) is used. This is
+default. To inhibit the warning messages, use \fB\-Wno-multichar\fR.
+Usually they indicate a typo in the user's code, as they have
+implementation-defined values, and should not be used in portable code.
+.Ip "\fB\-Wsystem-headers\fR" 4
+.IX Item "-Wsystem-headers"
+Print warning messages for constructs found in system header files.
+Warnings from system headers are normally suppressed, on the assumption
+that they usually do not indicate real problems and would only make the
+compiler output harder to read. Using this command line option tells
+\&\s-1GCC\s0 to emit warnings from system headers as if they occurred in user
+code. However, note that using \fB\-Wall\fR in conjunction with this
+option will \fInot\fR warn about unknown pragmas in system
+headers\-\-\-for that, \fB\-Wunknown-pragmas\fR must also be used.
+.PP
+The following \fB\-W...\fR options are not implied by \fB\-Wall\fR.
+Some of them warn about constructions that users generally do not
+consider questionable, but which occasionally you might wish to check
+for; others warn about constructions that are necessary or hard to avoid
+in some cases, and there is no simple way to modify the code to suppress
+the warning.
+.Ip "\fB\-W\fR" 4
+.IX Item "-W"
+Print extra warning messages for these events:
+.RS 4
+.Ip "\(bu" 4
+A function can return either with or without a value. (Falling
+off the end of the function body is considered returning without
+a value.) For example, this function would evoke such a
+warning:
+.Sp
+.Vb 5
+\& foo (a)
+\& {
+\& if (a > 0)
+\& return a;
+\& }
+.Ve
+.Ip "\(bu" 4
+An expression-statement or the left-hand side of a comma expression
+contains no side effects.
+To suppress the warning, cast the unused expression to void.
+For example, an expression such as \fBx[i,j]\fR will cause a warning,
+but \fBx[(void)i,j]\fR will not.
+.Ip "\(bu" 4
+An unsigned value is compared against zero with \fB<\fR or \fB<=\fR.
+.Ip "\(bu" 4
+A comparison like \fBx<=y<=z\fR appears; this is equivalent to
+\&\fB(x<=y ? 1 : 0) <= z\fR, which is a different interpretation from
+that of ordinary mathematical notation.
+.Ip "\(bu" 4
+Storage-class specifiers like \f(CW\*(C`static\*(C'\fR are not the first things in
+a declaration. According to the C Standard, this usage is obsolescent.
+.Ip "\(bu" 4
+The return type of a function has a type qualifier such as \f(CW\*(C`const\*(C'\fR.
+Such a type qualifier has no effect, since the value returned by a
+function is not an lvalue. (But don't warn about the \s-1GNU\s0 extension of
+\&\f(CW\*(C`volatile void\*(C'\fR return types. That extension will be warned about
+if \fB\-pedantic\fR is specified.)
+.Ip "\(bu" 4
+If \fB\-Wall\fR or \fB\-Wunused\fR is also specified, warn about unused
+arguments.
+.Ip "\(bu" 4
+A comparison between signed and unsigned values could produce an
+incorrect result when the signed value is converted to unsigned.
+(But don't warn if \fB\-Wno-sign-compare\fR is also specified.)
+.Ip "\(bu" 4
+An aggregate has a partly bracketed initializer.
+For example, the following code would evoke such a warning,
+because braces are missing around the initializer for \f(CW\*(C`x.h\*(C'\fR:
+.Sp
+.Vb 3
+\& struct s { int f, g; };
+\& struct t { struct s h; int i; };
+\& struct t x = { 1, 2, 3 };
+.Ve
+.Ip "\(bu" 4
+An aggregate has an initializer which does not initialize all members.
+For example, the following code would cause such a warning, because
+\&\f(CW\*(C`x.h\*(C'\fR would be implicitly initialized to zero:
+.Sp
+.Vb 2
+\& struct s { int f, g, h; };
+\& struct s x = { 3, 4 };
+.Ve
+.RE
+.RS 4
+.RE
+.Ip "\fB\-Wfloat-equal\fR" 4
+.IX Item "-Wfloat-equal"
+Warn if floating point values are used in equality comparisons.
+.Sp
+The idea behind this is that sometimes it is convenient (for the
+programmer) to consider floating-point values as approximations to
+infinitely precise real numbers. If you are doing this, then you need
+to compute (by analysing the code, or in some other way) the maximum or
+likely maximum error that the computation introduces, and allow for it
+when performing comparisons (and when producing output, but that's a
+different problem). In particular, instead of testing for equality, you
+would check to see whether the two values have ranges that overlap; and
+this is done with the relational operators, so equality comparisons are
+probably mistaken.
+.Ip "\fB\-Wtraditional\fR (C only)" 4
+.IX Item "-Wtraditional (C only)"
+Warn about certain constructs that behave differently in traditional and
+\&\s-1ISO\s0 C. Also warn about \s-1ISO\s0 C constructs that have no traditional C
+equivalent, and/or problematic constructs which should be avoided.
+.RS 4
+.Ip "\(bu" 4
+Macro parameters that appear within string literals in the macro body.
+In traditional C macro replacement takes place within string literals,
+but does not in \s-1ISO\s0 C.
+.Ip "\(bu" 4
+In traditional C, some preprocessor directives did not exist.
+Traditional preprocessors would only consider a line to be a directive
+if the \fB#\fR appeared in column 1 on the line. Therefore
+\&\fB\-Wtraditional\fR warns about directives that traditional C
+understands but would ignore because the \fB#\fR does not appear as the
+first character on the line. It also suggests you hide directives like
+\&\fB#pragma\fR not understood by traditional C by indenting them. Some
+traditional implementations would not recognize \fB#elif\fR, so it
+suggests avoiding it altogether.
+.Ip "\(bu" 4
+A function-like macro that appears without arguments.
+.Ip "\(bu" 4
+The unary plus operator.
+.Ip "\(bu" 4
+The \fBU\fR integer constant suffix, or the \fBF\fR or \fBL\fR floating point
+constant suffixes. (Traditional C does support the \fBL\fR suffix on integer
+constants.) Note, these suffixes appear in macros defined in the system
+headers of most modern systems, e.g. the \fB_MIN\fR/\fB_MAX\fR macros in \f(CW\*(C`<limits.h>\*(C'\fR.
+Use of these macros in user code might normally lead to spurious
+warnings, however gcc's integrated preprocessor has enough context to
+avoid warning in these cases.
+.Ip "\(bu" 4
+A function declared external in one block and then used after the end of
+the block.
+.Ip "\(bu" 4
+A \f(CW\*(C`switch\*(C'\fR statement has an operand of type \f(CW\*(C`long\*(C'\fR.
+.Ip "\(bu" 4
+A non-\f(CW\*(C`static\*(C'\fR function declaration follows a \f(CW\*(C`static\*(C'\fR one.
+This construct is not accepted by some traditional C compilers.
+.Ip "\(bu" 4
+The \s-1ISO\s0 type of an integer constant has a different width or
+signedness from its traditional type. This warning is only issued if
+the base of the constant is ten. I.e. hexadecimal or octal values, which
+typically represent bit patterns, are not warned about.
+.Ip "\(bu" 4
+Usage of \s-1ISO\s0 string concatenation is detected.
+.Ip "\(bu" 4
+Initialization of automatic aggregates.
+.Ip "\(bu" 4
+Identifier conflicts with labels. Traditional C lacks a separate
+namespace for labels.
+.Ip "\(bu" 4
+Initialization of unions. If the initializer is zero, the warning is
+omitted. This is done under the assumption that the zero initializer in
+user code appears conditioned on e.g. \f(CW\*(C`_\|_STDC_\|_\*(C'\fR to avoid missing
+initializer warnings and relies on default initialization to zero in the
+traditional C case.
+.Ip "\(bu" 4
+Conversions by prototypes between fixed/floating point values and vice
+versa. The absence of these prototypes when compiling with traditional
+C would cause serious problems. This is a subset of the possible
+conversion warnings, for the full set use \fB\-Wconversion\fR.
+.RE
+.RS 4
+.RE
+.Ip "\fB\-Wundef\fR" 4
+.IX Item "-Wundef"
+Warn if an undefined identifier is evaluated in an \fB#if\fR directive.
+.Ip "\fB\-Wshadow\fR" 4
+.IX Item "-Wshadow"
+Warn whenever a local variable shadows another local variable, parameter or
+global variable or whenever a built-in function is shadowed.
+.Ip "\fB\-Wlarger-than-\fR\fIlen\fR" 4
+.IX Item "-Wlarger-than-len"
+Warn whenever an object of larger than \fIlen\fR bytes is defined.
+.Ip "\fB\-Wpointer-arith\fR" 4
+.IX Item "-Wpointer-arith"
+Warn about anything that depends on the ``size of'' a function type or
+of \f(CW\*(C`void\*(C'\fR. \s-1GNU\s0 C assigns these types a size of 1, for
+convenience in calculations with \f(CW\*(C`void *\*(C'\fR pointers and pointers
+to functions.
+.Ip "\fB\-Wbad-function-cast\fR (C only)" 4
+.IX Item "-Wbad-function-cast (C only)"
+Warn whenever a function call is cast to a non-matching type.
+For example, warn if \f(CW\*(C`int malloc()\*(C'\fR is cast to \f(CW\*(C`anything *\*(C'\fR.
+.Ip "\fB\-Wcast-qual\fR" 4
+.IX Item "-Wcast-qual"
+Warn whenever a pointer is cast so as to remove a type qualifier from
+the target type. For example, warn if a \f(CW\*(C`const char *\*(C'\fR is cast
+to an ordinary \f(CW\*(C`char *\*(C'\fR.
+.Ip "\fB\-Wcast-align\fR" 4
+.IX Item "-Wcast-align"
+Warn whenever a pointer is cast such that the required alignment of the
+target is increased. For example, warn if a \f(CW\*(C`char *\*(C'\fR is cast to
+an \f(CW\*(C`int *\*(C'\fR on machines where integers can only be accessed at
+two- or four-byte boundaries.
+.Ip "\fB\-Wwrite-strings\fR" 4
+.IX Item "-Wwrite-strings"
+When compiling C, give string constants the type \f(CW\*(C`const
+char[\f(CIlength\f(CW]\*(C'\fR so that
+copying the address of one into a non-\f(CW\*(C`const\*(C'\fR \f(CW\*(C`char *\*(C'\fR
+pointer will get a warning; when compiling \*(C+, warn about the
+deprecated conversion from string constants to \f(CW\*(C`char *\*(C'\fR.
+These warnings will help you find at
+compile time code that can try to write into a string constant, but
+only if you have been very careful about using \f(CW\*(C`const\*(C'\fR in
+declarations and prototypes. Otherwise, it will just be a nuisance;
+this is why we did not make \fB\-Wall\fR request these warnings.
+.Ip "\fB\-Wconversion\fR" 4
+.IX Item "-Wconversion"
+Warn if a prototype causes a type conversion that is different from what
+would happen to the same argument in the absence of a prototype. This
+includes conversions of fixed point to floating and vice versa, and
+conversions changing the width or signedness of a fixed point argument
+except when the same as the default promotion.
+.Sp
+Also, warn if a negative integer constant expression is implicitly
+converted to an unsigned type. For example, warn about the assignment
+\&\f(CW\*(C`x = \-1\*(C'\fR if \f(CW\*(C`x\*(C'\fR is unsigned. But do not warn about explicit
+casts like \f(CW\*(C`(unsigned) \-1\*(C'\fR.
+.Ip "\fB\-Wsign-compare\fR" 4
+.IX Item "-Wsign-compare"
+Warn when a comparison between signed and unsigned values could produce
+an incorrect result when the signed value is converted to unsigned.
+This warning is also enabled by \fB\-W\fR; to get the other warnings
+of \fB\-W\fR without this warning, use \fB\-W \-Wno-sign-compare\fR.
+.Ip "\fB\-Waggregate-return\fR" 4
+.IX Item "-Waggregate-return"
+Warn if any functions that return structures or unions are defined or
+called. (In languages where you can return an array, this also elicits
+a warning.)
+.Ip "\fB\-Wstrict-prototypes\fR (C only)" 4
+.IX Item "-Wstrict-prototypes (C only)"
+Warn if a function is declared or defined without specifying the
+argument types. (An old-style function definition is permitted without
+a warning if preceded by a declaration which specifies the argument
+types.)
+.Ip "\fB\-Wmissing-prototypes\fR (C only)" 4
+.IX Item "-Wmissing-prototypes (C only)"
+Warn if a global function is defined without a previous prototype
+declaration. This warning is issued even if the definition itself
+provides a prototype. The aim is to detect global functions that fail
+to be declared in header files.
+.Ip "\fB\-Wmissing-declarations\fR" 4
+.IX Item "-Wmissing-declarations"
+Warn if a global function is defined without a previous declaration.
+Do so even if the definition itself provides a prototype.
+Use this option to detect global functions that are not declared in
+header files.
+.Ip "\fB\-Wmissing-noreturn\fR" 4
+.IX Item "-Wmissing-noreturn"
+Warn about functions which might be candidates for attribute \f(CW\*(C`noreturn\*(C'\fR.
+Note these are only possible candidates, not absolute ones. Care should
+be taken to manually verify functions actually do not ever return before
+adding the \f(CW\*(C`noreturn\*(C'\fR attribute, otherwise subtle code generation
+bugs could be introduced. You will not get a warning for \f(CW\*(C`main\*(C'\fR in
+hosted C environments.
+.Ip "\fB\-Wmissing-format-attribute\fR" 4
+.IX Item "-Wmissing-format-attribute"
+If \fB\-Wformat\fR is enabled, also warn about functions which might be
+candidates for \f(CW\*(C`format\*(C'\fR attributes. Note these are only possible
+candidates, not absolute ones. \s-1GCC\s0 will guess that \f(CW\*(C`format\*(C'\fR
+attributes might be appropriate for any function that calls a function
+like \f(CW\*(C`vprintf\*(C'\fR or \f(CW\*(C`vscanf\*(C'\fR, but this might not always be the
+case, and some functions for which \f(CW\*(C`format\*(C'\fR attributes are
+appropriate may not be detected. This option has no effect unless
+\&\fB\-Wformat\fR is enabled (possibly by \fB\-Wall\fR).
+.Ip "\fB\-Wno-deprecated-declarations\fR" 4
+.IX Item "-Wno-deprecated-declarations"
+Do not warn about uses of functions, variables, and types marked as
+deprecated by using the \f(CW\*(C`deprecated\*(C'\fR attribute.
+(@pxref{Function Attributes}, \f(CW@pxref\fR{Variable Attributes},
+\&\f(CW@pxref\fR{Type Attributes}.)
+.Ip "\fB\-Wpacked\fR" 4
+.IX Item "-Wpacked"
+Warn if a structure is given the packed attribute, but the packed
+attribute has no effect on the layout or size of the structure.
+Such structures may be mis-aligned for little benefit. For
+instance, in this code, the variable \f(CW\*(C`f.x\*(C'\fR in \f(CW\*(C`struct bar\*(C'\fR
+will be misaligned even though \f(CW\*(C`struct bar\*(C'\fR does not itself
+have the packed attribute:
+.Sp
+.Vb 8
+\& struct foo {
+\& int x;
+\& char a, b, c, d;
+\& } __attribute__((packed));
+\& struct bar {
+\& char z;
+\& struct foo f;
+\& };
+.Ve
+.Ip "\fB\-Wpadded\fR" 4
+.IX Item "-Wpadded"
+Warn if padding is included in a structure, either to align an element
+of the structure or to align the whole structure. Sometimes when this
+happens it is possible to rearrange the fields of the structure to
+reduce the padding and so make the structure smaller.
+.Ip "\fB\-Wredundant-decls\fR" 4
+.IX Item "-Wredundant-decls"
+Warn if anything is declared more than once in the same scope, even in
+cases where multiple declaration is valid and changes nothing.
+.Ip "\fB\-Wnested-externs\fR (C only)" 4
+.IX Item "-Wnested-externs (C only)"
+Warn if an \f(CW\*(C`extern\*(C'\fR declaration is encountered within a function.
+.Ip "\fB\-Wunreachable-code\fR" 4
+.IX Item "-Wunreachable-code"
+Warn if the compiler detects that code will never be executed.
+.Sp
+This option is intended to warn when the compiler detects that at
+least a whole line of source code will never be executed, because
+some condition is never satisfied or because it is after a
+procedure that never returns.
+.Sp
+It is possible for this option to produce a warning even though there
+are circumstances under which part of the affected line can be executed,
+so care should be taken when removing apparently-unreachable code.
+.Sp
+For instance, when a function is inlined, a warning may mean that the
+line is unreachable in only one inlined copy of the function.
+.Sp
+This option is not made part of \fB\-Wall\fR because in a debugging
+version of a program there is often substantial code which checks
+correct functioning of the program and is, hopefully, unreachable
+because the program does work. Another common use of unreachable
+code is to provide behavior which is selectable at compile-time.
+.Ip "\fB\-Winline\fR" 4
+.IX Item "-Winline"
+Warn if a function can not be inlined and it was declared as inline.
+.Ip "\fB\-Wno-long-double\fR" 4
+.IX Item "-Wno-long-double"
+Inhibit warning if the \fBlong double\fR type is used. (\s-1APPLE\s0 \s-1ONLY\s0)
+.Ip "\fB\-Wlong-long\fR" 4
+.IX Item "-Wlong-long"
+Warn if \fBlong long\fR type is used. This is default. To inhibit
+the warning messages, use \fB\-Wno-long-long\fR. Flags
+\&\fB\-Wlong-long\fR and \fB\-Wno-long-long\fR are taken into account
+only when \fB\-pedantic\fR flag is used.
+.Ip "\fB\-Wdisabled-optimization\fR" 4
+.IX Item "-Wdisabled-optimization"
+Warn if a requested optimization pass is disabled. This warning does
+not generally indicate that there is anything wrong with your code; it
+merely indicates that \s-1GCC\s0's optimizers were unable to handle the code
+effectively. Often, the problem is that your code is too big or too
+complex; \s-1GCC\s0 will refuse to optimize programs when the optimization
+itself is likely to take inordinate amounts of time.
+.Ip "\fB\-Werror\fR" 4
+.IX Item "-Werror"
+Make all warnings into errors.
+.Sh "Options for Debugging Your Program or \s-1GCC\s0"
+.IX Subsection "Options for Debugging Your Program or GCC"
+\&\s-1GCC\s0 has various special options that are used for debugging
+either your program or \s-1GCC:\s0
+.Ip "\fB\-g\fR" 4
+.IX Item "-g"
+Produce debugging information in the operating system's native format
+(stabs, \s-1COFF\s0, \s-1XCOFF\s0, or \s-1DWARF\s0). \s-1GDB\s0 can work with this debugging
+information.
+.Sp
+On most systems that use stabs format, \fB\-g\fR enables use of extra
+debugging information that only \s-1GDB\s0 can use; this extra information
+makes debugging work better in \s-1GDB\s0 but will probably make other debuggers
+crash or
+refuse to read the program. If you want to control for certain whether
+to generate the extra information, use \fB\-gstabs+\fR or \fB\-gstabs\fR
+(see below).
+.Sp
+Unlike most other C compilers, \s-1GCC\s0 allows you to use \fB\-g\fR with
+\&\fB\-O\fR. The shortcuts taken by optimized code may occasionally
+produce surprising results: some variables you declared may not exist
+at all; flow of control may briefly move where you did not expect it;
+some statements may not be executed because they compute constant
+results or their values were already at hand; some statements may
+execute in different places because they were moved out of loops.
+.Sp
+Nevertheless it proves possible to debug optimized output. This makes
+it reasonable to use the optimizer for programs that might have bugs.
+.Sp
+The following options are useful when \s-1GCC\s0 is generated with the
+capability for more than one debugging format.
+.Ip "\fB\-ggdb\fR" 4
+.IX Item "-ggdb"
+Produce debugging information for use by \s-1GDB\s0. This means to use the
+most expressive format available (\s-1DWARF\s0 2, stabs, or the native format
+if neither of those are supported), including \s-1GDB\s0 extensions if at all
+possible.
+.Ip "\fB\-gstabs\fR" 4
+.IX Item "-gstabs"
+Produce debugging information in stabs format (if that is supported),
+without \s-1GDB\s0 extensions. This is the format used by \s-1DBX\s0 on most \s-1BSD\s0
+systems. On \s-1MIPS\s0, Alpha and System V Release 4 systems this option
+produces stabs debugging output which is not understood by \s-1DBX\s0 or \s-1SDB\s0.
+On System V Release 4 systems this option requires the \s-1GNU\s0 assembler.
+.Ip "\fB\-gstabs+\fR" 4
+.IX Item "-gstabs+"
+Produce debugging information in stabs format (if that is supported),
+using \s-1GNU\s0 extensions understood only by the \s-1GNU\s0 debugger (\s-1GDB\s0). The
+use of these extensions is likely to make other debuggers crash or
+refuse to read the program.
+.Sp
+(Other debug formats, such as \fB\-gcoff\fR, are not supported in
+Darwin or Mac \s-1OS\s0 X.)
+.Ip "\fB\-g\fR\fIlevel\fR" 4
+.IX Item "-glevel"
+.PD 0
+.Ip "\fB\-ggdb\fR\fIlevel\fR" 4
+.IX Item "-ggdblevel"
+.Ip "\fB\-gstabs\fR\fIlevel\fR" 4
+.IX Item "-gstabslevel"
+.PD
+Request debugging information and also use \fIlevel\fR to specify how
+much information. The default level is 2.
+.Sp
+Level 1 produces minimal information, enough for making backtraces in
+parts of the program that you don't plan to debug. This includes
+descriptions of functions and external variables, but no information
+about local variables and no line numbers.
+.Sp
+Level 3 includes extra information, such as all the macro definitions
+present in the program. Some debuggers support macro expansion when
+you use \fB\-g3\fR.
+.Ip "\fB\-p\fR" 4
+.IX Item "-p"
+Generate extra code to write profile information suitable for the
+analysis program \f(CW\*(C`prof\*(C'\fR. You must use this option when compiling
+the source files you want data about, and you must also use it when
+linking.
+.Ip "\fB\-pg\fR" 4
+.IX Item "-pg"
+Generate extra code to write profile information suitable for the
+analysis program \f(CW\*(C`gprof\*(C'\fR. You must use this option when compiling
+the source files you want data about, and you must also use it when
+linking.
+.Ip "\fB\-a\fR" 4
+.IX Item "-a"
+Generate extra code to write profile information for basic blocks, which will
+record the number of times each basic block is executed, the basic block start
+address, and the function name containing the basic block. If \fB\-g\fR is
+used, the line number and filename of the start of the basic block will also be
+recorded. If not overridden by the machine description, the default action is
+to append to the text file \fIbb.out\fR.
+.Sp
+This data could be analyzed by a program like \f(CW\*(C`tcov\*(C'\fR. Note,
+however, that the format of the data is not what \f(CW\*(C`tcov\*(C'\fR expects.
+Eventually \s-1GNU\s0 \f(CW\*(C`gprof\*(C'\fR should be extended to process this data.
+.Ip "\fB\-Q\fR" 4
+.IX Item "-Q"
+Makes the compiler print out each function name as it is compiled, and
+print some statistics about each pass when it finishes.
+.Ip "\fB\-ftime-report\fR" 4
+.IX Item "-ftime-report"
+Makes the compiler print some statistics about the time consumed by each
+pass when it finishes.
+.Ip "\fB\-fmem-report\fR" 4
+.IX Item "-fmem-report"
+Makes the compiler print some statistics about permanent memory
+allocation when it finishes.
+.Ip "\fB\-fprofile-arcs\fR" 4
+.IX Item "-fprofile-arcs"
+Instrument \fIarcs\fR during compilation to generate coverage data
+or for profile-directed block ordering. During execution the program
+records how many times each branch is executed and how many times it is
+taken. When the compiled program exits it saves this data to a file
+called \fI\fIsourcename\fI.da\fR for each source file.
+.Sp
+For profile-directed block ordering, compile the program with
+\&\fB\-fprofile-arcs\fR plus optimization and code generation options,
+generate the arc profile information by running the program on a
+selected workload, and then compile the program again with the same
+optimization and code generation options plus
+\&\fB\-fbranch-probabilities\fR.
+.Sp
+The other use of \fB\-fprofile-arcs\fR is for use with \f(CW\*(C`gcov\*(C'\fR,
+when it is used with the \fB\-ftest-coverage\fR option. \s-1GCC\s0
+supports two methods of determining code coverage: the options that
+support \f(CW\*(C`gcov\*(C'\fR, and options \fB\-a\fR and \fB\-ax\fR, which
+write information to text files. The options that support \f(CW\*(C`gcov\*(C'\fR
+do not need to instrument every arc in the program, so a program compiled
+with them runs faster than a program compiled with \fB\-a\fR, which
+adds instrumentation code to every basic block in the program. The
+tradeoff: since \f(CW\*(C`gcov\*(C'\fR does not have execution counts for all
+branches, it must start with the execution counts for the instrumented
+branches, and then iterate over the program flow graph until the entire
+graph has been solved. Hence, \f(CW\*(C`gcov\*(C'\fR runs a little more slowly than
+a program which uses information from \fB\-a\fR and \fB\-ax\fR.
+.Sp
+With \fB\-fprofile-arcs\fR, for each function of your program \s-1GCC\s0
+creates a program flow graph, then finds a spanning tree for the graph.
+Only arcs that are not on the spanning tree have to be instrumented: the
+compiler adds code to count the number of times that these arcs are
+executed. When an arc is the only exit or only entrance to a block, the
+instrumentation code can be added to the block; otherwise, a new basic
+block must be created to hold the instrumentation code.
+.Sp
+This option makes it possible to estimate branch probabilities and to
+calculate basic block execution counts. In general, basic block
+execution counts as provided by \fB\-a\fR do not give enough
+information to estimate all branch probabilities.
+.Ip "\fB\-ftest-coverage\fR" 4
+.IX Item "-ftest-coverage"
+Create data files for the \f(CW\*(C`gcov\*(C'\fR code-coverage utility.
+The data file names begin with the name of your source file:
+.RS 4
+.Ip "\fIsourcename\fR\fB.bb\fR" 4
+.IX Item "sourcename.bb"
+A mapping from basic blocks to line numbers, which \f(CW\*(C`gcov\*(C'\fR uses to
+associate basic block execution counts with line numbers.
+.Ip "\fIsourcename\fR\fB.bbg\fR" 4
+.IX Item "sourcename.bbg"
+A list of all arcs in the program flow graph. This allows \f(CW\*(C`gcov\*(C'\fR
+to reconstruct the program flow graph, so that it can compute all basic
+block and arc execution counts from the information in the
+\&\f(CW\*(C`\f(CIsourcename\f(CW.da\*(C'\fR file.
+.RE
+.RS 4
+.Sp
+Use \fB\-ftest-coverage\fR with \fB\-fprofile-arcs\fR; the latter
+option adds instrumentation to the program, which then writes
+execution counts to another data file:
+.RS 4
+.RE
+.Ip "\fIsourcename\fR\fB.da\fR" 4
+.IX Item "sourcename.da"
+Runtime arc execution counts, used in conjunction with the arc
+information in the file \f(CW\*(C`\f(CIsourcename\f(CW.bbg\*(C'\fR.
+.RE
+.RS 4
+.Sp
+Coverage data will map better to the source files if
+\&\fB\-ftest-coverage\fR is used without optimization.
+.RE
+.Ip "\fB\-d\fR\fIletters\fR" 4
+.IX Item "-dletters"
+Says to make debugging dumps during compilation at times specified by
+\&\fIletters\fR. This is used for debugging the compiler. The file names
+for most of the dumps are made by appending a pass number and a word to
+the source file name (e.g. \fIfoo.c.00.rtl\fR or \fIfoo.c.01.sibling\fR).
+Here are the possible letters for use in \fIletters\fR, and their meanings:
+.RS 4
+.Ip "\fBA\fR" 4
+.IX Item "A"
+Annotate the assembler output with miscellaneous debugging information.
+.Ip "\fBb\fR" 4
+.IX Item "b"
+Dump after computing branch probabilities, to \fI\fIfile\fI.14.bp\fR.
+.Ip "\fBB\fR" 4
+.IX Item "B"
+Dump after block reordering, to \fI\fIfile\fI.29.bbro\fR.
+.Ip "\fBc\fR" 4
+.IX Item "c"
+Dump after instruction combination, to the file \fI\fIfile\fI.16.combine\fR.
+.Ip "\fBC\fR" 4
+.IX Item "C"
+Dump after the first if conversion, to the file \fI\fIfile\fI.17.ce\fR.
+.Ip "\fBd\fR" 4
+.IX Item "d"
+Dump after delayed branch scheduling, to \fI\fIfile\fI.31.dbr\fR.
+.Ip "\fBD\fR" 4
+.IX Item "D"
+Dump all macro definitions, at the end of preprocessing, in addition to
+normal output.
+.Ip "\fBe\fR" 4
+.IX Item "e"
+Dump after \s-1SSA\s0 optimizations, to \fI\fIfile\fI.04.ssa\fR and
+\&\fI\fIfile\fI.07.ussa\fR.
+.Ip "\fBE\fR" 4
+.IX Item "E"
+Dump after the second if conversion, to \fI\fIfile\fI.26.ce2\fR.
+.Ip "\fBf\fR" 4
+.IX Item "f"
+Dump after life analysis, to \fI\fIfile\fI.15.life\fR.
+.Ip "\fBF\fR" 4
+.IX Item "F"
+Dump after purging \f(CW\*(C`ADDRESSOF\*(C'\fR codes, to \fI\fIfile\fI.09.addressof\fR.
+.Ip "\fBg\fR" 4
+.IX Item "g"
+Dump after global register allocation, to \fI\fIfile\fI.21.greg\fR.
+.Ip "\fBh\fR" 4
+.IX Item "h"
+Dump after finalization of \s-1EH\s0 handling code, to \fI\fIfile\fI.02.eh\fR.
+.Ip "\fBk\fR" 4
+.IX Item "k"
+Dump after reg-to-stack conversion, to \fI\fIfile\fI.28.stack\fR.
+.Ip "\fBo\fR" 4
+.IX Item "o"
+Dump after post-reload optimizations, to \fI\fIfile\fI.22.postreload\fR.
+.Ip "\fBG\fR" 4
+.IX Item "G"
+Dump after \s-1GCSE\s0, to \fI\fIfile\fI.10.gcse\fR.
+.Ip "\fBi\fR" 4
+.IX Item "i"
+Dump after sibling call optimizations, to \fI\fIfile\fI.01.sibling\fR.
+.Ip "\fBj\fR" 4
+.IX Item "j"
+Dump after the first jump optimization, to \fI\fIfile\fI.03.jump\fR.
+.Ip "\fBk\fR" 4
+.IX Item "k"
+Dump after conversion from registers to stack, to \fI\fIfile\fI.32.stack\fR.
+.Ip "\fBl\fR" 4
+.IX Item "l"
+Dump after local register allocation, to \fI\fIfile\fI.20.lreg\fR.
+.Ip "\fBL\fR" 4
+.IX Item "L"
+Dump after loop optimization, to \fI\fIfile\fI.11.loop\fR.
+.Ip "\fBM\fR" 4
+.IX Item "M"
+Dump after performing the machine dependent reorganisation pass, to
+\&\fI\fIfile\fI.30.mach\fR.
+.Ip "\fBn\fR" 4
+.IX Item "n"
+Dump after register renumbering, to \fI\fIfile\fI.25.rnreg\fR.
+.Ip "\fBN\fR" 4
+.IX Item "N"
+Dump after the register move pass, to \fI\fIfile\fI.18.regmove\fR.
+.Ip "\fBr\fR" 4
+.IX Item "r"
+Dump after \s-1RTL\s0 generation, to \fI\fIfile\fI.00.rtl\fR.
+.Ip "\fBR\fR" 4
+.IX Item "R"
+Dump after the second scheduling pass, to \fI\fIfile\fI.27.sched2\fR.
+.Ip "\fBs\fR" 4
+.IX Item "s"
+Dump after \s-1CSE\s0 (including the jump optimization that sometimes follows
+\&\s-1CSE\s0), to \fI\fIfile\fI.08.cse\fR.
+.Ip "\fBS\fR" 4
+.IX Item "S"
+Dump after the first scheduling pass, to \fI\fIfile\fI.19.sched\fR.
+.Ip "\fBt\fR" 4
+.IX Item "t"
+Dump after the second \s-1CSE\s0 pass (including the jump optimization that
+sometimes follows \s-1CSE\s0), to \fI\fIfile\fI.12.cse2\fR.
+.Ip "\fBw\fR" 4
+.IX Item "w"
+Dump after the second flow pass, to \fI\fIfile\fI.23.flow2\fR.
+.Ip "\fBX\fR" 4
+.IX Item "X"
+Dump after \s-1SSA\s0 dead code elimination, to \fI\fIfile\fI.06.ssadce\fR.
+.Ip "\fBz\fR" 4
+.IX Item "z"
+Dump after the peephole pass, to \fI\fIfile\fI.24.peephole2\fR.
+.Ip "\fBa\fR" 4
+.IX Item "a"
+Produce all the dumps listed above.
+.Ip "\fBm\fR" 4
+.IX Item "m"
+Print statistics on memory usage, at the end of the run, to
+standard error.
+.Ip "\fBp\fR" 4
+.IX Item "p"
+Annotate the assembler output with a comment indicating which
+pattern and alternative was used. The length of each instruction is
+also printed.
+.Ip "\fBP\fR" 4
+.IX Item "P"
+Dump the \s-1RTL\s0 in the assembler output as a comment before each instruction.
+Also turns on \fB\-dp\fR annotation.
+.Ip "\fBv\fR" 4
+.IX Item "v"
+For each of the other indicated dump files (except for
+\&\fI\fIfile\fI.00.rtl\fR), dump a representation of the control flow graph
+suitable for viewing with \s-1VCG\s0 to \fI\fIfile\fI.\fIpass\fI.vcg\fR.
+.Ip "\fBx\fR" 4
+.IX Item "x"
+Just generate \s-1RTL\s0 for a function instead of compiling it. Usually used
+with \fBr\fR.
+.Ip "\fBy\fR" 4
+.IX Item "y"
+Dump debugging information during parsing, to standard error.
+.RE
+.RS 4
+.RE
+.Ip "\fB\-fdump-unnumbered\fR" 4
+.IX Item "-fdump-unnumbered"
+When doing debugging dumps (see \fB\-d\fR option above), suppress instruction
+numbers and line number note output. This makes it more feasible to
+use diff on debugging dumps for compiler invocations with different
+options, in particular with and without \fB\-g\fR.
+.Ip "\fB\-fdump-translation-unit\fR (C and \*(C+ only)" 4
+.IX Item "-fdump-translation-unit (C and only)"
+.PD 0
+.Ip "\fB\-fdump-translation-unit-\fR\fIoptions\fR\fB \fR(C and \*(C+ only)" 4
+.IX Item "-fdump-translation-unit-options (C and only)"
+.PD
+Dump a representation of the tree structure for the entire translation
+unit to a file. The file name is made by appending \fI.tu\fR to the
+source file name. If the \fB-\fR\fIoptions\fR form is used, \fIoptions\fR
+controls the details of the dump as described for the
+\&\fB\-fdump-tree\fR options.
+.Ip "\fB\-fdump-class-hierarchy\fR (\*(C+ only)" 4
+.IX Item "-fdump-class-hierarchy ( only)"
+.PD 0
+.Ip "\fB\-fdump-class-hierarchy-\fR\fIoptions\fR\fB \fR(\*(C+ only)" 4
+.IX Item "-fdump-class-hierarchy-options ( only)"
+.PD
+Dump a representation of each class's hierarchy and virtual function
+table layout to a file. The file name is made by appending \fI.class\fR
+to the source file name. If the \fB-\fR\fIoptions\fR form is used,
+\&\fIoptions\fR controls the details of the dump as described for the
+\&\fB\-fdump-tree\fR options.
+.Ip "\fB\-fdump-tree-\fR\fIswitch\fR\fB \fR(\*(C+ only)" 4
+.IX Item "-fdump-tree-switch ( only)"
+.PD 0
+.Ip "\fB\-fdump-tree-\fR\fIswitch\fR\fB-\fR\fIoptions\fR\fB \fR(\*(C+ only)" 4
+.IX Item "-fdump-tree-switch-options ( only)"
+.PD
+Control the dumping at various stages of processing the intermediate
+language tree to a file. The file name is generated by appending a switch
+specific suffix to the source file name. If the \fB-\fR\fIoptions\fR
+form is used, \fIoptions\fR is a list of \fB-\fR separated options that
+control the details of the dump. Not all options are applicable to all
+dumps, those which are not meaningful will be ignored. The following
+options are available
+.RS 4
+.Ip "\fBaddress\fR" 4
+.IX Item "address"
+Print the address of each node. Usually this is not meaningful as it
+changes according to the environment and source file. Its primary use
+is for tying up a dump file with a debug environment.
+.Ip "\fBslim\fR" 4
+.IX Item "slim"
+Inhibit dumping of members of a scope or body of a function merely
+because that scope has been reached. Only dump such items when they
+are directly reachable by some other path.
+.Ip "\fBall\fR" 4
+.IX Item "all"
+Turn on all options.
+.RE
+.RS 4
+.Sp
+The following tree dumps are possible:
+.RS 4
+.RE
+.Ip "\fBoriginal\fR" 4
+.IX Item "original"
+Dump before any tree based optimization, to \fI\fIfile\fI.original\fR.
+.Ip "\fBoptimized\fR" 4
+.IX Item "optimized"
+Dump after all tree based optimization, to \fI\fIfile\fI.optimized\fR.
+.Ip "\fBinlined\fR" 4
+.IX Item "inlined"
+Dump after function inlining, to \fI\fIfile\fI.inlined\fR.
+.RE
+.RS 4
+.RE
+.Ip "\fB\-fpretend-float\fR" 4
+.IX Item "-fpretend-float"
+When running a cross-compiler, pretend that the target machine uses the
+same floating point format as the host machine. This causes incorrect
+output of the actual floating constants, but the actual instruction
+sequence will probably be the same as \s-1GCC\s0 would make when running on
+the target machine.
+.Ip "\fB\-save-temps\fR" 4
+.IX Item "-save-temps"
+Store the usual ``temporary'' intermediate files permanently; place them
+in the current directory and name them based on the source file. Thus,
+compiling \fIfoo.c\fR with \fB\-c \-save-temps\fR would produce files
+\&\fIfoo.i\fR and \fIfoo.s\fR, as well as \fIfoo.o\fR. This creates a
+preprocessed \fIfoo.i\fR output file even though the compiler now
+normally uses an integrated preprocessor.
+.Ip "\fB\-time\fR" 4
+.IX Item "-time"
+Report the \s-1CPU\s0 time taken by each subprocess in the compilation
+sequence. For C source files, this is the compiler proper and assembler
+(plus the linker if linking is done). The output looks like this:
+.Sp
+.Vb 2
+\& # cc1 0.12 0.01
+\& # as 0.00 0.01
+.Ve
+The first number on each line is the ``user time,'' that is time spent
+executing the program itself. The second number is ``system time,''
+time spent executing operating system routines on behalf of the program.
+Both numbers are in seconds.
+.Ip "\fB\-print-file-name=\fR\fIlibrary\fR" 4
+.IX Item "-print-file-name=library"
+Print the full absolute name of the library file \fIlibrary\fR that
+would be used when linking\-\-\-and don't do anything else. With this
+option, \s-1GCC\s0 does not compile or link anything; it just prints the
+file name.
+.Ip "\fB\-print-multi-directory\fR" 4
+.IX Item "-print-multi-directory"
+Print the directory name corresponding to the multilib selected by any
+other switches present in the command line. This directory is supposed
+to exist in \fB\s-1GCC_EXEC_PREFIX\s0\fR.
+.Ip "\fB\-print-multi-lib\fR" 4
+.IX Item "-print-multi-lib"
+Print the mapping from multilib directory names to compiler switches
+that enable them. The directory name is separated from the switches by
+\&\fB;\fR, and each switch starts with an \fB@} instead of the
+\&\f(CB@samp\fB{-\fR, without spaces between multiple switches. This is supposed to
+ease shell-processing.
+.Ip "\fB\-print-prog-name=\fR\fIprogram\fR" 4
+.IX Item "-print-prog-name=program"
+Like \fB\-print-file-name\fR, but searches for a program such as \fBcpp\fR.
+.Ip "\fB\-print-libgcc-file-name\fR" 4
+.IX Item "-print-libgcc-file-name"
+Same as \fB\-print-file-name=libgcc.a\fR.
+.Sp
+This is useful when you use \fB\-nostdlib\fR or \fB\-nodefaultlibs\fR
+but you do want to link with \fIlibgcc.a\fR. You can do
+.Sp
+.Vb 1
+\& gcc -nostdlib <files>... `gcc -print-libgcc-file-name`
+.Ve
+.Ip "\fB\-print-search-dirs\fR" 4
+.IX Item "-print-search-dirs"
+Print the name of the configured installation directory and a list of
+program and library directories gcc will search\-\-\-and don't do anything else.
+.Sp
+This is useful when gcc prints the error message
+\&\fBinstallation problem, cannot exec cpp0: No such file or directory\fR.
+To resolve this you either need to put \fIcpp0\fR and the other compiler
+components where gcc expects to find them, or you can set the environment
+variable \fB\s-1GCC_EXEC_PREFIX\s0\fR to the directory where you installed them.
+Don't forget the trailing '/'.
+.Ip "\fB\-dumpmachine\fR" 4
+.IX Item "-dumpmachine"
+Print the compiler's target machine (for example,
+\&\fBi686\-pc-linux-gnu\fR)\-\-\-and don't do anything else.
+.Ip "\fB\-dumpversion\fR" 4
+.IX Item "-dumpversion"
+Print the compiler version (for example, \fB3.0\fR)\-\-\-and don't do
+anything else.
+.Ip "\fB\-dumpspecs\fR" 4
+.IX Item "-dumpspecs"
+Print the compiler's built-in specs\-\-\-and don't do anything else. (This
+is used when \s-1GCC\s0 itself is being built.)
+.Sh "Options That Control Optimization"
+.IX Subsection "Options That Control Optimization"
+These options control various sorts of optimizations:
+.Ip "\fB\-O\fR" 4
+.IX Item "-O"
+.PD 0
+.Ip "\fB\-O1\fR" 4
+.IX Item "-O1"
+.PD
+Optimize. Optimizing compilation takes somewhat more time, and a lot
+more memory for a large function.
+.Sp
+Without \fB\-O\fR, the compiler's goal is to reduce the cost of
+compilation and to make debugging produce the expected results.
+Statements are independent: if you stop the program with a breakpoint
+between statements, you can then assign a new value to any variable or
+change the program counter to any other statement in the function and
+get exactly the results you would expect from the source code.
+.Sp
+With \fB\-O\fR, the compiler tries to reduce code size and execution
+time, without performing any optimizations that take a great deal of
+compilation time.
+.Sp
+When you specify \fB\-O\fR, the compiler turns on \fB\-fthread-jumps\fR
+and \fB\-fdefer-pop\fR on all machines. The compiler turns on
+\&\fB\-fdelayed-branch\fR on machines that have delay slots, and
+\&\fB\-fomit-frame-pointer\fR on machines that can support debugging even
+without a frame pointer. On some machines the compiler also turns
+on other flags.
+.Sp
+In Apple's version of \s-1GCC\s0, \fB\-fstrict-aliasing\fR,
+\&\fB\-freorder-blocks\fR, and \fB\-fsched-interblock\fR
+are disabled by default when optimizing.
+.Ip "\fB\-O2\fR" 4
+.IX Item "-O2"
+Optimize even more. \s-1GCC\s0 performs nearly all supported optimizations
+that do not involve a space-speed tradeoff. The compiler does not
+perform loop unrolling or function inlining when you specify \fB\-O2\fR.
+As compared to \fB\-O\fR, this option increases both compilation time
+and the performance of the generated code.
+.Sp
+\&\fB\-O2\fR turns on all optional optimizations except for loop unrolling,
+function inlining, and register renaming. It also turns on the
+\&\fB\-fforce-mem\fR option on all machines and frame pointer elimination
+on machines where doing so does not interfere with debugging.
+.Sp
+Please note the warning under \fB\-fgcse\fR about
+invoking \fB\-O2\fR on programs that use computed gotos.
+.Ip "\fB\-O3\fR" 4
+.IX Item "-O3"
+Optimize yet more. \fB\-O3\fR turns on all optimizations specified by
+\&\fB\-O2\fR and also turns on the \fB\-finline-functions\fR and
+\&\fB\-frename-registers\fR options.
+.Ip "\fB\-O0\fR" 4
+.IX Item "-O0"
+Do not optimize.
+.Ip "\fB\-Os\fR" 4
+.IX Item "-Os"
+Optimize for size. \fB\-Os\fR enables all \fB\-O2\fR optimizations that
+do not typically increase code size. It also performs further
+optimizations designed to reduce code size.
+.Sp
+If you use multiple \fB\-O\fR options, with or without level numbers,
+the last such option is the one that is effective.
+.PP
+Options of the form \fB\-f\fR\fIflag\fR specify machine-independent
+flags. Most flags have both positive and negative forms; the negative
+form of \fB\-ffoo\fR would be \fB\-fno-foo\fR. In the table below,
+only one of the forms is listed\-\-\-the one which is not the default.
+You can figure out the other form by either removing \fBno-\fR or
+adding it.
+.Ip "\fB\-ffloat-store\fR" 4
+.IX Item "-ffloat-store"
+Do not store floating point variables in registers, and inhibit other
+options that might change whether a floating point value is taken from a
+register or memory.
+.Sp
+This option prevents undesirable excess precision on machines such as
+the 68000 where the floating registers (of the 68881) keep more
+precision than a \f(CW\*(C`double\*(C'\fR is supposed to have. Similarly for the
+x86 architecture. For most programs, the excess precision does only
+good, but a few programs rely on the precise definition of \s-1IEEE\s0 floating
+point. Use \fB\-ffloat-store\fR for such programs, after modifying
+them to store all pertinent intermediate computations into variables.
+.Ip "\fB\-fno-default-inline\fR" 4
+.IX Item "-fno-default-inline"
+Do not make member functions inline by default merely because they are
+defined inside the class scope (\*(C+ only). Otherwise, when you specify
+\&\fB\-O\fR, member functions defined inside class scope are compiled
+inline by default; i.e., you don't need to add \fBinline\fR in front of
+the member function name.
+.Ip "\fB\-fno-defer-pop\fR" 4
+.IX Item "-fno-defer-pop"
+Always pop the arguments to each function call as soon as that function
+returns. For machines which must pop arguments after a function call,
+the compiler normally lets arguments accumulate on the stack for several
+function calls and pops them all at once.
+.Ip "\fB\-fforce-mem\fR" 4
+.IX Item "-fforce-mem"
+Force memory operands to be copied into registers before doing
+arithmetic on them. This produces better code by making all memory
+references potential common subexpressions. When they are not common
+subexpressions, instruction combination should eliminate the separate
+register-load. The \fB\-O2\fR option turns on this option.
+.Ip "\fB\-fforce-addr\fR" 4
+.IX Item "-fforce-addr"
+Force memory address constants to be copied into registers before
+doing arithmetic on them. This may produce better code just as
+\&\fB\-fforce-mem\fR may.
+.Ip "\fB\-fomit-frame-pointer\fR" 4
+.IX Item "-fomit-frame-pointer"
+Don't keep the frame pointer in a register for functions that
+don't need one. This avoids the instructions to save, set up and
+restore frame pointers; it also makes an extra register available
+in many functions. \fBIt also makes debugging impossible on
+some machines.\fR
+.Sp
+On some machines, such as the \s-1VAX\s0, this flag has no effect, because
+the standard calling sequence automatically handles the frame pointer
+and nothing is saved by pretending it doesn't exist. The
+machine-description macro \f(CW\*(C`FRAME_POINTER_REQUIRED\*(C'\fR controls
+whether a target machine supports this flag.
+.Ip "\fB\-foptimize-sibling-calls\fR" 4
+.IX Item "-foptimize-sibling-calls"
+Optimize sibling and tail recursive calls.
+.Ip "\fB\-ftrapv\fR" 4
+.IX Item "-ftrapv"
+This option generates traps for signed overflow on addition, subtraction,
+multiplication operations.
+.Ip "\fB\-fno-inline\fR" 4
+.IX Item "-fno-inline"
+Don't pay attention to the \f(CW\*(C`inline\*(C'\fR keyword. Normally this option
+is used to keep the compiler from expanding any functions inline.
+Note that if you are not optimizing, no functions can be expanded inline.
+.Ip "\fB\-finline-functions\fR" 4
+.IX Item "-finline-functions"
+Integrate all simple functions into their callers. The compiler
+heuristically decides which functions are simple enough to be worth
+integrating in this way.
+.Sp
+If all calls to a given function are integrated, and the function is
+declared \f(CW\*(C`static\*(C'\fR, then the function is normally not output as
+assembler code in its own right.
+.Ip "\fB\-finline-limit=\fR\fIn\fR" 4
+.IX Item "-finline-limit=n"
+By default, gcc limits the size of functions that can be inlined. This flag
+allows the control of this limit for functions that are explicitly marked as
+inline (ie marked with the inline keyword or defined within the class
+definition in c++). \fIn\fR is the size of functions that can be inlined in
+number of pseudo instructions (not counting parameter handling). The default
+value of \fIn\fR is 600.
+Increasing this value can result in more inlined code at
+the cost of compilation time and memory consumption. Decreasing usually makes
+the compilation faster and less code will be inlined (which presumably
+means slower programs). This option is particularly useful for programs that
+use inlining heavily such as those based on recursive templates with \*(C+.
+.Sp
+\&\fINote:\fR pseudo instruction represents, in this particular context, an
+abstract measurement of function's size. In no way, it represents a count
+of assembly instructions and as such its exact meaning might change from one
+release to an another.
+.Ip "\fB\-fkeep-inline-functions\fR" 4
+.IX Item "-fkeep-inline-functions"
+Even if all calls to a given function are integrated, and the function
+is declared \f(CW\*(C`static\*(C'\fR, nevertheless output a separate run-time
+callable version of the function. This switch does not affect
+\&\f(CW\*(C`extern inline\*(C'\fR functions.
+.Ip "\fB\-fkeep-static-consts\fR" 4
+.IX Item "-fkeep-static-consts"
+Emit variables declared \f(CW\*(C`static const\*(C'\fR when optimization isn't turned
+on, even if the variables aren't referenced.
+.Sp
+\&\s-1GCC\s0 enables this option by default. If you want to force the compiler to
+check if the variable was referenced, regardless of whether or not
+optimization is turned on, use the \fB\-fno-keep-static-consts\fR option.
+.Ip "\fB\-fmerge-constants\fR" 4
+.IX Item "-fmerge-constants"
+Attempt to merge identical constants (string constants and floating point
+constants) accross compilation units.
+.Sp
+This option is default for optimized compilation if assembler and linker
+support it. Use \fB\-fno-merge-constants\fR to inhibit this behavior.
+.Ip "\fB\-fmerge-all-constants\fR" 4
+.IX Item "-fmerge-all-constants"
+Attempt to merge identical constants and identical variables.
+.Sp
+This option implies \fB\-fmerge-constants\fR. In addition to
+\&\fB\-fmerge-constants\fR this considers e.g. even constant initialized
+arrays or initialized constant variables with integral or floating point
+types. Languages like C or \*(C+ require each non-automatic variable to
+have distinct location, so using this option will result in non-conforming
+behavior.
+.Ip "\fB\-fno-function-cse\fR" 4
+.IX Item "-fno-function-cse"
+Do not put function addresses in registers; make each instruction that
+calls a constant function contain the function's address explicitly.
+.Sp
+This option results in less efficient code, but some strange hacks
+that alter the assembler output may be confused by the optimizations
+performed when this option is not used.
+.Ip "\fB\-ffast-math\fR" 4
+.IX Item "-ffast-math"
+Sets \fB\-fno-math-errno\fR, \fB\-funsafe-math-optimizations\fR, and \fB\-fno-trapping-math\fR.
+.Sp
+This option causes the preprocessor macro \f(CW\*(C`_\|_FAST_MATH_\|_\*(C'\fR to be defined.
+.Sp
+This option should never be turned on by any \fB\-O\fR option since
+it can result in incorrect output for programs which depend on
+an exact implementation of \s-1IEEE\s0 or \s-1ISO\s0 rules/specifications for
+math functions.
+.Ip "\fB\-fno-math-errno\fR" 4
+.IX Item "-fno-math-errno"
+Do not set \s-1ERRNO\s0 after calling math functions that are executed
+with a single instruction, e.g., sqrt. A program that relies on
+\&\s-1IEEE\s0 exceptions for math error handling may want to use this flag
+for speed while maintaining \s-1IEEE\s0 arithmetic compatibility.
+.Sp
+This option should never be turned on by any \fB\-O\fR option since
+it can result in incorrect output for programs which depend on
+an exact implementation of \s-1IEEE\s0 or \s-1ISO\s0 rules/specifications for
+math functions.
+.Sp
+The default is \fB\-fmath-errno\fR.
+.Ip "\fB\-funsafe-math-optimizations\fR" 4
+.IX Item "-funsafe-math-optimizations"
+Allow optimizations for floating-point arithmetic that (a) assume
+that arguments and results are valid and (b) may violate \s-1IEEE\s0 or
+\&\s-1ANSI\s0 standards. When used at link-time, it may include libraries
+or startup files that change the default \s-1FPU\s0 control word or other
+similar optimizations.
+.Sp
+This option should never be turned on by any \fB\-O\fR option since
+it can result in incorrect output for programs which depend on
+an exact implementation of \s-1IEEE\s0 or \s-1ISO\s0 rules/specifications for
+math functions.
+.Sp
+The default is \fB\-fno-unsafe-math-optimizations\fR.
+.Ip "\fB\-fno-trapping-math\fR" 4
+.IX Item "-fno-trapping-math"
+Compile code assuming that floating-point operations cannot generate
+user-visible traps. Setting this option may allow faster code
+if one relies on ``non-stop'' \s-1IEEE\s0 arithmetic, for example.
+.Sp
+This option should never be turned on by any \fB\-O\fR option since
+it can result in incorrect output for programs which depend on
+an exact implementation of \s-1IEEE\s0 or \s-1ISO\s0 rules/specifications for
+math functions.
+.Sp
+The default is \fB\-ftrapping-math\fR.
+.PP
+The following options control specific optimizations. The \fB\-O2\fR
+option turns on all of these optimizations except \fB\-funroll-loops\fR
+and \fB\-funroll-all-loops\fR. On most machines, the \fB\-O\fR option
+turns on the \fB\-fthread-jumps\fR and \fB\-fdelayed-branch\fR options,
+but specific machines may handle it differently.
+.PP
+You can use the following flags in the rare cases when ``fine-tuning''
+of optimizations to be performed is desired.
+.PP
+Not all of the optimizations performed by \s-1GCC\s0 have \fB\-f\fR options
+to control them.
+.Ip "\fB\-fstrength-reduce\fR" 4
+.IX Item "-fstrength-reduce"
+Perform the optimizations of loop strength reduction and
+elimination of iteration variables.
+.Ip "\fB\-fthread-jumps\fR" 4
+.IX Item "-fthread-jumps"
+Perform optimizations where we check to see if a jump branches to a
+location where another comparison subsumed by the first is found. If
+so, the first branch is redirected to either the destination of the
+second branch or a point immediately following it, depending on whether
+the condition is known to be true or false.
+.Ip "\fB\-fcse-follow-jumps\fR" 4
+.IX Item "-fcse-follow-jumps"
+In common subexpression elimination, scan through jump instructions
+when the target of the jump is not reached by any other path. For
+example, when \s-1CSE\s0 encounters an \f(CW\*(C`if\*(C'\fR statement with an
+\&\f(CW\*(C`else\*(C'\fR clause, \s-1CSE\s0 will follow the jump when the condition
+tested is false.
+.Ip "\fB\-fcse-skip-blocks\fR" 4
+.IX Item "-fcse-skip-blocks"
+This is similar to \fB\-fcse-follow-jumps\fR, but causes \s-1CSE\s0 to
+follow jumps which conditionally skip over blocks. When \s-1CSE\s0
+encounters a simple \f(CW\*(C`if\*(C'\fR statement with no else clause,
+\&\fB\-fcse-skip-blocks\fR causes \s-1CSE\s0 to follow the jump around the
+body of the \f(CW\*(C`if\*(C'\fR.
+.Ip "\fB\-frerun-cse-after-loop\fR" 4
+.IX Item "-frerun-cse-after-loop"
+Re-run common subexpression elimination after loop optimizations has been
+performed.
+.Ip "\fB\-frerun-loop-opt\fR" 4
+.IX Item "-frerun-loop-opt"
+Run the loop optimizer twice.
+.Ip "\fB\-fgcse\fR" 4
+.IX Item "-fgcse"
+Perform a global common subexpression elimination pass.
+This pass also performs global constant and copy propagation.
+.Sp
+\&\fINote:\fR When compiling a program using computed gotos, a \s-1GCC\s0
+extension, you may get better runtime performance if you disable
+the global common subexpression elmination pass by adding
+\&\fB\-fno-gcse\fR to the command line.
+.Ip "\fB\-fgcse-lm\fR" 4
+.IX Item "-fgcse-lm"
+When \fB\-fgcse-lm\fR is enabled, global common subexpression elimination will
+attempt to move loads which are only killed by stores into themselves. This
+allows a loop containing a load/store sequence to be changed to a load outside
+the loop, and a copy/store within the loop.
+.Ip "\fB\-fgcse-sm\fR" 4
+.IX Item "-fgcse-sm"
+When \fB\-fgcse-sm\fR is enabled, A store motion pass is run after global common
+subexpression elimination. This pass will attempt to move stores out of loops.
+When used in conjunction with \fB\-fgcse-lm\fR, loops containing a load/store sequence
+can be changed to a load before the loop and a store after the loop.
+.Ip "\fB\-fdelete-null-pointer-checks\fR" 4
+.IX Item "-fdelete-null-pointer-checks"
+Use global dataflow analysis to identify and eliminate useless checks
+for null pointers. The compiler assumes that dereferencing a null
+pointer would have halted the program. If a pointer is checked after
+it has already been dereferenced, it cannot be null.
+.Sp
+In some environments, this assumption is not true, and programs can
+safely dereference null pointers. Use
+\&\fB\-fno-delete-null-pointer-checks\fR to disable this optimization
+for programs which depend on that behavior.
+.Ip "\fB\-fexpensive-optimizations\fR" 4
+.IX Item "-fexpensive-optimizations"
+Perform a number of minor optimizations that are relatively expensive.
+.Ip "\fB\-foptimize-register-move\fR" 4
+.IX Item "-foptimize-register-move"
+.PD 0
+.Ip "\fB\-fregmove\fR" 4
+.IX Item "-fregmove"
+.PD
+Attempt to reassign register numbers in move instructions and as
+operands of other simple instructions in order to maximize the amount of
+register tying. This is especially helpful on machines with two-operand
+instructions. \s-1GCC\s0 enables this optimization by default with \fB\-O2\fR
+or higher.
+.Sp
+Note \fB\-fregmove\fR and \fB\-foptimize-register-move\fR are the same
+optimization.
+.Ip "\fB\-fdelayed-branch\fR" 4
+.IX Item "-fdelayed-branch"
+If supported for the target machine, attempt to reorder instructions
+to exploit instruction slots available after delayed branch
+instructions.
+.Ip "\fB\-fschedule-insns\fR" 4
+.IX Item "-fschedule-insns"
+If supported for the target machine, attempt to reorder instructions to
+eliminate execution stalls due to required data being unavailable. This
+helps machines that have slow floating point or memory load instructions
+by allowing other instructions to be issued until the result of the load
+or floating point instruction is required.
+.Ip "\fB\-fschedule-insns2\fR" 4
+.IX Item "-fschedule-insns2"
+Similar to \fB\-fschedule-insns\fR, but requests an additional pass of
+instruction scheduling after register allocation has been done. This is
+especially useful on machines with a relatively small number of
+registers and where memory load instructions take more than one cycle.
+.Ip "\fB\-ffunction-sections\fR" 4
+.IX Item "-ffunction-sections"
+.PD 0
+.Ip "\fB\-fdata-sections\fR" 4
+.IX Item "-fdata-sections"
+.PD
+Place each function or data item into its own section in the output
+file if the target supports arbitrary sections. The name of the
+function or the name of the data item determines the section's name
+in the output file.
+.Sp
+Use these options on systems where the linker can perform optimizations
+to improve locality of reference in the instruction space. \s-1HPPA\s0
+processors running \s-1HP-UX\s0 and Sparc processors running Solaris 2 have
+linkers with such optimizations. Other systems using the \s-1ELF\s0 object format
+as well as \s-1AIX\s0 may have these optimizations in the future.
+.Sp
+Only use these options when there are significant benefits from doing
+so. When you specify these options, the assembler and linker will
+create larger object and executable files and will also be slower.
+You will not be able to use \f(CW\*(C`gprof\*(C'\fR on all systems if you
+specify this option and you may have problems with debugging if
+you specify both this option and \fB\-g\fR.
+.Ip "\fB\-fcaller-saves\fR" 4
+.IX Item "-fcaller-saves"
+Enable values to be allocated in registers that will be clobbered by
+function calls, by emitting extra instructions to save and restore the
+registers around such calls. Such allocation is done only when it
+seems to result in better code than would otherwise be produced.
+.Sp
+This option is always enabled by default on certain machines, usually
+those which have no call-preserved registers to use instead.
+.Sp
+For all machines, optimization level 2 and higher enables this flag by
+default.
+.Ip "\fB\-funroll-loops\fR" 4
+.IX Item "-funroll-loops"
+Unroll loops whose number of iterations can be determined at compile
+time or upon entry to the loop. \fB\-funroll-loops\fR implies both
+\&\fB\-fstrength-reduce\fR and \fB\-frerun-cse-after-loop\fR. This
+option makes code larger, and may or may not make it run faster.
+.Ip "\fB\-funroll-all-loops\fR" 4
+.IX Item "-funroll-all-loops"
+Unroll all loops, even if their number of iterations is uncertain when
+the loop is entered. This usually makes programs run more slowly.
+\&\fB\-funroll-all-loops\fR implies the same options as
+\&\fB\-funroll-loops\fR,
+.Ip "\fB\-fprefetch-loop-arrays\fR" 4
+.IX Item "-fprefetch-loop-arrays"
+If supported by the target machine, generate instructions to prefetch
+memory to improve the performance of loops that access large arrays.
+.Ip "\fB\-fmove-all-movables\fR" 4
+.IX Item "-fmove-all-movables"
+Forces all invariant computations in loops to be moved
+outside the loop.
+.Ip "\fB\-freduce-all-givs\fR" 4
+.IX Item "-freduce-all-givs"
+Forces all general-induction variables in loops to be
+strength-reduced.
+.Sp
+\&\fINote:\fR When compiling programs written in Fortran,
+\&\fB\-fmove-all-movables\fR and \fB\-freduce-all-givs\fR are enabled
+by default when you use the optimizer.
+.Sp
+These options may generate better or worse code; results are highly
+dependent on the structure of loops within the source code.
+.Sp
+These two options are intended to be removed someday, once
+they have helped determine the efficacy of various
+approaches to improving loop optimizations.
+.Sp
+Please let us (<\fBgcc@gcc.gnu.org\fR> and <\fBfortran@gnu.org\fR>)
+know how use of these options affects
+the performance of your production code.
+We're very interested in code that runs \fIslower\fR
+when these options are \fIenabled\fR.
+.Ip "\fB\-fno-peephole\fR" 4
+.IX Item "-fno-peephole"
+.PD 0
+.Ip "\fB\-fno-peephole2\fR" 4
+.IX Item "-fno-peephole2"
+.PD
+Disable any machine-specific peephole optimizations. The difference
+between \fB\-fno-peephole\fR and \fB\-fno-peephole2\fR is in how they
+are implemented in the compiler; some targets use one, some use the
+other, a few use both.
+.Ip "\fB\-fbranch-probabilities\fR" 4
+.IX Item "-fbranch-probabilities"
+After running a program compiled with \fB\-fprofile-arcs\fR, you can compile it a second time using
+\&\fB\-fbranch-probabilities\fR, to improve optimizations based on
+the number of times each branch was taken. When the program
+compiled with \fB\-fprofile-arcs\fR exits it saves arc execution
+counts to a file called \fI\fIsourcename\fI.da\fR for each source
+file The information in this data file is very dependent on the
+structure of the generated code, so you must use the same source code
+and the same optimization options for both compilations.
+.Sp
+With \fB\-fbranch-probabilities\fR, \s-1GCC\s0 puts a \fB\s-1REG_EXEC_COUNT\s0\fR
+note on the first instruction of each basic block, and a
+\&\fB\s-1REG_BR_PROB\s0\fR note on each \fB\s-1JUMP_INSN\s0\fR and \fB\s-1CALL_INSN\s0\fR.
+These can be used to improve optimization. Currently, they are only
+used in one place: in \fIreorg.c\fR, instead of guessing which path a
+branch is mostly to take, the \fB\s-1REG_BR_PROB\s0\fR values are used to
+exactly determine which path is taken more often.
+.Ip "\fB\-fno-guess-branch-probability\fR" 4
+.IX Item "-fno-guess-branch-probability"
+Do not guess branch probabilities using a randomized model.
+.Sp
+Sometimes gcc will opt to use a randomized model to guess branch
+probabilities, when none are available from either profiling feedback
+(\fB\-fprofile-arcs\fR) or \fB_\|_builtin_expect\fR. This means that
+different runs of the compiler on the same program may produce different
+object code.
+.Sp
+In a hard real-time system, people don't want different runs of the
+compiler to produce code that has different behavior; minimizing
+non-determinism is of paramount import. This switch allows users to
+reduce non-determinism, possibly at the expense of inferior
+optimization.
+.Ip "\fB\-fstrict-aliasing\fR" 4
+.IX Item "-fstrict-aliasing"
+Allows the compiler to assume the strictest aliasing rules applicable to
+the language being compiled. For C (and \*(C+), this activates
+optimizations based on the type of expressions. In particular, an
+object of one type is assumed never to reside at the same address as an
+object of a different type, unless the types are almost the same. For
+example, an \f(CW\*(C`unsigned int\*(C'\fR can alias an \f(CW\*(C`int\*(C'\fR, but not a
+\&\f(CW\*(C`void*\*(C'\fR or a \f(CW\*(C`double\*(C'\fR. A character type may alias any other
+type.
+.Sp
+Pay special attention to code like this:
+.Sp
+.Vb 4
+\& union a_union {
+\& int i;
+\& double d;
+\& };
+.Ve
+.Vb 5
+\& int f() {
+\& a_union t;
+\& t.d = 3.0;
+\& return t.i;
+\& }
+.Ve
+The practice of reading from a different union member than the one most
+recently written to (called ``type-punning'') is common. Even with
+\&\fB\-fstrict-aliasing\fR, type-punning is allowed, provided the memory
+is accessed through the union type. So, the code above will work as
+expected. However, this code might not:
+.Sp
+.Vb 7
+\& int f() {
+\& a_union t;
+\& int* ip;
+\& t.d = 3.0;
+\& ip = &t.i;
+\& return *ip;
+\& }
+.Ve
+Every language that wishes to perform language-specific alias analysis
+should define a function that computes, given an \f(CW\*(C`tree\*(C'\fR
+node, an alias set for the node. Nodes in different alias sets are not
+allowed to alias. For an example, see the C front-end function
+\&\f(CW\*(C`c_get_alias_set\*(C'\fR.
+.Ip "\fB\-falign-functions\fR" 4
+.IX Item "-falign-functions"
+.PD 0
+.Ip "\fB\-falign-functions=\fR\fIn\fR" 4
+.IX Item "-falign-functions=n"
+.PD
+Align the start of functions to the next power-of-two greater than
+\&\fIn\fR, skipping up to \fIn\fR bytes. For instance,
+\&\fB\-falign-functions=32\fR aligns functions to the next 32\-byte
+boundary, but \fB\-falign-functions=24\fR would align to the next
+32\-byte boundary only if this can be done by skipping 23 bytes or less.
+.Sp
+\&\fB\-fno-align-functions\fR and \fB\-falign-functions=1\fR are
+equivalent and mean that functions will not be aligned.
+.Sp
+Some assemblers only support this flag when \fIn\fR is a power of two;
+in that case, it is rounded up.
+.Sp
+If \fIn\fR is not specified, use a machine-dependent default.
+.Ip "\fB\-falign-labels\fR" 4
+.IX Item "-falign-labels"
+.PD 0
+.Ip "\fB\-falign-labels=\fR\fIn\fR" 4
+.IX Item "-falign-labels=n"
+.PD
+Align all branch targets to a power-of-two boundary, skipping up to
+\&\fIn\fR bytes like \fB\-falign-functions\fR. This option can easily
+make code slower, because it must insert dummy operations for when the
+branch target is reached in the usual flow of the code.
+.Sp
+If \fB\-falign-loops\fR or \fB\-falign-jumps\fR are applicable and
+are greater than this value, then their values are used instead.
+.Sp
+If \fIn\fR is not specified, use a machine-dependent default which is
+very likely to be \fB1\fR, meaning no alignment.
+.Sp
+This option does not work on Mac \s-1OS\s0 X.
+.Ip "\fB\-falign-loops\fR" 4
+.IX Item "-falign-loops"
+.PD 0
+.Ip "\fB\-falign-loops=\fR\fIn\fR" 4
+.IX Item "-falign-loops=n"
+.PD
+Align loops to a power-of-two boundary, skipping up to \fIn\fR bytes
+like \fB\-falign-functions\fR. The hope is that the loop will be
+executed many times, which will make up for any execution of the dummy
+operations.
+.Sp
+If \fIn\fR is not specified, use a machine-dependent default.
+.Sp
+This option does not work on Mac \s-1OS\s0 X.
+.Ip "\fB\-falign-jumps\fR" 4
+.IX Item "-falign-jumps"
+.PD 0
+.Ip "\fB\-falign-jumps=\fR\fIn\fR" 4
+.IX Item "-falign-jumps=n"
+.PD
+Align branch targets to a power-of-two boundary, for branch targets
+where the targets can only be reached by jumping, skipping up to \fIn\fR
+bytes like \fB\-falign-functions\fR. In this case, no dummy operations
+need be executed.
+.Sp
+If \fIn\fR is not specified, use a machine-dependent default.
+.Sp
+This option does not work on Mac \s-1OS\s0 X.
+.Ip "\fB\-fssa\fR" 4
+.IX Item "-fssa"
+Perform optimizations in static single assignment form. Each function's
+flow graph is translated into \s-1SSA\s0 form, optimizations are performed, and
+the flow graph is translated back from \s-1SSA\s0 form. Users should not
+specify this option, since it is not yet ready for production use.
+.Ip "\fB\-fssa-ccp\fR" 4
+.IX Item "-fssa-ccp"
+Perform Sparse Conditional Constant Propagation in \s-1SSA\s0 form. Requires
+\&\fB\-fssa\fR. Like \fB\-fssa\fR, this is an experimental feature.
+.Ip "\fB\-fssa-dce\fR" 4
+.IX Item "-fssa-dce"
+Perform aggressive dead-code elimination in \s-1SSA\s0 form. Requires \fB\-fssa\fR.
+Like \fB\-fssa\fR, this is an experimental feature.
+.Ip "\fB\-fsingle-precision-constant\fR" 4
+.IX Item "-fsingle-precision-constant"
+Treat floating point constant as single precision constant instead of
+implicitly converting it to double precision constant.
+.Ip "\fB\-frename-registers\fR" 4
+.IX Item "-frename-registers"
+Attempt to avoid false dependencies in scheduled code by making use
+of registers left over after register allocation. This optimization
+will most benefit processors with lots of registers. It can, however,
+make debugging impossible, since variables will no longer stay in
+a ``home register''.
+.Ip "\fB\-fno-cprop-registers\fR" 4
+.IX Item "-fno-cprop-registers"
+After register allocation and post-register allocation instruction splitting,
+we perform a copy-propagation pass to try to reduce scheduling dependencies
+and occasionally eliminate the copy.
+.Ip "\fB\*(--param\fR \fIname\fR\fB=\fR\fIvalue\fR" 4
+.IX Item "param name=value"
+In some places, \s-1GCC\s0 uses various constants to control the amount of
+optimization that is done. For example, \s-1GCC\s0 will not inline functions
+that contain more that a certain number of instructions. You can
+control some of these constants on the command-line using the
+\&\fB\*(--param\fR option.
+.Sp
+In each case, the \fIvalue\fR is an integer. The allowable choices for
+\&\fIname\fR are given in the following table:
+.RS 4
+.Ip "\fBmax-delay-slot-insn-search\fR" 4
+.IX Item "max-delay-slot-insn-search"
+The maximum number of instructions to consider when looking for an
+instruction to fill a delay slot. If more than this arbitrary number of
+instructions is searched, the time savings from filling the delay slot
+will be minimal so stop searching. Increasing values mean more
+aggressive optimization, making the compile time increase with probably
+small improvement in executable run time.
+.Ip "\fBmax-delay-slot-live-search\fR" 4
+.IX Item "max-delay-slot-live-search"
+When trying to fill delay slots, the maximum number of instructions to
+consider when searching for a block with valid live register
+information. Increasing this arbitrarily chosen value means more
+aggressive optimization, increasing the compile time. This parameter
+should be removed when the delay slot code is rewritten to maintain the
+control-flow graph.
+.Ip "\fBmax-gcse-memory\fR" 4
+.IX Item "max-gcse-memory"
+The approximate maximum amount of memory that will be allocated in
+order to perform the global common subexpression elimination
+optimization. If more memory than specified is required, the
+optimization will not be done.
+.Ip "\fBmax-gcse-passes\fR" 4
+.IX Item "max-gcse-passes"
+The maximum number of passes of \s-1GCSE\s0 to run.
+.Ip "\fBmax-pending-list-length\fR" 4
+.IX Item "max-pending-list-length"
+The maximum number of pending dependencies scheduling will allow
+before flushing the current state and starting over. Large functions
+with few branches or calls can create excessively large lists which
+needlessly consume memory and resources.
+.Ip "\fBmax-inline-insns\fR" 4
+.IX Item "max-inline-insns"
+If an function contains more than this many instructions, it
+will not be inlined. This option is precisely equivalent to
+\&\fB\-finline-limit\fR.
+.RE
+.RS 4
+.RE
+.Sh "Options Controlling the Preprocessor"
+.IX Subsection "Options Controlling the Preprocessor"
+These options control the C preprocessor, which is run on each C source
+file before actual compilation.
+.PP
+If you use the \fB\-E\fR option, nothing is done except preprocessing.
+Some of these options make sense only together with \fB\-E\fR because
+they cause the preprocessor output to be unsuitable for actual
+compilation.
+.PP
+You can use \fB\-Wp,\fR\fIoption\fR to bypass the compiler driver
+and pass \fIoption\fR directly through to the preprocessor. If
+\&\fIoption\fR contains commas, it is split into multiple options at the
+commas. However, many options are modified, translated or interpreted
+by the compiler driver before being passed to the preprocessor, and
+\&\fB\-Wp\fR forcibly bypasses this phase. The preprocessor's direct
+interface is undocumented and subject to change, so whenever possible
+you should avoid using \fB\-Wp\fR and let the driver handle the
+options instead.
+.Ip "\fB\-D\fR \fIname\fR" 4
+.IX Item "-D name"
+Predefine \fIname\fR as a macro, with definition \f(CW\*(C`1\*(C'\fR.
+.Ip "\fB\-D\fR \fIname\fR\fB=\fR\fIdefinition\fR" 4
+.IX Item "-D name=definition"
+Predefine \fIname\fR as a macro, with definition \fIdefinition\fR.
+There are no restrictions on the contents of \fIdefinition\fR, but if
+you are invoking the preprocessor from a shell or shell-like program you
+may need to use the shell's quoting syntax to protect characters such as
+spaces that have a meaning in the shell syntax.
+.Sp
+If you wish to define a function-like macro on the command line, write
+its argument list with surrounding parentheses before the equals sign
+(if any). Parentheses are meaningful to most shells, so you will need
+to quote the option. With \fBsh\fR and \fBcsh\fR,
+\&\fB\-D'\fR\fIname\fR\fB(\fR\fIargs...\fR\fB)=\fR\fIdefinition\fR\fB'\fR works.
+.Sp
+\&\fB\-D\fR and \fB\-U\fR options are processed in the order they
+are given on the command line. All \fB\-imacros\fR \fIfile\fR and
+\&\fB\-include\fR \fIfile\fR options are processed after all
+\&\fB\-D\fR and \fB\-U\fR options.
+.Ip "\fB\-U\fR \fIname\fR" 4
+.IX Item "-U name"
+Cancel any previous definition of \fIname\fR, either built in or
+provided with a \fB\-D\fR option.
+.Ip "\fB\-undef\fR" 4
+.IX Item "-undef"
+Do not predefine any system-specific macros. The common predefined
+macros remain defined.
+.Ip "\fB\-I\fR \fIdir\fR" 4
+.IX Item "-I dir"
+Add the directory \fIdir\fR to the list of directories to be searched
+for header files.
+Directories named by \fB\-I\fR are searched before the standard
+system include directories.
+.Sp
+It is dangerous to specify a standard system include directory in an
+\&\fB\-I\fR option. This defeats the special treatment of system
+headers
+\&. It can also defeat the repairs to buggy system headers which \s-1GCC\s0
+makes when it is installed.
+.Ip "\fB\-o\fR \fIfile\fR" 4
+.IX Item "-o file"
+Write output to \fIfile\fR. This is the same as specifying \fIfile\fR
+as the second non-option argument to \fBcpp\fR. \fBgcc\fR has a
+different interpretation of a second non-option argument, so you must
+use \fB\-o\fR to specify the output file.
+.Ip "\fB\-Wall\fR" 4
+.IX Item "-Wall"
+Turns on all optional warnings which are desirable for normal code. At
+present this is \fB\-Wcomment\fR and \fB\-Wtrigraphs\fR. Note that
+many of the preprocessor's warnings are on by default and have no
+options to control them.
+.Ip "\fB\-Wcomment\fR" 4
+.IX Item "-Wcomment"
+.PD 0
+.Ip "\fB\-Wcomments\fR" 4
+.IX Item "-Wcomments"
+.PD
+Warn whenever a comment-start sequence \fB/*\fR appears in a \fB/*\fR
+comment, or whenever a backslash-newline appears in a \fB//\fR comment.
+(Both forms have the same effect.)
+.Ip "\fB\-Wtrigraphs\fR" 4
+.IX Item "-Wtrigraphs"
+Warn if any trigraphs are encountered. This option used to take effect
+only if \fB\-trigraphs\fR was also specified, but now works
+independently. Warnings are not given for trigraphs within comments, as
+they do not affect the meaning of the program.
+.Ip "\fB\-Wtraditional\fR" 4
+.IX Item "-Wtraditional"
+Warn about certain constructs that behave differently in traditional and
+\&\s-1ISO\s0 C. Also warn about \s-1ISO\s0 C constructs that have no traditional C
+equivalent, and problematic constructs which should be avoided.
+.Ip "\fB\-Wimport\fR" 4
+.IX Item "-Wimport"
+Warn the first time \fB#import\fR is used.
+.Ip "\fB\-Wundef\fR" 4
+.IX Item "-Wundef"
+Warn whenever an identifier which is not a macro is encountered in an
+\&\fB#if\fR directive, outside of \fBdefined\fR. Such identifiers are
+replaced with zero.
+.Ip "\fB\-Werror\fR" 4
+.IX Item "-Werror"
+Make all warnings into hard errors. Source code which triggers warnings
+will be rejected.
+.Ip "\fB\-Wsystem-headers\fR" 4
+.IX Item "-Wsystem-headers"
+Issue warnings for code in system headers. These are normally unhelpful
+in finding bugs in your own code, therefore suppressed. If you are
+responsible for the system library, you may want to see them.
+.Ip "\fB\-w\fR" 4
+.IX Item "-w"
+Suppress all warnings, including those which \s-1GNU\s0 \s-1CPP\s0 issues by default.
+.Ip "\fB\-pedantic\fR" 4
+.IX Item "-pedantic"
+Issue all the mandatory diagnostics listed in the C standard. Some of
+them are left out by default, since they trigger frequently on harmless
+code.
+.Ip "\fB\-pedantic-errors\fR" 4
+.IX Item "-pedantic-errors"
+Issue all the mandatory diagnostics, and make all mandatory diagnostics
+into errors. This includes mandatory diagnostics that \s-1GCC\s0 issues
+without \fB\-pedantic\fR but treats as warnings.
+.Ip "\fB\-M\fR" 4
+.IX Item "-M"
+Instead of outputting the result of preprocessing, output a rule
+suitable for \fBmake\fR describing the dependencies of the main
+source file. The preprocessor outputs one \fBmake\fR rule containing
+the object file name for that source file, a colon, and the names of all
+the included files, including those coming from \fB\-include\fR or
+\&\fB\-imacros\fR command line options.
+.Sp
+Unless specified explicitly (with \fB\-MT\fR or \fB\-MQ\fR), the
+object file name consists of the basename of the source file with any
+suffix replaced with object file suffix. If there are many included
+files then the rule is split into several lines using \fB\e\fR\-newline.
+The rule has no commands.
+.Sp
+This option does not suppress the preprocessor's debug output, such as
+\&\fB\-dM\fR. To avoid mixing such debug output with the dependency
+rules you should explicitly specify the dependency output file with
+\&\fB\-MF\fR, or use an environment variable like
+\&\fB\s-1DEPENDENCIES_OUTPUT\s0\fR. Debug output
+will still be sent to the regular output stream as normal.
+.Sp
+Passing \fB\-M\fR to the driver implies \fB\-E\fR.
+.Ip "\fB\-MM\fR" 4
+.IX Item "-MM"
+Like \fB\-M\fR but do not mention header files that are found in
+system header directories, nor header files that are included,
+directly or indirectly, from such a header.
+.Sp
+This implies that the choice of angle brackets or double quotes in an
+\&\fB#include\fR directive does not in itself determine whether that
+header will appear in \fB\-MM\fR dependency output. This is a
+slight change in semantics from \s-1GCC\s0 versions 3.0 and earlier.
+.Ip "\fB\-MF\fR \fIfile\fR" 4
+.IX Item "-MF file"
+@anchor{\-MF}
+When used with \fB\-M\fR or \fB\-MM\fR, specifies a
+file to write the dependencies to. If no \fB\-MF\fR switch is given
+the preprocessor sends the rules to the same place it would have sent
+preprocessed output.
+.Sp
+When used with the driver options \fB\-MD\fR or \fB\-MMD\fR,
+\&\fB\-MF\fR overrides the default dependency output file.
+.Ip "\fB\-dependency-file\fR" 4
+.IX Item "-dependency-file"
+Like \fB\-MF\fR. (\s-1APPLE\s0 \s-1ONLY\s0)
+.Ip "\fB\-MG\fR" 4
+.IX Item "-MG"
+When used with \fB\-M\fR or \fB\-MM\fR, \fB\-MG\fR says to treat missing
+header files as generated files and assume they live in the same
+directory as the source file. It suppresses preprocessed output, as a
+missing header file is ordinarily an error.
+.Sp
+This feature is used in automatic updating of makefiles.
+.Ip "\fB\-MP\fR" 4
+.IX Item "-MP"
+This option instructs \s-1CPP\s0 to add a phony target for each dependency
+other than the main file, causing each to depend on nothing. These
+dummy rules work around errors \fBmake\fR gives if you remove header
+files without updating the \fIMakefile\fR to match.
+.Sp
+This is typical output:
+.Sp
+.Vb 1
+\& test.o: test.c test.h
+.Ve
+.Vb 1
+\& test.h:
+.Ve
+.Ip "\fB\-MT\fR \fItarget\fR" 4
+.IX Item "-MT target"
+Change the target of the rule emitted by dependency generation. By
+default \s-1CPP\s0 takes the name of the main input file, including any path,
+deletes any file suffix such as \fB.c\fR, and appends the platform's
+usual object suffix. The result is the target.
+.Sp
+An \fB\-MT\fR option will set the target to be exactly the string you
+specify. If you want multiple targets, you can specify them as a single
+argument to \fB\-MT\fR, or use multiple \fB\-MT\fR options.
+.Sp
+For example, \fB\-MT\ '$(objpfx)foo.o'\fR might give
+.Sp
+.Vb 1
+\& $(objpfx)foo.o: foo.c
+.Ve
+.Ip "\fB\-MQ\fR \fItarget\fR" 4
+.IX Item "-MQ target"
+Same as \fB\-MT\fR, but it quotes any characters which are special to
+Make. \fB\-MQ\ '$(objpfx)foo.o'\fR gives
+.Sp
+.Vb 1
+\& $$(objpfx)foo.o: foo.c
+.Ve
+The default target is automatically quoted, as if it were given with
+\&\fB\-MQ\fR.
+.Ip "\fB\-MD\fR" 4
+.IX Item "-MD"
+\&\fB\-MD\fR is equivalent to \fB\-M \-MF\fR \fIfile\fR, except that
+\&\fB\-E\fR is not implied. The driver determines \fIfile\fR based on
+whether an \fB\-o\fR option is given. If it is, the driver uses its
+argument but with a suffix of \fI.d\fR, otherwise it take the
+basename of the input file and applies a \fI.d\fR suffix.
+.Sp
+If \fB\-MD\fR is used in conjunction with \fB\-E\fR, any
+\&\fB\-o\fR switch is understood to specify the dependency output file
+(but \f(CW@pxref\fR{\-MF}), but if used without \fB\-E\fR, each \fB\-o\fR
+is understood to specify a target object file.
+.Sp
+Since \fB\-E\fR is not implied, \fB\-MD\fR can be used to generate
+a dependency output file as a side-effect of the compilation process.
+.Ip "\fB\-MMD\fR" 4
+.IX Item "-MMD"
+Like \fB\-MD\fR except mention only user header files, not system
+\&\-header files.
+.Ip "\fB\-x c\fR" 4
+.IX Item "-x c"
+.PD 0
+.Ip "\fB\-x c++\fR" 4
+.IX Item "-x c++"
+.Ip "\fB\-x objective-c\fR" 4
+.IX Item "-x objective-c"
+.Ip "\fB\-x objective-c++\fR" 4
+.IX Item "-x objective-c++"
+.Ip "\fB\-x assembler-with-cpp\fR" 4
+.IX Item "-x assembler-with-cpp"
+.PD
+Specify the source language: C, \*(C+, Objective-C, Objective-\*(C+, or assembly. This has
+nothing to do with standards conformance or extensions; it merely
+selects which base syntax to expect. If you give none of these options,
+cpp will deduce the language from the extension of the source file:
+\&\fB.c\fR, \fB.cc\fR, \fB.m\fR, \fB.mm\fR, or \fB.S\fR. Some other common
+extensions for \*(C+ and assembly are also recognized. If cpp does not
+recognize the extension, it will treat the file as C; this is the most
+generic mode.
+.Sp
+\&\fBNote:\fR Previous versions of cpp accepted a \fB\-lang\fR option
+which selected both the language and the standards conformance level.
+This option has been removed, because it conflicts with the \fB\-l\fR
+option.
+.Ip "\fB\-std=\fR\fIstandard\fR" 4
+.IX Item "-std=standard"
+.PD 0
+.Ip "\fB\-ansi\fR" 4
+.IX Item "-ansi"
+.PD
+Specify the standard to which the code should conform. Currently cpp
+only knows about the standards for C; other language standards will be
+added in the future.
+.Sp
+\&\fIstandard\fR
+may be one of:
+.RS 4
+.if n .Ip "\f(CW""""iso9899:1990""""\fR" 4
+.el .Ip "\f(CWiso9899:1990\fR" 4
+.IX Item "iso9899:1990"
+.PD 0
+.if n .Ip "\f(CW""""c89""""\fR" 4
+.el .Ip "\f(CWc89\fR" 4
+.IX Item "c89"
+.PD
+The \s-1ISO\s0 C standard from 1990. \fBc89\fR is the customary shorthand for
+this version of the standard.
+.Sp
+The \fB\-ansi\fR option is equivalent to \fB\-std=c89\fR.
+.if n .Ip "\f(CW""""iso9899:199409""""\fR" 4
+.el .Ip "\f(CWiso9899:199409\fR" 4
+.IX Item "iso9899:199409"
+The 1990 C standard, as amended in 1994.
+.if n .Ip "\f(CW""""iso9899:1999""""\fR" 4
+.el .Ip "\f(CWiso9899:1999\fR" 4
+.IX Item "iso9899:1999"
+.PD 0
+.if n .Ip "\f(CW""""c99""""\fR" 4
+.el .Ip "\f(CWc99\fR" 4
+.IX Item "c99"
+.if n .Ip "\f(CW""""iso9899:199x""""\fR" 4
+.el .Ip "\f(CWiso9899:199x\fR" 4
+.IX Item "iso9899:199x"
+.if n .Ip "\f(CW""""c9x""""\fR" 4
+.el .Ip "\f(CWc9x\fR" 4
+.IX Item "c9x"
+.PD
+The revised \s-1ISO\s0 C standard, published in December 1999. Before
+publication, this was known as C9X.
+.if n .Ip "\f(CW""""gnu89""""\fR" 4
+.el .Ip "\f(CWgnu89\fR" 4
+.IX Item "gnu89"
+The 1990 C standard plus \s-1GNU\s0 extensions. This is the default.
+.if n .Ip "\f(CW""""gnu99""""\fR" 4
+.el .Ip "\f(CWgnu99\fR" 4
+.IX Item "gnu99"
+.PD 0
+.if n .Ip "\f(CW""""gnu9x""""\fR" 4
+.el .Ip "\f(CWgnu9x\fR" 4
+.IX Item "gnu9x"
+.PD
+The 1999 C standard plus \s-1GNU\s0 extensions.
+.RE
+.RS 4
+.RE
+.Ip "\fB\-I-\fR" 4
+.IX Item "-I-"
+Split the include path. Any directories specified with \fB\-I\fR
+options before \fB\-I-\fR are searched only for headers requested with
+\&\f(CW\*(C`#include\ "\f(CIfile\f(CW"\*(C'\fR; they are not searched for
+\&\f(CW\*(C`#include\ <\f(CIfile\f(CW>\*(C'\fR. If additional directories are
+specified with \fB\-I\fR options after the \fB\-I-\fR, those
+directories are searched for all \fB#include\fR directives.
+.Sp
+In addition, \fB\-I-\fR inhibits the use of the directory of the current
+file directory as the first search directory for \f(CW\*(C`#include\ "\f(CIfile\f(CW"\*(C'\fR.
+.Ip "\fB\-nostdinc\fR" 4
+.IX Item "-nostdinc"
+Do not search the standard system directories for header files.
+Only the directories you have specified with \fB\-I\fR options
+(and the directory of the current file, if appropriate) are searched.
+.Ip "\fB\-nostdinc++\fR" 4
+.IX Item "-nostdinc++"
+Do not search for header files in the \*(C+\-specific standard directories,
+but do still search the other standard directories. (This option is
+used when building the \*(C+ library.)
+.Ip "\fB\-include\fR \fIfile\fR" 4
+.IX Item "-include file"
+Process \fIfile\fR as if \f(CW\*(C`#include "file"\*(C'\fR appeared as the first
+line of the primary source file. However, the first directory searched
+for \fIfile\fR is the preprocessor's working directory \fIinstead of\fR
+the directory containing the main source file. If not found there, it
+is searched for in the remainder of the \f(CW\*(C`#include "..."\*(C'\fR search
+chain as normal.
+.Sp
+If multiple \fB\-include\fR options are given, the files are included
+in the order they appear on the command line.
+.Ip "\fB\-imacros\fR \fIfile\fR" 4
+.IX Item "-imacros file"
+Exactly like \fB\-include\fR, except that any output produced by
+scanning \fIfile\fR is thrown away. Macros it defines remain defined.
+This allows you to acquire all the macros from a header without also
+processing its declarations.
+.Sp
+All files specified by \fB\-imacros\fR are processed before all files
+specified by \fB\-include\fR.
+.Ip "\fB\-idirafter\fR \fIdir\fR" 4
+.IX Item "-idirafter dir"
+Search \fIdir\fR for header files, but do it \fIafter\fR all
+directories specified with \fB\-I\fR and the standard system directories
+have been exhausted. \fIdir\fR is treated as a system include directory.
+.Ip "\fB\-iprefix\fR \fIprefix\fR" 4
+.IX Item "-iprefix prefix"
+Specify \fIprefix\fR as the prefix for subsequent \fB\-iwithprefix\fR
+options. If the prefix represents a directory, you should include the
+final \fB/\fR.
+.Ip "\fB\-iwithprefix\fR \fIdir\fR" 4
+.IX Item "-iwithprefix dir"
+.PD 0
+.Ip "\fB\-iwithprefixbefore\fR \fIdir\fR" 4
+.IX Item "-iwithprefixbefore dir"
+.PD
+Append \fIdir\fR to the prefix specified previously with
+\&\fB\-iprefix\fR, and add the resulting directory to the include search
+path. \fB\-iwithprefixbefore\fR puts it in the same place \fB\-I\fR
+would; \fB\-iwithprefix\fR puts it where \fB\-idirafter\fR would.
+.Sp
+Use of these options is discouraged.
+.Ip "\fB\-isystem\fR \fIdir\fR" 4
+.IX Item "-isystem dir"
+Search \fIdir\fR for header files, after all directories specified by
+\&\fB\-I\fR but before the standard system directories. Mark it
+as a system directory, so that it gets the same special treatment as
+is applied to the standard system directories.
+.Ip "\fB\-fpreprocessed\fR" 4
+.IX Item "-fpreprocessed"
+Indicate to the preprocessor that the input file has already been
+preprocessed. This suppresses things like macro expansion, trigraph
+conversion, escaped newline splicing, and processing of most directives.
+The preprocessor still recognizes and removes comments, so that you can
+pass a file preprocessed with \fB\-C\fR to the compiler without
+problems. In this mode the integrated preprocessor is little more than
+a tokenizer for the front ends.
+.Sp
+\&\fB\-fpreprocessed\fR is implicit if the input file has one of the
+extensions \fB.i\fR, \fB.ii\fR or \fB.mi\fR. These are the
+extensions that \s-1GCC\s0 uses for preprocessed files created by
+\&\fB\-save-temps\fR.
+.Ip "\fB\-ftabstop=\fR\fIwidth\fR" 4
+.IX Item "-ftabstop=width"
+Set the distance between tab stops. This helps the preprocessor report
+correct column numbers in warnings or errors, even if tabs appear on the
+line. If the value is less than 1 or greater than 100, the option is
+ignored. The default is 8.
+.Ip "\fB\-fno-show-column\fR" 4
+.IX Item "-fno-show-column"
+Do not print column numbers in diagnostics. This may be necessary if
+diagnostics are being scanned by a program that does not understand the
+column numbers, such as \fBdejagnu\fR.
+.Ip "\fB\-A\fR \fIpredicate\fR\fB=\fR\fIanswer\fR" 4
+.IX Item "-A predicate=answer"
+Make an assertion with the predicate \fIpredicate\fR and answer
+\&\fIanswer\fR. This form is preferred to the older form \fB\-A\fR
+\&\fIpredicate\fR\fB(\fR\fIanswer\fR\fB)\fR, which is still supported, because
+it does not use shell special characters.
+.Ip "\fB\-A -\fR\fIpredicate\fR\fB=\fR\fIanswer\fR" 4
+.IX Item "-A -predicate=answer"
+Cancel an assertion with the predicate \fIpredicate\fR and answer
+\&\fIanswer\fR.
+.Ip "\fB\-A-\fR" 4
+.IX Item "-A-"
+Cancel all predefined assertions and all assertions preceding it on
+the command line. Also, undefine all predefined macros and all
+macros preceding it on the command line. (This is a historical wart and
+may change in the future.)
+.Ip "\fB\-dCHARS\fR" 4
+.IX Item "-dCHARS"
+\&\fI\s-1CHARS\s0\fR is a sequence of one or more of the following characters,
+and must not be preceded by a space. Other characters are interpreted
+by the compiler proper, or reserved for future versions of \s-1GCC\s0, and so
+are silently ignored. If you specify characters whose behavior
+conflicts, the result is undefined.
+.RS 4
+.Ip "\fBM\fR" 4
+.IX Item "M"
+Instead of the normal output, generate a list of \fB#define\fR
+directives for all the macros defined during the execution of the
+preprocessor, including predefined macros. This gives you a way of
+finding out what is predefined in your version of the preprocessor.
+Assuming you have no file \fIfoo.h\fR, the command
+.Sp
+.Vb 1
+\& touch foo.h; cpp -dM foo.h
+.Ve
+will show all the predefined macros.
+.Ip "\fBD\fR" 4
+.IX Item "D"
+Like \fBM\fR except in two respects: it does \fInot\fR include the
+predefined macros, and it outputs \fIboth\fR the \fB#define\fR
+directives and the result of preprocessing. Both kinds of output go to
+the standard output file.
+.Ip "\fBN\fR" 4
+.IX Item "N"
+Like \fBD\fR, but emit only the macro names, not their expansions.
+.Ip "\fBI\fR" 4
+.IX Item "I"
+Output \fB#include\fR directives in addition to the result of
+preprocessing.
+.RE
+.RS 4
+.RE
+.Ip "\fB\-P\fR" 4
+.IX Item "-P"
+Inhibit generation of linemarkers in the output from the preprocessor.
+This might be useful when running the preprocessor on something that is
+not C code, and will be sent to a program which might be confused by the
+linemarkers.
+.Ip "\fB\-C\fR" 4
+.IX Item "-C"
+Do not discard comments. All comments are passed through to the output
+file, except for comments in processed directives, which are deleted
+along with the directive.
+.Sp
+You should be prepared for side effects when using \fB\-C\fR; it
+causes the preprocessor to treat comments as tokens in their own right.
+For example, comments appearing at the start of what would be a
+directive line have the effect of turning that line into an ordinary
+source line, since the first token on the line is no longer a \fB#\fR.
+.Ip "\fB\-gcc\fR" 4
+.IX Item "-gcc"
+Define the macros _\|_GNUC_\|_, _\|_GNUC_MINOR_\|_ and
+_\|_GNUC_PATCHLEVEL_\|_. These are defined automatically when you use
+\&\fBgcc \-E\fR; you can turn them off in that case with
+\&\fB\-no-gcc\fR.
+.Ip "\fB\-traditional\fR" 4
+.IX Item "-traditional"
+Try to imitate the behavior of old-fashioned C, as opposed to \s-1ISO\s0
+C.
+.Ip "\fB\-trigraphs\fR" 4
+.IX Item "-trigraphs"
+Process trigraph sequences.
+These are three-character sequences, all starting with \fB??\fR, that
+are defined by \s-1ISO\s0 C to stand for single characters. For example,
+\&\fB??/\fR stands for \fB\e\fR, so \fB'??/n'\fR is a character
+constant for a newline. By default, \s-1GCC\s0 ignores trigraphs, but in
+standard-conforming modes it converts them. See the \fB\-std\fR and
+\&\fB\-ansi\fR options.
+.Sp
+The nine trigraphs and their replacements are
+.Sp
+.Vb 2
+\& Trigraph: ??( ??) ??< ??> ??= ??/ ??' ??! ??-
+\& Replacement: [ ] { } # \e ^ | ~
+.Ve
+.Ip "\fB\-remap\fR" 4
+.IX Item "-remap"
+Enable special code to work around file systems which only permit very
+short file names, such as \s-1MS-DOS\s0.
+.Ip "\fB\-$\fR" 4
+.IX Item "-$"
+Forbid the use of \fB$\fR in identifiers. The C standard allows
+implementations to define extra characters that can appear in
+identifiers. By default \s-1GNU\s0 \s-1CPP\s0 permits \fB$\fR, a common extension.
+.Ip "\fB\-h\fR" 4
+.IX Item "-h"
+.PD 0
+.Ip "\fB\*(--help\fR" 4
+.IX Item "help"
+.Ip "\fB\*(--target-help\fR" 4
+.IX Item "target-help"
+.PD
+Print text describing all the command line options instead of
+preprocessing anything.
+.Ip "\fB\-v\fR" 4
+.IX Item "-v"
+Verbose mode. Print out \s-1GNU\s0 \s-1CPP\s0's version number at the beginning of
+execution, and report the final form of the include path.
+.Ip "\fB\-H\fR" 4
+.IX Item "-H"
+Print the name of each header file used, in addition to other normal
+activities. Each name is indented to show how deep in the
+\&\fB#include\fR stack it is.
+.Ip "\fB\-version\fR" 4
+.IX Item "-version"
+.PD 0
+.Ip "\fB\*(--version\fR" 4
+.IX Item "version"
+.PD
+Print out \s-1GNU\s0 \s-1CPP\s0's version number. With one dash, proceed to
+preprocess as normal. With two dashes, exit immediately.
+.Sh "Passing Options to the Assembler"
+.IX Subsection "Passing Options to the Assembler"
+You can pass options to the assembler.
+.Ip "\fB\-Wa,\fR\fIoption\fR" 4
+.IX Item "-Wa,option"
+Pass \fIoption\fR as an option to the assembler. If \fIoption\fR
+contains commas, it is split into multiple options at the commas.
+.Sh "Options for Linking"
+.IX Subsection "Options for Linking"
+These options come into play when the compiler links object files into
+an executable output file. They are meaningless if the compiler is
+not doing a link step.
+.PP
+In addition to the options listed below, Apple's \s-1GCC\s0 also accepts and
+passes nearly all of the options defined by the linker \fBld\fR and by
+the library tool \fBlibtool\fR. Common options include
+\&\fB\-framework\fR, \fB\-dynamic\fR, \fB\-bundle\fR,
+\&\fB\-flat_namespace\fR, and so forth. See the ld and libtool man pages
+for further details.
+.Ip "\fIobject-file-name\fR" 4
+.IX Item "object-file-name"
+A file name that does not end in a special recognized suffix is
+considered to name an object file or library. (Object files are
+distinguished from libraries by the linker according to the file
+contents.) If linking is done, these object files are used as input
+to the linker.
+.Ip "\fB\-c\fR" 4
+.IX Item "-c"
+.PD 0
+.Ip "\fB\-S\fR" 4
+.IX Item "-S"
+.Ip "\fB\-E\fR" 4
+.IX Item "-E"
+.PD
+If any of these options is used, then the linker is not run, and
+object file names should not be used as arguments.
+.Ip "\fB\-l\fR\fIlibrary\fR" 4
+.IX Item "-llibrary"
+.PD 0
+.Ip "\fB\-l\fR \fIlibrary\fR" 4
+.IX Item "-l library"
+.PD
+Search the library named \fIlibrary\fR when linking. (The second
+alternative with the library as a separate argument is only for
+\&\s-1POSIX\s0 compliance and is not recommended.)
+.Sp
+It makes a difference where in the command you write this option; the
+linker searches and processes libraries and object files in the order they
+are specified. Thus, \fBfoo.o \-lz bar.o\fR searches library \fBz\fR
+after file \fIfoo.o\fR but before \fIbar.o\fR. If \fIbar.o\fR refers
+to functions in \fBz\fR, those functions may not be loaded.
+.Sp
+The linker searches a standard list of directories for the library,
+which is actually a file named \fIlib\fIlibrary\fI.a\fR. The linker
+then uses this file as if it had been specified precisely by name.
+.Sp
+The directories searched include several standard system directories
+plus any that you specify with \fB\-L\fR.
+.Sp
+Normally the files found this way are library files\-\-\-archive files
+whose members are object files. The linker handles an archive file by
+scanning through it for members which define symbols that have so far
+been referenced but not defined. But if the file that is found is an
+ordinary object file, it is linked in the usual fashion. The only
+difference between using an \fB\-l\fR option and specifying a file name
+is that \fB\-l\fR surrounds \fIlibrary\fR with \fBlib\fR and \fB.a\fR
+and searches several directories.
+.Ip "\fB\-lobjc\fR" 4
+.IX Item "-lobjc"
+You need this special case of the \fB\-l\fR option in order to
+link an Objective-C program.
+.Ip "\fB\-nostartfiles\fR" 4
+.IX Item "-nostartfiles"
+Do not use the standard system startup files when linking.
+The standard system libraries are used normally, unless \fB\-nostdlib\fR
+or \fB\-nodefaultlibs\fR is used.
+.Ip "\fB\-nodefaultlibs\fR" 4
+.IX Item "-nodefaultlibs"
+Do not use the standard system libraries when linking.
+Only the libraries you specify will be passed to the linker.
+The standard startup files are used normally, unless \fB\-nostartfiles\fR
+is used. The compiler may generate calls to memcmp, memset, and memcpy
+for System V (and \s-1ISO\s0 C) environments or to bcopy and bzero for
+\&\s-1BSD\s0 environments. These entries are usually resolved by entries in
+libc. These entry points should be supplied through some other
+mechanism when this option is specified.
+.Ip "\fB\-nostdlib\fR" 4
+.IX Item "-nostdlib"
+Do not use the standard system startup files or libraries when linking.
+No startup files and only the libraries you specify will be passed to
+the linker. The compiler may generate calls to memcmp, memset, and memcpy
+for System V (and \s-1ISO\s0 C) environments or to bcopy and bzero for
+\&\s-1BSD\s0 environments. These entries are usually resolved by entries in
+libc. These entry points should be supplied through some other
+mechanism when this option is specified.
+.Ip "\fB\-no-c++filt\fR" 4
+.IX Item "-no-c++filt"
+By default all linker diagnostic output is piped through c++filt.
+This option suppresses that behavior. (\s-1APPLE\s0 \s-1ONLY\s0)
+.Sp
+One of the standard libraries bypassed by \fB\-nostdlib\fR and
+\&\fB\-nodefaultlibs\fR is \fIlibgcc.a\fR, a library of internal subroutines
+that \s-1GCC\s0 uses to overcome shortcomings of particular machines, or special
+needs for some languages.
+.Sp
+In most cases, you need \fIlibgcc.a\fR even when you want to avoid
+other standard libraries. In other words, when you specify \fB\-nostdlib\fR
+or \fB\-nodefaultlibs\fR you should usually specify \fB\-lgcc\fR as well.
+This ensures that you have no unresolved references to internal \s-1GCC\s0
+library subroutines. (For example, \fB_\|_main\fR, used to ensure \*(C+
+constructors will be called.)
+.Ip "\fB\-s\fR" 4
+.IX Item "-s"
+Remove all symbol table and relocation information from the executable.
+.Ip "\fB\-static\fR" 4
+.IX Item "-static"
+On systems that support dynamic linking, this prevents linking with the shared
+libraries. On other systems, this option has no effect.
+.Sp
+This option will not work on Mac \s-1OS\s0 X unless all of your libraries
+(including \fIlibgcc.a\fR) have also been compiled with
+\&\fB\-static\fR.
+.Ip "\fB\-shared\fR" 4
+.IX Item "-shared"
+Produce a shared object which can then be linked with other objects to
+form an executable. Not all systems support this option. For predictable
+results, you must also specify the same set of options that were used to
+generate code (\fB\-fpic\fR, \fB\-fPIC\fR, or model suboptions)
+when you specify this option.[1]
+.Sp
+This option is not supported on Mac \s-1OS\s0 X.
+.Ip "\fB\-shared-libgcc\fR" 4
+.IX Item "-shared-libgcc"
+.PD 0
+.Ip "\fB\-static-libgcc\fR" 4
+.IX Item "-static-libgcc"
+.PD
+On systems that provide \fIlibgcc\fR as a shared library, these options
+force the use of either the shared or static version respectively.
+If no shared version of \fIlibgcc\fR was built when the compiler was
+configured, these options have no effect.
+.Sp
+There are several situations in which an application should use the
+shared \fIlibgcc\fR instead of the static version. The most common
+of these is when the application wishes to throw and catch exceptions
+across different shared libraries. In that case, each of the libraries
+as well as the application itself should use the shared \fIlibgcc\fR.
+.Sp
+Therefore, the G++ and \s-1GCJ\s0 drivers automatically add
+\&\fB\-shared-libgcc\fR whenever you build a shared library or a main
+executable, because \*(C+ and Java programs typically use exceptions, so
+this is the right thing to do.
+.Sp
+If, instead, you use the \s-1GCC\s0 driver to create shared libraries, you may
+find that they will not always be linked with the shared \fIlibgcc\fR.
+If \s-1GCC\s0 finds, at its configuration time, that you have a \s-1GNU\s0 linker that
+does not support option \fB\*(--eh-frame-hdr\fR, it will link the shared
+version of \fIlibgcc\fR into shared libraries by default. Otherwise,
+it will take advantage of the linker and optimize away the linking with
+the shared version of \fIlibgcc\fR, linking with the static version of
+libgcc by default. This allows exceptions to propagate through such
+shared libraries, without incurring relocation costs at library load
+time.
+.Sp
+However, if a library or main executable is supposed to throw or catch
+exceptions, you must link it using the G++ or \s-1GCJ\s0 driver, as appropriate
+for the languages used in the program, or using the option
+\&\fB\-shared-libgcc\fR, such that it is linked with the shared
+\&\fIlibgcc\fR.
+.Ip "\fB\-symbolic\fR" 4
+.IX Item "-symbolic"
+Bind references to global symbols when building a shared object. Warn
+about any unresolved references (unless overridden by the link editor
+option \fB\-Xlinker \-z \-Xlinker defs\fR). Only a few systems support
+this option.
+.Ip "\fB\-Xlinker\fR \fIoption\fR" 4
+.IX Item "-Xlinker option"
+Pass \fIoption\fR as an option to the linker. You can use this to
+supply system-specific linker options which \s-1GCC\s0 does not know how to
+recognize.
+.Sp
+If you want to pass an option that takes an argument, you must use
+\&\fB\-Xlinker\fR twice, once for the option and once for the argument.
+For example, to pass \fB\-assert definitions\fR, you must write
+\&\fB\-Xlinker \-assert \-Xlinker definitions\fR. It does not work to write
+\&\fB\-Xlinker \*(L"\-assert definitions\*(R"\fR, because this passes the entire
+string as a single argument, which is not what the linker expects.
+.Ip "\fB\-Wl,\fR\fIoption\fR" 4
+.IX Item "-Wl,option"
+Pass \fIoption\fR as an option to the linker. If \fIoption\fR contains
+commas, it is split into multiple options at the commas.
+.Ip "\fB\-u\fR \fIsymbol\fR" 4
+.IX Item "-u symbol"
+Pretend the symbol \fIsymbol\fR is undefined, to force linking of
+library modules to define it. You can use \fB\-u\fR multiple times with
+different symbols to force loading of additional library modules.
+.Sh "Options for Directory Search"
+.IX Subsection "Options for Directory Search"
+These options specify directories to search for header files, for
+libraries and for parts of the compiler:
+.Ip "\fB\-I\fR\fIdir\fR" 4
+.IX Item "-Idir"
+Add the directory \fIdir\fR to the head of the list of directories to be
+searched for header files. This can be used to override a system header
+file, substituting your own version, since these directories are
+searched before the system header file directories. However, you should
+not use this option to add directories that contain vendor-supplied
+system header files (use \fB\-isystem\fR for that). If you use more than
+one \fB\-I\fR option, the directories are scanned in left-to-right
+order; the standard system directories come after.
+.Sp
+If a standard system include directory, or a directory specified with
+\&\fB\-isystem\fR, is also specified with \fB\-I\fR, it will be
+searched only in the position requested by \fB\-I\fR. Also, it will
+not be considered a system include directory. If that directory really
+does contain system headers, there is a good chance that they will
+break. For instance, if \s-1GCC\s0's installation procedure edited the headers
+in \fI/usr/include\fR to fix bugs, \fB\-I/usr/include\fR will cause the
+original, buggy headers to be found instead of the corrected ones. \s-1GCC\s0
+will issue a warning when a system include directory is hidden in this
+way.
+.Ip "\fB\-I-\fR" 4
+.IX Item "-I-"
+Any directories you specify with \fB\-I\fR options before the \fB\-I-\fR
+option are searched only for the case of \fB#include "\fR\fIfile\fR\fB"\fR;
+they are not searched for \fB#include <\fR\fIfile\fR\fB>\fR.
+.Sp
+If additional directories are specified with \fB\-I\fR options after
+the \fB\-I-\fR, these directories are searched for all \fB#include\fR
+directives. (Ordinarily \fIall\fR \fB\-I\fR directories are used
+this way.)
+.Sp
+In addition, the \fB\-I-\fR option inhibits the use of the current
+directory (where the current input file came from) as the first search
+directory for \fB#include "\fR\fIfile\fR\fB"\fR. There is no way to
+override this effect of \fB\-I-\fR. With \fB\-I.\fR you can specify
+searching the directory which was current when the compiler was
+invoked. That is not exactly the same as what the preprocessor does
+by default, but it is often satisfactory.
+.Sp
+\&\fB\-I-\fR does not inhibit the use of the standard system directories
+for header files. Thus, \fB\-I-\fR and \fB\-nostdinc\fR are
+independent.
+.Ip "\fB\-L\fR\fIdir\fR" 4
+.IX Item "-Ldir"
+Add directory \fIdir\fR to the list of directories to be searched
+for \fB\-l\fR.
+.Ip "\fB\-F\fR\fIdir\fR" 4
+.IX Item "-Fdir"
+In Apple's version of \s-1GCC\s0 only, add the directory \fIdir\fR to the head
+of the list of directories to be searched for frameworks.
+.Sp
+The framework search algorithm is, for an inclusion of
+\&\fB<Fmwk/Header.h>\fR, to look for files named
+\&\fI\fIpath\fI/Fmwk.framework/Headers/Header.h\fR or
+\&\fI\fIpath\fI/Fmwk.framework/PrivateHeaders/Header.h\fR where
+\&\fIpath\fR includes \fI/System/Library/Frameworks/\fR
+\&\fI/Library/Frameworks/\fR, and \fI/Local/Library/Frameworks/\fR, plus
+any additional paths specified by \fB\-F\fR.
+.Sp
+All the \fB\-F\fR options are also passed to the linker.
+.Ip "\fB\-B\fR\fIprefix\fR" 4
+.IX Item "-Bprefix"
+This option specifies where to find the executables, libraries,
+include files, and data files of the compiler itself.
+.Sp
+The compiler driver program runs one or more of the subprograms
+\&\fIcpp\fR, \fIcc1\fR, \fIas\fR and \fIld\fR. It tries
+\&\fIprefix\fR as a prefix for each program it tries to run, both with and
+without \fImachine\fR\fB/\fR\fIversion\fR\fB/\fR.
+.Sp
+For each subprogram to be run, the compiler driver first tries the
+\&\fB\-B\fR prefix, if any. If that name is not found, or if \fB\-B\fR
+was not specified, the driver tries two standard prefixes, which are
+\&\fI/usr/lib/gcc/\fR and \fI/usr/local/lib/gcc-lib/\fR. If neither of
+those results in a file name that is found, the unmodified program
+name is searched for using the directories specified in your
+\&\fB\s-1PATH\s0\fR environment variable.
+.Sp
+The compiler will check to see if the path provided by the \fB\-B\fR
+refers to a directory, and if necessary it will add a directory
+separator character at the end of the path.
+.Sp
+\&\fB\-B\fR prefixes that effectively specify directory names also apply
+to libraries in the linker, because the compiler translates these
+options into \fB\-L\fR options for the linker. They also apply to
+includes files in the preprocessor, because the compiler translates these
+options into \fB\-isystem\fR options for the preprocessor. In this case,
+the compiler appends \fBinclude\fR to the prefix.
+.Sp
+The run-time support file \fIlibgcc.a\fR can also be searched for using
+the \fB\-B\fR prefix, if needed. If it is not found there, the two
+standard prefixes above are tried, and that is all. The file is left
+out of the link if it is not found by those means.
+.Sp
+Another way to specify a prefix much like the \fB\-B\fR prefix is to use
+the environment variable \fB\s-1GCC_EXEC_PREFIX\s0\fR.
+.Sp
+As a special kludge, if the path provided by \fB\-B\fR is
+\&\fI[dir/]stage\fIN\fI/\fR, where \fIN\fR is a number in the range 0 to
+9, then it will be replaced by \fI[dir/]include\fR. This is to help
+with boot-strapping the compiler.
+.Ip "\fB\-specs=\fR\fIfile\fR" 4
+.IX Item "-specs=file"
+Process \fIfile\fR after the compiler reads in the standard \fIspecs\fR
+file, in order to override the defaults that the \fIgcc\fR driver
+program uses when determining what switches to pass to \fIcc1\fR,
+\&\fIcc1plus\fR, \fIas\fR, \fIld\fR, etc. More than one
+\&\fB\-specs=\fR\fIfile\fR can be specified on the command line, and they
+are processed in order, from left to right.
+.Sh "Specifying Target Machine and Compiler Version"
+.IX Subsection "Specifying Target Machine and Compiler Version"
+By default, \s-1GCC\s0 compiles code for the same type of machine that you
+are using. However, it can also be installed as a cross-compiler, to
+compile for some other type of machine. In fact, several different
+configurations of \s-1GCC\s0, for different target machines, can be
+installed side by side. Then you specify which one to use with the
+\&\fB\-b\fR option.
+.PP
+In addition, older and newer versions of \s-1GCC\s0 can be installed side
+by side. One of them (probably the newest) will be the default, but
+you may sometimes wish to use another.
+.Ip "\fB\-b\fR \fImachine\fR" 4
+.IX Item "-b machine"
+The argument \fImachine\fR specifies the target machine for compilation.
+This is useful when you have installed \s-1GCC\s0 as a cross-compiler.
+.Sp
+The value to use for \fImachine\fR is the same as was specified as the
+machine type when configuring \s-1GCC\s0 as a cross-compiler. For
+example, if a cross-compiler was configured with \fBconfigure
+i386v\fR, meaning to compile for an 80386 running System V, then you
+would specify \fB\-b i386v\fR to run that cross compiler.
+.Sp
+When you do not specify \fB\-b\fR, it normally means to compile for
+the same type of machine that you are using.
+.Ip "\fB\-V\fR \fIversion\fR" 4
+.IX Item "-V version"
+The argument \fIversion\fR specifies which version of \s-1GCC\s0 to run.
+This is useful when multiple versions are installed. For example,
+\&\fIversion\fR might be \fB2.0\fR, meaning to run \s-1GCC\s0 version 2.0.
+.Sp
+The default version, when you do not specify \fB\-V\fR, is the last
+version of \s-1GCC\s0 that you installed.
+.PP
+The \fB\-b\fR and \fB\-V\fR options actually work by controlling part of
+the file name used for the executable files and libraries used for
+compilation. A given version of \s-1GCC\s0, for a given target machine, is
+normally kept in the directory \fI/usr/local/lib/gcc-lib/\fImachine\fI/\fIversion\fI\fR.
+.PP
+Thus, sites can customize the effect of \fB\-b\fR or \fB\-V\fR either by
+changing the names of these directories or adding alternate names (or
+symbolic links). If in directory \fI/usr/local/lib/gcc-lib/\fR the
+file \fI80386\fR is a link to the file \fIi386v\fR, then \fB\-b
+80386\fR becomes an alias for \fB\-b i386v\fR.
+.PP
+In one respect, the \fB\-b\fR or \fB\-V\fR do not completely change
+to a different compiler: the top-level driver program \fBgcc\fR
+that you originally invoked continues to run and invoke the other
+executables (preprocessor, compiler per se, assembler and linker)
+that do the real work. However, since no real work is done in the
+driver program, it usually does not matter that the driver program
+in use is not the one for the specified target. It is common for the
+interface to the other executables to change incompatibly between
+compiler versions, so unless the version specified is very close to that
+of the driver (for example, \fB\-V 3.0\fR with a driver program from \s-1GCC\s0
+version 3.0.1), use of \fB\-V\fR may not work; for example, using
+\&\fB\-V 2.95.2\fR will not work with a driver program from \s-1GCC\s0 3.0.
+.PP
+The only way that the driver program depends on the target machine is
+in the parsing and handling of special machine-specific options.
+However, this is controlled by a file which is found, along with the
+other executables, in the directory for the specified version and
+target machine. As a result, a single installed driver program adapts
+to any specified target machine, and sufficiently similar compiler
+versions.
+.PP
+The driver program executable does control one significant thing,
+however: the default version and target machine. Therefore, you can
+install different instances of the driver program, compiled for
+different targets or versions, under different names.
+.PP
+For example, if the driver for version 2.0 is installed as \fBogcc\fR
+and that for version 2.1 is installed as \fBgcc\fR, then the command
+\&\fBgcc\fR will use version 2.1 by default, while \fBogcc\fR will use
+2.0 by default. However, you can choose either version with either
+command with the \fB\-V\fR option.
+.Sh "Hardware Models and Configurations"
+.IX Subsection "Hardware Models and Configurations"
+Earlier we discussed the standard option \fB\-b\fR which chooses among
+different installed compilers for completely different target
+machines, such as \s-1VAX\s0 vs. 68000 vs. 80386.
+.PP
+In addition, each of these target machine types can have its own
+special options, starting with \fB\-m\fR, to choose among various
+hardware models or configurations\-\-\-for example, 68010 vs 68020,
+floating coprocessor or none. A single installed version of the
+compiler can compile for any model or configuration, according to the
+options specified.
+.PP
+Some configurations of the compiler also support additional special
+options, usually for compatibility with other compilers on the same
+platform.
+.PP
+These options are defined by the macro \f(CW\*(C`TARGET_SWITCHES\*(C'\fR in the
+machine description. The default for the options is also defined by
+that macro, which enables you to change the defaults.
+.PP
+.I "\s-1IBM\s0 \s-1RS/6000\s0 and PowerPC Options"
+.IX Subsection "IBM RS/6000 and PowerPC Options"
+.PP
+These \fB\-m\fR options are defined for the \s-1IBM\s0 \s-1RS/6000\s0 and PowerPC:
+.Ip "\fB\-mpower\fR" 4
+.IX Item "-mpower"
+.PD 0
+.Ip "\fB\-mno-power\fR" 4
+.IX Item "-mno-power"
+.Ip "\fB\-mpower2\fR" 4
+.IX Item "-mpower2"
+.Ip "\fB\-mno-power2\fR" 4
+.IX Item "-mno-power2"
+.Ip "\fB\-mpowerpc\fR" 4
+.IX Item "-mpowerpc"
+.Ip "\fB\-mno-powerpc\fR" 4
+.IX Item "-mno-powerpc"
+.Ip "\fB\-mpowerpc-gpopt\fR" 4
+.IX Item "-mpowerpc-gpopt"
+.Ip "\fB\-mno-powerpc-gpopt\fR" 4
+.IX Item "-mno-powerpc-gpopt"
+.Ip "\fB\-mpowerpc-gfxopt\fR" 4
+.IX Item "-mpowerpc-gfxopt"
+.Ip "\fB\-mno-powerpc-gfxopt\fR" 4
+.IX Item "-mno-powerpc-gfxopt"
+.Ip "\fB\-mpowerpc64\fR" 4
+.IX Item "-mpowerpc64"
+.Ip "\fB\-mno-powerpc64\fR" 4
+.IX Item "-mno-powerpc64"
+.PD
+\&\s-1GCC\s0 supports two related instruction set architectures for the
+\&\s-1RS/6000\s0 and PowerPC. The \fI\s-1POWER\s0\fR instruction set are those
+instructions supported by the \fBrios\fR chip set used in the original
+\&\s-1RS/6000\s0 systems and the \fIPowerPC\fR instruction set is the
+architecture of the Motorola MPC5xx, MPC6xx, MPC8xx microprocessors, and
+the \s-1IBM\s0 4xx microprocessors.
+.Sp
+Neither architecture is a subset of the other. However there is a
+large common subset of instructions supported by both. An \s-1MQ\s0
+register is included in processors supporting the \s-1POWER\s0 architecture.
+.Sp
+You use these options to specify which instructions are available on the
+processor you are using. The default value of these options is
+determined when configuring \s-1GCC\s0. Specifying the
+\&\fB\-mcpu=\fR\fIcpu_type\fR overrides the specification of these
+options. We recommend you use the \fB\-mcpu=\fR\fIcpu_type\fR option
+rather than the options listed above.
+.Sp
+The \fB\-mpower\fR option allows \s-1GCC\s0 to generate instructions that
+are found only in the \s-1POWER\s0 architecture and to use the \s-1MQ\s0 register.
+Specifying \fB\-mpower2\fR implies \fB\-power\fR and also allows \s-1GCC\s0
+to generate instructions that are present in the \s-1POWER2\s0 architecture but
+not the original \s-1POWER\s0 architecture.
+.Sp
+The \fB\-mpowerpc\fR option allows \s-1GCC\s0 to generate instructions that
+are found only in the 32\-bit subset of the PowerPC architecture.
+Specifying \fB\-mpowerpc-gpopt\fR implies \fB\-mpowerpc\fR and also allows
+\&\s-1GCC\s0 to use the optional PowerPC architecture instructions in the
+General Purpose group, including floating-point square root. Specifying
+\&\fB\-mpowerpc-gfxopt\fR implies \fB\-mpowerpc\fR and also allows \s-1GCC\s0 to
+use the optional PowerPC architecture instructions in the Graphics
+group, including floating-point select.
+.Sp
+The \fB\-mpowerpc64\fR option allows \s-1GCC\s0 to generate the additional
+64\-bit instructions that are found in the full PowerPC64 architecture
+and to treat GPRs as 64\-bit, doubleword quantities. \s-1GCC\s0 defaults to
+\&\fB\-mno-powerpc64\fR.
+.Sp
+If you specify both \fB\-mno-power\fR and \fB\-mno-powerpc\fR, \s-1GCC\s0
+will use only the instructions in the common subset of both
+architectures plus some special \s-1AIX\s0 common-mode calls, and will not use
+the \s-1MQ\s0 register. Specifying both \fB\-mpower\fR and \fB\-mpowerpc\fR
+permits \s-1GCC\s0 to use any instruction from either architecture and to
+allow use of the \s-1MQ\s0 register; specify this for the Motorola \s-1MPC601\s0.
+.Ip "\fB\-mnew-mnemonics\fR" 4
+.IX Item "-mnew-mnemonics"
+.PD 0
+.Ip "\fB\-mold-mnemonics\fR" 4
+.IX Item "-mold-mnemonics"
+.PD
+Select which mnemonics to use in the generated assembler code. With
+\&\fB\-mnew-mnemonics\fR, \s-1GCC\s0 uses the assembler mnemonics defined for
+the PowerPC architecture. With \fB\-mold-mnemonics\fR it uses the
+assembler mnemonics defined for the \s-1POWER\s0 architecture. Instructions
+defined in only one architecture have only one mnemonic; \s-1GCC\s0 uses that
+mnemonic irrespective of which of these options is specified.
+.Sp
+\&\s-1GCC\s0 defaults to the mnemonics appropriate for the architecture in
+use. Specifying \fB\-mcpu=\fR\fIcpu_type\fR sometimes overrides the
+value of these option. Unless you are building a cross-compiler, you
+should normally not specify either \fB\-mnew-mnemonics\fR or
+\&\fB\-mold-mnemonics\fR, but should instead accept the default.
+.Ip "\fB\-mcpu=\fR\fIcpu_type\fR" 4
+.IX Item "-mcpu=cpu_type"
+Set architecture type, register usage, choice of mnemonics, and
+instruction scheduling parameters for machine type \fIcpu_type\fR.
+Supported values for \fIcpu_type\fR are \fBrios\fR, \fBrios1\fR,
+\&\fBrsc\fR, \fBrios2\fR, \fBrs64a\fR, \fB601\fR, \fB602\fR,
+\&\fB603\fR, \fB603e\fR, \fB604\fR, \fB604e\fR, \fB620\fR,
+\&\fB630\fR, \fB740\fR, \fB7400\fR, \fB7450\fR, \fB750\fR,
+\&\fBpower\fR, \fBpower2\fR, \fBpowerpc\fR, \fB403\fR, \fB505\fR,
+\&\fB801\fR, \fB821\fR, \fB823\fR, and \fB860\fR and \fBcommon\fR.
+.Sp
+\&\fB\-mcpu=common\fR selects a completely generic processor. Code
+generated under this option will run on any \s-1POWER\s0 or PowerPC processor.
+\&\s-1GCC\s0 will use only the instructions in the common subset of both
+architectures, and will not use the \s-1MQ\s0 register. \s-1GCC\s0 assumes a generic
+processor model for scheduling purposes.
+.Sp
+\&\fB\-mcpu=power\fR, \fB\-mcpu=power2\fR, \fB\-mcpu=powerpc\fR, and
+\&\fB\-mcpu=powerpc64\fR specify generic \s-1POWER\s0, \s-1POWER2\s0, pure 32\-bit
+PowerPC (i.e., not \s-1MPC601\s0), and 64\-bit PowerPC architecture machine
+types, with an appropriate, generic processor model assumed for
+scheduling purposes.
+.Sp
+The other options specify a specific processor. Code generated under
+those options will run best on that processor, and may not run at all on
+others.
+.Sp
+The \fB\-mcpu\fR options automatically enable or disable other
+\&\fB\-m\fR options as follows:
+.RS 4
+.Ip "\fBcommon\fR" 4
+.IX Item "common"
+\&\fB\-mno-power\fR, \fB\-mno-powerc\fR
+.Ip "\fBpower\fR" 4
+.IX Item "power"
+.PD 0
+.Ip "\fBpower2\fR" 4
+.IX Item "power2"
+.Ip "\fBrios1\fR" 4
+.IX Item "rios1"
+.Ip "\fBrios2\fR" 4
+.IX Item "rios2"
+.Ip "\fBrsc\fR" 4
+.IX Item "rsc"
+.PD
+\&\fB\-mpower\fR, \fB\-mno-powerpc\fR, \fB\-mno-new-mnemonics\fR
+.Ip "\fBpowerpc\fR" 4
+.IX Item "powerpc"
+.PD 0
+.Ip "\fBrs64a\fR" 4
+.IX Item "rs64a"
+.Ip "\fB602\fR" 4
+.IX Item "602"
+.Ip "\fB603\fR" 4
+.IX Item "603"
+.Ip "\fB603e\fR" 4
+.IX Item "603e"
+.Ip "\fB604\fR" 4
+.IX Item "604"
+.Ip "\fB620\fR" 4
+.IX Item "620"
+.Ip "\fB630\fR" 4
+.IX Item "630"
+.Ip "\fB740\fR" 4
+.IX Item "740"
+.Ip "\fB7400\fR" 4
+.IX Item "7400"
+.Ip "\fB7450\fR" 4
+.IX Item "7450"
+.Ip "\fB750\fR" 4
+.IX Item "750"
+.Ip "\fB505\fR" 4
+.IX Item "505"
+.PD
+\&\fB\-mno-power\fR, \fB\-mpowerpc\fR, \fB\-mnew-mnemonics\fR
+.Ip "\fB601\fR" 4
+.IX Item "601"
+\&\fB\-mpower\fR, \fB\-mpowerpc\fR, \fB\-mnew-mnemonics\fR
+.Ip "\fB403\fR" 4
+.IX Item "403"
+.PD 0
+.Ip "\fB821\fR" 4
+.IX Item "821"
+.Ip "\fB860\fR" 4
+.IX Item "860"
+.PD
+\&\fB\-mno-power\fR, \fB\-mpowerpc\fR, \fB\-mnew-mnemonics\fR, \fB\-msoft-float\fR
+.RE
+.RS 4
+.RE
+.Ip "\fB\-mtune=\fR\fIcpu_type\fR" 4
+.IX Item "-mtune=cpu_type"
+Set the instruction scheduling parameters for machine type
+\&\fIcpu_type\fR, but do not set the architecture type, register usage, or
+choice of mnemonics, as \fB\-mcpu=\fR\fIcpu_type\fR would. The same
+values for \fIcpu_type\fR are used for \fB\-mtune\fR as for
+\&\fB\-mcpu\fR. If both are specified, the code generated will use the
+architecture, registers, and mnemonics set by \fB\-mcpu\fR, but the
+scheduling parameters set by \fB\-mtune\fR.
+.Ip "\fB\-maltivec\fR" 4
+.IX Item "-maltivec"
+.PD 0
+.Ip "\fB\-mno-altivec\fR" 4
+.IX Item "-mno-altivec"
+.PD
+These switches enable or disable the use of built-in functions that
+allow access to the AltiVec instruction set. You may also need to set
+\&\fB\-mabi=altivec\fR to adjust the current \s-1ABI\s0 with AltiVec \s-1ABI\s0
+enhancements.
+.Sp
+This option is not supported on Mac \s-1OS\s0 X; use \fB\-faltivec\fR instead.
+.Ip "\fB\-mfull-toc\fR" 4
+.IX Item "-mfull-toc"
+.PD 0
+.Ip "\fB\-mno-fp-in-toc\fR" 4
+.IX Item "-mno-fp-in-toc"
+.Ip "\fB\-mno-sum-in-toc\fR" 4
+.IX Item "-mno-sum-in-toc"
+.Ip "\fB\-mminimal-toc\fR" 4
+.IX Item "-mminimal-toc"
+.PD
+Modify generation of the \s-1TOC\s0 (Table Of Contents), which is created for
+every executable file. The \fB\-mfull-toc\fR option is selected by
+default. In that case, \s-1GCC\s0 will allocate at least one \s-1TOC\s0 entry for
+each unique non-automatic variable reference in your program. \s-1GCC\s0
+will also place floating-point constants in the \s-1TOC\s0. However, only
+16,384 entries are available in the \s-1TOC\s0.
+.Sp
+If you receive a linker error message that saying you have overflowed
+the available \s-1TOC\s0 space, you can reduce the amount of \s-1TOC\s0 space used
+with the \fB\-mno-fp-in-toc\fR and \fB\-mno-sum-in-toc\fR options.
+\&\fB\-mno-fp-in-toc\fR prevents \s-1GCC\s0 from putting floating-point
+constants in the \s-1TOC\s0 and \fB\-mno-sum-in-toc\fR forces \s-1GCC\s0 to
+generate code to calculate the sum of an address and a constant at
+run-time instead of putting that sum into the \s-1TOC\s0. You may specify one
+or both of these options. Each causes \s-1GCC\s0 to produce very slightly
+slower and larger code at the expense of conserving \s-1TOC\s0 space.
+.Sp
+If you still run out of space in the \s-1TOC\s0 even when you specify both of
+these options, specify \fB\-mminimal-toc\fR instead. This option causes
+\&\s-1GCC\s0 to make only one \s-1TOC\s0 entry for every file. When you specify this
+option, \s-1GCC\s0 will produce code that is slower and larger but which
+uses extremely little \s-1TOC\s0 space. You may wish to use this option
+only on files that contain less frequently executed code.
+.Ip "\fB\-maix64\fR" 4
+.IX Item "-maix64"
+.PD 0
+.Ip "\fB\-maix32\fR" 4
+.IX Item "-maix32"
+.PD
+Enable 64\-bit \s-1AIX\s0 \s-1ABI\s0 and calling convention: 64\-bit pointers, 64\-bit
+\&\f(CW\*(C`long\*(C'\fR type, and the infrastructure needed to support them.
+Specifying \fB\-maix64\fR implies \fB\-mpowerpc64\fR and
+\&\fB\-mpowerpc\fR, while \fB\-maix32\fR disables the 64\-bit \s-1ABI\s0 and
+implies \fB\-mno-powerpc64\fR. \s-1GCC\s0 defaults to \fB\-maix32\fR.
+.Ip "\fB\-mxl-call\fR" 4
+.IX Item "-mxl-call"
+.PD 0
+.Ip "\fB\-mno-xl-call\fR" 4
+.IX Item "-mno-xl-call"
+.PD
+On \s-1AIX\s0, pass floating-point arguments to prototyped functions beyond the
+register save area (\s-1RSA\s0) on the stack in addition to argument FPRs. The
+\&\s-1AIX\s0 calling convention was extended but not initially documented to
+handle an obscure K&R C case of calling a function that takes the
+address of its arguments with fewer arguments than declared. \s-1AIX\s0 \s-1XL\s0
+compilers access floating point arguments which do not fit in the
+\&\s-1RSA\s0 from the stack when a subroutine is compiled without
+optimization. Because always storing floating-point arguments on the
+stack is inefficient and rarely needed, this option is not enabled by
+default and only is necessary when calling subroutines compiled by \s-1AIX\s0
+\&\s-1XL\s0 compilers without optimization.
+.Ip "\fB\-mpe\fR" 4
+.IX Item "-mpe"
+Support \fI\s-1IBM\s0 \s-1RS/6000\s0 \s-1SP\s0\fR \fIParallel Environment\fR (\s-1PE\s0). Link an
+application written to use message passing with special startup code to
+enable the application to run. The system must have \s-1PE\s0 installed in the
+standard location (\fI/usr/lpp/ppe.poe/\fR), or the \fIspecs\fR file
+must be overridden with the \fB\-specs=\fR option to specify the
+appropriate directory location. The Parallel Environment does not
+support threads, so the \fB\-mpe\fR option and the \fB\-pthread\fR
+option are incompatible.
+.Ip "\fB\-malign-mac68k\fR" 4
+.IX Item "-malign-mac68k"
+.PD 0
+.Ip "\fB\-malign-power\fR" 4
+.IX Item "-malign-power"
+.Ip "\fB\-malign-natural\fR" 4
+.IX Item "-malign-natural"
+.PD
+The option \fB\-malign-mac68k\fR causes structure fields to be aligned
+on 2\-byte boundaries, in order to be compatible with m68k compiler
+output. The option \fB\-malign-power\fR is the standard alignment
+mode for the PowerPC. The option \fB\-malign-natural\fR is an
+extension of PowerPC alignment that aligns larger data types such as
+doubles on their natural boundaries. (\s-1APPLE\s0 \s-1ONLY\s0)
+.Ip "\fB\-msoft-float\fR" 4
+.IX Item "-msoft-float"
+.PD 0
+.Ip "\fB\-mhard-float\fR" 4
+.IX Item "-mhard-float"
+.PD
+Generate code that does not use (uses) the floating-point register set.
+Software floating point emulation is provided if you use the
+\&\fB\-msoft-float\fR option, and pass the option to \s-1GCC\s0 when linking.
+.Ip "\fB\-mmultiple\fR" 4
+.IX Item "-mmultiple"
+.PD 0
+.Ip "\fB\-mno-multiple\fR" 4
+.IX Item "-mno-multiple"
+.PD
+Generate code that uses (does not use) the load multiple word
+instructions and the store multiple word instructions. These
+instructions are generated by default on \s-1POWER\s0 systems, and not
+generated on PowerPC systems. Do not use \fB\-mmultiple\fR on little
+endian PowerPC systems, since those instructions do not work when the
+processor is in little endian mode. The exceptions are \s-1PPC740\s0 and
+\&\s-1PPC750\s0 which permit the instructions usage in little endian mode.
+.Ip "\fB\-mstring\fR" 4
+.IX Item "-mstring"
+.PD 0
+.Ip "\fB\-mno-string\fR" 4
+.IX Item "-mno-string"
+.PD
+Generate code that uses (does not use) the load string instructions
+and the store string word instructions to save multiple registers and
+do small block moves. These instructions are generated by default on
+\&\s-1POWER\s0 systems, and not generated on PowerPC systems. Do not use
+\&\fB\-mstring\fR on little endian PowerPC systems, since those
+instructions do not work when the processor is in little endian mode.
+The exceptions are \s-1PPC740\s0 and \s-1PPC750\s0 which permit the instructions
+usage in little endian mode.
+.Ip "\fB\-mupdate\fR" 4
+.IX Item "-mupdate"
+.PD 0
+.Ip "\fB\-mno-update\fR" 4
+.IX Item "-mno-update"
+.PD
+Generate code that uses (does not use) the load or store instructions
+that update the base register to the address of the calculated memory
+location. These instructions are generated by default. If you use
+\&\fB\-mno-update\fR, there is a small window between the time that the
+stack pointer is updated and the address of the previous frame is
+stored, which means code that walks the stack frame across interrupts or
+signals may get corrupted data.
+.Ip "\fB\-mfused-madd\fR" 4
+.IX Item "-mfused-madd"
+.PD 0
+.Ip "\fB\-mno-fused-madd\fR" 4
+.IX Item "-mno-fused-madd"
+.PD
+Generate code that uses (does not use) the floating point multiply and
+accumulate instructions. These instructions are generated by default if
+hardware floating is used.
+.Ip "\fB\-mno-bit-align\fR" 4
+.IX Item "-mno-bit-align"
+.PD 0
+.Ip "\fB\-mbit-align\fR" 4
+.IX Item "-mbit-align"
+.PD
+On System V.4 and embedded PowerPC systems do not (do) force structures
+and unions that contain bit-fields to be aligned to the base type of the
+bit-field.
+.Sp
+For example, by default a structure containing nothing but 8
+\&\f(CW\*(C`unsigned\*(C'\fR bit-fields of length 1 would be aligned to a 4 byte
+boundary and have a size of 4 bytes. By using \fB\-mno-bit-align\fR,
+the structure would be aligned to a 1 byte boundary and be one byte in
+size.
+.Ip "\fB\-mno-strict-align\fR" 4
+.IX Item "-mno-strict-align"
+.PD 0
+.Ip "\fB\-mstrict-align\fR" 4
+.IX Item "-mstrict-align"
+.PD
+On System V.4 and embedded PowerPC systems do not (do) assume that
+unaligned memory references will be handled by the system.
+.Ip "\fB\-mrelocatable\fR" 4
+.IX Item "-mrelocatable"
+.PD 0
+.Ip "\fB\-mno-relocatable\fR" 4
+.IX Item "-mno-relocatable"
+.PD
+On embedded PowerPC systems generate code that allows (does not allow)
+the program to be relocated to a different address at runtime. If you
+use \fB\-mrelocatable\fR on any module, all objects linked together must
+be compiled with \fB\-mrelocatable\fR or \fB\-mrelocatable-lib\fR.
+.Ip "\fB\-mrelocatable-lib\fR" 4
+.IX Item "-mrelocatable-lib"
+.PD 0
+.Ip "\fB\-mno-relocatable-lib\fR" 4
+.IX Item "-mno-relocatable-lib"
+.PD
+On embedded PowerPC systems generate code that allows (does not allow)
+the program to be relocated to a different address at runtime. Modules
+compiled with \fB\-mrelocatable-lib\fR can be linked with either modules
+compiled without \fB\-mrelocatable\fR and \fB\-mrelocatable-lib\fR or
+with modules compiled with the \fB\-mrelocatable\fR options.
+.Ip "\fB\-mno-toc\fR" 4
+.IX Item "-mno-toc"
+.PD 0
+.Ip "\fB\-mtoc\fR" 4
+.IX Item "-mtoc"
+.PD
+On System V.4 and embedded PowerPC systems do not (do) assume that
+register 2 contains a pointer to a global area pointing to the addresses
+used in the program.
+.Ip "\fB\-mlittle\fR" 4
+.IX Item "-mlittle"
+.PD 0
+.Ip "\fB\-mlittle-endian\fR" 4
+.IX Item "-mlittle-endian"
+.PD
+On System V.4 and embedded PowerPC systems compile code for the
+processor in little endian mode. The \fB\-mlittle-endian\fR option is
+the same as \fB\-mlittle\fR.
+.Ip "\fB\-mbig\fR" 4
+.IX Item "-mbig"
+.PD 0
+.Ip "\fB\-mbig-endian\fR" 4
+.IX Item "-mbig-endian"
+.PD
+On System V.4 and embedded PowerPC systems compile code for the
+processor in big endian mode. The \fB\-mbig-endian\fR option is
+the same as \fB\-mbig\fR.
+.Ip "\fB\-mdynamic-no-pic\fR" 4
+.IX Item "-mdynamic-no-pic"
+On Darwin and Mac \s-1OS\s0 X systems, compile code so that it is not
+relocatable, but that its external references are relocatable. The
+resulting code is suitable for applications, but not shared
+libraries. (\s-1APPLE\s0 \s-1ONLY\s0)
+.Ip "\fB\-mlong-branch\fR" 4
+.IX Item "-mlong-branch"
+On Darwin and Mac \s-1OS\s0 X systems, compile calls to use a 32\-bit
+destination address. This is to support kernel extensions, which may
+load anywhere within the kernel address space. (\s-1APPLE\s0 \s-1ONLY\s0)
+.Ip "\fB\-mcall-sysv\fR" 4
+.IX Item "-mcall-sysv"
+On System V.4 and embedded PowerPC systems compile code using calling
+conventions that adheres to the March 1995 draft of the System V
+Application Binary Interface, PowerPC processor supplement. This is the
+default unless you configured \s-1GCC\s0 using \fBpowerpc-*\-eabiaix\fR.
+.Ip "\fB\-mcall-sysv-eabi\fR" 4
+.IX Item "-mcall-sysv-eabi"
+Specify both \fB\-mcall-sysv\fR and \fB\-meabi\fR options.
+.Ip "\fB\-mcall-sysv-noeabi\fR" 4
+.IX Item "-mcall-sysv-noeabi"
+Specify both \fB\-mcall-sysv\fR and \fB\-mno-eabi\fR options.
+.Ip "\fB\-mcall-aix\fR" 4
+.IX Item "-mcall-aix"
+On System V.4 and embedded PowerPC systems compile code using calling
+conventions that are similar to those used on \s-1AIX\s0. This is the
+default if you configured \s-1GCC\s0 using \fBpowerpc-*\-eabiaix\fR.
+.Ip "\fB\-mcall-solaris\fR" 4
+.IX Item "-mcall-solaris"
+On System V.4 and embedded PowerPC systems compile code for the Solaris
+operating system.
+.Ip "\fB\-mcall-linux\fR" 4
+.IX Item "-mcall-linux"
+On System V.4 and embedded PowerPC systems compile code for the
+Linux-based \s-1GNU\s0 system.
+.Ip "\fB\-mcall-gnu\fR" 4
+.IX Item "-mcall-gnu"
+On System V.4 and embedded PowerPC systems compile code for the
+Hurd-based \s-1GNU\s0 system.
+.Ip "\fB\-mcall-netbsd\fR" 4
+.IX Item "-mcall-netbsd"
+On System V.4 and embedded PowerPC systems compile code for the
+NetBSD operating system.
+.Ip "\fB\-maix-struct-return\fR" 4
+.IX Item "-maix-struct-return"
+Return all structures in memory (as specified by the \s-1AIX\s0 \s-1ABI\s0).
+.Ip "\fB\-msvr4\-struct-return\fR" 4
+.IX Item "-msvr4-struct-return"
+Return structures smaller than 8 bytes in registers (as specified by the
+\&\s-1SVR4\s0 \s-1ABI\s0).
+.Ip "\fB\-mabi=altivec\fR" 4
+.IX Item "-mabi=altivec"
+Extend the current \s-1ABI\s0 with AltiVec \s-1ABI\s0 extensions. This does not
+change the default \s-1ABI\s0, instead it adds the AltiVec \s-1ABI\s0 extensions to
+the current \s-1ABI\s0.
+.Sp
+This option is effectively permanently enabled on Mac \s-1OS\s0 X.
+.Ip "\fB\-mabi=no-altivec\fR" 4
+.IX Item "-mabi=no-altivec"
+Disable AltiVec \s-1ABI\s0 extensions for the current \s-1ABI\s0.
+.Sp
+This option will not work on Mac \s-1OS\s0 X.
+.Ip "\fB\-mprototype\fR" 4
+.IX Item "-mprototype"
+.PD 0
+.Ip "\fB\-mno-prototype\fR" 4
+.IX Item "-mno-prototype"
+.PD
+On System V.4 and embedded PowerPC systems assume that all calls to
+variable argument functions are properly prototyped. Otherwise, the
+compiler must insert an instruction before every non prototyped call to
+set or clear bit 6 of the condition code register (\fI\s-1CR\s0\fR) to
+indicate whether floating point values were passed in the floating point
+registers in case the function takes a variable arguments. With
+\&\fB\-mprototype\fR, only calls to prototyped variable argument functions
+will set or clear the bit.
+.Ip "\fB\-msim\fR" 4
+.IX Item "-msim"
+On embedded PowerPC systems, assume that the startup module is called
+\&\fIsim-crt0.o\fR and that the standard C libraries are \fIlibsim.a\fR and
+\&\fIlibc.a\fR. This is the default for \fBpowerpc-*\-eabisim\fR.
+configurations.
+.Ip "\fB\-mmvme\fR" 4
+.IX Item "-mmvme"
+On embedded PowerPC systems, assume that the startup module is called
+\&\fIcrt0.o\fR and the standard C libraries are \fIlibmvme.a\fR and
+\&\fIlibc.a\fR.
+.Ip "\fB\-mads\fR" 4
+.IX Item "-mads"
+On embedded PowerPC systems, assume that the startup module is called
+\&\fIcrt0.o\fR and the standard C libraries are \fIlibads.a\fR and
+\&\fIlibc.a\fR.
+.Ip "\fB\-myellowknife\fR" 4
+.IX Item "-myellowknife"
+On embedded PowerPC systems, assume that the startup module is called
+\&\fIcrt0.o\fR and the standard C libraries are \fIlibyk.a\fR and
+\&\fIlibc.a\fR.
+.Ip "\fB\-mvxworks\fR" 4
+.IX Item "-mvxworks"
+On System V.4 and embedded PowerPC systems, specify that you are
+compiling for a VxWorks system.
+.Ip "\fB\-memb\fR" 4
+.IX Item "-memb"
+On embedded PowerPC systems, set the \fI\s-1PPC_EMB\s0\fR bit in the \s-1ELF\s0 flags
+header to indicate that \fBeabi\fR extended relocations are used.
+.Ip "\fB\-meabi\fR" 4
+.IX Item "-meabi"
+.PD 0
+.Ip "\fB\-mno-eabi\fR" 4
+.IX Item "-mno-eabi"
+.PD
+On System V.4 and embedded PowerPC systems do (do not) adhere to the
+Embedded Applications Binary Interface (eabi) which is a set of
+modifications to the System V.4 specifications. Selecting \fB\-meabi\fR
+means that the stack is aligned to an 8 byte boundary, a function
+\&\f(CW\*(C`_\|_eabi\*(C'\fR is called to from \f(CW\*(C`main\*(C'\fR to set up the eabi
+environment, and the \fB\-msdata\fR option can use both \f(CW\*(C`r2\*(C'\fR and
+\&\f(CW\*(C`r13\*(C'\fR to point to two separate small data areas. Selecting
+\&\fB\-mno-eabi\fR means that the stack is aligned to a 16 byte boundary,
+do not call an initialization function from \f(CW\*(C`main\*(C'\fR, and the
+\&\fB\-msdata\fR option will only use \f(CW\*(C`r13\*(C'\fR to point to a single
+small data area. The \fB\-meabi\fR option is on by default if you
+configured \s-1GCC\s0 using one of the \fBpowerpc*\-*\-eabi*\fR options.
+.Ip "\fB\-msdata=eabi\fR" 4
+.IX Item "-msdata=eabi"
+On System V.4 and embedded PowerPC systems, put small initialized
+\&\f(CW\*(C`const\*(C'\fR global and static data in the \fB.sdata2\fR section, which
+is pointed to by register \f(CW\*(C`r2\*(C'\fR. Put small initialized
+non-\f(CW\*(C`const\*(C'\fR global and static data in the \fB.sdata\fR section,
+which is pointed to by register \f(CW\*(C`r13\*(C'\fR. Put small uninitialized
+global and static data in the \fB.sbss\fR section, which is adjacent to
+the \fB.sdata\fR section. The \fB\-msdata=eabi\fR option is
+incompatible with the \fB\-mrelocatable\fR option. The
+\&\fB\-msdata=eabi\fR option also sets the \fB\-memb\fR option.
+.Ip "\fB\-msdata=sysv\fR" 4
+.IX Item "-msdata=sysv"
+On System V.4 and embedded PowerPC systems, put small global and static
+data in the \fB.sdata\fR section, which is pointed to by register
+\&\f(CW\*(C`r13\*(C'\fR. Put small uninitialized global and static data in the
+\&\fB.sbss\fR section, which is adjacent to the \fB.sdata\fR section.
+The \fB\-msdata=sysv\fR option is incompatible with the
+\&\fB\-mrelocatable\fR option.
+.Ip "\fB\-msdata=default\fR" 4
+.IX Item "-msdata=default"
+.PD 0
+.Ip "\fB\-msdata\fR" 4
+.IX Item "-msdata"
+.PD
+On System V.4 and embedded PowerPC systems, if \fB\-meabi\fR is used,
+compile code the same as \fB\-msdata=eabi\fR, otherwise compile code the
+same as \fB\-msdata=sysv\fR.
+.Ip "\fB\-msdata-data\fR" 4
+.IX Item "-msdata-data"
+On System V.4 and embedded PowerPC systems, put small global and static
+data in the \fB.sdata\fR section. Put small uninitialized global and
+static data in the \fB.sbss\fR section. Do not use register \f(CW\*(C`r13\*(C'\fR
+to address small data however. This is the default behavior unless
+other \fB\-msdata\fR options are used.
+.Ip "\fB\-msdata=none\fR" 4
+.IX Item "-msdata=none"
+.PD 0
+.Ip "\fB\-mno-sdata\fR" 4
+.IX Item "-mno-sdata"
+.PD
+On embedded PowerPC systems, put all initialized global and static data
+in the \fB.data\fR section, and all uninitialized data in the
+\&\fB.bss\fR section.
+.Ip "\fB\-G\fR \fInum\fR" 4
+.IX Item "-G num"
+On embedded PowerPC systems, put global and static items less than or
+equal to \fInum\fR bytes into the small data or bss sections instead of
+the normal data or bss section. By default, \fInum\fR is 8. The
+\&\fB\-G\fR \fInum\fR switch is also passed to the linker.
+All modules should be compiled with the same \fB\-G\fR \fInum\fR value.
+.Ip "\fB\-mregnames\fR" 4
+.IX Item "-mregnames"
+.PD 0
+.Ip "\fB\-mno-regnames\fR" 4
+.IX Item "-mno-regnames"
+.PD
+On System V.4 and embedded PowerPC systems do (do not) emit register
+names in the assembly language output using symbolic forms.
+.Ip "\fB\-pthread\fR" 4
+.IX Item "-pthread"
+Adds support for multithreading with the \fIpthreads\fR library.
+This option sets flags for both the preprocessor and linker.
+.PP
+.I "Intel 386 and \s-1AMD\s0 x86\-64 Options"
+.IX Subsection "Intel 386 and AMD x86-64 Options"
+.PP
+These \fB\-m\fR options are defined for the i386 and x86\-64 family of
+computers:
+.Ip "\fB\-mcpu=\fR\fIcpu-type\fR" 4
+.IX Item "-mcpu=cpu-type"
+Tune to \fIcpu-type\fR everything applicable about the generated code, except
+for the \s-1ABI\s0 and the set of available instructions. The choices for
+\&\fIcpu-type\fR are \fBi386\fR, \fBi486\fR, \fBi586\fR, \fBi686\fR,
+\&\fBpentium\fR, \fBpentium-mmx\fR, \fBpentiumpro\fR, \fBpentium2\fR,
+\&\fBpentium3\fR, \fBpentium4\fR, \fBk6\fR, \fBk6\-2\fR, \fBk6\-3\fR,
+\&\fBathlon\fR, \fBathlon-tbird\fR, \fBathlon-4\fR, \fBathlon-xp\fR
+and \fBathlon-mp\fR.
+.Sp
+While picking a specific \fIcpu-type\fR will schedule things appropriately
+for that particular chip, the compiler will not generate any code that
+does not run on the i386 without the \fB\-march=\fR\fIcpu-type\fR option
+being used. \fBi586\fR is equivalent to \fBpentium\fR and \fBi686\fR
+is equivalent to \fBpentiumpro\fR. \fBk6\fR and \fBathlon\fR are the
+\&\s-1AMD\s0 chips as opposed to the Intel ones.
+.Ip "\fB\-march=\fR\fIcpu-type\fR" 4
+.IX Item "-march=cpu-type"
+Generate instructions for the machine type \fIcpu-type\fR. The choices
+for \fIcpu-type\fR are the same as for \fB\-mcpu\fR. Moreover,
+specifying \fB\-march=\fR\fIcpu-type\fR implies \fB\-mcpu=\fR\fIcpu-type\fR.
+.Ip "\fB\-m386\fR" 4
+.IX Item "-m386"
+.PD 0
+.Ip "\fB\-m486\fR" 4
+.IX Item "-m486"
+.Ip "\fB\-mpentium\fR" 4
+.IX Item "-mpentium"
+.Ip "\fB\-mpentiumpro\fR" 4
+.IX Item "-mpentiumpro"
+.PD
+These options are synonyms for \fB\-mcpu=i386\fR, \fB\-mcpu=i486\fR,
+\&\fB\-mcpu=pentium\fR, and \fB\-mcpu=pentiumpro\fR respectively.
+These synonyms are deprecated.
+.Ip "\fB\-mfpmath=\fR\fIunit\fR" 4
+.IX Item "-mfpmath=unit"
+generate floating point arithmetics for selected unit \fIunit\fR. the choices
+for \fIunit\fR are:
+.RS 4
+.Ip "\fB387\fR" 4
+.IX Item "387"
+Use the standard 387 floating point coprocessor present majority of chips and
+emulated otherwise. Code compiled with this option will run almost everywhere.
+The temporary results are computed in 80bit precesion instead of precision
+specified by the type resulting in slightly different results compared to most
+of other chips. See \fB\-ffloat-store\fR for more detailed description.
+.Sp
+This is the default choice for i386 compiler.
+.Ip "\fBsse\fR" 4
+.IX Item "sse"
+Use scalar floating point instructions present in the \s-1SSE\s0 instruction set.
+This instruction set is supported by Pentium3 and newer chips, in the \s-1AMD\s0 line
+by Athlon-4, Athlon-xp and Athlon-mp chips. The earlier version of \s-1SSE\s0
+instruction set supports only single precision arithmetics, thus the double and
+extended precision arithmetics is still done using 387. Later version, present
+only in Pentium4 and the future \s-1AMD\s0 x86\-64 chips supports double precision
+arithmetics too.
+.Sp
+For i387 you need to use \fB\-march=\fR\fIcpu-type\fR, \fB\-msse\fR or
+\&\fB\-msse2\fR switches to enable \s-1SSE\s0 extensions and make this option
+effective. For x86\-64 compiler, these extensions are enabled by default.
+.Sp
+The resulting code should be considerably faster in majority of cases and avoid
+the numerical instability problems of 387 code, but may break some existing
+code that expects temporaries to be 80bit.
+.Sp
+This is the default choice for x86\-64 compiler.
+.Ip "\fBsse,387\fR" 4
+.IX Item "sse,387"
+Attempt to utilize both instruction sets at once. This effectivly double the
+amount of available registers and on chips with separate execution units for
+387 and \s-1SSE\s0 the execution resources too. Use this option with care, as it is
+still experimental, because gcc register allocator does not model separate
+functional units well resulting in instable performance.
+.RE
+.RS 4
+.RE
+.Ip "\fB\-masm=\fR\fIdialect\fR" 4
+.IX Item "-masm=dialect"
+Output asm instructions using selected \fIdialect\fR. Supported choices are
+\&\fBintel\fR or \fBatt\fR (the default one).
+.Ip "\fB\-mieee-fp\fR" 4
+.IX Item "-mieee-fp"
+.PD 0
+.Ip "\fB\-mno-ieee-fp\fR" 4
+.IX Item "-mno-ieee-fp"
+.PD
+Control whether or not the compiler uses \s-1IEEE\s0 floating point
+comparisons. These handle correctly the case where the result of a
+comparison is unordered.
+.Ip "\fB\-msoft-float\fR" 4
+.IX Item "-msoft-float"
+Generate output containing library calls for floating point.
+\&\fBWarning:\fR the requisite libraries are not part of \s-1GCC\s0.
+Normally the facilities of the machine's usual C compiler are used, but
+this can't be done directly in cross-compilation. You must make your
+own arrangements to provide suitable library functions for
+cross-compilation.
+.Sp
+On machines where a function returns floating point results in the 80387
+register stack, some floating point opcodes may be emitted even if
+\&\fB\-msoft-float\fR is used.
+.Ip "\fB\-mno-fp-ret-in-387\fR" 4
+.IX Item "-mno-fp-ret-in-387"
+Do not use the \s-1FPU\s0 registers for return values of functions.
+.Sp
+The usual calling convention has functions return values of types
+\&\f(CW\*(C`float\*(C'\fR and \f(CW\*(C`double\*(C'\fR in an \s-1FPU\s0 register, even if there
+is no \s-1FPU\s0. The idea is that the operating system should emulate
+an \s-1FPU\s0.
+.Sp
+The option \fB\-mno-fp-ret-in-387\fR causes such values to be returned
+in ordinary \s-1CPU\s0 registers instead.
+.Ip "\fB\-mno-fancy-math-387\fR" 4
+.IX Item "-mno-fancy-math-387"
+Some 387 emulators do not support the \f(CW\*(C`sin\*(C'\fR, \f(CW\*(C`cos\*(C'\fR and
+\&\f(CW\*(C`sqrt\*(C'\fR instructions for the 387. Specify this option to avoid
+generating those instructions. This option is the default on FreeBSD,
+OpenBSD and NetBSD. This option is overridden when \fB\-march\fR
+indicates that the target cpu will always have an \s-1FPU\s0 and so the
+instruction will not need emulation. As of revision 2.6.1, these
+instructions are not generated unless you also use the
+\&\fB\-funsafe-math-optimizations\fR switch.
+.Ip "\fB\-malign-double\fR" 4
+.IX Item "-malign-double"
+.PD 0
+.Ip "\fB\-mno-align-double\fR" 4
+.IX Item "-mno-align-double"
+.PD
+Control whether \s-1GCC\s0 aligns \f(CW\*(C`double\*(C'\fR, \f(CW\*(C`long double\*(C'\fR, and
+\&\f(CW\*(C`long long\*(C'\fR variables on a two word boundary or a one word
+boundary. Aligning \f(CW\*(C`double\*(C'\fR variables on a two word boundary will
+produce code that runs somewhat faster on a \fBPentium\fR at the
+expense of more memory.
+.Ip "\fB\-m128bit-long-double\fR" 4
+.IX Item "-m128bit-long-double"
+Control the size of \f(CW\*(C`long double\*(C'\fR type. i386 application binary interface
+specify the size to be 12 bytes, while modern architectures (Pentium and newer)
+prefer \f(CW\*(C`long double\*(C'\fR aligned to 8 or 16 byte boundary. This is
+impossible to reach with 12 byte long doubles in the array accesses.
+.Sp
+\&\fBWarning:\fR if you use the \fB\-m128bit-long-double\fR switch, the
+structures and arrays containing \f(CW\*(C`long double\*(C'\fR will change their size as
+well as function calling convention for function taking \f(CW\*(C`long double\*(C'\fR
+will be modified.
+.Ip "\fB\-m96bit-long-double\fR" 4
+.IX Item "-m96bit-long-double"
+Set the size of \f(CW\*(C`long double\*(C'\fR to 96 bits as required by the i386
+application binary interface. This is the default.
+.Ip "\fB\-msvr3\-shlib\fR" 4
+.IX Item "-msvr3-shlib"
+.PD 0
+.Ip "\fB\-mno-svr3\-shlib\fR" 4
+.IX Item "-mno-svr3-shlib"
+.PD
+Control whether \s-1GCC\s0 places uninitialized local variables into the
+\&\f(CW\*(C`bss\*(C'\fR or \f(CW\*(C`data\*(C'\fR segments. \fB\-msvr3\-shlib\fR places them
+into \f(CW\*(C`bss\*(C'\fR. These options are meaningful only on System V Release 3.
+.Ip "\fB\-mrtd\fR" 4
+.IX Item "-mrtd"
+Use a different function-calling convention, in which functions that
+take a fixed number of arguments return with the \f(CW\*(C`ret\*(C'\fR \fInum\fR
+instruction, which pops their arguments while returning. This saves one
+instruction in the caller since there is no need to pop the arguments
+there.
+.Sp
+You can specify that an individual function is called with this calling
+sequence with the function attribute \fBstdcall\fR. You can also
+override the \fB\-mrtd\fR option by using the function attribute
+\&\fBcdecl\fR.
+.Sp
+\&\fBWarning:\fR this calling convention is incompatible with the one
+normally used on Unix, so you cannot use it if you need to call
+libraries compiled with the Unix compiler.
+.Sp
+Also, you must provide function prototypes for all functions that
+take variable numbers of arguments (including \f(CW\*(C`printf\*(C'\fR);
+otherwise incorrect code will be generated for calls to those
+functions.
+.Sp
+In addition, seriously incorrect code will result if you call a
+function with too many arguments. (Normally, extra arguments are
+harmlessly ignored.)
+.Ip "\fB\-mregparm=\fR\fInum\fR" 4
+.IX Item "-mregparm=num"
+Control how many registers are used to pass integer arguments. By
+default, no registers are used to pass arguments, and at most 3
+registers can be used. You can control this behavior for a specific
+function by using the function attribute \fBregparm\fR.
+.Sp
+\&\fBWarning:\fR if you use this switch, and
+\&\fInum\fR is nonzero, then you must build all modules with the same
+value, including any libraries. This includes the system libraries and
+startup modules.
+.Ip "\fB\-mpreferred-stack-boundary=\fR\fInum\fR" 4
+.IX Item "-mpreferred-stack-boundary=num"
+Attempt to keep the stack boundary aligned to a 2 raised to \fInum\fR
+byte boundary. If \fB\-mpreferred-stack-boundary\fR is not specified,
+the default is 4 (16 bytes or 128 bits), except when optimizing for code
+size (\fB\-Os\fR), in which case the default is the minimum correct
+alignment (4 bytes for x86, and 8 bytes for x86\-64).
+.Sp
+On Pentium and PentiumPro, \f(CW\*(C`double\*(C'\fR and \f(CW\*(C`long double\*(C'\fR values
+should be aligned to an 8 byte boundary (see \fB\-malign-double\fR) or
+suffer significant run time performance penalties. On Pentium \s-1III\s0, the
+Streaming \s-1SIMD\s0 Extension (\s-1SSE\s0) data type \f(CW\*(C`_\|_m128\*(C'\fR suffers similar
+penalties if it is not 16 byte aligned.
+.Sp
+To ensure proper alignment of this values on the stack, the stack boundary
+must be as aligned as that required by any value stored on the stack.
+Further, every function must be generated such that it keeps the stack
+aligned. Thus calling a function compiled with a higher preferred
+stack boundary from a function compiled with a lower preferred stack
+boundary will most likely misalign the stack. It is recommended that
+libraries that use callbacks always use the default setting.
+.Sp
+This extra alignment does consume extra stack space, and generally
+increases code size. Code that is sensitive to stack space usage, such
+as embedded systems and operating system kernels, may want to reduce the
+preferred alignment to \fB\-mpreferred-stack-boundary=2\fR.
+.Ip "\fB\-mmmx\fR" 4
+.IX Item "-mmmx"
+.PD 0
+.Ip "\fB\-mno-mmx\fR" 4
+.IX Item "-mno-mmx"
+.Ip "\fB\-msse\fR" 4
+.IX Item "-msse"
+.Ip "\fB\-mno-sse\fR" 4
+.IX Item "-mno-sse"
+.Ip "\fB\-msse2\fR" 4
+.IX Item "-msse2"
+.Ip "\fB\-mno-sse2\fR" 4
+.IX Item "-mno-sse2"
+.Ip "\fB\-m3dnow\fR" 4
+.IX Item "-m3dnow"
+.Ip "\fB\-mno-3dnow\fR" 4
+.IX Item "-mno-3dnow"
+.PD
+These switches enable or disable the use of built-in functions that allow
+direct access to the \s-1MMX\s0, \s-1SSE\s0 and 3Dnow extensions of the instruction set.
+.Ip "\fB\-mpush-args\fR" 4
+.IX Item "-mpush-args"
+.PD 0
+.Ip "\fB\-mno-push-args\fR" 4
+.IX Item "-mno-push-args"
+.PD
+Use \s-1PUSH\s0 operations to store outgoing parameters. This method is shorter
+and usually equally fast as method using \s-1SUB/MOV\s0 operations and is enabled
+by default. In some cases disabling it may improve performance because of
+improved scheduling and reduced dependencies.
+.Ip "\fB\-maccumulate-outgoing-args\fR" 4
+.IX Item "-maccumulate-outgoing-args"
+If enabled, the maximum amount of space required for outgoing arguments will be
+computed in the function prologue. This is faster on most modern CPUs
+because of reduced dependencies, improved scheduling and reduced stack usage
+when preferred stack boundary is not equal to 2. The drawback is a notable
+increase in code size. This switch implies \fB\-mno-push-args\fR.
+.Ip "\fB\-mthreads\fR" 4
+.IX Item "-mthreads"
+Support thread-safe exception handling on \fBMingw32\fR. Code that relies
+on thread-safe exception handling must compile and link all code with the
+\&\fB\-mthreads\fR option. When compiling, \fB\-mthreads\fR defines
+\&\fB\-D_MT\fR; when linking, it links in a special thread helper library
+\&\fB\-lmingwthrd\fR which cleans up per thread exception handling data.
+.Ip "\fB\-mno-align-stringops\fR" 4
+.IX Item "-mno-align-stringops"
+Do not align destination of inlined string operations. This switch reduces
+code size and improves performance in case the destination is already aligned,
+but gcc don't know about it.
+.Ip "\fB\-minline-all-stringops\fR" 4
+.IX Item "-minline-all-stringops"
+By default \s-1GCC\s0 inlines string operations only when destination is known to be
+aligned at least to 4 byte boundary. This enables more inlining, increase code
+size, but may improve performance of code that depends on fast memcpy, strlen
+and memset for short lengths.
+.Ip "\fB\-momit-leaf-frame-pointer\fR" 4
+.IX Item "-momit-leaf-frame-pointer"
+Don't keep the frame pointer in a register for leaf functions. This
+avoids the instructions to save, set up and restore frame pointers and
+makes an extra register available in leaf functions. The option
+\&\fB\-fomit-frame-pointer\fR removes the frame pointer for all functions
+which might make debugging harder.
+.PP
+These \fB\-m\fR switches are supported in addition to the above
+on \s-1AMD\s0 x86\-64 processors in 64\-bit environments.
+.Ip "\fB\-m32\fR" 4
+.IX Item "-m32"
+.PD 0
+.Ip "\fB\-m64\fR" 4
+.IX Item "-m64"
+.PD
+Generate code for a 32\-bit or 64\-bit environment.
+The 32\-bit environment sets int, long and pointer to 32 bits and
+generates code that runs on any i386 system.
+The 64\-bit environment sets int to 32 bits and long and pointer
+to 64 bits and generates code for \s-1AMD\s0's x86\-64 architecture.
+.Ip "\fB\-mno-red-zone\fR" 4
+.IX Item "-mno-red-zone"
+Do not use a so called red zone for x86\-64 code. The red zone is mandated
+by the x86\-64 \s-1ABI\s0, it is a 128\-byte area beyond the location of the
+stack pointer that will not be modified by signal or interrupt handlers
+and therefore can be used for temporary data without adjusting the stack
+pointer. The flag \fB\-mno-red-zone\fR disables this red zone.
+.Sh "Options for Code Generation Conventions"
+.IX Subsection "Options for Code Generation Conventions"
+These machine-independent options control the interface conventions
+used in code generation.
+.PP
+Most of them have both positive and negative forms; the negative form
+of \fB\-ffoo\fR would be \fB\-fno-foo\fR. In the table below, only
+one of the forms is listed\-\-\-the one which is not the default. You
+can figure out the other form by either removing \fBno-\fR or adding
+it.
+.Ip "\fB\-fexceptions\fR" 4
+.IX Item "-fexceptions"
+Enable exception handling. Generates extra code needed to propagate
+exceptions. For some targets, this implies \s-1GCC\s0 will generate frame
+unwind information for all functions, which can produce significant data
+size overhead, although it does not affect execution. If you do not
+specify this option, \s-1GCC\s0 will enable it by default for languages like
+\&\*(C+ which normally require exception handling, and disable it for
+languages like C that do not normally require it. However, you may need
+to enable this option when compiling C code that needs to interoperate
+properly with exception handlers written in \*(C+. You may also wish to
+disable this option if you are compiling older \*(C+ programs that don't
+use exception handling.
+.Ip "\fB\-fnon-call-exceptions\fR" 4
+.IX Item "-fnon-call-exceptions"
+Generate code that allows trapping instructions to throw exceptions.
+Note that this requires platform-specific runtime support that does
+not exist everywhere. Moreover, it only allows \fItrapping\fR
+instructions to throw exceptions, i.e. memory references or floating
+point instructions. It does not allow exceptions to be thrown from
+arbitrary signal handlers such as \f(CW\*(C`SIGALRM\*(C'\fR.
+.Ip "\fB\-funwind-tables\fR" 4
+.IX Item "-funwind-tables"
+Similar to \fB\-fexceptions\fR, except that it will just generate any needed
+static data, but will not affect the generated code in any other way.
+You will normally not enable this option; instead, a language processor
+that needs this handling would enable it on your behalf.
+.Ip "\fB\-fasynchronous-unwind-tables\fR" 4
+.IX Item "-fasynchronous-unwind-tables"
+Generate unwind table in dwarf2 format, if supported by target machine. The
+table is exact at each instruction boundary, so it can be used for stack
+unwinding from asynchronous events (such as debugger or garbage collector).
+.Ip "\fB\-fpcc-struct-return\fR" 4
+.IX Item "-fpcc-struct-return"
+Return ``short'' \f(CW\*(C`struct\*(C'\fR and \f(CW\*(C`union\*(C'\fR values in memory like
+longer ones, rather than in registers. This convention is less
+efficient, but it has the advantage of allowing intercallability between
+GCC-compiled files and files compiled with other compilers.
+.Sp
+The precise convention for returning structures in memory depends
+on the target configuration macros.
+.Sp
+Short structures and unions are those whose size and alignment match
+that of some integer type.
+.Ip "\fB\-freg-struct-return\fR" 4
+.IX Item "-freg-struct-return"
+Return \f(CW\*(C`struct\*(C'\fR and \f(CW\*(C`union\*(C'\fR values in registers when possible.
+This is more efficient for small structures than
+\&\fB\-fpcc-struct-return\fR.
+.Sp
+If you specify neither \fB\-fpcc-struct-return\fR nor
+\&\fB\-freg-struct-return\fR, \s-1GCC\s0 defaults to whichever convention is
+standard for the target. If there is no standard convention, \s-1GCC\s0
+defaults to \fB\-fpcc-struct-return\fR, except on targets where \s-1GCC\s0 is
+the principal compiler. In those cases, we can choose the standard, and
+we chose the more efficient register return alternative.
+.Ip "\fB\-fshort-enums\fR" 4
+.IX Item "-fshort-enums"
+Allocate to an \f(CW\*(C`enum\*(C'\fR type only as many bytes as it needs for the
+declared range of possible values. Specifically, the \f(CW\*(C`enum\*(C'\fR type
+will be equivalent to the smallest integer type which has enough room.
+.Ip "\fB\-fshort-double\fR" 4
+.IX Item "-fshort-double"
+Use the same size for \f(CW\*(C`double\*(C'\fR as for \f(CW\*(C`float\*(C'\fR.
+.Ip "\fB\-fshared-data\fR" 4
+.IX Item "-fshared-data"
+Requests that the data and non-\f(CW\*(C`const\*(C'\fR variables of this
+compilation be shared data rather than private data. The distinction
+makes sense only on certain operating systems, where shared data is
+shared between processes running the same program, while private data
+exists in one copy per process.
+.Ip "\fB\-fno-common\fR" 4
+.IX Item "-fno-common"
+In C, allocate even uninitialized global variables in the data section of the
+object file, rather than generating them as common blocks. This has the
+effect that if the same variable is declared (without \f(CW\*(C`extern\*(C'\fR) in
+two different compilations, you will get an error when you link them.
+The only reason this might be useful is if you wish to verify that the
+program will work on other systems which always work this way.
+.Ip "\fB\-fno-ident\fR" 4
+.IX Item "-fno-ident"
+Ignore the \fB#ident\fR directive.
+.Ip "\fB\-fno-gnu-linker\fR" 4
+.IX Item "-fno-gnu-linker"
+Do not output global initializations (such as \*(C+ constructors and
+destructors) in the form used by the \s-1GNU\s0 linker (on systems where the \s-1GNU\s0
+linker is the standard method of handling them). Use this option when
+you want to use a non-GNU linker, which also requires using the
+\&\fBcollect2\fR program to make sure the system linker includes
+constructors and destructors. (\fBcollect2\fR is included in the \s-1GCC\s0
+distribution.) For systems which \fImust\fR use \fBcollect2\fR, the
+compiler driver \fBgcc\fR is configured to do this automatically.
+.Ip "\fB\-finhibit-size-directive\fR" 4
+.IX Item "-finhibit-size-directive"
+Don't output a \f(CW\*(C`.size\*(C'\fR assembler directive, or anything else that
+would cause trouble if the function is split in the middle, and the
+two halves are placed at locations far apart in memory. This option is
+used when compiling \fIcrtstuff.c\fR; you should not need to use it
+for anything else.
+.Ip "\fB\-fverbose-asm\fR" 4
+.IX Item "-fverbose-asm"
+Put extra commentary information in the generated assembly code to
+make it more readable. This option is generally only of use to those
+who actually need to read the generated assembly code (perhaps while
+debugging the compiler itself).
+.Sp
+\&\fB\-fno-verbose-asm\fR, the default, causes the
+extra information to be omitted and is useful when comparing two assembler
+files.
+.Ip "\fB\-fvolatile\fR" 4
+.IX Item "-fvolatile"
+Consider all memory references through pointers to be volatile.
+.Ip "\fB\-fvolatile-global\fR" 4
+.IX Item "-fvolatile-global"
+Consider all memory references to extern and global data items to
+be volatile. \s-1GCC\s0 does not consider static data items to be volatile
+because of this switch.
+.Ip "\fB\-fvolatile-static\fR" 4
+.IX Item "-fvolatile-static"
+Consider all memory references to static data to be volatile.
+.Ip "\fB\-fpic\fR" 4
+.IX Item "-fpic"
+Generate position-independent code (\s-1PIC\s0) suitable for use in a shared
+library, if supported for the target machine. Such code accesses all
+constant addresses through a global offset table (\s-1GOT\s0). The dynamic
+loader resolves the \s-1GOT\s0 entries when the program starts (the dynamic
+loader is not part of \s-1GCC\s0; it is part of the operating system). If
+the \s-1GOT\s0 size for the linked executable exceeds a machine-specific
+maximum size, you get an error message from the linker indicating that
+\&\fB\-fpic\fR does not work; in that case, recompile with \fB\-fPIC\fR
+instead. (These maximums are 16k on the m88k, 8k on the Sparc, and 32k
+on the m68k and \s-1RS/6000\s0. The 386 has no such limit.)
+.Sp
+Position-independent code requires special support, and therefore works
+only on certain machines. For the 386, \s-1GCC\s0 supports \s-1PIC\s0 for System V
+but not for the Sun 386i. Code generated for the \s-1IBM\s0 \s-1RS/6000\s0 is always
+position-independent.
+.Sp
+\&\fB\-fpic\fR is not supported on Mac \s-1OS\s0 X.
+.Ip "\fB\-fPIC\fR" 4
+.IX Item "-fPIC"
+If supported for the target machine, emit position-independent code,
+suitable for dynamic linking and avoiding any limit on the size of the
+global offset table. This option makes a difference on the m68k, m88k,
+and the Sparc.
+.Sp
+Position-independent code requires special support, and therefore works
+only on certain machines.
+.Sp
+\&\fB\-fPIC\fR is the default on Darwin and Mac \s-1OS\s0 X.
+.Ip "\fB\-ffixed-\fR\fIreg\fR" 4
+.IX Item "-ffixed-reg"
+Treat the register named \fIreg\fR as a fixed register; generated code
+should never refer to it (except perhaps as a stack pointer, frame
+pointer or in some other fixed role).
+.Sp
+\&\fIreg\fR must be the name of a register. The register names accepted
+are machine-specific and are defined in the \f(CW\*(C`REGISTER_NAMES\*(C'\fR
+macro in the machine description macro file.
+.Sp
+This flag does not have a negative form, because it specifies a
+three-way choice.
+.Ip "\fB\-fcall-used-\fR\fIreg\fR" 4
+.IX Item "-fcall-used-reg"
+Treat the register named \fIreg\fR as an allocable register that is
+clobbered by function calls. It may be allocated for temporaries or
+variables that do not live across a call. Functions compiled this way
+will not save and restore the register \fIreg\fR.
+.Sp
+It is an error to used this flag with the frame pointer or stack pointer.
+Use of this flag for other registers that have fixed pervasive roles in
+the machine's execution model will produce disastrous results.
+.Sp
+This flag does not have a negative form, because it specifies a
+three-way choice.
+.Ip "\fB\-fcall-saved-\fR\fIreg\fR" 4
+.IX Item "-fcall-saved-reg"
+Treat the register named \fIreg\fR as an allocable register saved by
+functions. It may be allocated even for temporaries or variables that
+live across a call. Functions compiled this way will save and restore
+the register \fIreg\fR if they use it.
+.Sp
+It is an error to used this flag with the frame pointer or stack pointer.
+Use of this flag for other registers that have fixed pervasive roles in
+the machine's execution model will produce disastrous results.
+.Sp
+A different sort of disaster will result from the use of this flag for
+a register in which function values may be returned.
+.Sp
+This flag does not have a negative form, because it specifies a
+three-way choice.
+.Ip "\fB\-fpack-struct\fR" 4
+.IX Item "-fpack-struct"
+Pack all structure members together without holes. Usually you would
+not want to use this option, since it makes the code suboptimal, and
+the offsets of structure members won't agree with system libraries.
+.Ip "\fB\-finstrument-functions\fR" 4
+.IX Item "-finstrument-functions"
+Generate instrumentation calls for entry and exit to functions. Just
+after function entry and just before function exit, the following
+profiling functions will be called with the address of the current
+function and its call site. (On some platforms,
+\&\f(CW\*(C`_\|_builtin_return_address\*(C'\fR does not work beyond the current
+function, so the call site information may not be available to the
+profiling functions otherwise.)
+.Sp
+.Vb 4
+\& void __cyg_profile_func_enter (void *this_fn,
+\& void *call_site);
+\& void __cyg_profile_func_exit (void *this_fn,
+\& void *call_site);
+.Ve
+The first argument is the address of the start of the current function,
+which may be looked up exactly in the symbol table.
+.Sp
+This instrumentation is also done for functions expanded inline in other
+functions. The profiling calls will indicate where, conceptually, the
+inline function is entered and exited. This means that addressable
+versions of such functions must be available. If all your uses of a
+function are expanded inline, this may mean an additional expansion of
+code size. If you use \fBextern inline\fR in your C code, an
+addressable version of such functions must be provided. (This is
+normally the case anyways, but if you get lucky and the optimizer always
+expands the functions inline, you might have gotten away without
+providing static copies.)
+.Sp
+A function may be given the attribute \f(CW\*(C`no_instrument_function\*(C'\fR, in
+which case this instrumentation will not be done. This can be used, for
+example, for the profiling functions listed above, high-priority
+interrupt routines, and any functions from which the profiling functions
+cannot safely be called (perhaps signal handlers, if the profiling
+routines generate output or allocate memory).
+.Ip "\fB\-fstack-check\fR" 4
+.IX Item "-fstack-check"
+Generate code to verify that you do not go beyond the boundary of the
+stack. You should specify this flag if you are running in an
+environment with multiple threads, but only rarely need to specify it in
+a single-threaded environment since stack overflow is automatically
+detected on nearly all systems if there is only one stack.
+.Sp
+Note that this switch does not actually cause checking to be done; the
+operating system must do that. The switch causes generation of code
+to ensure that the operating system sees the stack being extended.
+.Ip "\fB\-fstack-limit-register=\fR\fIreg\fR" 4
+.IX Item "-fstack-limit-register=reg"
+.PD 0
+.Ip "\fB\-fstack-limit-symbol=\fR\fIsym\fR" 4
+.IX Item "-fstack-limit-symbol=sym"
+.Ip "\fB\-fno-stack-limit\fR" 4
+.IX Item "-fno-stack-limit"
+.PD
+Generate code to ensure that the stack does not grow beyond a certain value,
+either the value of a register or the address of a symbol. If the stack
+would grow beyond the value, a signal is raised. For most targets,
+the signal is raised before the stack overruns the boundary, so
+it is possible to catch the signal without taking special precautions.
+.Sp
+For instance, if the stack starts at absolute address \fB0x80000000\fR
+and grows downwards, you can use the flags
+\&\fB\-fstack-limit-symbol=_\|_stack_limit\fR and
+\&\fB\-Wl,\-\-defsym,_\|_stack_limit=0x7ffe0000\fR to enforce a stack limit
+of 128KB. Note that this may only work with the \s-1GNU\s0 linker.
+.Ip "\fB\-fargument-alias\fR" 4
+.IX Item "-fargument-alias"
+.PD 0
+.Ip "\fB\-fargument-noalias\fR" 4
+.IX Item "-fargument-noalias"
+.Ip "\fB\-fargument-noalias-global\fR" 4
+.IX Item "-fargument-noalias-global"
+.PD
+Specify the possible relationships among parameters and between
+parameters and global data.
+.Sp
+\&\fB\-fargument-alias\fR specifies that arguments (parameters) may
+alias each other and may alias global storage.\fB\-fargument-noalias\fR specifies that arguments do not alias
+each other, but may alias global storage.\fB\-fargument-noalias-global\fR specifies that arguments do not
+alias each other and do not alias global storage.
+.Sp
+Each language will automatically use whatever option is required by
+the language standard. You should not need to use these options yourself.
+.Ip "\fB\-fleading-underscore\fR" 4
+.IX Item "-fleading-underscore"
+This option and its counterpart, \fB\-fno-leading-underscore\fR, forcibly
+change the way C symbols are represented in the object file. One use
+is to help link with legacy assembly code.
+.Sp
+Be warned that you should know what you are doing when invoking this
+option, and that not all targets provide complete support for it.
+.SH "ENVIRONMENT"
+.IX Header "ENVIRONMENT"
+This section describes several environment variables that affect how \s-1GCC\s0
+operates. Some of them work by specifying directories or prefixes to use
+when searching for various kinds of files. Some are used to specify other
+aspects of the compilation environment.
+.PP
+Note that you can also specify places to search using options such as
+\&\fB\-B\fR, \fB\-I\fR and \fB\-L\fR. These
+take precedence over places specified using environment variables, which
+in turn take precedence over those specified by the configuration of \s-1GCC\s0.
+.Ip "\fB\s-1LANG\s0\fR" 4
+.IX Item "LANG"
+.PD 0
+.Ip "\fB\s-1LC_CTYPE\s0\fR" 4
+.IX Item "LC_CTYPE"
+.Ip "\fB\s-1LC_MESSAGES\s0\fR" 4
+.IX Item "LC_MESSAGES"
+.Ip "\fB\s-1LC_ALL\s0\fR" 4
+.IX Item "LC_ALL"
+.PD
+These environment variables control the way that \s-1GCC\s0 uses
+localization information that allow \s-1GCC\s0 to work with different
+national conventions. \s-1GCC\s0 inspects the locale categories
+\&\fB\s-1LC_CTYPE\s0\fR and \fB\s-1LC_MESSAGES\s0\fR if it has been configured to do
+so. These locale categories can be set to any value supported by your
+installation. A typical value is \fBen_UK\fR for English in the United
+Kingdom.
+.Sp
+The \fB\s-1LC_CTYPE\s0\fR environment variable specifies character
+classification. \s-1GCC\s0 uses it to determine the character boundaries in
+a string; this is needed for some multibyte encodings that contain quote
+and escape characters that would otherwise be interpreted as a string
+end or escape.
+.Sp
+The \fB\s-1LC_MESSAGES\s0\fR environment variable specifies the language to
+use in diagnostic messages.
+.Sp
+If the \fB\s-1LC_ALL\s0\fR environment variable is set, it overrides the value
+of \fB\s-1LC_CTYPE\s0\fR and \fB\s-1LC_MESSAGES\s0\fR; otherwise, \fB\s-1LC_CTYPE\s0\fR
+and \fB\s-1LC_MESSAGES\s0\fR default to the value of the \fB\s-1LANG\s0\fR
+environment variable. If none of these variables are set, \s-1GCC\s0
+defaults to traditional C English behavior.
+.Ip "\fB\s-1TMPDIR\s0\fR" 4
+.IX Item "TMPDIR"
+If \fB\s-1TMPDIR\s0\fR is set, it specifies the directory to use for temporary
+files. \s-1GCC\s0 uses temporary files to hold the output of one stage of
+compilation which is to be used as input to the next stage: for example,
+the output of the preprocessor, which is the input to the compiler
+proper.
+.Ip "\fB\s-1GCC_EXEC_PREFIX\s0\fR" 4
+.IX Item "GCC_EXEC_PREFIX"
+If \fB\s-1GCC_EXEC_PREFIX\s0\fR is set, it specifies a prefix to use in the
+names of the subprograms executed by the compiler. No slash is added
+when this prefix is combined with the name of a subprogram, but you can
+specify a prefix that ends with a slash if you wish.
+.Sp
+If \fB\s-1GCC_EXEC_PREFIX\s0\fR is not set, \s-1GCC\s0 will attempt to figure out
+an appropriate prefix to use based on the pathname it was invoked with.
+.Sp
+If \s-1GCC\s0 cannot find the subprogram using the specified prefix, it
+tries looking in the usual places for the subprogram.
+.Sp
+The default value of \fB\s-1GCC_EXEC_PREFIX\s0\fR is
+\&\fI\fIprefix\fI/lib/gcc-lib/\fR where \fIprefix\fR is the value
+of \f(CW\*(C`prefix\*(C'\fR when you ran the \fIconfigure\fR script.
+.Sp
+Other prefixes specified with \fB\-B\fR take precedence over this prefix.
+.Sp
+This prefix is also used for finding files such as \fIcrt0.o\fR that are
+used for linking.
+.Sp
+In addition, the prefix is used in an unusual way in finding the
+directories to search for header files. For each of the standard
+directories whose name normally begins with \fB/usr/local/lib/gcc-lib\fR
+(more precisely, with the value of \fB\s-1GCC_INCLUDE_DIR\s0\fR), \s-1GCC\s0 tries
+replacing that beginning with the specified prefix to produce an
+alternate directory name. Thus, with \fB\-Bfoo/\fR, \s-1GCC\s0 will search
+\&\fIfoo/bar\fR where it would normally search \fI/usr/local/lib/bar\fR.
+These alternate directories are searched first; the standard directories
+come next.
+.Ip "\fB\s-1COMPILER_PATH\s0\fR" 4
+.IX Item "COMPILER_PATH"
+The value of \fB\s-1COMPILER_PATH\s0\fR is a colon-separated list of
+directories, much like \fB\s-1PATH\s0\fR. \s-1GCC\s0 tries the directories thus
+specified when searching for subprograms, if it can't find the
+subprograms using \fB\s-1GCC_EXEC_PREFIX\s0\fR.
+.Ip "\fB\s-1LIBRARY_PATH\s0\fR" 4
+.IX Item "LIBRARY_PATH"
+The value of \fB\s-1LIBRARY_PATH\s0\fR is a colon-separated list of
+directories, much like \fB\s-1PATH\s0\fR. When configured as a native compiler,
+\&\s-1GCC\s0 tries the directories thus specified when searching for special
+linker files, if it can't find them using \fB\s-1GCC_EXEC_PREFIX\s0\fR. Linking
+using \s-1GCC\s0 also uses these directories when searching for ordinary
+libraries for the \fB\-l\fR option (but directories specified with
+\&\fB\-L\fR come first).
+.Ip "\fB\s-1LANG\s0\fR" 4
+.IX Item "LANG"
+This variable is used to pass locale information to the compiler. One way in
+which this information is used is to determine the character set to be used
+when character literals, string literals and comments are parsed in C and \*(C+.
+When the compiler is configured to allow multibyte characters,
+the following values for \fB\s-1LANG\s0\fR are recognized:
+.RS 4
+.Ip "\fBC-JIS\fR" 4
+.IX Item "C-JIS"
+Recognize \s-1JIS\s0 characters.
+.Ip "\fBC-SJIS\fR" 4
+.IX Item "C-SJIS"
+Recognize \s-1SJIS\s0 characters.
+.Ip "\fBC-EUCJP\fR" 4
+.IX Item "C-EUCJP"
+Recognize \s-1EUCJP\s0 characters.
+.RE
+.RS 4
+.Sp
+If \fB\s-1LANG\s0\fR is not defined, or if it has some other value, then the
+compiler will use mblen and mbtowc as defined by the default locale to
+recognize and translate multibyte characters.
+.RE
+.PP
+Some additional environments variables affect the behavior of the
+preprocessor.
+.Ip "\fB\s-1CPATH\s0\fR" 4
+.IX Item "CPATH"
+.PD 0
+.Ip "\fBC_INCLUDE_PATH\fR" 4
+.IX Item "C_INCLUDE_PATH"
+.Ip "\fB\s-1CPLUS_INCLUDE_PATH\s0\fR" 4
+.IX Item "CPLUS_INCLUDE_PATH"
+.Ip "\fB\s-1OBJC_INCLUDE_PATH\s0\fR" 4
+.IX Item "OBJC_INCLUDE_PATH"
+.PD
+Each variable's value is a list of directories separated by a special
+character, much like \fB\s-1PATH\s0\fR, in which to look for header files.
+The special character, \f(CW\*(C`PATH_SEPARATOR\*(C'\fR, is target-dependent and
+determined at \s-1GCC\s0 build time. For Windows-based targets it is a
+semicolon, and for almost all other targets it is a colon.
+.Sp
+\&\fB\s-1CPATH\s0\fR specifies a list of directories to be searched as if
+specified with \fB\-I\fR, but after any paths given with \fB\-I\fR
+options on the command line. The environment variable is used
+regardless of which language is being preprocessed.
+.Sp
+The remaining environment variables apply only when preprocessing the
+particular language indicated. Each specifies a list of directories
+to be searched as if specified with \fB\-isystem\fR, but after any
+paths given with \fB\-isystem\fR options on the command line.
+.Ip "\fB\s-1DEPENDENCIES_OUTPUT\s0\fR" 4
+.IX Item "DEPENDENCIES_OUTPUT"
+@anchor{\s-1DEPENDENCIES_OUTPUT\s0}
+If this variable is set, its value specifies how to output
+dependencies for Make based on the non-system header files processed
+by the compiler. System header files are ignored in the dependency
+output.
+.Sp
+The value of \fB\s-1DEPENDENCIES_OUTPUT\s0\fR can be just a file name, in
+which case the Make rules are written to that file, guessing the target
+name from the source file name. Or the value can have the form
+\&\fIfile\fR\fB \fR\fItarget\fR, in which case the rules are written to
+file \fIfile\fR using \fItarget\fR as the target name.
+.Sp
+In other words, this environment variable is equivalent to combining
+the options \fB\-MM\fR and \fB\-MF\fR,
+with an optional \fB\-MT\fR switch too.
+.Ip "\fB\s-1SUNPRO_DEPENDENCIES\s0\fR" 4
+.IX Item "SUNPRO_DEPENDENCIES"
+This variable is the same as the environment variable
+\&\fB\s-1DEPENDENCIES_OUTPUT\s0\fR, except that
+system header files are not ignored, so it implies \fB\-M\fR rather
+than \fB\-MM\fR.
+.SH "BUGS"
+.IX Header "BUGS"
+To report bugs to Apple, see
+<\fBhttp://developer.apple.com/bugreporter\fR>.
+.SH "FOOTNOTES"
+.IX Header "FOOTNOTES"
+.Ip "1." 4
+On some systems, \fBgcc \-shared\fR
+needs to build supplementary stub code for constructors to work. On
+multi-libbed systems, \fBgcc \-shared\fR must select the correct support
+libraries to link against. Failing to supply the correct flags may lead
+to subtle defects. Supplying them in cases where they are not necessary
+is innocuous.
+.SH "SEE ALSO"
+.IX Header "SEE ALSO"
+\&\fIgpl\fR\|(7), \fIgfdl\fR\|(7), \fIfsf-funding\fR\|(7),
+\&\fIcpp\fR\|(1), \fIgcov\fR\|(1), \fIg77\fR\|(1), \fIas\fR\|(1), \fIld\fR\|(1), \fIgdb\fR\|(1), \fIadb\fR\|(1), \fIdbx\fR\|(1), \fIsdb\fR\|(1)
+and the Info entries for \fIgcc\fR, \fIcpp\fR, \fIg77\fR, \fIas\fR,
+\&\fIld\fR, \fIbinutils\fR and \fIgdb\fR.
+.SH "AUTHOR"
+.IX Header "AUTHOR"
+See the Info entry for \fBgcc\fR, or
+<\fBhttp://gcc.gnu.org/onlinedocs/gcc/Contributors.html\fR>,
+for contributors to \s-1GCC\s0.
+.SH "COPYRIGHT"
+.IX Header "COPYRIGHT"
+Copyright (c) 1988, 1989, 1992, 1993, 1994, 1995, 1996, 1997,
+1998, 1999, 2000, 2001, 2002 Free Software Foundation, Inc.
+.PP
+Permission is granted to copy, distribute and/or modify this document
+under the terms of the \s-1GNU\s0 Free Documentation License, Version 1.1 or
+any later version published by the Free Software Foundation; with the
+Invariant Sections being ``\s-1GNU\s0 General Public License'' and ``Funding
+Free Software'', the Front-Cover texts being (a) (see below), and with
+the Back-Cover Texts being (b) (see below). A copy of the license is
+included in the \fIgfdl\fR\|(7) man page.
+.PP
+(a) The \s-1FSF\s0's Front-Cover Text is:
+.PP
+.Vb 1
+\& A GNU Manual
+.Ve
+(b) The \s-1FSF\s0's Back-Cover Text is:
+.PP
+.Vb 3
+\& You have freedom to copy and modify this GNU Manual, like GNU
+\& software. Copies published by the Free Software Foundation raise
+\& funds for GNU development.
+.Ve
diff --git a/man-pages/gcov3.1 b/man-pages/gcov3.1
new file mode 100644
index 00000000000..f68ba8afbf2
--- /dev/null
+++ b/man-pages/gcov3.1
@@ -0,0 +1,453 @@
+.\" Automatically generated by Pod::Man version 1.15
+.\" Wed Jun 19 19:36:24 2002
+.\"
+.\" Standard preamble:
+.\" ======================================================================
+.de Sh \" Subsection heading
+.br
+.if t .Sp
+.ne 5
+.PP
+\fB\\$1\fR
+.PP
+..
+.de Sp \" Vertical space (when we can't use .PP)
+.if t .sp .5v
+.if n .sp
+..
+.de Ip \" List item
+.br
+.ie \\n(.$>=3 .ne \\$3
+.el .ne 3
+.IP "\\$1" \\$2
+..
+.de Vb \" Begin verbatim text
+.ft CW
+.nf
+.ne \\$1
+..
+.de Ve \" End verbatim text
+.ft R
+
+.fi
+..
+.\" Set up some character translations and predefined strings. \*(-- will
+.\" give an unbreakable dash, \*(PI will give pi, \*(L" will give a left
+.\" double quote, and \*(R" will give a right double quote. | will give a
+.\" real vertical bar. \*(C+ will give a nicer C++. Capital omega is used
+.\" to do unbreakable dashes and therefore won't be available. \*(C` and
+.\" \*(C' expand to `' in nroff, nothing in troff, for use with C<>
+.tr \(*W-|\(bv\*(Tr
+.ds C+ C\v'-.1v'\h'-1p'\s-2+\h'-1p'+\s0\v'.1v'\h'-1p'
+.ie n \{\
+. ds -- \(*W-
+. ds PI pi
+. if (\n(.H=4u)&(1m=24u) .ds -- \(*W\h'-12u'\(*W\h'-12u'-\" diablo 10 pitch
+. if (\n(.H=4u)&(1m=20u) .ds -- \(*W\h'-12u'\(*W\h'-8u'-\" diablo 12 pitch
+. ds L" ""
+. ds R" ""
+. ds C` ""
+. ds C' ""
+'br\}
+.el\{\
+. ds -- \|\(em\|
+. ds PI \(*p
+. ds L" ``
+. ds R" ''
+'br\}
+.\"
+.\" If the F register is turned on, we'll generate index entries on stderr
+.\" for titles (.TH), headers (.SH), subsections (.Sh), items (.Ip), and
+.\" index entries marked with X<> in POD. Of course, you'll have to process
+.\" the output yourself in some meaningful fashion.
+.if \nF \{\
+. de IX
+. tm Index:\\$1\t\\n%\t"\\$2"
+..
+. nr % 0
+. rr F
+.\}
+.\"
+.\" For nroff, turn off justification. Always turn off hyphenation; it
+.\" makes way too many mistakes in technical documents.
+.hy 0
+.if n .na
+.\"
+.\" Accent mark definitions (@(#)ms.acc 1.5 88/02/08 SMI; from UCB 4.2).
+.\" Fear. Run. Save yourself. No user-serviceable parts.
+.bd B 3
+. \" fudge factors for nroff and troff
+.if n \{\
+. ds #H 0
+. ds #V .8m
+. ds #F .3m
+. ds #[ \f1
+. ds #] \fP
+.\}
+.if t \{\
+. ds #H ((1u-(\\\\n(.fu%2u))*.13m)
+. ds #V .6m
+. ds #F 0
+. ds #[ \&
+. ds #] \&
+.\}
+. \" simple accents for nroff and troff
+.if n \{\
+. ds ' \&
+. ds ` \&
+. ds ^ \&
+. ds , \&
+. ds ~ ~
+. ds /
+.\}
+.if t \{\
+. ds ' \\k:\h'-(\\n(.wu*8/10-\*(#H)'\'\h"|\\n:u"
+. ds ` \\k:\h'-(\\n(.wu*8/10-\*(#H)'\`\h'|\\n:u'
+. ds ^ \\k:\h'-(\\n(.wu*10/11-\*(#H)'^\h'|\\n:u'
+. ds , \\k:\h'-(\\n(.wu*8/10)',\h'|\\n:u'
+. ds ~ \\k:\h'-(\\n(.wu-\*(#H-.1m)'~\h'|\\n:u'
+. ds / \\k:\h'-(\\n(.wu*8/10-\*(#H)'\z\(sl\h'|\\n:u'
+.\}
+. \" troff and (daisy-wheel) nroff accents
+.ds : \\k:\h'-(\\n(.wu*8/10-\*(#H+.1m+\*(#F)'\v'-\*(#V'\z.\h'.2m+\*(#F'.\h'|\\n:u'\v'\*(#V'
+.ds 8 \h'\*(#H'\(*b\h'-\*(#H'
+.ds o \\k:\h'-(\\n(.wu+\w'\(de'u-\*(#H)/2u'\v'-.3n'\*(#[\z\(de\v'.3n'\h'|\\n:u'\*(#]
+.ds d- \h'\*(#H'\(pd\h'-\w'~'u'\v'-.25m'\f2\(hy\fP\v'.25m'\h'-\*(#H'
+.ds D- D\\k:\h'-\w'D'u'\v'-.11m'\z\(hy\v'.11m'\h'|\\n:u'
+.ds th \*(#[\v'.3m'\s+1I\s-1\v'-.3m'\h'-(\w'I'u*2/3)'\s-1o\s+1\*(#]
+.ds Th \*(#[\s+2I\s-2\h'-\w'I'u*3/5'\v'-.3m'o\v'.3m'\*(#]
+.ds ae a\h'-(\w'a'u*4/10)'e
+.ds Ae A\h'-(\w'A'u*4/10)'E
+. \" corrections for vroff
+.if v .ds ~ \\k:\h'-(\\n(.wu*9/10-\*(#H)'\s-2\u~\d\s+2\h'|\\n:u'
+.if v .ds ^ \\k:\h'-(\\n(.wu*10/11-\*(#H)'\v'-.4m'^\v'.4m'\h'|\\n:u'
+. \" for low resolution devices (crt and lpr)
+.if \n(.H>23 .if \n(.V>19 \
+\{\
+. ds : e
+. ds 8 ss
+. ds o a
+. ds d- d\h'-1'\(ga
+. ds D- D\h'-1'\(hy
+. ds th \o'bp'
+. ds Th \o'LP'
+. ds ae ae
+. ds Ae AE
+.\}
+.rm #[ #] #H #V #F C
+.\" ======================================================================
+.\"
+.IX Title "GCOV 1"
+.TH GCOV 1 "gcc-3.1" "2002-06-19" "GNU"
+.UC
+.SH "NAME"
+gcov \- coverage testing tool
+.SH "SYNOPSIS"
+.IX Header "SYNOPSIS"
+gcov [\fB\-v\fR|\fB\*(--version\fR] [\fB\-h\fR|\fB\*(--help\fR]
+ [\fB\-b\fR|\fB\*(--branch-probabilities\fR] [\fB\-c\fR|\fB\*(--branch-counts\fR]
+ [\fB\-n\fR|\fB\*(--no-output\fR] [\fB\-l\fR|\fB\*(--long-file-names\fR]
+ [\fB\-f\fR|\fB\*(--function-summaries\fR]
+ [\fB\-o\fR|\fB\*(--object-directory\fR \fIdirectory\fR] \fIsourcefile\fR
+.SH "DESCRIPTION"
+.IX Header "DESCRIPTION"
+\&\fBgcov\fR is a test coverage program. Use it in concert with \s-1GCC\s0
+to analyze your programs to help create more efficient, faster
+running code. You can use \fBgcov\fR as a profiling tool to help
+discover where your optimization efforts will best affect your code. You
+can also use \fBgcov\fR along with the other profiling tool,
+\&\fBgprof\fR, to assess which parts of your code use the greatest amount
+of computing time.
+.PP
+Profiling tools help you analyze your code's performance. Using a
+profiler such as \fBgcov\fR or \fBgprof\fR, you can find out some
+basic performance statistics, such as:
+.Ip "\(bu" 4
+how often each line of code executes
+.Ip "\(bu" 4
+what lines of code are actually executed
+.Ip "\(bu" 4
+how much computing time each section of code uses
+.PP
+Once you know these things about how your code works when compiled, you
+can look at each module to see which modules should be optimized.
+\&\fBgcov\fR helps you determine where to work on optimization.
+.PP
+Software developers also use coverage testing in concert with
+testsuites, to make sure software is actually good enough for a release.
+Testsuites can verify that a program works as expected; a coverage
+program tests to see how much of the program is exercised by the
+testsuite. Developers can then determine what kinds of test cases need
+to be added to the testsuites to create both better testing and a better
+final product.
+.PP
+You should compile your code without optimization if you plan to use
+\&\fBgcov\fR because the optimization, by combining some lines of code
+into one function, may not give you as much information as you need to
+look for `hot spots' where the code is using a great deal of computer
+time. Likewise, because \fBgcov\fR accumulates statistics by line (at
+the lowest resolution), it works best with a programming style that
+places only one statement on each line. If you use complicated macros
+that expand to loops or to other control structures, the statistics are
+less helpful\-\-\-they only report on the line where the macro call
+appears. If your complex macros behave like functions, you can replace
+them with inline functions to solve this problem.
+.PP
+\&\fBgcov\fR creates a logfile called \fI\fIsourcefile\fI.gcov\fR which
+indicates how many times each line of a source file \fI\fIsourcefile\fI.c\fR
+has executed. You can use these logfiles along with \fBgprof\fR to aid
+in fine-tuning the performance of your programs. \fBgprof\fR gives
+timing information you can use along with the information you get from
+\&\fBgcov\fR.
+.PP
+\&\fBgcov\fR works only on code compiled with \s-1GCC\s0. It is not
+compatible with any other profiling or test coverage mechanism.
+.SH "OPTIONS"
+.IX Header "OPTIONS"
+.Ip "\fB\-h\fR" 4
+.IX Item "-h"
+.PD 0
+.Ip "\fB\*(--help\fR" 4
+.IX Item "help"
+.PD
+Display help about using \fBgcov\fR (on the standard output), and
+exit without doing any further processing.
+.Ip "\fB\-v\fR" 4
+.IX Item "-v"
+.PD 0
+.Ip "\fB\*(--version\fR" 4
+.IX Item "version"
+.PD
+Display the \fBgcov\fR version number (on the standard output),
+and exit without doing any further processing.
+.Ip "\fB\-b\fR" 4
+.IX Item "-b"
+.PD 0
+.Ip "\fB\*(--branch-probabilities\fR" 4
+.IX Item "branch-probabilities"
+.PD
+Write branch frequencies to the output file, and write branch summary
+info to the standard output. This option allows you to see how often
+each branch in your program was taken.
+.Ip "\fB\-c\fR" 4
+.IX Item "-c"
+.PD 0
+.Ip "\fB\*(--branch-counts\fR" 4
+.IX Item "branch-counts"
+.PD
+Write branch frequencies as the number of branches taken, rather than
+the percentage of branches taken.
+.Ip "\fB\-n\fR" 4
+.IX Item "-n"
+.PD 0
+.Ip "\fB\*(--no-output\fR" 4
+.IX Item "no-output"
+.PD
+Do not create the \fBgcov\fR output file.
+.Ip "\fB\-l\fR" 4
+.IX Item "-l"
+.PD 0
+.Ip "\fB\*(--long-file-names\fR" 4
+.IX Item "long-file-names"
+.PD
+Create long file names for included source files. For example, if the
+header file \fIx.h\fR contains code, and was included in the file
+\&\fIa.c\fR, then running \fBgcov\fR on the file \fIa.c\fR will produce
+an output file called \fIa.c.x.h.gcov\fR instead of \fIx.h.gcov\fR.
+This can be useful if \fIx.h\fR is included in multiple source files.
+.Ip "\fB\-f\fR" 4
+.IX Item "-f"
+.PD 0
+.Ip "\fB\*(--function-summaries\fR" 4
+.IX Item "function-summaries"
+.PD
+Output summaries for each function in addition to the file level summary.
+.Ip "\fB\-o\fR \fIdirectory\fR" 4
+.IX Item "-o directory"
+.PD 0
+.Ip "\fB\*(--object-directory\fR \fIdirectory\fR" 4
+.IX Item "object-directory directory"
+.PD
+The directory where the object files live. Gcov will search for \fI.bb\fR,
+\&\fI.bbg\fR, and \fI.da\fR files in this directory.
+.PP
+When using \fBgcov\fR, you must first compile your program with two
+special \s-1GCC\s0 options: \fB\-fprofile-arcs \-ftest-coverage\fR.
+This tells the compiler to generate additional information needed by
+gcov (basically a flow graph of the program) and also includes
+additional code in the object files for generating the extra profiling
+information needed by gcov. These additional files are placed in the
+directory where the source code is located.
+.PP
+Running the program will cause profile output to be generated. For each
+source file compiled with \fB\-fprofile-arcs\fR, an accompanying \fI.da\fR
+file will be placed in the source directory.
+.PP
+Running \fBgcov\fR with your program's source file names as arguments
+will now produce a listing of the code along with frequency of execution
+for each line. For example, if your program is called \fItmp.c\fR, this
+is what you see when you use the basic \fBgcov\fR facility:
+.PP
+.Vb 5
+\& $ gcc -fprofile-arcs -ftest-coverage tmp.c
+\& $ a.out
+\& $ gcov tmp.c
+\& 87.50% of 8 source lines executed in file tmp.c
+\& Creating tmp.c.gcov.
+.Ve
+The file \fItmp.c.gcov\fR contains output from \fBgcov\fR.
+Here is a sample:
+.PP
+.Vb 3
+\& main()
+\& {
+\& 1 int i, total;
+.Ve
+.Vb 1
+\& 1 total = 0;
+.Ve
+.Vb 2
+\& 11 for (i = 0; i < 10; i++)
+\& 10 total += i;
+.Ve
+.Vb 5
+\& 1 if (total != 45)
+\& ###### printf ("Failure\en");
+\& else
+\& 1 printf ("Success\en");
+\& 1 }
+.Ve
+When you use the \fB\-b\fR option, your output looks like this:
+.PP
+.Vb 6
+\& $ gcov -b tmp.c
+\& 87.50% of 8 source lines executed in file tmp.c
+\& 80.00% of 5 branches executed in file tmp.c
+\& 80.00% of 5 branches taken at least once in file tmp.c
+\& 50.00% of 2 calls executed in file tmp.c
+\& Creating tmp.c.gcov.
+.Ve
+Here is a sample of a resulting \fItmp.c.gcov\fR file:
+.PP
+.Vb 3
+\& main()
+\& {
+\& 1 int i, total;
+.Ve
+.Vb 1
+\& 1 total = 0;
+.Ve
+.Vb 5
+\& 11 for (i = 0; i < 10; i++)
+\& branch 0 taken = 91%
+\& branch 1 taken = 100%
+\& branch 2 taken = 100%
+\& 10 total += i;
+.Ve
+.Vb 9
+\& 1 if (total != 45)
+\& branch 0 taken = 100%
+\& ###### printf ("Failure\en");
+\& call 0 never executed
+\& branch 1 never executed
+\& else
+\& 1 printf ("Success\en");
+\& call 0 returns = 100%
+\& 1 }
+.Ve
+For each basic block, a line is printed after the last line of the basic
+block describing the branch or call that ends the basic block. There can
+be multiple branches and calls listed for a single source line if there
+are multiple basic blocks that end on that line. In this case, the
+branches and calls are each given a number. There is no simple way to map
+these branches and calls back to source constructs. In general, though,
+the lowest numbered branch or call will correspond to the leftmost construct
+on the source line.
+.PP
+For a branch, if it was executed at least once, then a percentage
+indicating the number of times the branch was taken divided by the
+number of times the branch was executed will be printed. Otherwise, the
+message ``never executed'' is printed.
+.PP
+For a call, if it was executed at least once, then a percentage
+indicating the number of times the call returned divided by the number
+of times the call was executed will be printed. This will usually be
+100%, but may be less for functions call \f(CW\*(C`exit\*(C'\fR or \f(CW\*(C`longjmp\*(C'\fR,
+and thus may not return every time they are called.
+.PP
+The execution counts are cumulative. If the example program were
+executed again without removing the \fI.da\fR file, the count for the
+number of times each line in the source was executed would be added to
+the results of the previous \fIrun\fR\|(s). This is potentially useful in
+several ways. For example, it could be used to accumulate data over a
+number of program runs as part of a test verification suite, or to
+provide more accurate long-term information over a large number of
+program runs.
+.PP
+The data in the \fI.da\fR files is saved immediately before the program
+exits. For each source file compiled with \fB\-fprofile-arcs\fR, the profiling
+code first attempts to read in an existing \fI.da\fR file; if the file
+doesn't match the executable (differing number of basic block counts) it
+will ignore the contents of the file. It then adds in the new execution
+counts and finally writes the data to the file.
+.Sh "Using \fBgcov\fP with \s-1GCC\s0 Optimization"
+.IX Subsection "Using gcov with GCC Optimization"
+If you plan to use \fBgcov\fR to help optimize your code, you must
+first compile your program with two special \s-1GCC\s0 options:
+\&\fB\-fprofile-arcs \-ftest-coverage\fR. Aside from that, you can use any
+other \s-1GCC\s0 options; but if you want to prove that every single line
+in your program was executed, you should not compile with optimization
+at the same time. On some machines the optimizer can eliminate some
+simple code lines by combining them with other lines. For example, code
+like this:
+.PP
+.Vb 4
+\& if (a != b)
+\& c = 1;
+\& else
+\& c = 0;
+.Ve
+can be compiled into one instruction on some machines. In this case,
+there is no way for \fBgcov\fR to calculate separate execution counts
+for each line because there isn't separate code for each line. Hence
+the \fBgcov\fR output looks like this if you compiled the program with
+optimization:
+.PP
+.Vb 4
+\& 100 if (a != b)
+\& 100 c = 1;
+\& 100 else
+\& 100 c = 0;
+.Ve
+The output shows that this block of code, combined by optimization,
+executed 100 times. In one sense this result is correct, because there
+was only one instruction representing all four of these lines. However,
+the output does not indicate how many times the result was 0 and how
+many times the result was 1.
+.SH "SEE ALSO"
+.IX Header "SEE ALSO"
+\&\fIgpl\fR\|(7), \fIgfdl\fR\|(7), \fIfsf-funding\fR\|(7), \fIgcc\fR\|(1) and the Info entry for \fIgcc\fR.
+.SH "COPYRIGHT"
+.IX Header "COPYRIGHT"
+Copyright (c) 1996, 1997, 1999, 2000, 2001 Free Software Foundation, Inc.
+.PP
+Permission is granted to copy, distribute and/or modify this document
+under the terms of the \s-1GNU\s0 Free Documentation License, Version 1.1 or
+any later version published by the Free Software Foundation; with the
+Invariant Sections being ``\s-1GNU\s0 General Public License'' and ``Funding
+Free Software'', the Front-Cover texts being (a) (see below), and with
+the Back-Cover Texts being (b) (see below). A copy of the license is
+included in the \fIgfdl\fR\|(7) man page.
+.PP
+(a) The \s-1FSF\s0's Front-Cover Text is:
+.PP
+.Vb 1
+\& A GNU Manual
+.Ve
+(b) The \s-1FSF\s0's Back-Cover Text is:
+.PP
+.Vb 3
+\& You have freedom to copy and modify this GNU Manual, like GNU
+\& software. Copies published by the Free Software Foundation raise
+\& funds for GNU development.
+.Ve
diff --git a/more-hdrs/assert.h b/more-hdrs/assert.h
new file mode 100644
index 00000000000..0bd55b020c8
--- /dev/null
+++ b/more-hdrs/assert.h
@@ -0,0 +1,71 @@
+/* DO NOT EDIT THIS FILE.
+
+ It has been auto-edited by fixincludes from:
+
+ "/usr/include/assert.h"
+
+ This had to be done to correct non-standard usages in the
+ original, manufacturer supplied header file. */
+
+#ifndef FIXINC_BROKEN_ASSERT_STDLIB_CHECK
+#define FIXINC_BROKEN_ASSERT_STDLIB_CHECK 1
+
+#ifdef __cplusplus
+#include <stdlib.h>
+#endif
+/* Allow this file to be included multiple times
+ with different settings of NDEBUG. */
+#undef assert
+#undef __assert
+
+#ifdef NDEBUG
+#define assert(ignore) ((void) 0)
+#else
+
+#ifndef __GNUC__
+
+#define assert(expression) \
+ ((void) ((expression) ? 0 : __assert (expression, __FILE__, __LINE__)))
+
+#define __assert(expression, file, lineno) \
+ (printf ("%s:%u: failed assertion\n", file, lineno), \
+ abort (), 0)
+
+#else
+
+#if defined(__STDC__) || defined (__cplusplus)
+
+/* Defined in libgcc.a */
+#ifdef __cplusplus
+extern "C" {
+extern void __eprintf (const char *, const char *, unsigned, const char *)
+ __attribute__ ((noreturn));
+}
+#else
+extern void __eprintf (const char *, const char *, unsigned, const char *)
+ __attribute__ ((noreturn));
+#endif
+
+#define assert(expression) \
+ ((void) ((expression) ? 0 : __assert (#expression, __FILE__, __LINE__)))
+
+#define __assert(expression, file, line) \
+ (__eprintf ("%s:%u: failed assertion `%s'\n", \
+ file, line, expression), 0)
+
+#else /* no __STDC__ and not C++; i.e. -traditional. */
+
+extern void __eprintf () __attribute__ ((noreturn)); /* Defined in libgcc.a */
+
+#define assert(expression) \
+ ((void) ((expression) ? 0 : __assert (expression, __FILE__, __LINE__)))
+
+#define __assert(expression, file, lineno) \
+ (__eprintf ("%s:%u: failed assertion `%s'\n", \
+ file, lineno, "expression"), 0)
+
+#endif /* no __STDC__ and not C++; i.e. -traditional. */
+#endif /* no __GNU__; i.e., /bin/cc. */
+#endif
+
+#endif /* FIXINC_BROKEN_ASSERT_STDLIB_CHECK */
diff --git a/more-hdrs/float.h b/more-hdrs/float.h
new file mode 100644
index 00000000000..366d745abbf
--- /dev/null
+++ b/more-hdrs/float.h
@@ -0,0 +1,98 @@
+/* This file exists soley to keep Metrowerks' compilers happy. The version
+ used by GCC 3.4 and later can be found in /usr/lib/gcc, although it's
+ not very informative. */
+
+#ifndef _FLOAT_H_
+#define _FLOAT_H_
+
+#ifndef __MWERKS__
+#error This file is only for Metrowerks compatibilty.
+#endif
+
+/* Define various characteristics of floating-point types, if needed. */
+#ifndef __FLT_RADIX__
+#define __FLT_RADIX__ 2
+#endif
+#ifndef __FLT_MANT_DIG__
+#define __FLT_MANT_DIG__ 24
+#endif
+#ifndef __FLT_DIG__
+#define __FLT_DIG__ 6
+#endif
+#ifndef __FLT_EPSILON__
+#define __FLT_EPSILON__ 1.19209290e-07F
+#endif
+#ifndef __FLT_MIN__
+#define __FLT_MIN__ 1.17549435e-38F
+#endif
+#ifndef __FLT_MAX__
+#define __FLT_MAX__ 3.40282347e+38F
+#endif
+#ifndef __FLT_MIN_EXP__
+#define __FLT_MIN_EXP__ (-125)
+#endif
+#ifndef __FLT_MIN_10_EXP__
+#define __FLT_MIN_10_EXP__ (-37)
+#endif
+#ifndef __FLT_MAX_EXP__
+#define __FLT_MAX_EXP__ 128
+#endif
+#ifndef __FLT_MAX_10_EXP__
+#define __FLT_MAX_10_EXP__ 38
+#endif
+#ifndef __DBL_MANT_DIG__
+#define __DBL_MANT_DIG__ 53
+#endif
+#ifndef __DBL_DIG__
+#define __DBL_DIG__ 15
+#endif
+#ifndef __DBL_EPSILON__
+#define __DBL_EPSILON__ 2.2204460492503131e-16
+#endif
+#ifndef __DBL_MIN__
+#define __DBL_MIN__ 2.2250738585072014e-308
+#endif
+#ifndef __DBL_MAX__
+#define __DBL_MAX__ 1.7976931348623157e+308
+#endif
+#ifndef __DBL_MIN_EXP__
+#define __DBL_MIN_EXP__ (-1021)
+#endif
+#ifndef __DBL_MIN_10_EXP__
+#define __DBL_MIN_10_EXP__ (-307)
+#endif
+#ifndef __DBL_MAX_EXP__
+#define __DBL_MAX_EXP__ 1024
+#endif
+#ifndef __DBL_MAX_10_EXP__
+#define __DBL_MAX_10_EXP__ 308
+#endif
+#ifndef __LDBL_MANT_DIG__
+#define __LDBL_MANT_DIG__ 53
+#endif
+#ifndef __LDBL_DIG__
+#define __LDBL_DIG__ 15
+#endif
+#ifndef __LDBL_EPSILON__
+#define __LDBL_EPSILON__ 2.2204460492503131e-16
+#endif
+#ifndef __LDBL_MIN__
+#define __LDBL_MIN__ 2.2250738585072014e-308
+#endif
+#ifndef __LDBL_MAX__
+#define __LDBL_MAX__ 1.7976931348623157e+308
+#endif
+#ifndef __LDBL_MIN_EXP__
+#define __LDBL_MIN_EXP__ (-1021)
+#endif
+#ifndef __LDBL_MIN_10_EXP__
+#define __LDBL_MIN_10_EXP__ (-307)
+#endif
+#ifndef __LDBL_MAX_EXP__
+#define __LDBL_MAX_EXP__ 1024
+#endif
+#ifndef __LDBL_MAX_10_EXP__
+#define __LDBL_MAX_10_EXP__ 308
+#endif
+
+#endif
diff --git a/more-hdrs/inttypes.h b/more-hdrs/inttypes.h
new file mode 100644
index 00000000000..a203cc7613c
--- /dev/null
+++ b/more-hdrs/inttypes.h
@@ -0,0 +1,308 @@
+/*
+ * Copyright (c) 2000,2001 Apple Computer, Inc. All rights reserved.
+ *
+ * @APPLE_LICENSE_HEADER_START@
+ *
+ * The contents of this file constitute Original Code as defined in and
+ * are subject to the Apple Public Source License Version 1.1 (the
+ * "License"). You may not use this file except in compliance with the
+ * License. Please obtain a copy of the License at
+ * http://www.apple.com/publicsource and read it before using this file.
+ *
+ * This Original Code and all software distributed under the License are
+ * distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY KIND, EITHER
+ * EXPRESS OR IMPLIED, AND APPLE HEREBY DISCLAIMS ALL SUCH WARRANTIES,
+ * INCLUDING WITHOUT LIMITATION, ANY WARRANTIES OF MERCHANTABILITY,
+ * FITNESS FOR A PARTICULAR PURPOSE OR NON-INFRINGEMENT. Please see the
+ * License for the specific language governing rights and limitations
+ * under the License.
+ *
+ * @APPLE_LICENSE_HEADER_END@
+ */
+
+/*
+ * <inttypes.h> -- Standard C header, defined in ISO/IEC 9899:1999
+ * (aka "C99"), section 7.8. This defines format string conversion
+ * specifiers suitable for use within arguments to fprintf and fscanf
+ * and their ilk.
+ */
+
+#if !defined(_INTTYPES_H_)
+#define _INTTYPES_H_
+
+#include <sys/cdefs.h> /* For __BEGIN_DECLS and __END_DECLS */
+#include <machine/ansi.h> /* For _BSD_WCHAR_T_ */
+#include <stdint.h>
+
+#if !defined(__STDC_VERSION__) || (__STDC_VERSION__ < 199901L)
+ /* Translator is not ISO/IEC 9899:1999-compliant. */
+# if !defined(restrict)
+# define restrict
+# define __RESTRICT_KEYWORD_DEFINED__
+# endif
+#endif
+
+/* "C++ implementations should define these macros only when
+ * __STDC_FORMAT_MACROS is defined before <inttypes.h> is included."
+ */
+#if (! defined(__cplusplus)) || defined(__STDC_FORMAT_MACROS)
+
+# undef __PRI_8_LENGTH_MODIFIER__
+# undef __PRI_64_LENGTH_MODIFIER__
+# undef __SCN_8_LENGTH_MODIFIER__
+# undef __SCN_64_LENGTH_MODIFIER__
+
+# if defined(__STDC_LIBRARY_SUPPORTED__)
+# define __PRI_8_LENGTH_MODIFIER__ "hh"
+# define __PRI_64_LENGTH_MODIFIER__ "ll"
+# define __SCN_8_LENGTH_MODIFIER__ "hh"
+# define __SCN_64_LENGTH_MODIFIER__ "ll"
+# else
+# define __PRI_8_LENGTH_MODIFIER__ "" /* none */
+# define __PRI_64_LENGTH_MODIFIER__ "q"
+# endif
+
+# define PRId8 __PRI_8_LENGTH_MODIFIER__ "d"
+# define PRIi8 __PRI_8_LENGTH_MODIFIER__ "i"
+# define PRIo8 __PRI_8_LENGTH_MODIFIER__ "o"
+# define PRIu8 __PRI_8_LENGTH_MODIFIER__ "u"
+# define PRIx8 __PRI_8_LENGTH_MODIFIER__ "x"
+# define PRIX8 __PRI_8_LENGTH_MODIFIER__ "X"
+
+# define PRId16 "hd"
+# define PRIi16 "hi"
+# define PRIo16 "ho"
+# define PRIu16 "hu"
+# define PRIx16 "hx"
+# define PRIX16 "hX"
+
+# define PRId32 "d"
+# define PRIi32 "i"
+# define PRIo32 "o"
+# define PRIu32 "u"
+# define PRIx32 "x"
+# define PRIX32 "X"
+
+# define PRId64 __PRI_64_LENGTH_MODIFIER__ "d"
+# define PRIi64 __PRI_64_LENGTH_MODIFIER__ "i"
+# define PRIo64 __PRI_64_LENGTH_MODIFIER__ "o"
+# define PRIu64 __PRI_64_LENGTH_MODIFIER__ "u"
+# define PRIx64 __PRI_64_LENGTH_MODIFIER__ "x"
+# define PRIX64 __PRI_64_LENGTH_MODIFIER__ "X"
+
+# define PRIdLEAST8 PRId8
+# define PRIiLEAST8 PRIi8
+# define PRIoLEAST8 PRIo8
+# define PRIuLEAST8 PRIu8
+# define PRIxLEAST8 PRIx8
+# define PRIXLEAST8 PRIX8
+
+# define PRIdLEAST16 PRId16
+# define PRIiLEAST16 PRIi16
+# define PRIoLEAST16 PRIo16
+# define PRIuLEAST16 PRIu16
+# define PRIxLEAST16 PRIx16
+# define PRIXLEAST16 PRIX16
+
+# define PRIdLEAST32 PRId32
+# define PRIiLEAST32 PRIi32
+# define PRIoLEAST32 PRIo32
+# define PRIuLEAST32 PRIu32
+# define PRIxLEAST32 PRIx32
+# define PRIXLEAST32 PRIX32
+
+# define PRIdLEAST64 PRId64
+# define PRIiLEAST64 PRIi64
+# define PRIoLEAST64 PRIo64
+# define PRIuLEAST64 PRIu64
+# define PRIxLEAST64 PRIx64
+# define PRIXLEAST64 PRIX64
+
+# define PRIdFAST8 PRId32
+# define PRIiFAST8 PRIi32
+# define PRIoFAST8 PRIo32
+# define PRIuFAST8 PRIu32
+# define PRIxFAST8 PRIx32
+# define PRIXFAST8 PRIX32
+
+# define PRIdFAST16 PRId32
+# define PRIiFAST16 PRIi32
+# define PRIoFAST16 PRIo32
+# define PRIuFAST16 PRIu32
+# define PRIxFAST16 PRIx32
+# define PRIXFAST16 PRIX32
+
+# define PRIdFAST32 PRId32
+# define PRIiFAST32 PRIi32
+# define PRIoFAST32 PRIo32
+# define PRIuFAST32 PRIu32
+# define PRIxFAST32 PRIx32
+# define PRIXFAST32 PRIX32
+
+# define PRIdFAST64 PRId64
+# define PRIiFAST64 PRIi64
+# define PRIoFAST64 PRIo64
+# define PRIuFAST64 PRIu64
+# define PRIxFAST64 PRIx64
+# define PRIXFAST64 PRIX64
+
+# define PRIdPTR PRId32
+# define PRIiPTR PRIi32
+# define PRIoPTR PRIo32
+# define PRIuPTR PRIu32
+# define PRIxPTR PRIx32
+# define PRIXPTR PRIX32
+
+# define PRIdMAX PRId64
+# define PRIiMAX PRIi64
+# define PRIoMAX PRIo64
+# define PRIuMAX PRIu64
+# define PRIxMAX PRIx64
+# define PRIXMAX PRIX64
+
+# if defined(__SCN_8_LENGTH_MODIFIER__)
+# define SCNd8 __SCN_8_LENGTH_MODIFIER__ "d"
+# define SCNi8 __SCN_8_LENGTH_MODIFIER__ "i"
+# define SCNo8 __SCN_8_LENGTH_MODIFIER__ "o"
+# define SCNu8 __SCN_8_LENGTH_MODIFIER__ "u"
+# define SCNx8 __SCN_8_LENGTH_MODIFIER__ "x"
+# endif
+
+# define SCNd16 "hd"
+# define SCNi16 "hi"
+# define SCNo16 "ho"
+# define SCNu16 "hu"
+# define SCNx16 "hx"
+
+# define SCNd32 "ld"
+# define SCNi32 "li"
+# define SCNo32 "lo"
+# define SCNu32 "lu"
+# define SCNx32 "lx"
+
+# if defined(__SCN_64_LENGTH_MODIFIER__)
+# define SCNd64 __SCN_64_LENGTH_MODIFIER__ "d"
+# define SCNi64 __SCN_64_LENGTH_MODIFIER__ "i"
+# define SCNo64 __SCN_64_LENGTH_MODIFIER__ "o"
+# define SCNu64 __SCN_64_LENGTH_MODIFIER__ "u"
+# define SCNx64 __SCN_64_LENGTH_MODIFIER__ "x"
+# endif
+
+# if defined(__SCN_8_LENGTH_MODIFIER__)
+# define SCNdLEAST8 SCNd8
+# define SCNiLEAST8 SCNi8
+# define SCNoLEAST8 SCNo8
+# define SCNuLEAST8 SCNu8
+# define SCNxLEAST8 SCNx8
+# endif
+
+# define SCNdLEAST16 SCNd16
+# define SCNiLEAST16 SCNi16
+# define SCNoLEAST16 SCNo16
+# define SCNuLEAST16 SCNu16
+# define SCNxLEAST16 SCNx16
+
+# define SCNdLEAST32 SCNd32
+# define SCNiLEAST32 SCNi32
+# define SCNoLEAST32 SCNo32
+# define SCNuLEAST32 SCNu32
+# define SCNxLEAST32 SCNx32
+
+# if defined(__SCN_64_LENGTH_MODIFIER__)
+# define SCNdLEAST64 SCNd64
+# define SCNiLEAST64 SCNi64
+# define SCNoLEAST64 SCNo64
+# define SCNuLEAST64 SCNu64
+# define SCNxLEAST64 SCNx64
+# endif
+
+# define SCNdFAST8 SCNd32
+# define SCNiFAST8 SCNi32
+# define SCNoFAST8 SCNo32
+# define SCNuFAST8 SCNu32
+# define SCNxFAST8 SCNx32
+
+# define SCNdFAST16 SCNd32
+# define SCNiFAST16 SCNi32
+# define SCNoFAST16 SCNo32
+# define SCNuFAST16 SCNu32
+# define SCNxFAST16 SCNx32
+
+# define SCNdFAST32 SCNd32
+# define SCNiFAST32 SCNi32
+# define SCNoFAST32 SCNo32
+# define SCNuFAST32 SCNu32
+# define SCNxFAST32 SCNx32
+
+# if defined(__SCN_64_LENGTH_MODIFIER__)
+# define SCNdFAST64 SCNd64
+# define SCNiFAST64 SCNi64
+# define SCNoFAST64 SCNo64
+# define SCNuFAST64 SCNu64
+# define SCNxFAST64 SCNx64
+# endif
+
+# define SCNdPTR SCNd32
+# define SCNiPTR SCNi32
+# define SCNoPTR SCNo32
+# define SCNuPTR SCNu32
+# define SCNxPTR SCNx32
+
+# if defined(__SCN_64_LENGTH_MODIFIER__)
+# define SCNdMAX SCNd64
+# define SCNiMAX SCNi64
+# define SCNoMAX SCNo64
+# define SCNuMAX SCNu64
+# define SCNxMAX SCNx64
+# endif
+
+#endif /* if C++, then __STDC_FORMAT_MACROS enables the above macros */
+
+__BEGIN_DECLS
+
+ /* 7.8.2.1 */
+ extern intmax_t imaxabs(intmax_t j);
+
+ /* 7.8.2.2 */
+ typedef struct {
+ intmax_t quot;
+ intmax_t rem;
+ } imaxdiv_t;
+
+ extern imaxdiv_t imaxdiv(intmax_t numer, intmax_t denom);
+
+ /* 7.8.2.3 */
+ extern intmax_t strtoimax(const char * restrict nptr, char ** restrict endptr, int base);
+ extern uintmax_t strtoumax(const char * restrict nptr, char ** restrict endptr, int base);
+
+#ifndef __cplusplus /* wchar_t is a built-in type in C++ */
+# ifndef _BSD_WCHAR_T_DEFINED_
+# define _BSD_WCHAR_T_DEFINED_
+ typedef _BSD_WCHAR_T_ wchar_t;
+# endif
+#endif
+
+ /* 7.8.2.4 */
+ extern intmax_t wcstoimax(const wchar_t * restrict nptr, wchar_t ** restrict endptr, int base);
+ extern uintmax_t wcstoumax(const wchar_t * restrict nptr, wchar_t ** restrict endptr, int base);
+
+__END_DECLS
+
+/*
+ No need to #undef the __*_{8,64}_LENGTH_MODIFIER__ macros;
+ in fact, you can't #undef them, because later uses of any of
+ their dependents will *not* then do the intended substitution.
+ Expansion of a #define like this one:
+
+ #define x IDENT y
+
+ uses the cpp value of IDENT at the location where x is *expanded*,
+ not where it is #defined.
+*/
+
+#if defined(__RESTRICT_KEYWORD_DEFINED__)
+# undef restrict
+# undef __RESTRICT_KEYWORD_DEFINED__
+#endif
+
+#endif /* !_INTTYPES_H_ */
diff --git a/more-hdrs/machine/limits.h b/more-hdrs/machine/limits.h
new file mode 100644
index 00000000000..67d35383bf5
--- /dev/null
+++ b/more-hdrs/machine/limits.h
@@ -0,0 +1,11 @@
+/* This is the `system' limits.h, independent of any particular
+ compiler. GCC provides its own limits.h which can be found in
+ /usr/lib/gcc, although it is not very informative.
+ This file is public domain. */
+#if defined (__ppc__)
+#include <ppc/limits.h>
+#elif defined (__i386__)
+#include <i386/limits.h>
+#else
+#error architecture not supported
+#endif
diff --git a/more-hdrs/ppc_intrinsics.h b/more-hdrs/ppc_intrinsics.h
new file mode 100644
index 00000000000..c9418abdba6
--- /dev/null
+++ b/more-hdrs/ppc_intrinsics.h
@@ -0,0 +1,939 @@
+/* APPLE LOCAL PPC_INTRINSICS */
+
+/* Definitions for PowerPC intrinsic instructions
+ Copyright (C) 2002 Free Software Foundation, Inc.
+
+This file is part of GCC.
+
+GCC is free software; you can redistribute it and/or modify it under
+the terms of the GNU General Public License as published by the Free
+Software Foundation; either version 2, or (at your option) any later
+version.
+
+GCC is distributed in the hope that it will be useful, but WITHOUT ANY
+WARRANTY; without even the implied warranty of MERCHANTABILITY or
+FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+for more details.
+
+You should have received a copy of the GNU General Public License
+along with GCC; see the file COPYING. If not, write to the Free
+Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+02111-1307, USA. */
+
+/* As a special exception, if you include this header file into source
+ files compiled by GCC, this header file does not by itself cause
+ the resulting executable to be covered by the GNU General Public
+ License. This exception does not however invalidate any other
+ reasons why the executable file might be covered by the GNU General
+ Public License. */
+
+/*
+ * The following PowerPC intrinsics are provided by this header:
+ *
+ * Low-Level Processor Synchronization
+ * __eieio - Enforce In-Order Execution of I/O
+ * __isync - Instruction Synchronize
+ * __sync - Synchronize
+ *
+ * Manipulating the Contents of a Variable or Register
+ * __cntlzw - Count Leading Zeros Word
+ * __rlwimi - Rotate Left Word Immediate then Mask Insert
+ * __rlwinm - Rotate Left Word Immediate then AND with Mask
+ * __rlwnm - Rotate Left Word then AND with Mask
+ *
+ * Byte-Reversing Functions
+ * __lhbrx - Load Half Word Byte-Reverse Indexed
+ * __lwbrx - Load Word Byte-Reverse Indexed
+ * __sthbrx - Store Half Word Byte-Reverse Indexed
+ * __stwbrx - Store Word Byte-Reverse Indexed
+ *
+ * Data Cache Manipulation
+ * __dcba - Data Cache Block Allocate
+ * __dcba - Data Cache Block Flush
+ * __dcbst - Data Cache Block Store
+ * __dcbt - Data Cache Block Touch
+ * __dcbtst - Data Cache Block Touch for Store
+ * __dcbz - Data Cache Block Set to Zero
+ *
+ * Setting the Floating-Point Environment
+ * __setflm - Set Floating-point Mode
+ *
+ * Math Functions
+ * __fabs - Floating-Point Absolute Value
+ * __fnabs - Floating Negative Absolute Value
+ * __fctiw - Floating Convert to Integer Word
+ * __fctiwz - Floating Convert to Integer Word with Round toward Zero
+ * __fmadd - Floating Multiply-Add (Double-Precision)
+ * __fmadds - Floating Multiply-Add Single
+ * __fmsub - Floating Multiply-Subract (Double-Precision)
+ * __fmsubs - Floating Multiply-Subract Single
+ * __fmul - Floating Multiply (Double-Precision)
+ * __fmuls - Floating Multiply Single
+ * __fnmadd - Floating Negative Multiply-Add (Double-Precision)
+ * __fnmadds - Floating Negative Multiply-Add Single
+ * __fnmsub - Floating Negative Multiply-Subtract (Double-Precision)
+ * __fnmsubs - Floating Negative Multiply-Subtract Single
+ * __fres - Floating Reciprocal Estimate
+ * __frsp - Floating Round to Single-Precision
+ * __frsqrte - Floating Reciprocal Square Root Estimate
+ * __frsqrtes - Floating Reciprocal Square Root Estimate Single
+ * __fsel - Floating Select
+ * __fsels - Floating Select (Single-Precision variant)
+ * __fsqrt - Floating-Point Square Root (Double-Precision)
+ * __fsqrts - Floating-Point Square Root Single-Precision
+ * __mulhw - Multiply High Word
+ * __mulhwu - Multiply High Word Unsigned
+ * __stfiwx - Store Floating-Point as Integer Word Indexed
+ *
+ * Miscellaneous Functions
+ * __astrcmp - assembly strcmp
+ * __icbi - Instruction Cache Block Invalidate
+ * __mffs - Move from FPSCR
+ * __mfspr - Move from Special Purpose Register
+ * __mtfsf - Move to SPSCR Fields
+ * __mtspr - Move to Special Purpose Register
+ * __OSReadSwapSInt16 - lhbrx for signed shorts
+ * __OSReadSwapUInt16 - lhbrx for unsigned shorts
+ *
+ * TO DO:
+ * - Desired:
+ * mullw
+ * - Available in CodeWarrior, not yet implemented here:
+ * abs, labs, fabsf, fnabsf
+ *
+ * NOTES:
+ * - Some of the intrinsics need to be macros because certain
+ * parameters MUST be integer constants and not values in registers.
+ * - The declarations use __asm__ instead of asm and __inline__ instead
+ * of inline to prevent errors when -ansi is specified.
+ * - Some of the intrinsic definitions use the "volatile" specifier on
+ * the "asm" statements in order to work around what appears to be
+ * a bug in the compiler/optimizer. In general we have avoided the
+ * use of "volatile" because it suppresses optimization on the
+ * generated instructions. The instructions to which "volatile"
+ * has been added where it appears that it should not be needed are
+ * lhbrx and lwbrx.
+ *
+ * Contributors: Fred Forsman (editor), Turly O'Connor, Ian Ollmann
+ * Last modified: June 4, 2002
+ */
+
+#ifndef _PPC_INTRINSICS_H_
+#define _PPC_INTRINSICS_H_
+
+#if defined(__ppc__) && ! defined(__MWERKS__)
+
+/*******************************************************************
+ * Special Purpose Registers (SPRs) *
+ *******************************************************************/
+
+#define __SPR_MQR 0 /* PPC 601 only */
+#define __SPR_XER 1
+#define __SPR_RTCU 4 /* Real time clock upper. PPC 601 only.*/
+#define __SPR_RTCL 5 /* Real time clock lower. PPC 601 only.*/
+#define __SPR_LR 8
+#define __SPR_CTR 9
+#define __SPR_VRSAVE 256 /* AltiVec */
+#define __SPR_TBL 268 /* Time-base Lower. Not on PPC 601 */
+#define __SPR_TBU 269 /* Time-base Upper. Not on PPC 601 */
+#define __SPR_UMMCR2 928 /* PPC 74xx */
+#define __SPR_UPMC5 929 /* PPC 745x */
+#define __SPR_UPMC6 930 /* PPC 745x */
+#define __SPR_UBAMR 935 /* PPC 7400 and 7410 */
+#define __SPR_UMMCR0 936 /* PPC 74xx and 750 */
+#define __SPR_UPMC1 937 /* PPC 74xx and 750 */
+#define __SPR_UPMC2 938 /* PPC 74xx and 750 */
+#define __SPR_USIAR 939 /* PPC 74xx and 750 */
+#define __SPR_UMMCR1 940 /* PPC 74xx and 750 */
+#define __SPR_UPMC3 941 /* PPC 74xx and 750 */
+#define __SPR_UPMC4 942 /* PPC 74xx and 750 */
+#define __SPR_PIR 1023 /* supervisor level only! */
+
+/*
+ * Shorthand macros for some commonly used SPR's.
+ */
+#define __mfxer() __mfspr(__SPR_XER)
+#define __mflr() __mfspr(__SPR_LR)
+#define __mfctr() __mfspr(__SPR_CTR)
+#define __mfvrsave() __mfspr(__SPR_VRSAVE)
+#define __mftb() __mfspr(__SPR_TBL)
+#define __mftbu() __mfspr(__SPR_TBU)
+
+#define __mtlr(value) __mtspr(__SPR_LR, value)
+#define __mtxer(value) __mtspr(__SPR_XER, value)
+#define __mtctr(value) __mtspr(__SPR_CTR, value)
+#define __mtvrsave(value) __mtspr(__SPR_VRSAVE, value)
+
+
+/*******************************************************************
+ * Low-Level Processor Synchronization *
+ *******************************************************************/
+
+/*
+ * __eieio - Enforce In-Order Execution of I/O
+ *
+ * void __eieio (void);
+ */
+#define __eieio() __asm__ ("eieio" : : : "memory")
+
+/*
+ * __isync - Instruction Synchronize
+ *
+ * void __isync (void);
+ */
+#define __isync() \
+ __asm__ volatile ("isync")
+
+/*
+ * __sync - Synchronize
+ *
+ * void __sync (void);
+ */
+#define __sync() __asm__ volatile ("sync")
+
+
+/*******************************************************************
+ * Byte-Reversing Functions *
+ *******************************************************************/
+
+/*
+ * __lhbrx - Load Half Word Byte-Reverse Indexed
+ *
+ * int __lhbrx(void *, int);
+ */
+#define __lhbrx(base, index) \
+ ({ unsigned short lhbrxResult; \
+ __asm__ volatile ("lhbrx %0, %1, %2" : "=r" (lhbrxResult) : "b%" (index), "r" (base) : "memory"); \
+ /*return*/ lhbrxResult; })
+
+/*
+ * __lwbrx - Load Word Byte-Reverse Indexed
+ *
+ * int __lwbrx(void *, int);
+ */
+#define __lwbrx(base, index) \
+ ({ unsigned long lwbrxResult; \
+ __asm__ volatile ("lwbrx %0, %1, %2" : "=r" (lwbrxResult) : "b%" (index), "r" (base) : "memory"); \
+ /*return*/ lwbrxResult; })
+
+/*
+ * __sthbrx - Store Half Word Byte-Reverse Indexed
+ *
+ * int __sthbrx(unsigned short, void *, int);
+ */
+#define __sthbrx(value, base, index) \
+ __asm__ ("sthbrx %0, %1, %2" : : "r" (value), "b%" (index), "r" (base) : "memory")
+
+/*
+ * __stwbrx - Store Word Byte-Reverse Indexed
+ *
+ * int __sthbrx(unsigned int, void *, int);
+ */
+#define __stwbrx(value, base, index) \
+ __asm__ ("stwbrx %0, %1, %2" : : "r" (value), "b%" (index), "r" (base) : "memory")
+
+
+/*******************************************************************
+ * Manipulating the Contents of a Variable or Register *
+ *******************************************************************/
+
+/*
+ * __cntlzw - Count Leading Zeros Word
+ */
+static inline int __cntlzw (int value) __attribute__((always_inline));
+static inline int
+__cntlzw (int value)
+{
+ long result;
+ __asm__ ("cntlzw %0, %1"
+ /* outputs: */ : "=r" (result)
+ /* inputs: */ : "r" (value));
+ return result;
+}
+
+/*
+ * __rlwimi - Rotate Left Word Immediate then Mask Insert
+ *
+ * int __rlwimi(int, int, int, int, int);
+ *
+ * We don't mention "%1" below: operand[1] needs to be skipped as
+ * it's just a placeholder to let the compiler know that rA is read
+ * from as well as written to.
+ */
+#define __rlwimi(rA, rS, cnt, mb, me) \
+ ({ __asm__ ("rlwimi %0,%2,%3,%4,%5" : "=r" (rA) \
+ : "0" (rA), "r" (rS), "n" (cnt), "n" (mb), "n" (me)); \
+ /*return*/ rA;})
+
+/*
+ * __rlwinm - Rotate Left Word Immediate then AND with Mask
+ *
+ * int __rlwinm(int, int, int, int);
+ */
+#define __rlwinm(rS, cnt, mb, me) \
+ ({ unsigned long val, src = (rS); \
+ __asm__ ("rlwinm %0,%1,%2,%3,%4" : "=r" (val) \
+ : "r" (src), "n" (cnt), "n" (mb), "n" (me)); \
+ /*return*/ val;})
+
+/*
+ * __rlwnm - Rotate Left Word then AND with Mask
+ *
+ * int __rlwnm(int, int, int, int);
+ */
+#define __rlwnm(value, leftRotateBits, maskStart, maskEnd) \
+ ({ long result; \
+ __asm__ ("rlwnm %0, %1, %2, %3, %4" : "=r" (result) : \
+ "r" (value), "r" (leftRotateBits), "n" (maskStart), "n" (maskEnd)); \
+ /*return */ result; })
+
+
+/*******************************************************************
+ * Data Cache Manipulation *
+ *******************************************************************/
+
+/*
+ * --- Data Cache Block instructions ---
+ *
+ * Please see Motorola's "The Programming Environments for 32-Bit
+ * Microprocessors" for a description of what these do.
+ *
+ * Parameter descriptions:
+ *
+ * base starting address for figuring out where the
+ * cacheline is
+ *
+ * index byte count to be added to the base address for
+ * purposes of calculating the effective address
+ * of the cacheline to be operated on.
+ *
+ * Effective Address of cacheline to be manipulated =
+ * (char*) base + index
+ *
+ * WARNING: The size and alignment of cachelines are subject to
+ * change on future processors! Cachelines are 32 bytes in
+ * size and are aligned to 32 bytes on PowerPC 601, 603, 604,
+ * 750, 7400, 7410, 7450, and 7455.
+ *
+ */
+
+/*
+ * __dcba - Data Cache Block Allocate
+ *
+ * void __dcba(void *, int)
+ *
+ * WARNING: dcba is a valid instruction only on PowerPC 7400, 7410,
+ * 7450 and 7455.
+ */
+#define __dcba(base, index) \
+ __asm__ ("dcba %0, %1" : /*no result*/ : "b%" (index), "r" (base) : "memory")
+
+/*
+ * __dcbf - Data Cache Block Flush
+ *
+ * void __dcbf(void *, int);
+ */
+#define __dcbf(base, index) \
+ __asm__ ("dcbf %0, %1" : /*no result*/ : "b%" (index), "r" (base) : "memory")
+
+/*
+ * __dcbst - Data Cache Block Store
+ *
+ * void __dcbst(void *, int);
+ */
+#define __dcbst(base, index) \
+ __asm__ ("dcbst %0, %1" : /*no result*/ : "b%" (index), "r" (base) : "memory")
+
+/*
+ * __dcbt - Data Cache Block Touch
+ *
+ * void __dcbt(void *, int);
+ */
+#define __dcbt(base, index) \
+ __asm__ ("dcbt %0, %1" : /*no result*/ : "b%" (index), "r" (base) : "memory")
+
+/*
+ * __dcbtst - Data Cache Block Touch for Store
+ *
+ * void __dcbtst(void *, int);
+ */
+#define __dcbtst(base, index) \
+ __asm__ ("dcbtst %0, %1" : /*no result*/ : "b%" (index), "r" (base) : "memory")
+
+/*
+ * __dcbz - Data Cache Block Set to Zero
+ *
+ * void __dcbz(void *, int);
+ */
+#define __dcbz(base, index) \
+ __asm__ ("dcbz %0, %1" : /*no result*/ : "b%" (index), "r" (base) : "memory")
+
+
+/*******************************************************************
+ * Setting the Floating-Point Environment *
+ *******************************************************************/
+
+/*
+ * __setflm - Set Floating-point Mode
+ *
+ * Sets the FPSCR (floating-point status and control register),
+ * returning the original value.
+ *
+ * ??? CW: float __setflm(float);
+ */
+static inline double __setflm (double newflm) __attribute__((always_inline));
+static inline double
+__setflm(double newflm)
+{
+ double original;
+
+ __asm__ ("mffs %0"
+ /* outputs: */ : "=f" (original));
+ __asm__ ("mtfsf 255,%0"
+ /* outputs: */ : /* none */
+ /* inputs: */ : "f" (newflm));
+ return original;
+}
+
+
+/*******************************************************************
+ * Math Functions *
+ *******************************************************************/
+
+/*
+ * __fabs - Floating-Point Absolute Value
+ */
+static inline double __fabs (double value) __attribute__((always_inline));
+static inline double
+__fabs (double value)
+{
+ double result;
+ __asm__ ("fabs %0, %1"
+ /* outputs: */ : "=f" (result)
+ /* inputs: */ : "f" (value));
+ return result;
+}
+
+/*
+ * __fnabs - Floating Negative Absolute Value
+ */
+static inline double __fnabs (double b) __attribute__((always_inline));
+static inline double
+__fnabs (double b)
+{
+ double result;
+ __asm__ ("fnabs %0, %1"
+ /* outputs: */ : "=f" (result)
+ /* inputs: */ : "f" (b));
+ return result;
+}
+
+/*
+ * fctiw - Floating Convert to Integer Word
+ *
+ * Convert the input value to a signed long and place in the low 32
+ * bits of the FP register. Clip to LONG_MIN or LONG_MAX if the FP
+ * value exceeds the range representable by a long. Use the rounding
+ * mode indicated in the FPSCR.
+ */
+static inline double __fctiw (double b) __attribute__((always_inline));
+static inline double
+__fctiw (double b)
+{
+ double result;
+ __asm__ ("fctiw %0, %1"
+ /* outputs: */ : "=f" (result)
+ /* inputs: */ : "f" (b));
+ return result;
+}
+
+/*
+ * fctiwz - Floating Convert to Integer Word with Round toward Zero
+ *
+ * Convert the input value to a signed long and place in the low 32
+ * bits of the FP register. Clip to LONG_MIN or LONG_MAX if the FP
+ * value exceeds the range representable by a long.
+ */
+static inline double __fctiwz (double b) __attribute__((always_inline));
+static inline double
+__fctiwz (double b)
+{
+ double result;
+ __asm__ ("fctiwz %0, %1"
+ /* outputs: */ : "=f" (result)
+ /* inputs: */ : "f" (b));
+ return result;
+}
+
+/*
+ * fmadd - Floating Multiply-Add (Double-Precision)
+ *
+ * (a * c + b) double precision
+ */
+static inline double __fmadd (double a, double c, double b) __attribute__((always_inline));
+static inline double
+__fmadd (double a, double c, double b)
+{
+ double result;
+ __asm__ ("fmadd %0, %1, %2, %3"
+ /* outputs: */ : "=f" (result)
+ /* inputs: */ : "f" (a), "f" (c), "f" (b));
+ return result;
+}
+
+/*
+ * fmadds - Floating Multiply-Add Single
+ *
+ * (a * c + b) single precision
+ *
+ * Double precision arguments are used to prevent the compiler from
+ * issuing frsp instructions upstream.
+ */
+static inline float __fmadds (double a, double c, double b) __attribute__((always_inline));
+static inline float
+__fmadds (double a, double c, double b)
+{
+ float result;
+ __asm__ ("fmadds %0, %1, %2, %3"
+ /* outputs: */ : "=f" (result)
+ /* inputs: */ : "f" (a), "f" (c), "f" (b));
+ return result;
+}
+
+/*
+ * fmsub - Floating Multiply-Subract (Double-Precision)
+ *
+ * (a * c - b) double precision
+ */
+static inline double __fmsub (double a, double c, double b) __attribute__((always_inline));
+static inline double
+__fmsub (double a, double c, double b)
+{
+ double result;
+ __asm__ ("fmsub %0, %1, %2, %3"
+ /* outputs: */ : "=f" (result)
+ /* inputs: */ : "f" (a), "f" (c), "f" (b));
+ return result;
+}
+
+/*
+ * fmsubs - Floating Multiply-Subract Single
+ *
+ * (a * c - b) single precision
+ *
+ * Double precision arguments are used to prevent the compiler from
+ * issuing frsp instructions upstream.
+ */
+static inline float __fmsubs (double a, double c, double b) __attribute__((always_inline));
+static inline float
+__fmsubs (double a, double c, double b)
+{
+ float result;
+ __asm__ ("fmsubs %0, %1, %2, %3"
+ /* outputs: */ : "=f" (result)
+ /* inputs: */ : "f" (a), "f" (c), "f" (b));
+ return result;
+}
+
+/*
+ * fmul - Floating Multiply (Double-Precision)
+ *
+ * (a * c) double precision
+ */
+static inline double __fmul (double a, double c) __attribute__((always_inline));
+static inline double
+__fmul (double a, double c)
+{
+ double result;
+ __asm__ ("fmul %0, %1, %2"
+ /* outputs: */ : "=f" (result)
+ /* inputs: */ : "f" (a), "f" (c));
+ return result;
+}
+
+/*
+ * fmuls - Floating Multiply Single
+ *
+ * (a * c) single precision
+ *
+ * Double precision arguments are used to prevent the compiler from
+ * issuing frsp instructions upstream.
+ */
+static inline float __fmuls (double a, double c) __attribute__((always_inline));
+static inline float
+__fmuls (double a, double c)
+{
+ float result;
+ __asm__ ("fmuls %0, %1, %2"
+ /* outputs: */ : "=f" (result)
+ /* inputs: */ : "f" (a), "f" (c));
+ return result;
+}
+
+/*
+ * __fnmadd - Floating Negative Multiply-Add (Double-Precision)
+ *
+ * -(a * c + b) double precision
+ */
+static inline double __fnmadd (double a, double c, double b) __attribute__((always_inline));
+static inline double
+__fnmadd (double a, double c, double b)
+{
+ double result;
+ __asm__ ("fnmadd %0, %1, %2, %3"
+ /* outputs: */ : "=f" (result)
+ /* inputs: */ : "f" (a), "f" (c), "f" (b));
+ return result;
+}
+
+/*
+ * __fnmadds - Floating Negative Multiply-Add Single
+ *
+ * -(a * c + b) single precision
+ *
+ * Double precision arguments are used to prevent the compiler from
+ * issuing frsp instructions upstream.
+ */
+static inline float __fnmadds (double a, double c, double b) __attribute__((always_inline));
+static inline float
+__fnmadds (double a, double c, double b)
+{
+ float result;
+ __asm__ ("fnmadds %0, %1, %2, %3"
+ /* outputs: */ : "=f" (result)
+ /* inputs: */ : "f" (a), "f" (c), "f" (b));
+ return result;
+}
+
+/*
+ * __fnmsub - Floating Negative Multiply-Subtract (Double-Precision)
+ *
+ * -(a * c - B) double precision
+ */
+static inline double __fnmsub (double a, double c, double b) __attribute__((always_inline));
+static inline double
+__fnmsub (double a, double c, double b)
+{
+ double result;
+ __asm__ ("fnmsub %0, %1, %2, %3"
+ /* outputs: */ : "=f" (result)
+ /* inputs: */ : "f" (a), "f" (c), "f" (b));
+ return result;
+}
+
+/*
+ * __fnmsubs - Floating Negative Multiply-Subtract Single
+ *
+ * -(a * c - b) single precision
+ *
+ * Double precision arguments are used to prevent the compiler from
+ * issuing frsp instructions upstream.
+ */
+static inline float __fnmsubs (double a, double c, double b) __attribute__((always_inline));
+static inline float
+__fnmsubs (double a, double c, double b)
+{
+ float result;
+ __asm__ ("fnmsubs %0, %1, %2, %3"
+ /* outputs: */ : "=f" (result)
+ /* inputs: */ : "f" (a), "f" (c), "f" (b));
+ return result;
+}
+
+/*
+ * __fres - Floating Reciprocal Estimate
+ *
+ * Produces a double precision result with 5 bits of accuracy.
+ * Note: not valid on the PowerPC 601.
+ *
+ * ??? CW: float __fres(float)
+ */
+static inline float __fres (float val) __attribute__((always_inline));
+static inline float
+__fres (float val)
+{
+ float estimate;
+ __asm__ ("fres %0,%1"
+ /* outputs: */ : "=f" (estimate)
+ /* inputs: */ : "f" (val));
+ return estimate;
+}
+
+/*
+ * __frsp - Floating Round to Single-Precision
+ */
+static inline float __frsp (double d) __attribute__((always_inline));
+static inline float
+__frsp (double d)
+{
+ float result;
+ __asm__ ("frsp %0, %1"
+ /* outputs: */ : "=f" (result)
+ /* inputs: */ : "f" (d));
+ return result;
+}
+
+/*
+ * __frsqrte - Floating Reciprocal Square Root Estimate
+ *
+ * Note: not valid on the PowerPC 601.
+ */
+static inline double __frsqrte (double val) __attribute__((always_inline));
+static inline double
+__frsqrte (double val)
+{
+ double estimate;
+
+ __asm__ ("frsqrte %0,%1"
+ /* outputs: */ : "=f" (estimate)
+ /* inputs: */ : "f" (val));
+ return estimate;
+}
+
+/*
+ * __frsqrtes - Floating Reciprocal Square Root Estimate Single
+ */
+static inline float __frsqrtes (double f) __attribute__((always_inline));
+static inline float
+__frsqrtes (double f)
+{
+ float result;
+ __asm__ ("frsqrte %0, %1"
+ /* outputs: */ : "=f" (result)
+ /* inputs: */ : "f" (f));
+ return result;
+}
+
+/*
+ * __fsel - Floating Select
+ *
+ * if (test >= 0) return a; else return b;
+ *
+ * Note: not valid on the PowerPC 601.
+ */
+static inline double __fsel (double test, double a, double b) __attribute__((always_inline));
+static inline double
+__fsel (double test, double a, double b)
+{
+ double result;
+ __asm__ ("fsel %0,%1,%2,%3"
+ /* outputs: */ : "=f" (result)
+ /* inputs: */ : "f" (test), "f" (a), "f" (b));
+ return result;
+}
+
+/*
+ * __fsels - Floating Select (Single-Precision variant)
+ *
+ * An artificial single precision variant of fsel. This produces the
+ * same results as fsel, but is useful because the result is cast as
+ * a float, discouraging the compiler from issuing a frsp instruction
+ * afterward.
+ */
+static inline float __fsels (double test, double a, double b) __attribute__((always_inline));
+static inline float
+__fsels (double test, double a, double b)
+{
+ float result;
+ __asm__ ("fsel %0,%1,%2,%3"
+ /* outputs: */ : "=f" (result)
+ /* inputs: */ : "f" (test), "f" (a), "f" (b));
+ return result;
+}
+
+/*
+ * __fsqrt - Floating-Point Square Root (Double-Precision)
+ *
+ * WARNING: Illegal instruction for PowerPC 603, 604, 750, 7400, 7410,
+ * 7450, and 7455
+ */
+static inline double __fsqrt (double b) __attribute__((always_inline));
+static inline double
+__fsqrt(double d)
+{
+ double result;
+ __asm__ ("fsqrt %0, %1"
+ /* outputs: */ : "=f" (result)
+ /* inputs: */ : "f" (d));
+ return result;
+}
+
+/*
+ * __fsqrts - Floating-Point Square Root Single-Precision
+ *
+ * WARNING: Illegal instruction for PowerPC 603, 604, 750, 7400, 7410,
+ * 7450, and 7455
+ */
+static inline float __fsqrts (float f) __attribute__((always_inline));
+static inline float
+__fsqrts (float f)
+{
+ float result;
+ __asm__ ("fsqrts %0, %1"
+ /* outputs: */ : "=f" (result)
+ /* inputs: */ : "f" (f));
+ return result;
+}
+
+/*
+ * __mulhw - Multiply High Word
+ */
+static inline int __mulhw (int a, int b) __attribute__((always_inline));
+static inline int
+__mulhw (int a, int b)
+{
+ long result;
+ __asm__ ("mulhw %0, %1, %2"
+ /* outputs: */ : "=r" (result)
+ /* inputs: */ : "r" (a), "r"(b));
+ return result;
+}
+
+/*
+ * __mulhwu - Multiply High Word Unsigned
+ */
+static inline unsigned int __mulhwu (unsigned int a, unsigned int b) __attribute__((always_inline));
+static inline unsigned int
+__mulhwu (unsigned int a, unsigned int b)
+{
+ unsigned long result;
+ __asm__ ("mulhwu %0, %1, %2"
+ /* outputs: */ : "=r" (result)
+ /* inputs: */ : "r" (a), "r"(b));
+ return result;
+}
+
+/*
+ * __stfiwx - Store Floating-Point as Integer Word Indexed
+ *
+ * void x(int, void *, int);
+ */
+#define __stfiwx(value, base, index) \
+ __asm__ ("stfiwx %0, %1, %2" : /*no result*/ \
+ : "f" (value), "b%" (index), "r" (base) : "memory")
+
+
+/*******************************************************************
+ * Miscellaneous Functions *
+ *******************************************************************/
+
+/*
+ * __icbi - Instruction Cache Block Invalidate
+ *
+ * void __icbi(void *, int);
+ */
+#define __icbi(base, index) \
+ __asm__ ("icbi %0, %1" : /*no result*/ : "b%" (index), "r" (base) : "memory")
+
+/*
+ * __mffs - Move from FPSCR
+ */
+static inline double __mffs (void) __attribute__((always_inline));
+static inline double
+__mffs (void)
+{
+ double result;
+ __asm__ volatile ("mffs %0"
+ /* outputs: */ : "=f" (result));
+ return result;
+}
+
+/*
+ * __mfspr - Move from Special Purpose Register
+ *
+ * int __mfspr(int);
+ */
+#define __mfspr(spr) \
+ ({ long mfsprResult; \
+ __asm__ volatile ("mfspr %0, %1" : "=r" (mfsprResult) : "n" (spr)); \
+ /*return*/ mfsprResult; })
+
+/*
+ * __mtfsf - Move to SPSCR Fields
+ *
+ * void __mtfsf(int, int);
+ */
+#define __mtfsf(mask, newValue) \
+ __asm__ volatile ("mtfsf %0, %1" : : "n" (mask), "f" (newValue))
+
+/*
+ * __mtspr - Move to Special Purpose Register
+ *
+ * __mtspr x(int, int);
+ */
+#define __mtspr(spr, value) \
+ __asm__ volatile ("mtspr %0, %1" : : "n" (spr), "r" (value))
+
+/*
+ * __OSReadSwapSInt16
+ *
+ * lhbrx for signed shorts. This will do the required sign
+ * extension after load and byteswap.
+ */
+static inline signed short __OSReadSwapSInt16 (signed short *base, int index) __attribute__((always_inline));
+static inline signed short
+__OSReadSwapSInt16 (signed short *base, int index)
+{
+ signed long result;
+ __asm__ volatile ("lhbrx %0, %1, %2"
+ /* outputs: */ : "=r" (result)
+ /* inputs: */ : "b%" (index), "r" (base)
+ /* clobbers: */ : "memory");
+ return result;
+}
+
+/*
+ * __OSReadSwapUInt16
+ */
+static inline unsigned short __OSReadSwapUInt16 (volatile void *base, int inex) __attribute__((always_inline));
+static inline unsigned short
+__OSReadSwapUInt16 (volatile void *base, int index)
+{
+ unsigned long result;
+ __asm__ volatile ("lhbrx %0, %1, %2"
+ /* outputs: */ : "=r" (result)
+ /* inputs: */ : "b" (index), "r" (base)
+ /* clobbers: */ : "memory");
+ return result;
+}
+
+/*
+ * __astrcmp - assembly strcmp
+ */
+static inline int astrcmp (const char *in_s1, const char *in_s2) __attribute__((always_inline));
+static inline int
+astrcmp (const char *in_s1, const char *in_s2)
+{
+ int result, temp;
+ register const char *s1 = in_s1 - 1;
+ register const char *s2 = in_s2 - 1;
+
+ __asm__ ("1:lbzu %0,1(%1)\n"
+ "\tcmpwi cr1,%0,0\n"
+ "\tlbzu %3,1(%2)\n"
+ "\tsubf. %0,%3,%0\n"
+ "\tbeq- cr1,2f\n"
+ "\tbeq+ 1b\n2:"
+ /* outputs: */ : "=&r" (result), "+b" (s1), "+b" (s2), "=r" (temp)
+ /* inputs: */ :
+ /* clobbers: */ : "cr0", "cr1", "memory");
+
+ return result;
+
+ /*
+ * "=&r" (result) means: 'result' is written on (the '='), it's any GP
+ * register (the 'r'), and it must not be the same as
+ * any of the input registers (the '&').
+ * "+b" (s1) means: 's1' is read from and written to (the '+'),
+ * and it must be a base GP register (i.e., not R0.)
+ * "=r" (temp) means: 'temp' is any GP reg and it's only written to.
+ *
+ * "memory" in the 'clobbers' section means that gcc will make
+ * sure that anything that should be in memory IS there
+ * before calling this routine.
+ */
+}
+
+#endif /* defined(__ppc__) && ! defined(__MWERKS__) */
+
+#endif /* _PPC_INTRINSICS_H_ */
diff --git a/more-hdrs/stdarg.h b/more-hdrs/stdarg.h
new file mode 100644
index 00000000000..e12e16383c6
--- /dev/null
+++ b/more-hdrs/stdarg.h
@@ -0,0 +1,6 @@
+/* This file is public domain. */
+#ifdef __MWERKS__
+#include "mw_stdarg.h"
+#else
+#error "This header only supports __MWERKS__."
+#endif
diff --git a/more-hdrs/stdbool.h b/more-hdrs/stdbool.h
new file mode 100644
index 00000000000..ee1d976ce16
--- /dev/null
+++ b/more-hdrs/stdbool.h
@@ -0,0 +1,2 @@
+/* This file is public domain. */
+#error "stdbool.h has moved to avoid accidental use with a non-GCC compiler. Only GCC should have used stdbool.h due to licensing restrictions."
diff --git a/more-hdrs/stdint.h b/more-hdrs/stdint.h
new file mode 100644
index 00000000000..ce729ca94a5
--- /dev/null
+++ b/more-hdrs/stdint.h
@@ -0,0 +1,203 @@
+/*
+ * Copyright (c) 2000,2001 Apple Computer, Inc. All rights reserved.
+ *
+ * We build on <machine/types.h> rather than <sys/types.h> in order to
+ * minimize the global namespace pollution (i.e., we'd like to define
+ * *only* those identifiers that the C standard mandates should be
+ * defined by <stdint.h>). Using <machine/types.h> means that (at
+ * least as of January 2001) all of the extra macros that do get
+ * #defined by #include'ing <stdint.h> are in the implementor's
+ * namespace ("_[A-Z].*" or "__.*").
+ *
+ * The reason that we do #include the relevant ...types.h instead of
+ * creating several "competing" typedefs is to make header collisions
+ * less likely during the transition to C99.
+ *
+ * Caveat: There are still five extra typedef's defined by doing it
+ * this way: "u_int{8,16,32,64}_t" and "register_t". Might be
+ * fixable via pre- and post- #defines, but probably not worth it.
+ */
+
+#ifndef _STDINT_H_
+#define _STDINT_H_
+
+#include <machine/types.h>
+
+
+/* from ISO/IEC 988:1999 spec */
+
+/* 7.18.1.1 Exact-width integer types */
+ /* int8_t is defined in <machine/types.h> */
+ /* int16_t is defined in <machine/types.h> */
+ /* int32_t is defined in <machine/types.h> */
+ /* int64_t is defined in <machine/types.h> */
+typedef u_int8_t uint8_t; /* u_int8_t is defined in <machine/types.h> */
+typedef u_int16_t uint16_t; /* u_int16_t is defined in <machine/types.h> */
+typedef u_int32_t uint32_t; /* u_int32_t is defined in <machine/types.h> */
+typedef u_int64_t uint64_t; /* u_int64_t is defined in <machine/types.h> */
+
+
+/* 7.18.1.2 Minumun-width integer types */
+typedef int8_t int_least8_t;
+typedef int16_t int_least16_t;
+typedef int32_t int_least32_t;
+typedef int64_t int_least64_t;
+typedef uint8_t uint_least8_t;
+typedef uint16_t uint_least16_t;
+typedef uint32_t uint_least32_t;
+typedef uint64_t uint_least64_t;
+
+
+/* 7.18.1.3 Fastest-width integer types */
+typedef int8_t int_fast8_t;
+typedef int16_t int_fast16_t;
+typedef int32_t int_fast32_t;
+typedef int64_t int_fast64_t;
+typedef uint8_t uint_fast8_t;
+typedef uint16_t uint_fast16_t;
+typedef uint32_t uint_fast32_t;
+typedef uint64_t uint_fast64_t;
+
+
+/* 7.18.1.4 Integer types capable of hgolding object pointers */
+ /* intptr_t is defined in <machine/types.h> */
+ /* uintptr_t is defined in <machine/types.h> */
+
+
+/* 7.18.1.5 Greatest-width integer types */
+typedef long long intmax_t;
+typedef unsigned long long uintmax_t;
+
+
+/* "C++ implementations should define these macros only when
+ * __STDC_LIMIT_MACROS is defined before <stdint.h> is included."
+ * In other words, if C++, then __STDC_LIMIT_MACROS enables the
+ * macros below. (Note that there also exists a different enabling
+ * macro (__STDC_CONSTANT_MACROS) for the last few, below.)
+ */
+#if (! defined(__cplusplus)) || defined(__STDC_LIMIT_MACROS)
+
+
+/* 7.18.2 Limits of specified-width integer types:
+ * These #defines specify the minimum and maximum limits
+ * of each of the types declared above.
+ */
+
+
+/* 7.18.2.1 Limits of exact-width integer types */
+#define INT8_MAX 127
+#define INT16_MAX 32767
+#define INT32_MAX 2147483647
+#define INT64_MAX 9223372036854775807LL
+
+#define INT8_MIN -128
+#define INT16_MIN -32768
+ /*
+ Note: the literal "most negative int" cannot be written in C --
+ the rules in the standard (section 6.4.4.1 in C99) will give it
+ an unsigned type, so INT32_MIN (and the most negative member of
+ any larger signed type) must be written via a constant expression.
+ */
+#define INT32_MIN (-INT32_MAX-1)
+#define INT64_MIN (-INT64_MAX-1)
+
+#define UINT8_MAX 255
+#define UINT16_MAX 65535
+#define UINT32_MAX 4294967295U
+#define UINT64_MAX 18446744073709551615ULL
+
+/* 7.18.2.2 Limits of minimum-width integer types */
+#define INT_LEAST8_MIN INT8_MIN
+#define INT_LEAST16_MIN INT16_MIN
+#define INT_LEAST32_MIN INT32_MIN
+#define INT_LEAST64_MIN INT64_MIN
+
+#define INT_LEAST8_MAX INT8_MAX
+#define INT_LEAST16_MAX INT16_MAX
+#define INT_LEAST32_MAX INT32_MAX
+#define INT_LEAST64_MAX INT64_MAX
+
+#define UINT_LEAST8_MAX UINT8_MAX
+#define UINT_LEAST16_MAX UINT16_MAX
+#define UINT_LEAST32_MAX UINT32_MAX
+#define UINT_LEAST64_MAX UINT64_MAX
+
+/* 7.18.2.3 Limits of fastest minimum-width integer types */
+#define INT_FAST8_MIN INT8_MIN
+#define INT_FAST16_MIN INT16_MIN
+#define INT_FAST32_MIN INT32_MIN
+#define INT_FAST64_MIN INT64_MIN
+
+#define INT_FAST8_MAX INT8_MAX
+#define INT_FAST16_MAX INT16_MAX
+#define INT_FAST32_MAX INT32_MAX
+#define INT_FAST64_MAX INT64_MAX
+
+#define UINT_FAST8_MAX UINT8_MAX
+#define UINT_FAST16_MAX UINT16_MAX
+#define UINT_FAST32_MAX UINT32_MAX
+#define UINT_FAST64_MAX UINT64_MAX
+
+/* 7.18.2.4 Limits of integer types capable of holding object pointers */
+
+#define INTPTR_MIN INT32_MIN
+#define INTPTR_MAX INT32_MAX
+
+#define UINTPTR_MAX UINT32_MAX
+
+/* 7.18.2.5 Limits of greatest-width integer types */
+#define INTMAX_MIN INT64_MIN
+#define INTMAX_MAX INT64_MAX
+
+#define UINTMAX_MAX UINT64_MAX
+
+/* 7.18.3 "Other" */
+#define PTRDIFF_MIN INT32_MIN
+#define PTRDIFF_MAX INT32_MAX
+
+/* We have no sig_atomic_t yet, so no SIG_ATOMIC_{MIN,MAX}.
+ Should end up being {-127,127} or {0,255} ... or bigger.
+ My bet would be on one of {U}INT32_{MIN,MAX}. */
+
+#define SIZE_MAX UINT32_MAX
+
+#ifndef WCHAR_MIN
+# define WCHAR_MIN 0
+#endif
+
+#ifndef WCHAR_MAX
+# ifdef __WCHAR_MAX__
+# define WCHAR_MAX __WCHAR_MAX__
+# else
+# define WCHAR_MAX 0x7fffffff
+# endif
+#endif
+
+/* We have no wint_t yet, so no WINT_{MIN,MAX}.
+ Should end up being {U}INT32_{MIN,MAX}, depending. */
+
+
+#endif /* if C++, then __STDC_LIMIT_MACROS enables the above macros */
+
+/* "C++ implementations should define these macros only when
+ * __STDC_CONSTANT_MACROS is defined before <stdint.h> is included."
+ */
+#if (! defined(__cplusplus)) || defined(__STDC_CONSTANT_MACROS)
+
+/* 7.18.4 Macros for integer constants */
+#define INT8_C(v) ((int8_t)v)
+#define INT16_C(v) ((int16_t)v)
+#define INT32_C(v) (v ## L)
+#define INT64_C(v) (v ## LL)
+
+#define UINT8_C(v) ((uint8_t)v)
+#define UINT16_C(v) ((uint16_t)v)
+#define UINT32_C(v) (v ## UL)
+#define UINT64_C(v) (v ## ULL)
+
+#define INTMAX_C(v) (v ## LL)
+#define UINTMAX_C(v) (v ## ULL)
+
+#endif /* if C++, then __STDC_CONSTANT_MACROS enables the above macros */
+
+#endif /* _STDINT_H_ */
diff --git a/more-hdrs/varargs.h b/more-hdrs/varargs.h
new file mode 100644
index 00000000000..83188caef34
--- /dev/null
+++ b/more-hdrs/varargs.h
@@ -0,0 +1,6 @@
+/* This file is public domain. */
+#ifdef __MWERKS__
+#include "mw_varargs.h"
+#else
+#error "This header only supports __MWERKS__."
+#endif
diff --git a/order-files/HOW TO BUILD b/order-files/HOW TO BUILD
new file mode 100644
index 00000000000..7cca046f37a
--- /dev/null
+++ b/order-files/HOW TO BUILD
@@ -0,0 +1,170 @@
+ Creating Order files, i.e., Scatter Loading the Compiler
+ --------------------------------------------------------
+
+This is a brief description on how to generate the cc1*.order files.
+The order files are intended to minimize the number of page-ins of
+the compiler as it is loaded. If there is enough memory this
+benifits only the first load of the compiler since it will stay
+resident after that.
+
+Unfortunately it's a manual process since one of the tools requires
+an explicit interrupt from the terminal. You should only need to
+(re)do the order files if there's any major reorganizations or
+additions to the compilers.
+
+There are five steps involved to genrrate the order files.
+
+1. Select test cases.
+
+ These should be "average" compilations to exercise each of the
+ cc1* compilers. They should be large enough to take enough time
+ to generate acceptible results. As of this writing the
+ following cases were chosen:
+
+ For cc1 - gcc/c-decl.c (from the compiler sources)
+ For cc1plus - Finder_FE/AboutWindow/AboutWindow.cp
+ For cc1obj - MailViewer/Compose.subproj/MessageEditor.m
+ For cc1objplus - devkit/cpp.subproj/Cpp-precomp.mm
+
+ Of these four the cc1objplus test case is not very good.
+ Unfortunately there are few .mm files of any significant size.
+ If a better one can be found it probably should be used.
+
+2. Capture the command lines needed to build the chosen files.
+
+ For the selected projects built with with PB set PB's building
+ preferences for detailed build logs. That way you can the
+ full command lines you need. In non-PB projects like gcc the
+ command lines are of course echoed on the terminal.
+
+3. Run selected command lines with -### to get the cc1* lines.
+
+ From the full command lines you need the cc1* lines generated
+ by the driver. The easiest way to get these is to add -###
+ to the full command lines captured in step 2.
+
+4. Prepare to generate the order files
+
+ If you don't already have it you should build a set of cc1*
+ compilers with -O2 with symbols. The easiest way to do this
+ is FSF-style but using buildit with build_gcc probably will
+ also work.
+
+ In the gcc objects directory you will of course have the cc1*
+ compilers. You need to substitute these in each of the cc1*
+ command lines captured in step 3. You also need to run these
+ with ~perf/bin/pcsample to generate the order files. Thus,
+ for each cc1* command line it should have the following in
+ the beginning in place of the original cc1* of the step 3
+ lines.
+
+ sudo ~perf/bin/pcsample -O -E $gcc3-obj/cc1* ... rest of line...
+
+ Where $gcc3-obj represents whatever the path is to the gcc3
+ objects directory and cc1* is one of the cc1* compilers (is
+ -B necessary here?).
+
+ Note, you need sudo because pcsample will only run as root.
+ Also, if you have a dual processor you need to reboot as in
+ single processor mode. If you don't pcscample will tell you
+ to do that by executing the command,
+
+ nvram boot-args="cpus=1"
+
+5. Generate the order files
+
+ Run the lines created in step 4. The order files (cc1*.order)
+ will be left in /tmp in the direectory indicated by the summary
+ that pcsample displays when you hit cmd-c to stop the pcsample
+ execution. Be sure to run pcsample long enough to compile the
+ entire program.
+
+ At this point you now have the order files created. You place
+ them in the order-files directory at the top level of the gcc
+ source directory.
+
+ You can also use them to measure he effects of these order files
+ on compiler page-ins. If you do this go to the next step (6).
+ Otherwisw you are ready to go.
+
+6. Creating the compilers with ther order files
+
+ You will need two versions of the cc1* files; the ones from above
+ and a set linked with their respective order file.
+
+ From a gcc compiler build extract the command lines that link
+ the cc1* files. Change the -o file to something else, for
+ example, cc1 to cc1X. Then add the following options to the
+ link line. Note, if you build using buildit and build_gcc the
+ lines will already be there referencing the order-files
+ directory. Otherwise you need to add,
+
+ -sectorder __TEXT __text $order/cc1*.order -e start
+
+ where $order is the directory containing the order file being
+ used and cc1* is of course a reference to a specific order
+ file.
+
+ 7. Measuring the performance improvement
+
+ You need to have two terminbal windows open; T1 and T2. The
+ execute the follwoing commands on the indicated terminals:
+
+ T2: sudo fs_usage -w > /tmp/fs.out1 (do NOT execute yet)
+ T1: ~perf/bin/flushmem (note this can take a while)
+ T2: fs_usage
+ T1: use cc1* line originally used to build order file
+ T2: ctl-c when cc1* compilation done
+
+ T2: sudo fs_usage -w > /tmp/fs.out2 (do not execute yet)
+ T1: ~perf/bin/flushmem
+ T2: fs_usage
+ T1: use cc1*X line originally used to build order file
+ T2: ctl-c when cc1XXX compilation done
+
+ In the first group of commands you use the original cc1* line
+ with the command line used to build the order file. You also
+ run fs_usage at the same time to measure the paging behavior.
+
+ The second group of commands is similar but you use the cc1*
+ linked with its order file (with the -sectorder stuff mentioned
+ in step 6). For this discussion call this compiler cc1*X.
+
+ In both cases you need to run ~perf/bin/flushmem to make sure
+ compiler is flused from the cached. That way you are
+ measuring the initial page-in bechavor as thee compiler is
+ loaded. Warning, the flushmem's sometimes take quite a
+ while.
+
+ At this point you should have /tmp/fs.out1 and /tmp/fs.out2.
+ You need to extract the page-ins times for the compilers in
+ order to sum them up. The easies way to do this is make the
+ data tab delimited for importing into Excel.
+
+ T1: fgrep cc1* /tmp/fs.out1 | fgrep PAGE_IN | \
+ tr -s "[:blank:]" '\t' >/tmp/cc1*.pageins-1
+ T1: fgrep cc1*X /tmp/fs.out2 | fgrep PAGE_IN | \
+ tr -s "[:blank:]" '\t' >/tmp/cc1*.pageins-2
+
+ Load each of these into Excel and sum the pagin times to
+ determine the percent change.
+
+ Remember that the '*'s in the above illustrations are not really
+ a '*'. It is just a short way to show the general command lines
+ where in reality you explicitly specify cc1, cc1plus, cc1obj, or
+ cc1objplus.
+
+ Also remember that you are measuring the page-in performance
+ improvement on the test cases used to generate the order files
+ in the first place. Thus you should expect that these would
+ probably show the greatest improvement. That is why it is
+ important to try to choose representative test cases in the
+ first place. You can try the measurements on other tests.
+ But that requires you again extracting the cc1* lines using
+ -###. The above procedure only uses the orignal files since
+ the command lines are already handy.
+
+
+
+
+
diff --git a/order-files/cc1.order b/order-files/cc1.order
new file mode 100644
index 00000000000..a3bd7b04a39
--- /dev/null
+++ b/order-files/cc1.order
@@ -0,0 +1,1188 @@
+start
+__start
+__dyld_init_check
+dyld_stub_binding_helper
+___darwin_gcc3_preregister_frame_info
+__call_mod_init_funcs
+__dyld_func_lookup
+_main
+_toplev_main
+_hex_init
+_general_init
+_xmalloc_set_program_name
+_diagnostic_initialize
+__obstack_begin
+_xmalloc
+_parse_options_and_default_flags
+_init_reg_sets
+_add_params
+_xrealloc
+_pfe_init
+_override_O_option
+_extract_override_options
+_lang_init_options
+_c_common_init_options
+_cpp_create_reader
+_init_library
+_init_trigraph_map
+_xcalloc
+_set_lang
+_deps_init
+_init_line_maps
+__cpp_init_tokenrun
+__cpp_get_buff
+_new_buff
+_pfe_s_malloc
+_pfe_malloc
+_gcc_obstack_init
+_pfe_obstack_chuck_alloc
+__cpp_init_includes
+_splay_tree_new
+_splay_tree_new_with_allocator
+_splay_tree_xmalloc_allocate
+_set_index_lang
+_set_target_switch
+_optimization_options
+_override_option
+_c_decode_option
+_cpp_handle_option
+_parse_option
+_independent_decode_option
+_xstrdup
+_append_include_chain
+__cpp_simplify_pathname
+_remove_component_p
+_new_pending_directive
+_dump_switch_p
+_decode_f_option
+_decode_g_option
+_set_Wunused
+_set_Wformat
+_decode_W_option
+_add_env_options
+_c_common_post_options
+_cpp_post_options
+_init_dependency_output
+_do_compile
+_process_options
+_rs6000_override_options
+_rs6000_parse_abi_options
+_rs6000_add_gc_roots
+_ggc_add_rtx_root
+_ggc_add_root
+_htab_create
+_higher_prime_number
+_machopic_add_gc_roots
+_ggc_add_tree_root
+_new_alias_set
+_floor_log2_wide
+_init_timevar
+_timevar_start
+_lang_independent_init
+_init_ggc
+_exact_log2_wide
+_pfe_s_calloc
+_pfe_calloc
+_init_stringpool
+_ht_create
+_init_obstacks
+_ggc_add_deletable_htab
+_init_emit_once
+_mode_for_size
+_gen_rtx
+_rtx_alloc
+_ggc_alloc
+_alloc_page
+_pfe_free
+_set_page_table_entry
+_gen_raw_REG
+_gen_rtx_fmt_i0
+_gen_rtx_fmt_w
+_ereal_atof
+_asctoe53
+_asctoeg
+_ecleaz
+_enormlz
+_eshup6
+_toe53
+_eiisnan
+_eshift
+_eshup1
+_e53toe
+_eshdn1
+_ecleazs
+_emovo
+_emovz
+_eaddm
+_eshup8
+_emdnorm
+_gen_rtx_CONST_INT
+_gen_const_vector_0
+_rtvec_alloc
+_gen_rtx_fmt_E0
+_gen_rtx_REG
+_init_regs
+_init_reg_sets_1
+_reg_class_subset_p
+_init_reg_modes
+_choose_hard_reg_mode
+_init_alias_once
+_init_stmt
+_init_loop
+_address_cost
+_memory_address_p
+_rs6000_legitimate_address
+_init_reload
+_gen_rtx_fmt_ee
+_gen_rtx_MEM
+_gen_rtx_fmt_e0
+_gen_rtx_fmt_s
+_pfe_savestring
+_plus_constant_wide
+_find_constant_term_loc
+_bitmap_initialize
+_init_function_once
+_varray_init
+_init_stor_layout_once
+_init_varasm_once
+_init_EXPR_INSN_LIST_cache
+_init_dummy_function_start
+_prepare_function_start
+_ggc_alloc_cleared
+_init_stmt_for_function
+_init_eh_for_function
+_init_emit
+_clear_emit_caches
+_init_virtual_regs
+_init_expr
+_init_varasm_status
+_init_temp_slots
+_init_pending_stack_adjust
+_rs6000_init_machine_status
+_init_expmed
+_start_sequence
+_rtx_cost
+_emit_insn
+_make_insn_raw
+_add_insn
+_init_recog
+_recog
+_recog_13
+_gpc_reg_operand
+_register_operand
+_recog_4
+_reg_or_cint_operand
+_recog_5
+_nonimmediate_operand
+_general_operand
+_input_operand
+_memory_operand
+_toc_relative_expr_p
+_constant_pool_expr_1
+_reg_or_short_operand
+_short_cint_operand
+_htab_find_slot_with_hash
+_const_int_htab_eq
+_init_expr_once
+_boolean_or_operator
+_boolean_operator
+_recog_1
+_reg_or_mem_operand
+_recog_7
+_recog_10
+_recog_9
+_altivec_register_operand
+_zero_constant
+_extract_insn
+_init_caller_save
+_constrain_operands
+_reg_fits_class_p
+_insn_extract
+_recog_memoized_1
+_cc_reg_operand
+_recog_6
+_record_builtin_type
+_build_decl
+_make_node
+_tree_size
+_pushdecl
+_lookup_name_current_level
+_c_common_nodes_and_builtins
+_get_identifier
+_ht_lookup
+_calc_hash
+_alloc_node
+_make_signed_type
+_default_set_default_type_attributes
+_fixup_signed_type
+_build_int_2_wide
+_layout_type
+_tree_int_cst_sgn
+_smallest_mode_for_size
+_size_int_wide
+_size_int_type_wide
+_force_fit_type
+_htab_find_slot
+_size_htab_hash
+_size_htab_eq
+_finalize_type_size
+_get_mode_alignment
+_round_type_align
+_round_up
+_size_binop
+_int_const_binop
+_integer_onep
+_tree_cons
+_make_unsigned_type
+_fixup_unsigned_type
+_identifier_global_value
+_signed_type
+_set_sizetype
+_copy_node
+_build_common_tree_nodes_2
+_build_pointer_type
+_build_qualified_type
+_get_qualified_type
+_build_type_copy
+_set_type_quals
+_mul_double
+_encode
+_decode
+_rs6000_build_va_list
+_make_vector
+_finish_vector_type
+_build_index_type
+_convert
+_convert_to_integer
+_build1
+_first_rtl_op
+_fold
+_fold_convert
+_compare_tree_int
+_host_integerp
+_tree_low_cst
+_type_hash_canon
+_type_hash_lookup
+_htab_find_with_hash
+_type_hash_add
+_build_array_type
+_build
+_integer_zerop
+_non_lvalue
+_add_double
+_simple_cst_equal
+_mode_for_size_tree
+_start_record_layout
+_place_field
+_layout_decl
+_default_ms_bitfield_layout_p
+_normalize_rli
+_normalize_offset
+_finish_record_layout
+_finalize_record_size
+_get_inner_array_type
+_rli_size_so_far
+_bit_from_pos
+_rli_size_unit_so_far
+_byte_from_pos
+_compute_record_mode
+_type_hash_eq
+_attribute_list_equal
+_attribute_list_contained
+_bit_position
+_int_bit_position
+_builtin_function
+_make_decl_rtl
+_decode_reg_name
+_darwin_encode_section_info
+_ggc_alloc_string
+_update_stubs
+_decl_attributes
+_default_insert_attributes
+_insert_default_attributes
+_c_common_insert_default_attributes
+_builtin_function_2
+_builtin_function_disabled_p
+_set_decl_assembler_name
+_is_attribute_p
+_c_init_decl_processing
+_build_function_type
+_type_hash_list
+_type_list_equal
+_start_fname_decls
+_set_dump_tree_p
+_c_objc_common_init
+_c_common_init
+_init_c_lex
+_get_fileinfo
+_splay_tree_lookup
+_splay_tree_splay
+_splay_tree_insert
+_cpp_get_callbacks
+_cpp_read_main_file
+__cpp_init_hashtable
+__cpp_init_directives
+_cpp_lookup
+__obstack_newchunk
+__cpp_init_internal_pragmas
+_cpp_register_pragma
+_lookup_pragma_entry
+_insert_pragma_entry
+__cpp_aligned_alloc
+_init_standard_includes
+_update_path
+_concat
+_translate_name
+_get_key_value
+_merge_include_chains
+_remove_dup_dirs
+_remove_dup_dir
+__cpp_read_file
+_open_file
+_find_or_create_entry
+_splay_tree_foreach
+_splay_tree_foreach_helper
+_inode_finder
+_stack_include_file
+_read_include_file
+_cpp_push_buffer
+__cpp_do_file_change
+_add_line_map
+_cb_file_change
+_update_header_times
+_extract_interface_info
+_init_pragma
+_add_c_tree_codes
+_ggc_add_tree_varray_root
+_lang_dependent_init
+_init_asm_output
+_init_eh
+_init_optabs
+_new_optab
+_init_all_optabs
+_init_integral_libfuncs
+_init_libfuncs
+_init_floating_libfuncs
+_init_one_libfunc
+_init_traps
+_push_srcloc
+_timevar_push
+_dwarf2out_do_frame
+_dbxout_init
+_getdecls
+_getpwd
+_output_quoted_string
+_assemble_name
+_maybe_get_identifier
+_text_section
+_dbxout_typedefs
+_dbxout_symbol
+_timevar_pop
+_compile_file
+_init_final
+_init_branch_prob
+_yyparse
+_dbxout_start_source_file
+_cpp_finish_options
+_init_builtins
+__cpp_define_builtin
+_run_directive
+_start_directive
+_do_define
+_lex_macro_node
+__cpp_lex_token
+__cpp_lex_direct
+_parse_identifier
+__cpp_create_definition
+_skip_whitespace
+_parse_string
+_unescaped_terminator_p
+_alloc_expansion_token
+_lex_expansion_token
+_handle_newline
+_pfe_is_cmd_ln_processing
+_end_directive
+_skip_rest_of_line
+__cpp_pop_buffer
+_parse_number
+_pfe_set_cmd_ln_processing
+_cpp_define
+_warn_of_redefinition
+__cpp_equiv_tokens
+__cpp_free_definition
+_pfe_reset_cmd_ln_processing
+_free_chain
+__cpp_push_next_buffer
+_yyparse_1
+_yylex
+__yylex
+_c_lex
+_cpp_get_token
+_get_effective_char
+_skip_block_comment
+_skip_escaped_newlines
+_trigraph_p
+__cpp_handle_directive
+_directive_diagnostics
+_do_include
+_do_include_common
+_parse_include
+_check_eol
+__cpp_execute_include
+_find_include_file
+_search_from
+_lbasename
+_splay_tree_splay_helper
+_adjust_column
+__cpp_extend_buff
+_parse_params
+_save_parameter
+_cb_line_change
+_yylexname
+_altivec_treat_as_keyword
+_ggc_collect
+_lookup_name
+_start_enum
+_lookup_tag
+_pushtag
+_build_enumerator
+_int_fits_type_p
+_build_binary_op
+_common_type
+_tree_int_cst_lt
+_type_for_size
+_const_binop
+_chainon
+_nreverse
+_finish_enum
+_in_parm_level_p
+_min_precision
+_tree_floor_log2
+_rest_of_type_compilation
+_shadow_tag
+_shadow_tag_warned
+_split_specs_attrs
+_lookup_tag_reverse
+_check_trad_stringification
+_xref_tag
+_pending_xref_error
+_build_tree_list
+_grokdeclarator
+_c_apply_type_quals_to_decl
+_grokfield
+_finish_decl
+_maybe_apply_renaming_pragma
+_get_pending_sizes
+_finish_struct
+_start_decl
+_maybe_apply_pragma_weak
+_rest_of_decl_compilation
+_start_struct
+_do_ifdef
+_push_conditional
+_do_else
+_do_endif
+_constant_expression_warning
+__cpp_pop_file_buffer
+_pop_srcloc
+_dbxout_end_source_file
+_make_pointer_declarator
+_pushlevel
+_make_binding_level
+_clear_parm_order
+_declare_parm_level
+_push_parm_decl
+_simple_type_promotes_to
+_c_promoting_integer_type_p
+_get_parm_info
+_gettags
+_storedecls
+_parmlist_tags_warning
+_poplevel
+_warn_about_unused_variables
+_build_nt
+_grokparms
+_unsigned_type
+_lex_number
+_build_compound_expr
+_internal_build_compound_expr
+_build_array_declarator
+_set_array_declarator_type
+_signed_or_unsigned_type
+_operand_equal_p
+_tree_int_cst_equal
+_neg_double
+_do_undef
+_warn_if_shadowing
+_build_decl_attribute_variant
+_gen_aux_info_record
+_collect_args
+_enter_macro_context
+_replace_args
+_expand_arg
+_push_ptoken_context
+_next_context
+__cpp_pop_context
+__cpp_release_buff
+_padding_token
+__cpp_temp_token
+_c_build_qualified_type
+_push_token_context
+_list_length
+_handle_noreturn_attribute
+_lookup_attribute
+_purge_cache
+_do_ifndef
+_do_if
+__cpp_parse_expr
+_lex
+_parse_number
+___udivdi3
+___udivmoddi4
+_funlike_invocation_p
+_parse_defined
+_cpp_warning
+__cpp_begin_message
+_do_elif
+_groktypename
+_c_sizeof
+_parser_build_binary_op
+_default_conversion
+_merge_type_attributes
+_merge_attributes
+_build_type_attribute_variant
+_extract_muldiv
+_unsigned_conversion_warning
+_overflow_warning
+_get_narrower
+_attribute_hash_list
+_duplicate_decls
+_comptypes
+_default_comp_type_attributes
+_function_types_compatible_p
+_self_promoting_args_p
+_merge_decl_attributes
+_handle_format_attribute
+_decode_format_attr
+_decode_format_type
+_start_function
+_announce_function
+_store_parm_decls
+_decl_function_context
+_storetags
+_init_function_start
+_decl_name
+_emit_line_note
+_set_file_and_line_for_stmt
+_emit_note
+_aggregate_value_p
+_hard_function_value
+_begin_stmt_tree
+_current_stmt_tree
+_c_begin_compound_stmt
+_build_stmt
+_add_stmt
+_stmts_are_full_exprs_p
+_clear_last_expr
+_add_scope_stmt
+_current_scope_stmt_stack
+_c_begin_if_stmt
+_build_external_ref
+_lookup_objc_ivar
+_assemble_external
+_build_indirect_ref
+_build_component_ref
+_lookup_field
+_build_unary_op
+_unary_complex_lvalue
+_get_unwidened
+_lvalue_or_else
+_lvalue_p
+_shorten_compare
+_twoval_comparison_p
+_invert_tree_comparison
+_truthvalue_conversion
+_build_c_cast
+_default_function_array_conversion
+_lex_charconst
+_cpp_interpret_charconst
+_cpp_parse_escape
+_truth_value_p
+_fold_range_test
+_make_range
+_fold_truthop
+_c_expand_start_cond
+_c_size_in_bytes
+_convert_to_pointer
+_build_modify_expr
+_require_complete_type
+_convert_for_assignment
+_convert_and_check
+_c_expand_return
+_build_return_stmt
+_c_finish_then
+_c_expand_start_else
+_build_function_call
+_decl_target_overloaded_intrinsic_p
+_convert_arguments
+_check_function_format
+_c_finish_else
+_c_expand_end_cond
+_kept_level_p
+_finish_function
+_clear_limbo_values
+_finish_fname_decls
+_finish_stmt_tree
+_free_after_parsing
+_free_stmt_status
+_free_after_compilation
+_free_eh_status
+_free_expr_status
+_free_emit_status
+_free_varasm_status
+_rs6000_free_machine_status
+_c_expand_body
+_tree_inlinable_function_p
+_inlinable_function_p
+_c_disregard_inline_limits
+_c_cannot_inline_tree_fn
+_function_attribute_inlinable_p
+_put_pending_sizes
+_walk_tree
+_inline_forbidden_p
+_statement_code_p
+_lhd_tree_inlining_walk_subtrees
+_get_callee_fndecl
+_setjmp_call_p
+_special_function_p
+_defer_fn
+_debug_nothing_tree
+_integer_all_onesp
+_distribute_bit_expr
+_place_union_field
+_cpp_pedwarn
+_do_include_next
+___divdi3
+___udivmoddi4
+_handle_malloc_attribute
+_type_lists_compatible_p
+_redeclaration_error_message
+_pedwarn
+_set_diagnostic_context
+_report_diagnostic
+_count_error
+_build_range_type
+_complete_array_type
+_start_init
+_push_string
+_really_start_incremental_init
+_process_init_element
+_push_member_name
+_output_init_element
+_initializer_constant_valid_p
+_lhd_return_tree
+_digest_init
+_output_pending_init_elements
+_pop_init_level
+_finish_init
+_store_init_value
+_assemble_variable
+_set_mem_attributes
+_get_alias_set
+_maybe_set_unchanging
+_can_address_p
+_handled_component_p
+_get_mem_attrs
+_mem_attrs_htab_hash
+_update_non_lazy_ptrs
+_app_disable
+_set_mem_align
+_mem_attrs_htab_eq
+_output_addressed_constants
+_resolve_unique_section
+_variable_section
+_darwin_set_section_for_var_p
+_data_section
+_try_section_alias
+_in_text_section
+_machopic_define_name
+_machopic_define_ident
+_machopic_ident_defined_p
+_machopic_classify_ident
+_name_needs_quotes
+_output_constant
+_int_size_in_bytes
+_output_constructor
+_int_byte_position
+_byte_position
+_expand_expr
+_get_subtarget
+_immed_double_const
+_assemble_integer
+_rs6000_assemble_integer
+_find_weak_imports
+_default_assemble_integer
+_integer_asm_op
+_assemble_integer_with_op
+_output_addr_const
+_global_bindings_p
+_handle_unused_attribute
+_add_decl_stmt
+_build_array_ref
+_pointer_int_sum
+_size_in_bytes
+_omit_one_operand
+_decl_constant_value_for_broken_optimization
+_comp_target_types
+_c_expand_expr_stmt
+_verify_sequence_points
+_verify_tree
+_warning_candidate_p
+_split_tree
+_lex_string
+_build_string
+_combine_strings
+_choose_string_type
+_mark_addressable
+_staticp
+_expand_tree_builtin
+_fold_builtin
+_invert_truthvalue
+_define_label
+_lookup_label
+_new_tlist
+_add_tlist
+_warn_for_collisions
+_warn_for_collisions_1
+_merge_tlist
+_decode_field_reference
+_get_inner_reference
+_hash_pointer
+_htab_find
+_eq_pointer
+_expand_call_inline
+_lhd_tree_inlining_tree_chain_matters_p
+_htab_expand
+_find_empty_slot_for_expand
+_expand_call
+_precompute_register_parameters
+_push_temp_slots
+_preserve_temp_slots
+_find_temp_slot_from_address
+_pop_temp_slots
+_combine_temp_slots
+_emit_queue
+_protect_from_queue
+_mark_temp_addr_taken
+_force_operand
+_save_fixed_argument_area
+_prepare_call_address
+_lookup_static_chain
+_load_register_parameters
+_emit_move_insn
+_emit_move_insn_1
+_gen_movsi
+_rs6000_emit_move
+_gen_sequence
+_end_sequence
+_use_reg
+_gen_rtx_fmt_e
+_easy_fp_constant
+_rs6000_machopic_legitimize_pic_address
+_machopic_legitimize_pic_address
+_machopic_indirect_data_reference
+_machopic_data_defined_p
+_machopic_function_base_name
+_gen_rtx_fmt_E
+_trunc_int_for_mode
+_num_insns_constant
+_num_insns_constant_wide
+_get_last_insn
+_function_arg
+_emit_call_1
+_gen_call_value
+_machopic_indirect_call_target
+_machopic_name_defined_p
+_machopic_stub_list_entry
+_gen_rtx_fmt_0
+_gen_rtvec
+_gen_rtvec_v
+_emit_call_insn
+_make_call_insn_raw
+_any_pending_cleanups
+_get_insns
+_gen_rtx_fmt_uuuu
+_expand_builtin
+_do_jump
+_do_pending_stack_adjust
+_can_compare_p
+_do_compare_rtx_and_jump
+_reverse_condition
+_swap_commutative_operands_p
+_commutative_operand_precedence
+_force_not_mem
+_emit_cmp_and_jump_insns
+_prepare_cmp_insn
+_preserve_subexpressions_p
+_emit_cmp_and_jump_insn_1
+_prepare_operand
+_gen_cmpsi
+_gen_beq
+_rs6000_emit_cbranch
+_rs6000_generate_compare
+_gen_reg_rtx
+_validate_condition_mode
+_gen_rtx_fmt_u00
+_gen_rtx_fmt_eee
+_emit_jump_insn
+_make_jump_insn_raw
+_start_cleanup_deferral
+_expand_builtin_strcmp
+_validate_arglist
+_c_getstr
+_string_constant
+_c_strlen
+_build_function_call_expr
+_expand_builtin_memcmp
+_flags_from_decl_or_type
+_init_cumulative_args
+_tree_last
+_rearrange_arg_list
+_initialize_argument_information
+_function_arg_pass_by_reference
+_promote_mode
+_no_reg_parm_stack_space
+_function_arg_partial_nregs
+_function_arg_skip
+_function_arg_boundary
+_locate_and_pad_parm
+_function_arg_padding
+_function_arg_mod_boundary
+_pad_to_arg_alignment
+_function_arg_advance
+_finalize_must_preallocate
+_function_ok_for_sibcall
+_unsafe_for_reeval
+_c_unsafe_for_reeval
+_expand_start_target_temps
+_expand_start_bindings_and_block
+_compute_argument_block_size
+_sbitmap_alloc
+_sbitmap_zero
+_compute_argument_addresses
+_rtx_for_function_call
+_output_constant_def
+_const_hash
+_record_constant
+_record_constant_1
+_set_mem_alias_set
+_copy_constant
+_gen_sibcall_value
+_gen_rtx_fmt_
+_emit_barrier_after
+_add_insn_after
+_copy_to_reg
+_expand_end_target_temps
+_expand_end_bindings
+_precompute_arguments
+_calls_function
+_calls_function_1
+_end_cleanup_deferral
+_gen_bne
+_emit_jump
+_gen_jump
+_emit_barrier
+_emit_label
+_genrtl_if_stmt
+_expand_stmt
+_prep_stmt
+_genrtl_compound_stmt
+_genrtl_scope_stmt
+_genrtl_expr_stmt_value
+_expand_expr_stmt_value
+_warn_if_unused_value
+_expand_assignment
+_copy_rtx
+_replace_equiv_address
+_update_temp_slot_address
+_rtx_equal_p
+_change_address_1
+_memory_address
+_force_reg
+_machopic_non_lazy_ptr_list_entry
+_set_unique_reg_note
+_find_reg_note
+_mark_reg_pointer
+_store_expr
+_queued_subexp_p
+_free_temp_slots
+_pfe_s_realloc
+_pfe_realloc
+_expand_start_else
+_gen_label_rtx
+_gen_rtx_fmt_iuu00iss
+_genrtl_do_pushlevel
+_expand_cond
+_expand_start_cond
+_gen_sibcall
+_gen_call
+_expand_end_cond
+_compare_constant
+_compare_constant_1
+_safe_from_p
+_expand_binop
+_convert_modes
+_reg_or_arith_cint_operand
+_gen_addsi3
+_add_operand
+_do_compare_and_jump
+_gen_movqi
+_convert_move
+_can_extend_p
+_emit_unop_insn
+_gen_extendqisi2
+_gen_extendqisi2_ppc
+_simplify_binary_operation
+_avoid_constant_pool_reference
+_break_out_memory_refs
+_genrtl_goto_stmt
+_label_rtx
+_expand_goto
+_expand_goto_internal
+_const_str_htab_eq
+_expand_fixup
+_expand_value_return
+_expand_return
+_genrtl_return_stmt
+_obstack_free
+_assign_temp
+_expand_null_return_1
+_clear_pending_stack_adjust
+_expand_function_end
+_finish_expr_for_function
+_in_sequence_p
+_emit_line_note_force
+_expand_eh_return
+_clobber_return_register
+_diddle_return_value
+_do_clobber_return_reg
+_emit_insn_after
+_use_return_register
+_do_use_return_reg
+_expand_fixups
+_fixup_gotos
+_rest_of_compilation
+_reorder_blocks
+_reorder_blocks_0
+_reorder_blocks_1
+_blocks_nreverse
+_purge_hard_subreg_sets
+_open_dump_file
+_optimize_sibling_and_tail_recursive_calls
+_find_exception_handler_labels
+_rebuild_jump_labels
+_init_label_info
+_mark_all_labels
+_mark_jump_label
+_find_unreachable_blocks
+_delete_unreachable_blocks
+_flow_delete_block_noexpunge
+_never_reached_warning
+_next_nonnote_insn
+_delete_insn_chain
+_can_delete_note_p
+_delete_insn
+_remove_insn
+_remove_edge
+_free_edge
+_expunge_block_nocompact
+_tidy_fallthru_edges
+_tidy_fallthru_edge
+_next_real_insn
+_forwarder_block_p
+_update_forwarder_flag
+_try_optimize_cfg
+_active_insn_p
+_simplejump_p
+_hook_void_bool_false
+_try_forward_edges
+_redirect_edge_and_branch
+_try_redirect_by_replacing_jump
+_redirect_edge_succ_nodup
+_redirect_edge_succ
+_flow_delete_block
+_expunge_block
+_onlyjump_p
+_side_effects_p
+_can_fallthru
+_next_active_insn
+_block_label
+_redirect_jump
+_redirect_exp
+_redirect_exp_1
+_validate_change
+_num_validated_changes
+_apply_change_group
+_insn_invalid_p
+_prev_nonnote_insn
+_computed_jump_p
+_computed_jump_p_1
+_returnjump_p
+_for_each_rtx
+_returnjump_p_1
+_branch_comparison_operator
+_merge_blocks
+_tail_recursion_label_p
+_merge_blocks_nomove
+_can_delete_label_p
+_in_expr_list_p
+_remove_node_from_expr_list
+_set_block_for_insn
+_label_is_jump_target_p
+_uses_addressof
+_sequence_uses_addressof
+_free_basic_block_vars
+_clear_edges
+_close_dump_file
+_htab_empty
+_doing_eh
+_emit_initial_value_sets
+_unshare_all_rtl
+_copy_rtx_if_shared
+_unshare_all_decls
+_unshare_all_rtl_1
+_max_reg_num
+_find_basic_blocks
+_count_basic_blocks
+_inside_basic_block_p
+_control_flow_insn_p
+_can_throw_internal
+_compute_bb_for_insn
+_make_edges
+_cached_make_edge
+_make_label_edge
+_try_simplify_condjump
+_any_uncondjump_p
+_pc_set
+_any_condjump_p
+_invert_jump
+_invert_exp
+_invert_exp_1
+_reversed_comparison_code
+_reversed_comparison_code_parts
+_invert_br_probabilities
+_update_br_prob_note
+_find_basic_blocks_1
+_create_basic_block_structure
+_reorder_insns
+_reorder_insns_nobb
+_thread_jump
+_comparison_dominates_p
+_find_if_header
+_find_if_block
+_find_cond_trap
+_block_has_only_trap
+_if_convert
+_process_if_block
+_noce_process_if_block
+_noce_get_condition
+_get_condition
+_canonicalize_condition
+_set_of
+_note_stores
+_set_of_1
+_first_active_insn
+_last_active_insn_p
+_clear_aux_for_blocks
+_free_bb_for_insn
+_delete_null_pointer_checks
+_get_bitmap_width
+_sbitmap_vector_alloc
+_reg_scan_mark_refs
+_reg_scan
+_cse_main
+_init_alias_analysis
+_record_set
+_find_base_value
+_rtx_varies_p
+_single_set_2
+_reg_overlap_mentioned_p
+_ggc_push_context
+_cse_end_of_basic_block
+_cse_basic_block
+_new_basic_block
+_cse_process_notes
+_cse_insn
+_canon_reg
+_fold_rtx
+_canon_hash
+_get_cse_reg_info
+_lookup
+_approx_reg_cost
+_approx_reg_cost_1
+_bitmap_set_bit
+_bitmap_element_allocate
+_bitmap_element_link
+_bitmap_clear
+_preferrable
+_insert_regs
+_make_new_qty
+_rehash_using_reg
+_insert
+_invalidate_from_clobbers
+_invalidate
+_delete_reg_equiv
+_lookup_for_remove
+_make_regs_eqv
+_check_for_label_ref
+_find_best_addr
+_notreg_cost
+_mention_regs
+_lookup_as_function
+_safe_hash
+_equiv_constant
+_asm_noperands
+_cancel_changes
+_exp_equiv_p
+_recog_33
+_mov_to_vrsave_operation
+_load_multiple_operation
+_store_multiple_operation
+_recog_25
+_current_file_function_operand
+_call_operand
+_immediate_operand
+_scratch_operand
+_remove_from_table
+_invalidate_memory
+_invalidate_for_call
+_remove_invalid_refs
+_refers_to_regno_p
+_gen_lowpart_if_possible
+_gen_lowpart_common
+_subreg_lowpart_offset
+_recog_3
+_invalidate_skipped_block
+_invalidate_skipped_set
+_canon_rtx
+_replace_equiv_address_nv
+_check_dependence
+_true_dependence
+_mems_in_disjoint_alias_sets_p
+_alias_sets_conflict_p
+_nonoverlapping_memrefs_p
+_simplify_relational_operation
+_simplify_ternary_operation
+_record_jump_equiv
+_find_comparison_args
+_record_jump_cond
+_get_addr
+_find_base_term
+_base_alias_check
+_memrefs_conflict_p
+_addr_side_effect_eval
+_rtx_equal_for_memref_p
+_aliases_everything_p
+_fixed_scalar_and_varying_struct_p
+_merge_equiv_classes
+_reg_mentioned_p
diff --git a/order-files/cc1obj.order b/order-files/cc1obj.order
new file mode 100644
index 00000000000..730010f4851
--- /dev/null
+++ b/order-files/cc1obj.order
@@ -0,0 +1,2163 @@
+start
+__start
+__dyld_init_check
+dyld_stub_binding_helper
+___darwin_gcc3_preregister_frame_info
+__call_mod_init_funcs
+__dyld_func_lookup
+_main
+_toplev_main
+_hex_init
+_general_init
+_xmalloc_set_program_name
+_diagnostic_initialize
+__obstack_begin
+_xmalloc
+_parse_options_and_default_flags
+_init_reg_sets
+_add_params
+_xrealloc
+_pfe_init
+_read_integral_parameter
+_override_O_option
+_extract_override_options
+_objc_init_options
+_c_common_init_options
+_cpp_create_reader
+_init_library
+_init_trigraph_map
+_xcalloc
+_set_lang
+_deps_init
+_init_line_maps
+__cpp_init_tokenrun
+__cpp_get_buff
+_new_buff
+_pfe_s_malloc
+_pfe_malloc
+_gcc_obstack_init
+_pfe_obstack_chuck_alloc
+__cpp_init_includes
+_splay_tree_new
+_splay_tree_new_with_allocator
+_splay_tree_xmalloc_allocate
+_set_index_lang
+_set_target_switch
+_optimization_options
+_override_option
+_objc_decode_option
+_c_decode_option
+_cpp_handle_option
+_parse_option
+_independent_decode_option
+_new_pending_directive
+_xstrdup
+_append_include_chain
+__cpp_simplify_pathname
+_hmap_load_header_map
+_dump_switch_p
+_decode_f_option
+_decode_g_option
+_set_Wunused
+_set_Wformat
+_decode_W_option
+_output_set_maximum_length
+_set_real_maximum_length
+_output_is_line_wrapping
+_add_env_options
+_objc_post_options
+_c_common_post_options
+_cpp_post_options
+_init_dependency_output
+_do_compile
+_process_options
+_rs6000_override_options
+_rs6000_parse_abi_options
+_rs6000_add_gc_roots
+_ggc_add_rtx_root
+_ggc_add_root
+_htab_create
+_higher_prime_number
+_machopic_add_gc_roots
+_ggc_add_tree_root
+_new_alias_set
+_floor_log2_wide
+_init_timevar
+_timevar_start
+_lang_independent_init
+_init_ggc
+_exact_log2_wide
+_pfe_s_calloc
+_pfe_calloc
+_init_stringpool
+_ht_create
+_init_obstacks
+_ggc_add_deletable_htab
+_init_emit_once
+_mode_for_size
+_gen_rtx
+_rtx_alloc
+_ggc_alloc
+_alloc_page
+_pfe_free
+_set_page_table_entry
+_gen_raw_REG
+_gen_rtx_fmt_i0
+_gen_rtx_fmt_w
+_ereal_atof
+_asctoe53
+_asctoeg
+_ecleaz
+_enormlz
+_eshup6
+_toe53
+_eiisnan
+_eshift
+_eshup1
+_e53toe
+_eshdn1
+_ecleazs
+_emovo
+_emovz
+_eaddm
+_eshup8
+_emdnorm
+_gen_rtx_CONST_INT
+_gen_const_vector_0
+_rtvec_alloc
+_gen_rtx_fmt_E0
+_gen_rtx_REG
+_init_regs
+_init_reg_sets_1
+_reg_class_subset_p
+_init_reg_modes
+_choose_hard_reg_mode
+_init_alias_once
+_init_stmt
+_init_loop
+_address_cost
+_memory_address_p
+_rs6000_legitimate_address
+_init_reload
+_gen_rtx_fmt_ee
+_gen_rtx_MEM
+_gen_rtx_fmt_e0
+_gen_rtx_fmt_s
+_pfe_savestring
+_plus_constant_wide
+_find_constant_term_loc
+_bitmap_initialize
+_init_function_once
+_varray_init
+_init_stor_layout_once
+_init_varasm_once
+_init_EXPR_INSN_LIST_cache
+_init_dummy_function_start
+_prepare_function_start
+_ggc_alloc_cleared
+_init_stmt_for_function
+_init_eh_for_function
+_init_emit
+_clear_emit_caches
+_init_virtual_regs
+_init_expr
+_init_varasm_status
+_init_temp_slots
+_init_pending_stack_adjust
+_rs6000_init_machine_status
+_init_expmed
+_start_sequence
+_rtx_cost
+_emit_insn
+_make_insn_raw
+_add_insn
+_init_recog
+_recog
+_recog_13
+_gpc_reg_operand
+_register_operand
+_recog_4
+_reg_or_cint_operand
+_recog_5
+_nonimmediate_operand
+_general_operand
+_input_operand
+_memory_operand
+_toc_relative_expr_p
+_constant_pool_expr_1
+_reg_or_short_operand
+_short_cint_operand
+_htab_find_slot_with_hash
+_const_int_htab_eq
+_init_expr_once
+_recog_6
+_recog_10
+_recog_9
+_altivec_register_operand
+_zero_constant
+_cc_reg_operand
+_end_sequence
+_init_caller_save
+_strict_memory_address_p
+_recog_memoized_1
+_extract_insn
+_insn_extract
+_constrain_operands
+_reg_fits_class_p
+_boolean_or_operator
+_boolean_operator
+_recog_1
+_reg_or_mem_operand
+_recog_7
+_make_node
+_build_decl
+_builtin_function
+_get_identifier
+_ht_lookup
+_calc_hash
+_alloc_node
+_tree_size
+_make_decl_rtl
+_decode_reg_name
+_darwin_encode_section_info
+_ggc_alloc_string
+_update_stubs
+_pushdecl
+_lookup_name_current_level
+_decl_attributes
+_default_insert_attributes
+_insert_default_attributes
+_c_common_insert_default_attributes
+_builtin_function_2
+_builtin_function_disabled_p
+_set_decl_assembler_name
+_c_common_nodes_and_builtins
+_is_attribute_p
+_list_length
+_handle_format_attribute
+_decode_format_attr
+_decode_format_type
+_chainon
+_lookup_attribute
+_tree_cons
+_build_type_attribute_variant
+_attribute_list_equal
+_attribute_list_contained
+_copy_node
+_set_type_quals
+_attribute_hash_list
+_type_hash_canon
+_type_hash_lookup
+_layout_type
+_htab_find_with_hash
+_type_hash_add
+_build_qualified_type
+_get_qualified_type
+_c_init_decl_processing
+_make_unsigned_type
+_default_set_default_type_attributes
+_fixup_unsigned_type
+_build_int_2_wide
+_tree_int_cst_sgn
+_smallest_mode_for_size
+_size_int_wide
+_size_int_type_wide
+_force_fit_type
+_htab_find_slot
+_size_htab_hash
+_size_htab_eq
+_finalize_type_size
+_get_mode_alignment
+_round_type_align
+_round_up
+_size_binop
+_int_const_binop
+_integer_onep
+_build_function_type
+_type_hash_list
+_type_hash_eq
+_type_list_equal
+__obstack_newchunk
+_start_fname_decls
+_set_dump_tree_p
+_c_objc_common_init
+_c_common_init
+_init_c_lex
+_get_fileinfo
+_splay_tree_lookup
+_splay_tree_splay
+_splay_tree_insert
+_cpp_get_callbacks
+_cpp_read_main_file
+__cpp_init_hashtable
+__cpp_init_directives
+_cpp_lookup
+__cpp_init_internal_pragmas
+_cpp_register_pragma
+_lookup_pragma_entry
+_insert_pragma_entry
+__cpp_aligned_alloc
+_init_standard_includes
+_update_path
+_remove_component_p
+_concat
+_translate_name
+_get_key_value
+_merge_include_chains
+_remove_dup_dirs
+_remove_dup_dir
+__cpp_read_file
+_open_file
+_find_or_create_entry
+_splay_tree_foreach
+_splay_tree_foreach_helper
+_inode_finder
+_stack_include_file
+_read_include_file
+_cpp_push_buffer
+__cpp_do_file_change
+_add_line_map
+_cb_file_change
+_update_header_times
+_extract_interface_info
+_init_pragma
+_add_c_tree_codes
+_ggc_add_tree_varray_root
+_objc_init
+_add_objc_tree_codes
+_init_objc
+_hash_init
+_synth_module_prologue
+_xref_tag
+_lookup_tag
+_pushtag
+_build_pointer_type
+_objc_declare_class
+_is_class_name
+_lookup_interface
+_lookup_name
+_generate_forward_declaration_to_string_table
+_build_nt
+_define_decl
+_start_decl
+_grokdeclarator
+_signed_type
+_signed_or_unsigned_type
+_build_array_type
+_layout_decl
+_c_apply_type_quals_to_decl
+_maybe_apply_pragma_weak
+_finish_decl
+_maybe_apply_renaming_pragma
+_complete_array_type
+_objc_check_decl
+_rest_of_decl_compilation
+_timevar_push
+_timevar_pop
+_get_pending_sizes
+_build_tree_list
+_objc_act_parse_init
+_lang_dependent_init
+_init_asm_output
+_init_eh
+_init_optabs
+_new_optab
+_init_all_optabs
+_init_integral_libfuncs
+_init_libfuncs
+_init_floating_libfuncs
+_init_one_libfunc
+_init_traps
+_push_srcloc
+_dwarf2out_do_frame
+_dbxout_init
+_getdecls
+_getpwd
+_output_quoted_string
+_assemble_name
+_maybe_get_identifier
+_text_section
+_dbxout_typedefs
+_dbxout_symbol
+_compile_file
+_init_final
+_init_branch_prob
+_yyparse
+_dbxout_start_source_file
+_cpp_finish_options
+_init_builtins
+__cpp_define_builtin
+_run_directive
+_start_directive
+_do_define
+_lex_macro_node
+__cpp_lex_token
+__cpp_lex_direct
+_parse_identifier
+__cpp_create_definition
+_skip_whitespace
+_parse_string
+_unescaped_terminator_p
+_alloc_expansion_token
+_lex_expansion_token
+_handle_newline
+_pfe_is_cmd_ln_processing
+_end_directive
+_skip_rest_of_line
+__cpp_pop_buffer
+_parse_number
+_pfe_set_cmd_ln_processing
+_cpp_define
+_warn_of_redefinition
+__cpp_equiv_tokens
+__cpp_free_definition
+_pfe_reset_cmd_ln_processing
+_free_chain
+__cpp_push_next_buffer
+_yyparse_1
+_yylex
+__yylex
+_c_lex
+_cpp_get_token
+_get_effective_char
+_skip_line_comment
+__cpp_handle_directive
+_directive_diagnostics
+_do_import
+_do_include_common
+_parse_include
+_check_eol
+__cpp_execute_include
+_find_include_file
+_hmap_lookup_path
+_splay_tree_splay_helper
+_find_framework_file
+__cpp_never_reread
+_skip_block_comment
+_adjust_column
+_do_ifndef
+_push_conditional
+_do_if
+__cpp_parse_expr
+_lex
+_parse_defined
+_do_else
+_do_endif
+__cpp_pop_file_buffer
+_purge_cache
+_pop_srcloc
+_dbxout_end_source_file
+_cb_line_change
+_yylexname
+_altivec_treat_as_keyword
+_pending_xref_error
+_split_specs_attrs
+_make_pointer_declarator
+_build1
+_first_rtl_op
+_build_type_copy
+_ggc_collect
+_start_struct
+_grokfield
+_finish_struct
+_in_parm_level_p
+_start_record_layout
+_place_field
+_integer_zerop
+_default_ms_bitfield_layout_p
+_normalize_rli
+_normalize_offset
+_compare_tree_int
+_finish_record_layout
+_finalize_record_size
+_convert
+_convert_to_integer
+_fold
+_fold_convert
+_mul_double
+_encode
+_decode
+_rli_size_so_far
+_bit_from_pos
+_rli_size_unit_so_far
+_byte_from_pos
+_compute_record_mode
+_host_integerp
+_bit_position
+_int_bit_position
+_tree_low_cst
+_simple_cst_equal
+_rest_of_type_compilation
+_get_object_reference
+_pushlevel
+_make_binding_level
+_clear_parm_order
+_declare_parm_level
+_push_parm_decl
+_simple_type_promotes_to
+_c_promoting_integer_type_p
+_warn_about_unused_variables
+_poplevel
+_grokparms
+_enter_macro_context
+_push_token_context
+_next_context
+_padding_token
+__cpp_temp_token
+__cpp_pop_context
+_warn_if_shadowing
+_get_parm_info
+_gettags
+_nreverse
+_storedecls
+_parmlist_tags_warning
+_build_decl_attribute_variant
+_gen_aux_info_record
+_c_build_qualified_type
+_parse_params
+_save_parameter
+_do_include
+_search_from
+_lbasename
+___udivmoddi4
+_parse_number
+_do_elif
+___udivdi3
+_skip_escaped_newlines
+_unsigned_type
+__cpp_extend_buff
+_build_index_type
+_build
+_non_lvalue
+_add_double
+_mode_for_size_tree
+_shadow_tag
+_shadow_tag_warned
+_lookup_tag_reverse
+_lex_number
+_build_compound_expr
+_internal_build_compound_expr
+_build_array_declarator
+_set_array_declarator_type
+_constant_expression_warning
+_operand_equal_p
+_tree_int_cst_equal
+_const_binop
+_neg_double
+_trigraph_p
+_build_enumerator
+_default_conversion
+_build_binary_op
+_common_type
+_tree_int_cst_lt
+_type_for_size
+_finish_enum
+_min_precision
+_tree_floor_log2
+_int_fits_type_p
+_start_enum
+_do_undef
+_do_ifdef
+_function_attribute_inlinable_p
+_c_cannot_inline_tree_fn
+_put_pending_sizes
+_walk_tree
+_inline_forbidden_p
+_statement_code_p
+_lhd_tree_inlining_walk_subtrees
+_get_callee_fndecl
+_setjmp_call_p
+_special_function_p
+_inlinable_function_p
+_c_expand_body
+_defer_fn
+_debug_nothing_tree
+_finish_function
+_start_function
+_announce_function
+_store_parm_decls
+_decl_function_context
+_storetags
+_init_function_start
+_objc_printable_name
+_objc_demangle
+_emit_line_note
+_set_file_and_line_for_stmt
+_emit_note
+_aggregate_value_p
+_hard_function_value
+_begin_stmt_tree
+_current_stmt_tree
+_c_begin_compound_stmt
+_build_stmt
+_add_stmt
+_stmts_are_full_exprs_p
+_clear_last_expr
+_add_scope_stmt
+_current_scope_stmt_stack
+_c_begin_if_stmt
+_build_external_ref
+_lookup_objc_ivar
+_assemble_external
+_build_indirect_ref
+_is_public
+_build_component_ref
+_lookup_field
+_truthvalue_conversion
+_convert_to_pointer
+_truth_value_p
+_twoval_comparison_p
+_optimize_bit_field_compare
+_get_inner_reference
+_c_expand_start_cond
+_parser_build_binary_op
+_split_tree
+_unsigned_conversion_warning
+_overflow_warning
+_build_array_ref
+_pointer_int_sum
+_size_in_bytes
+_extract_muldiv
+_c_expand_return
+_convert_for_assignment
+_objc_comptypes
+_build_return_stmt
+_c_finish_then
+_c_expand_end_cond
+_shorten_compare
+_get_narrower
+_invert_tree_comparison
+_fold_range_test
+_make_range
+_fold_truthop
+_merge_type_attributes
+_merge_attributes
+_swap_tree_comparison
+_convert_and_check
+_build_modify_expr
+_c_expand_expr_stmt
+_verify_sequence_points
+_verify_tree
+_warning_candidate_p
+_new_tlist
+_merge_tlist
+_add_tlist
+_warn_for_collisions
+_warn_for_collisions_1
+_require_complete_type
+_lvalue_or_else
+_lvalue_p
+_get_unwidened
+_negate_expr
+_build_function_call
+_decl_target_overloaded_intrinsic_p
+_convert_arguments
+_default_function_array_conversion
+_check_function_format
+_build_unary_op
+_unary_complex_lvalue
+_mark_addressable
+_byte_position
+_staticp
+_kept_level_p
+_lshift_double
+_place_union_field
+_get_inner_array_type
+__cpp_release_buff
+_funlike_invocation_p
+_collect_args
+_replace_args
+_expand_arg
+_push_ptoken_context
+_clear_limbo_values
+_finish_fname_decls
+_finish_stmt_tree
+_free_after_parsing
+_free_stmt_status
+_free_after_compilation
+_free_eh_status
+_free_expr_status
+_free_emit_status
+_free_varasm_status
+_rs6000_free_machine_status
+_tree_inlinable_function_p
+_c_disregard_inline_limits
+_merge_ranges
+_range_binop
+_build_range_check
+_invert_truthvalue
+_put_var_into_stack
+_integer_all_onesp
+_distribute_bit_expr
+_integer_pow2p
+_build_conditional_expr
+_operand_equal_for_comparison_p
+_decl_constant_value_for_broken_optimization
+_decl_constant_value
+_warn_about_long_double
+_duplicate_decls
+_comptypes
+_merge_decl_attributes
+_groktypename
+_c_sizeof
+_default_comp_type_attributes
+_function_types_compatible_p
+_self_promoting_args_p
+_type_lists_compatible_p
+_start_init
+_push_string
+_finish_init
+_store_init_value
+_digest_init
+_add_decl_stmt
+_build_c_cast
+_is_id
+_lex_string
+_build_string
+_combine_strings
+_choose_string_type
+_global_bindings_p
+_htab_expand
+_type_hash_hash
+_find_empty_slot_for_expand
+_get_static_reference
+_start_protocol
+_build_protocol_template
+_lookup_protocol
+_make_tree_vec
+_lookup_and_install_protocols
+_add_protocol
+_check_protocol_recursively
+_build_keyword_decl
+_adjust_type_for_id_default
+_is_objc_type_qualifier
+_build_method_decl
+_build_keyword_selector
+_add_instance_method
+_lookup_method
+_hash_lookup
+_hash_func
+_hash_enter
+_finish_protocol
+_start_class
+_add_class
+_add_class_method
+_finish_class
+_continue_class
+_build_ivar_chain
+_objc_copy_list
+_add_category
+_decode_field_reference
+_get_best_mode
+_comp_proto_with_proto
+_get_arg_type_list
+_groktypename_in_parm_context
+_hash_add_attr
+_add_instance_variable
+_type_for_mode
+_rshift_double
+_constant_boolean_node
+_omit_one_operand
+_unextend
+_make_bit_field_ref
+_all_ones_mask_p
+_do_float_handler
+_set_float_handler
+_parse_float
+_target_isinf
+_eisinf
+_eisnan
+restFP
+_build_real
+_convert_to_real
+_real_onep
+_ereal_cmp
+_ecmp
+_emovi
+_exact_real_inverse
+_ediv
+_eisneg
+_edivm
+_m16m
+_ecmpm
+_esubm
+_real_value_truncate
+_eclear
+_etoe53
+_real_twop
+saveFP
+_lex_charconst
+_cpp_interpret_charconst
+_do_pragma
+_darwin_pragma_options
+_push_field_alignment
+_pop_field_alignment
+_ht_expand
+_redeclaration_error_message
+_build_range_type
+_release_pages
+_ggc_mark_roots
+_ggc_mark_rtx_ptr
+_ggc_set_mark
+_ggc_mark_rtx_children
+_mark_optab
+_mark_ehl_map
+_ggc_mark_hash_table
+_zap_lists
+_ggc_mark_tree_ptr
+_mark_const_str_htab
+_htab_traverse
+_mark_const_hash_entry
+_maybe_mark_struct_function
+_ggc_mark_rtvec_children
+_mark_ident_hash
+_ht_forall
+_mark_ident
+_varray_grow
+_ggc_mark_trees
+_lang_mark_tree
+_c_mark_lang_decl
+_ggc_htab_delete
+_type_hash_marked_p
+_ggc_marked_p
+_type_hash_mark
+_htab_clear_slot
+_sweep_pages
+_c_expand_start_else
+_c_finish_else
+_stabilize_reference
+_stabilize_reference_1
+_c_begin_while_stmt
+_c_finish_while_stmt_cond
+_c_size_in_bytes
+_pedantic_non_lvalue
+_pop_label_level
+_build_message_expr
+_finish_message_expr
+_save_expr
+_contains_placeholder_p
+_lookup_instance_method_static
+_build_selector_reference
+_build_objc_method_call
+_build_selector_reference_decl
+_set_mem_attributes
+_get_alias_set
+_maybe_set_unchanging
+_can_address_p
+_handled_component_p
+_get_mem_attrs
+_mem_attrs_htab_hash
+_update_non_lazy_ptrs
+_pushdecl_top_level
+_comp_target_types
+_get_class_reference
+_build_class_reference_decl
+_receiver_is_class_object
+_lookup_class_method_static
+_initializer_constant_valid_p
+_lhd_return_tree
+_assemble_variable
+_app_disable
+_set_mem_align
+_mem_attrs_htab_eq
+_output_addressed_constants
+_output_constant_def
+_const_hash
+_record_constant
+_record_constant_1
+_set_mem_alias_set
+_output_constant_def_contents
+_cstring_section
+_data_section
+_try_section_alias
+_int_size_in_bytes
+_output_constant
+_assemble_string
+_decode_addr_const
+_objc_constant_string_object_section
+_objc_section_init
+_objc_cat_cls_meth_section
+_objc_cat_inst_meth_section
+_objc_string_object_section
+_cfstring_constant_object_section
+_objc_selector_refs_section
+_objc_selector_fixup_section
+_objc_cls_refs_section
+_objc_class_section
+_objc_meta_class_section
+_objc_cls_meth_section
+_objc_inst_meth_section
+_objc_protocol_section
+_objc_class_names_section
+_objc_meth_var_types_section
+_objc_meth_var_names_section
+_objc_category_section
+_objc_class_vars_section
+_objc_instance_vars_section
+_objc_module_info_section
+_objc_symbols_section
+_output_constructor
+_int_byte_position
+_expand_expr
+_get_subtarget
+_protect_from_queue
+_mark_temp_addr_taken
+_assemble_integer
+_rs6000_assemble_integer
+_find_weak_imports
+_default_assemble_integer
+_integer_asm_op
+_assemble_integer_with_op
+_output_addr_const
+_name_needs_quotes
+_immed_double_const
+_resolve_unique_section
+_variable_section
+_darwin_set_section_for_var_p
+_const_data_section
+_in_text_section
+_machopic_define_name
+_machopic_define_ident
+_machopic_ident_defined_p
+_machopic_classify_ident
+__cpp_backup_tokens
+_build_objc_string_object
+_add_class_reference
+_setup_string_decl
+_build_constructor
+_build_super_template
+_build_private_template
+_build_class_template
+_is_ivar
+_check_duplicates
+_locate_and_pad_parm
+_function_arg_padding
+_function_arg_boundary
+_function_arg_mod_boundary
+_pad_to_arg_alignment
+_assign_parms
+_function_arg_partial_nregs
+_function_arg_skip
+_no_reg_parm_stack_space
+_function_arg_advance
+_promote_mode
+_gen_reg_rtx
+_mark_user_reg
+_validize_mem
+_emit_move_insn
+_emit_move_insn_1
+_gen_movsi
+_rs6000_emit_move
+_gen_sequence
+_pfe_s_realloc
+_pfe_realloc
+_reg_mentioned_p
+_get_last_insn
+_mark_reg_pointer
+_function_arg_pass_by_reference
+_function_arg
+_emit_insns
+_expand_function_start
+_expand_pending_sizes
+_force_next_line_note
+_expand_stmt
+_prep_stmt
+_genrtl_compound_stmt
+_genrtl_scope_stmt
+_expand_start_bindings_and_block
+_push_temp_slots
+_genrtl_decl_stmt
+_anon_aggr_type_p
+_emit_local_var
+_expand_decl
+_expand_decl_init
+_expand_assignment
+_store_expr
+_queued_subexp_p
+_preserve_subexpressions_p
+_expand_call
+_flags_from_decl_or_type
+_init_cumulative_args
+_tree_last
+_rearrange_arg_list
+_initialize_argument_information
+_finalize_must_preallocate
+_any_pending_cleanups
+_function_ok_for_sibcall
+_unsafe_for_reeval
+_c_unsafe_for_reeval
+_assign_temp
+_precompute_arguments
+_calls_function
+_calls_function_1
+_value_member
+_compute_argument_block_size
+_compute_argument_addresses
+_rtx_for_function_call
+_precompute_register_parameters
+_rtx_equal_p
+_preserve_temp_slots
+_pop_temp_slots
+_combine_temp_slots
+_emit_queue
+_copy_rtx
+_replace_equiv_address
+_update_temp_slot_address
+_change_address_1
+_memory_address
+_force_reg
+_easy_fp_constant
+_gen_rtx_fmt_e
+_rs6000_machopic_legitimize_pic_address
+_machopic_legitimize_pic_address
+_machopic_indirect_data_reference
+_machopic_data_defined_p
+_machopic_function_base_name
+_gen_rtx_fmt_E
+_set_unique_reg_note
+_find_reg_note
+_find_temp_slot_from_address
+_copy_to_mode_reg
+_save_fixed_argument_area
+_prepare_call_address
+_lookup_static_chain
+_load_register_parameters
+_use_reg
+_trunc_int_for_mode
+_num_insns_constant
+_num_insns_constant_wide
+_emit_call_1
+_gen_call_value
+_machopic_indirect_call_target
+_machopic_name_defined_p
+_machopic_stub_list_entry
+_gen_rtx_fmt_0
+_gen_rtvec
+_gen_rtvec_v
+_emit_call_insn
+_make_call_insn_raw
+_get_insns
+_expand_start_target_temps
+_do_pending_stack_adjust
+_sbitmap_alloc
+_sbitmap_zero
+_gen_lowpart_SUBREG
+_subreg_lowpart_offset
+_gen_rtx_SUBREG
+_gen_rtx_fmt_ei
+_convert_modes
+_gen_lowpart
+_gen_lowpart_common
+_simplify_gen_subreg
+_simplify_subreg
+_gen_sibcall_value
+_gen_rtx_fmt_
+_emit_barrier_after
+_add_insn_after
+_expand_end_target_temps
+_expand_end_bindings
+_do_jump
+_can_compare_p
+_do_compare_and_jump
+_copy_to_reg
+_gen_rtx_fmt_uuuu
+_do_compare_rtx_and_jump
+_reverse_condition
+_swap_commutative_operands_p
+_commutative_operand_precedence
+_force_not_mem
+_emit_cmp_and_jump_insns
+_unsigned_condition
+_prepare_cmp_insn
+_emit_cmp_and_jump_insn_1
+_prepare_operand
+_gen_cmpsi
+_gen_bne
+_rs6000_emit_cbranch
+_rs6000_generate_compare
+_validate_condition_mode
+_gen_rtx_fmt_u00
+_gen_rtx_fmt_eee
+_emit_jump_insn
+_make_jump_insn_raw
+_genrtl_if_stmt
+_genrtl_expr_stmt_value
+_expand_expr_stmt_value
+_warn_if_unused_value
+_gen_call
+_free_temp_slots
+_expand_end_cond
+_emit_label
+_gen_sibcall
+_genrtl_return_stmt
+_expand_return
+_expand_value_return
+_expand_null_return_1
+_clear_pending_stack_adjust
+_expand_goto_internal
+_expand_fixup
+_emit_jump
+_gen_jump
+_emit_barrier
+_objc_expand_function_end
+_encode_method_prototype
+_encode_type_qualifiers
+_encode_type
+_encode_pointer
+_forwarding_offset
+_apply_args_register_offset
+_apply_args_size
+_encode_aggregate
+_expand_function_end
+_finish_expr_for_function
+_in_sequence_p
+_emit_line_note_force
+_expand_eh_return
+_clobber_return_register
+_diddle_return_value
+_do_clobber_return_reg
+_emit_insn_after
+_use_return_register
+_do_use_return_reg
+_expand_fixups
+_fixup_gotos
+_rest_of_compilation
+_reorder_blocks
+_reorder_blocks_0
+_reorder_blocks_1
+_blocks_nreverse
+_reorder_fix_fragments
+_pfe_varray_free
+_init_flow
+_open_dump_file
+_convert_from_eh_region_ranges
+_collect_eh_region_array
+_resolve_fixup_regions
+_convert_from_eh_region_ranges_1
+_remove_fixup_regions
+_remove_unreachable_regions
+_get_max_uid
+_remove_unnecessary_notes
+_remove_insn
+_alloc_INSN_LIST
+_gen_rtx_fmt_ue
+_free_INSN_LIST_node
+_init_function_for_compilation
+_purge_hard_subreg_sets
+_optimize_sibling_and_tail_recursive_calls
+_find_exception_handler_labels
+_rebuild_jump_labels
+_init_label_info
+_mark_all_labels
+_mark_jump_label
+_cse_basic_block
+_new_basic_block
+_any_uncondjump_p
+_pc_set
+_cse_process_notes
+_cse_insn
+_canon_reg
+_apply_change_group
+_fold_rtx
+_canon_hash
+_get_cse_reg_info
+_lookup
+_approx_reg_cost
+_for_each_rtx
+_approx_reg_cost_1
+_bitmap_set_bit
+_bitmap_element_allocate
+_bitmap_element_link
+_bitmap_clear
+_preferrable
+_validate_change
+_insert_regs
+_make_new_qty
+_rehash_using_reg
+_insert
+_invalidate_from_clobbers
+_invalidate
+_delete_reg_equiv
+_lookup_for_remove
+_make_regs_eqv
+_check_for_label_ref
+_lookup_as_function
+_safe_hash
+_exp_equiv_p
+_equiv_constant
+_simplify_binary_operation
+_avoid_constant_pool_reference
+_notreg_cost
+_insn_invalid_p
+_asm_noperands
+_cancel_changes
+_mention_regs
+_remove_invalid_refs
+_refers_to_regno_p
+_remove_from_table
+_gen_lowpart_if_possible
+_find_best_addr
+_recog_33
+_mov_to_vrsave_operation
+_load_multiple_operation
+_store_multiple_operation
+_recog_25
+_current_file_function_operand
+_call_operand
+_immediate_operand
+_scratch_operand
+_invalidate_memory
+_invalidate_for_call
+_recog_3
+_invalidate_skipped_block
+_note_stores
+_invalidate_skipped_set
+_cse_main
+_cse_end_of_basic_block
+_next_real_insn
+_prev_nonnote_insn
+_ggc_pop_context
+_end_alias_analysis
+_ggc_del_root
+_max_reg_num
+_find_basic_blocks
+_clear_edges
+_free_edge
+_count_basic_blocks
+_inside_basic_block_p
+_control_flow_insn_p
+_can_throw_internal
+_find_basic_blocks_1
+_create_basic_block_structure
+_compute_bb_for_insn
+_make_edges
+_cached_make_edge
+_computed_jump_p
+_computed_jump_p_1
+_returnjump_p
+_returnjump_p_1
+_make_label_edge
+_next_nonnote_insn
+_make_eh_edge
+_reachable_handlers
+_free_INSN_LIST_list
+_tidy_fallthru_edges
+_tidy_fallthru_edge
+_cleanup_cfg
+_delete_unreachable_blocks
+_find_unreachable_blocks
+_try_optimize_cfg
+_update_forwarder_flag
+_forwarder_block_p
+_active_insn_p
+_hook_void_bool_false
+_try_simplify_condjump
+_any_condjump_p
+_try_forward_edges
+_onlyjump_p
+_free_EXPR_LIST_list
+_free_bb_for_insn
+_delete_trivially_dead_insns
+_count_reg_usage
+_side_effects_p
+_canonicalize_condition
+_set_of
+_set_of_1
+_delete_null_pointer_checks
+_delete_null_pointer_checks_1
+_sbitmap_vector_zero
+_invalidate_nonnull_info
+_single_set_2
+_compute_available
+_sbitmap_vector_ones
+_sbitmap_ones
+_sbitmap_union_of_diff
+_sbitmap_intersection_of_preds
+_sbitmap_copy
+_clear_aux_for_edges
+_clear_aux_for_blocks
+_renumber_insns
+_close_dump_file
+_purge_addressof
+_hash_table_init
+_hash_table_init_n
+_compute_insns_for_mem
+_insns_for_mem_walk
+_hash_lookup
+_insns_for_mem_hash
+_compute_hash_table
+_record_last_reg_set_info
+_mark_call
+_record_last_mem_set_info
+_record_last_set_info
+_hash_scan_insn
+_hash_scan_set
+_find_reg_equal_equiv_note
+_oprs_available_p
+_oprs_unchanged_p
+_insert_set_in_table
+_hash_set
+_gcse_alloc
+_hash_scan_call
+_hash_scan_clobber
+_expr_equiv_p
+_one_cprop_pass
+_alloc_cprop_mem
+_sbitmap_vector_alloc
+_compute_cprop_data
+_compute_local_properties
+_compute_transp
+_cprop
+_reset_opr_set_tables
+_clear_modify_mem_tables
+_free_list
+_cprop_insn
+_note_uses
+_find_used_regs
+_mark_oprs_set
+_oprs_not_set_p
+_bitmap_bit_p
+_find_avail_set
+_lookup_set
+_mark_set
+_mark_clobber
+_free_cprop_mem
+_free_set_hash_table
+_gcse_main
+_free_gcse_mem
+_free_modify_mem_tables
+_alloc_gcse_mem
+_gmalloc
+_one_classic_gcse_pass
+_alloc_expr_hash_table
+_alloc_rd_mem
+_compute_expr_hash_table
+_want_to_gcse_p
+_set_noop_p
+_oprs_anticipatable_p
+_insert_expr_in_table
+_hash_expr
+_hash_expr_1
+_load_killed_in_block_p
+_find_comparison_args
+_comparison_dominates_p
+_simplify_relational_operation
+_simplify_ternary_operation
+_record_jump_equiv
+_reversed_comparison_code_parts
+_record_jump_cond
+_merge_equiv_classes
+_check_function_return_warnings
+_mark_constant_function
+_mark_dfs_back_edges
+_init_alias_analysis
+_record_set
+_find_base_value
+_rtx_varies_p
+_nonlocal_mentioned_p
+_flow_loops_find
+_calculate_dominance_info
+_init_dom_info
+_calc_dfs_tree
+_calc_dfs_tree_nonrec
+_calc_idoms
+_link_roots
+_idoms_to_doms
+_free_dom_info
+_flow_loops_tree_build
+_flow_loops_level_compute
+_estimate_probability
+_predict_edge_def
+_predict_edge
+_predict_insn
+_get_condition
+_predict_insn_def
+_combine_predictions_for_insn
+_dump_prediction
+_estimate_bb_frequencies
+_alloc_aux_for_blocks
+_alloc_aux_for_block
+_alloc_aux_for_edges
+_alloc_aux_for_edge
+_estimate_loops_at_level
+_propagate_freq
+_free_aux_for_blocks
+_free_aux_for_edges
+_flow_loops_free
+_life_analysis
+_allocate_reg_life_data
+_allocate_reg_info
+_allocate_bb_life_data
+_mark_regs_live_at_end
+_mark_reg
+_update_life_info
+_clear_log_links
+_calculate_global_regs_live
+_bitmap_operation
+_bitmap_copy
+_propagate_block
+_init_propagate_block_info
+_propagate_one_insn
+_insn_dead_p
+_mark_set_regs
+_mark_used_regs
+_mark_used_reg
+_volatile_refs_p
+_mark_set_1
+_invalidate_mems_from_set
+_bitmap_clear_bit
+_invalidate_mems_from_autoinc
+_free_propagate_block_info
+_bitmap_equal_p
+_sched_analyze
+_add_dependence_list_and_free
+_add_dependence
+_sched_analyze_insn
+_sched_analyze_1
+_sched_analyze_2
+_read_dependence
+_add_insn_mem_dependence
+_alloc_EXPR_LIST
+_add_dependence_list
+_flush_pending_lists
+_compute_jump_reg_dependencies
+_get_condition
+_compute_block_backward_dependences
+_add_branch_dependences
+_sets_likely_spilled
+_sets_likely_spilled_1
+_free_deps
+_schedule_region
+_get_block_head_tail
+_compute_forward_dependences
+_group_leader
+_set_priorities
+_priority
+_insn_cost
+_result_ready_cost
+_contributes_to_priority
+_rs6000_adjust_cost
+_get_attr_type
+_extract_constrain_insn_cached
+_extract_insn_cached
+_regclass
+_secondary_reload_class
+_scan_one_insn
+_record_operand_costs
+_record_reg_classes
+_find_regno_note
+_copy_cost
+_local_alloc
+_update_equiv_regs
+_reg_preferred_class
+_equiv_init_movable_p
+_equiv_init_varies_p
+_no_equiv
+_block_alloc
+_requires_inout
+_get_hard_reg_initial_reg
+_combine_regs
+_reg_is_born
+_alloc_qty
+_reg_alternate_class
+_wipe_dead_reg
+_mark_life
+_reg_is_set
+_multiple_sets
+_qty_sugg_compare_1
+_find_free_reg
+_post_mark_life
+_qty_compare_1
+_reg_set_to_hard_reg_set
+_qty_sugg_compare
+_qty_compare
+_global_alloc
+_global_conflicts
+_record_conflicts
+_mark_reg_clobber
+_mark_reg_death
+_mark_reg_store
+_set_preference
+_record_one_conflict
+_expand_preferences
+_allocno_compare
+_prune_preferences
+_find_reg
+_build_insn_chain
+_new_insn_chain
+_reg_dies
+_reg_becomes_live
+_reload
+_clear_secondary_mem
+_init_save_areas
+_mark_home_live
+_scan_paradoxical_subregs
+_function_invariant_p
+_init_elim_table
+_max_label_num
+_get_first_label_num
+_alter_reg
+_mark_not_eliminable
+_maybe_fix_stack_asms
+_finish_spills
+_rs6000_stack_info
+_first_reg_to_save
+_first_fp_reg_to_save
+_first_altivec_reg_to_save
+_rs6000_ra_ever_killed
+_push_topmost_sequence
+_pop_topmost_sequence
+_reg_overlap_mentioned_p
+_get_frame_size
+_get_func_frame_size
+_set_initial_elim_offsets
+_set_initial_label_offsets
+_calculate_needs_all_insns
+_set_label_offsets
+_eliminate_regs_in_insn
+_elimination_effects
+_eliminate_regs
+_check_eliminable_occurrences
+_find_reloads
+_update_eliminable_offsets
+_combine_reloads
+_operands_match_p
+_emit_reload_insns
+_emit_insns_before
+_emit_insns_after
+_reload_reg_reaches_end_p
+_reload_as_needed
+_subst_reloads
+_forget_old_reloads_1
+_push_reload
+_reload_inner_reg_of_subreg
+_find_reusable_reload
+_earlyclobber_operand_p
+_choose_reload_regs
+_choose_reload_regs_init
+_compute_use_by_pseudos
+_allocate_reload_reg
+_reload_reg_free_p
+_set_reload_reg
+_true_regnum
+_mark_reload_reg_in_use
+_do_input_reload
+_do_output_reload
+_set_offsets_for_label
+_verify_initial_elim_offsets
+_cleanup_subreg_operands
+_add_auto_inc_notes
+_auto_inc_p
+_replace_pseudos_in_call_usage
+_obstack_free
+_fixup_abnormal_edges
+_unshare_all_rtl_again
+_reset_used_flags
+_reset_used_decls
+_unshare_all_rtl
+_copy_rtx_if_shared
+_unshare_all_decls
+_unshare_all_rtl_1
+_reload_cse_regs
+_reload_cse_regs_1
+_cselib_init
+_clear_table
+_htab_empty
+_prologue_epilogue_contains
+_contains
+_cselib_process_insn
+_reload_cse_simplify
+_reload_cse_simplify_set
+_reload_cse_noop_set_p
+_rtx_equal_for_cselib_p
+_cselib_lookup
+_reload_cse_simplify_operands
+_cselib_record_sets
+_new_cselib_val
+_new_elt_loc_list
+_new_elt_list
+_cselib_invalidate_rtx
+_cselib_invalidate_regno
+_push_operand
+_cselib_record_set
+_hash_rtx
+_wrap_constant
+_cselib_subst_to_values
+_shallow_copy_rtx
+_cselib_lookup_mem
+_add_mem_for_addr
+_replace_equiv_address_nv
+_unchain_one_elt_list
+_unchain_one_elt_loc_list
+_entry_and_rtx_equal_p
+_cselib_invalidate_mem
+_cselib_invalidate_mem_1
+_cselib_mem_conflict_p
+_cselib_finish
+_htab_delete
+_reload_combine
+_reload_combine_note_use
+_reload_combine_note_store
+_get_value_hash
+_if_convert
+_find_if_header
+_find_if_block
+_process_if_block
+_find_cond_trap
+_block_has_only_trap
+_find_if_case_1
+_find_if_case_2
+_split_all_insns
+_split_insn
+_try_split
+_split_insns
+_const_int_operand
+_non_add_cint_operand
+_split_11
+_split_7
+_equality_operator
+_vector_comparison_operator
+_schedule_insns
+_scope_to_insns_initialize
+_delete_insn
+_sched_init
+_rs6000_issue_rate
+_init_dependency_caches
+_rtx_equal_for_memref_p
+_memrefs_conflict_p
+_canon_rtx
+_addr_side_effect_eval
+_write_dependence_p
+_output_dependence
+_mems_in_disjoint_alias_sets_p
+_alias_sets_conflict_p
+_nonoverlapping_memrefs_p
+_get_addr
+_base_alias_check
+_find_base_term
+_true_dependence
+_lsu_unit_blockage
+_actual_hazard
+_schedule_block
+_schedule_more_p
+_iu2_unit_blockage
+_can_schedule_ready_p
+_move_insn
+_move_insn1
+_reemit_notes
+_schedule_insn
+_new_ready
+_rs6000_adjust_priority
+_queue_to_ready
+_rank_for_schedule
+_function_units_used
+_rgn_rank
+_find_insn_list
+_no_real_insns_p
+_save_line_notes
+_rm_line_notes
+_rm_other_notes
+_clear_units
+_init_ready_list
+_ready_add
+_verify_local_live_at_start
+_reposition_prologue_and_epilogue_notes
+_reorder_insns
+_reorder_insns_nobb
+_set_block_for_insn
+_rm_redundant_line_notes
+_scope_to_insns_finalize
+_set_block_levels
+_change_scope
+_emit_note_before
+_add_insn_before
+_sched_finish
+_free_dependency_caches
+_add_noreturn_fake_exit_edges
+_try_crossjump_bb
+_try_crossjump_to_edge
+_outgoing_edges_match
+_remove_fake_edges
+_remove_fake_successors
+_compute_alignments
+_purge_line_number_notes
+_cleanup_barriers
+_split_all_insns_noflow
+_convert_to_eh_region_ranges
+_shorten_branches
+_insn_default_length
+_insn_variable_length_p
+_dwarf2out_begin_prologue
+_final_start_function
+_number_blocks
+_get_block_vector
+_all_blocks
+_rs6000_output_function_prologue
+_final
+_final_scan_insn
+_debug_nothing_int
+_peephole
+_scc_comparison_operator
+_constrain_operands_cached
+_get_insn_template
+_output_asm_insn
+_output_operand
+_print_operand
+_notice_source_line
+_dbxout_source_line
+_dbxout_source_file
+_dbxout_begin_block
+_simplify_subtraction
+_decode_rtx_const
+_walk_alter_subreg
+_output_address
+_print_operand_address
+_no_asm_to_stream
+_profile_after_prologue
+_output_406
+_machopic_validate_stub_or_non_lazy_ptr
+_output_405
+_output_541
+_output_cbranch
+_get_attr_length
+_output_asm_label
+_dbxout_end_block
+_final_end_function
+_rs6000_output_function_epilogue
+_output_compiler_stub
+_debug_nothing_void
+_assemble_end_function
+_output_after_function_constants
+_output_function_exception_table
+_free_basic_block_vars
+_regset_release_memory
+_bitmap_release_memory
+_dbxout_function_decl
+_dbxout_begin_function
+_dbxout_prepare_symbol
+_dbxout_type
+_dbxout_type_index
+_dbxout_queue_symbol
+_dbxout_type_name
+_dbxout_finish_symbol
+_dbxout_flush_symbol_queue
+_print_wide_int
+_dbxout_type_fields
+_print_int_cst_octal
+_print_octal
+_finish_method_def
+_optimize_inline_calls
+_lhd_tree_inlining_add_pending_fn_decls
+_expand_calls_inline
+_htab_find
+_hash_pointer
+_expand_call_inline
+_lhd_tree_inlining_tree_chain_matters_p
+_eq_pointer
+_init_recog_no_volatile
+_gen_label_rtx
+_gen_rtx_fmt_iuu00iss
+_genrtl_for_stmt
+_emit_nop
+_expand_start_loop_continue_elsewhere
+_expand_start_loop
+_genrtl_do_pushlevel
+_expand_cond
+_expand_exit_loop_top_cond
+_expand_exit_loop_if_false
+_gen_blt
+_expand_start_cond
+_gen_beq
+_expand_binop
+_reg_or_arith_cint_operand
+_gen_addsi3
+_add_operand
+_expand_increment
+_expand_end_loop
+_emit_label_before
+_emit_jump_insn_before
+_emit_barrier_before
+_maybe_remove_eh_handler
+_flow_delete_block_noexpunge
+_delete_insn_chain
+_can_delete_label_p
+_in_expr_list_p
+_remove_node_from_expr_list
+_can_delete_note_p
+_remove_edge
+_flow_delete_block
+_expunge_block
+_expunge_block_nocompact
+_redirect_edge_and_branch
+_try_redirect_by_replacing_jump
+_can_fallthru
+_next_active_insn
+_simplejump_p
+_never_reached_warning
+_ehl_hash
+_block_label
+_redirect_jump
+_redirect_exp
+_redirect_exp_1
+_num_validated_changes
+_branch_comparison_operator
+_redirect_edge_succ_nodup
+_redirect_edge_succ
+_merge_blocks
+_tail_recursion_label_p
+_sequence_uses_addressof
+_uses_addressof
+_replace_call_placeholder
+_call_ends_block_p
+_skip_copy_to_return_value
+_identify_call_return_value
+_skip_stack_adjustment
+_skip_pic_restore
+_reg_set_between_p
+_purge_reg_equiv_notes
+_remove_note
+_purge_mem_unchanging_flag
+_purge_addressof_1
+_hash_table_free
+_alloc_reg_set_mem
+_compute_sets
+_record_set_info
+_record_one_set
+_alloc_set_hash_table
+_compute_set_hash_table
+_compute_kill_rd
+_compute_rd
+_sbitmap_union_of_preds
+_alloc_avail_expr_mem
+_compute_ae_gen
+_compute_ae_kill
+_expr_killed_p
+_classic_gcse
+_lookup_expr
+_free_avail_expr_mem
+_free_rd_mem
+_free_expr_hash_table
+_one_code_hoisting_pass
+_cse_around_loop
+_cse_set_around_loop
+_addr_affects_sp_p
+_find_and_verify_loops
+_compute_luids
+_for_each_eh_label
+_mark_loop_jump
+_loop_optimize
+_reg_scan
+_reg_scan_mark_refs
+_find_single_use_in_loop
+_loop_regs_scan
+_count_one_set
+_reg_used_between_p
+_find_reg_fusage
+_find_regno_fusage
+_scan_loop
+_count_insns_in_loop
+_next_insn_in_loop
+_reg_in_basic_block_p
+_loop_invariant_p
+_consec_sets_invariant_p
+_loop_movables_add
+_skip_consec_insns
+_modified_between_p
+_reg_set_p
+_no_labels_between_p
+_may_trap_p
+_rtx_addr_can_trap_p
+_loop_reg_used_before_p
+_ignore_some_movables
+_force_movables
+_combine_movables
+_load_mems
+_reg_scan_update
+_strength_reduce
+_loop_bivs_find
+_for_each_insn_in_loop
+_check_insn_for_bivs
+_basic_induction_var
+_record_biv
+_loop_bivs_init_find
+_record_initial
+_get_condition_for_loop
+_valid_initial_value_p
+_loop_bivs_check
+_loop_givs_find
+_check_insn_for_givs
+_find_mem_givs
+_update_giv_derive
+_general_induction_var
+_simplify_giv_expr
+_loop_iterations
+_biv_total_increment
+_fold_rtx_mult_add
+_loop_find_equiv_value
+_find_common_reg_term
+_loop_givs_check
+_check_dbra_loop
+_count_nonfixed_reads
+_loop_biv_eliminable_p
+_maybe_eliminate_biv
+_maybe_eliminate_biv_1
+_check_ext_dependent_givs
+_combine_givs
+_loop_givs_dead_check
+_loop_givs_reduce
+_loop_givs_rescan
+_replace_regs
+_loop_ivs_free
+_loop_movables_free
+_ggc_push_context
+_regclass_init
+_thread_jump
+_reversed_comparison_code
+_compress
+_flow_depth_first_order_compute
+_flow_loop_nodes_find
+_sbitmap_first_set_bit
+_sbitmap_last_set_bit
+_flow_loop_scan
+_flow_loop_level_compute
+_flow_loop_exit_edges_find
+_find_auto_inc
+_delete_dead_jumptables
+_uninitialized_vars_warning
+_regno_uninitialized
+_initialize_uninitialized_subregs
+_combine_instructions
+_init_reg_last_arrays
+_setup_incoming_promotions
+_promoted_input_arg
+_record_value_for_reg
+_update_table_tick
+_get_last_value_validate
+_nonzero_bits
+_num_sign_bit_copies
+_set_nonzero_bits_and_sign_copies
+_expand_field_assignment
+_get_last_value
+_record_dead_and_set_regs
+_record_dead_and_set_regs_1
+_replace_rtx
+_recog_15
+_recog_21
+_recog_16
+_recog_17
+_recog_19
+_recog_31
+_recog_28
+_recog_26
+_stmw_operation
+_mtcrf_operation
+_lmw_operation
+_vrsave_operation
+_recog_for_combine
+_check_asm_operands
+_do_SUBST_INT
+_try_combine
+_undo_all
+_cant_combine_insn_p
+_can_combine_p
+_combinable_i3pat
+_do_SUBST
+_reg_referenced_p
+_dead_or_set_p
+_dead_or_set_regno_p
+_subst
+_combine_simplify_rtx
+_simplify_set
+_find_single_use
+_find_single_use_1
+_simplify_comparison
+_swap_condition
+_make_compound_operation
+_make_field_assignment
+_mark_used_regs_combine
+_use_crosses_set_p
+_volatile_insn_p
+_force_to_mode
+_recog_22
+_recog_23
+_any_operand
+_check_promoted_subreg
+_if_then_else_cond
+_simplify_if_then_else
+_combine_reversed_comparison_code
+_recog_30
+_contains_muldiv
+_apply_distributive_law
+_have_insn_for
+_move_deaths
+_restore_line_notes
+_free_pending_lists
+_finish_deps_global
+_init_deps_global
+_init_deps
+_unlink_line_notes
+_unlink_other_notes
+_leaf_function_p
+_allocate_initial_values
+_record_address_regs
+_assign_stack_local
+_assign_stack_local_1
+_find_reloads_address
+_regno_clobbered_p
+_copy_reloads
+_condjump_p
+_thread_prologue_and_epilogue_insns
+_gen_prologue
+_rs6000_emit_prologue
+_try_leaf_pic_optimization
+_name_encodes_objc_method_p
+_rs6000_frame_related
+_simplify_rtx
+_rs6000_maybe_dead
+_rs6000_emit_allocate_stack
+_gen_movsi_update
+_record_insns
+_insert_insn_on_edge
+_direct_return
+_gen_epilogue
+_rs6000_emit_epilogue
+_commit_edge_insertions
+_commit_one_edge_insertion
+_find_sub_basic_blocks
+_find_bb_boundaries
+_purge_dead_edges
+_compute_outgoing_frequencies
+___divdi3
+___udivmoddi4
+_gen_sibcall_epilogue
+_emit_insn_before
+_insns_match_p
+_copyprop_hardreg_forward
+_init_value_data
+_copyprop_hardreg_forward_1
+_preprocess_constraints
+_kill_clobbered_value
+_kill_autoinc_value
+_replace_oldest_value_reg
+_find_oldest_value_reg
+_kill_set_value
+_kill_value
+_kill_value_regno
+_set_value_regno
+_copy_value
+_replace_oldest_value_mem
+_replace_oldest_value_addr
+_recog_20
+_delete_noop_moves
+_noop_move_p
+_find_insn_reg_weight
+_init_regions
+_find_single_block_region
+_count_or_remove_death_notes
+_free_EXPR_LIST_node
+_assemble_start_function
+_output_408
+_purge_all_dead_edges
+_notice_stack_pointer_modification
+_notice_stack_pointer_modification_1
+_distribute_notes
+_reg_bitfield_target_p
+_distribute_links
+_undo_commit
+_remove_death
+_emit_note_after
+_reload_cse_delete_noop_set
+_references_value_p
+_reload_cse_move2add
+_move2add_note_store
+_sext_for_mode
+_start_method_def
+_synth_self_and_ucmd_args
+_handle_unused_attribute
+_expr_last
+_continue_method_def
+_really_start_method
+_lookup_method_in_protocol_list
+_find_label_refs
+_alloc_block
+_merge_blocks_nomove
+_skip_use_of_return_value
+_skip_unreturned_value
+_skip_jump_insn
+_doing_eh
+_emit_initial_value_sets
+_instantiate_virtual_regs
+_instantiate_decls
+_instantiate_decl
+_instantiate_decls_1
+_instantiate_virtual_regs_1
+_instantiate_new_reg
+_output_407
+_dbxout_parms
+_dbxout_block
+_dbxout_syms
+_dbxout_reg_parms
+_dbxout_symbol_location
+_dbxout_function_end
+_init_insn_lengths
+_clear_const_double_mem
+_expected_value_to_br_prob
+_prev_real_insn
+_insn_live_p
+_set_live_p
+_regmove_optimize
+_discover_flags_reg
+_gen_add3_insn
+_mark_flags_life_zones
+_find_matches
+_validate_replace_rtx
+_validate_replace_rtx_1
+_mirror_conflicts
+_nothrow_function_p
+_output_constant_pool
+_mark_constant_pool
+_htab_elements
+_function_section
+_unsave_expr
+_expand_start_else
+_machopic_non_lazy_ptr_list_entry
+_start_cleanup_deferral
+_end_cleanup_deferral
+_expand_loop_continue_here
+_genrtl_expr_stmt
+_delete_related_insns
+_canon_list_insert
+_mems_conflict_for_gcse_p
+_try_replace_reg
+_validate_replace_src
+_validate_replace_src_1
+_simplify_replace_rtx
+_try_pre_increment_1
+_try_pre_increment
+_find_use_as_address
+_split_2
+_cc_reg_not_cr0_operand
+_split_3
+_split_4
+_split_6
+_non_short_cint_operand
+_add_to_mem_set_list
+_comp_method_with_proto
+_force_operand
+_unsave_expr_now
+_unsave_expr_now_r
+_unsave_expr_1
+_duplicate_loop_exit_test
+_copy_loop_headers
+_invert_jump
+_invert_exp
+_invert_exp_1
+_invert_br_probabilities
+_update_br_prob_note
+_label_is_jump_target_p
+_get_bitmap_width
+_indirect_jump_in_function_p
+_prescan_loop
+_note_addr_stored
+_set_sched_group_p
+_remove_dependence
diff --git a/order-files/cc1objplus.order b/order-files/cc1objplus.order
new file mode 100644
index 00000000000..380a0e211c1
--- /dev/null
+++ b/order-files/cc1objplus.order
@@ -0,0 +1,952 @@
+start
+__start
+__dyld_init_check
+dyld_stub_binding_helper
+___darwin_gcc3_preregister_frame_info
+__call_mod_init_funcs
+__dyld_func_lookup
+_main
+_toplev_main
+_hex_init
+_general_init
+_xmalloc_set_program_name
+_diagnostic_initialize
+__obstack_begin
+_xmalloc
+_parse_options_and_default_flags
+_init_reg_sets
+_add_params
+_xrealloc
+_pfe_init
+_read_integral_parameter
+_override_O_option
+_extract_override_options
+_objc_init_options
+_cxx_init_options
+_c_common_init_options
+_cpp_create_reader
+_init_library
+_init_trigraph_map
+_xcalloc
+_set_lang
+_deps_init
+_init_line_maps
+__cpp_init_tokenrun
+__cpp_get_buff
+_new_buff
+_pfe_s_malloc
+_pfe_malloc
+_gcc_obstack_init
+_pfe_obstack_chuck_alloc
+__cpp_init_includes
+_splay_tree_new
+_splay_tree_new_with_allocator
+_splay_tree_xmalloc_allocate
+_set_index_lang
+_set_target_switch
+_optimization_options
+_override_option
+_objc_decode_option
+_cxx_decode_option
+_cpp_handle_option
+_parse_option
+_xstrdup
+_append_include_chain
+__cpp_simplify_pathname
+_independent_decode_option
+_new_pending_directive
+_hmap_load_header_map
+_decode_W_option
+_set_Wunused
+_compare_options
+_dump_switch_p
+_decode_f_option
+_output_set_maximum_length
+_set_real_maximum_length
+_output_is_line_wrapping
+_add_env_options
+_objc_post_options
+_c_common_post_options
+_cpp_post_options
+_init_dependency_output
+_do_compile
+_process_options
+_rs6000_override_options
+_rs6000_parse_abi_options
+_rs6000_add_gc_roots
+_ggc_add_rtx_root
+_ggc_add_root
+_htab_create
+_higher_prime_number
+_machopic_add_gc_roots
+_ggc_add_tree_root
+_new_alias_set
+_floor_log2_wide
+_init_timevar
+_timevar_start
+_lang_independent_init
+_init_ggc
+_exact_log2_wide
+_pfe_s_calloc
+_pfe_calloc
+_init_stringpool
+_ht_create
+_init_obstacks
+_ggc_add_deletable_htab
+_init_emit_once
+_mode_for_size
+_gen_rtx
+_rtx_alloc
+_ggc_alloc
+_alloc_page
+_pfe_free
+_set_page_table_entry
+_gen_raw_REG
+_gen_rtx_fmt_i0
+_gen_rtx_fmt_w
+_ereal_atof
+_asctoe53
+_asctoeg
+_ecleaz
+_enormlz
+_eshup6
+_toe53
+_eiisnan
+_eshift
+_eshup1
+_e53toe
+_eshdn1
+_ecleazs
+_emovo
+_emovz
+_eaddm
+_eshup8
+_emdnorm
+_init_reg_sets_1
+_reg_class_subset_p
+_init_regs
+_init_reg_modes
+_choose_hard_reg_mode
+_recog_13
+_nonimmediate_operand
+_general_operand
+_input_operand
+_memory_operand
+_register_operand
+_toc_relative_expr_p
+_constant_pool_expr_1
+_init_expmed
+_gen_rtx_CONST_INT
+_recog
+_gpc_reg_operand
+_recog_4
+_reg_or_cint_operand
+_rtx_cost
+_recog_5
+_reg_or_short_operand
+_short_cint_operand
+_htab_find_slot_with_hash
+_const_int_htab_eq
+_init_expr_once
+_gen_rtx_REG
+_recog_10
+_recog_9
+_altivec_register_operand
+_rs6000_legitimate_address
+_zero_constant
+_cc_reg_operand
+_constrain_operands
+_reg_fits_class_p
+_init_caller_save
+_extract_insn
+_insn_extract
+_gen_rtx_MEM
+_gen_rtx_fmt_e0
+_gen_rtx_fmt_ee
+_emit_insn
+_make_insn_raw
+_add_insn
+_recog_memoized_1
+_reg_or_mem_operand
+_recog_7
+_recog_6
+_boolean_or_operator
+_boolean_operator
+_recog_1
+_builtin_function_2
+_builtin_function
+_builtin_function_1
+_get_identifier
+_ht_lookup
+_calc_hash
+_alloc_node
+_make_node
+_tree_size
+_build_library_fn_1
+_build_lang_decl
+_build_decl
+_pfe_savestring
+_retrofit_lang_decl
+_ggc_alloc_cleared
+_pushdecl
+_lookup_name_current_level
+_namespace_binding
+_check_template_shadow
+_push_overloaded_decl
+_namespace_bindings_p
+_innermost_nonclass_level
+_set_namespace_binding
+_decls_match
+_warn_extern_redeclared_static
+_check_default_args
+_add_decl_to_level
+_make_decl_rtl
+_decode_reg_name
+_gen_rtx_fmt_s
+_darwin_encode_section_info
+_ggc_alloc_string
+_update_stubs
+_decl_attributes
+_init_attributes
+_default_insert_attributes
+_insert_default_attributes
+_c_common_insert_default_attributes
+_c_init_attributes
+_build_int_2_wide
+_tree_cons
+_builtin_function_disabled_p
+_mangle_decl
+_mangle_decl_string
+_c_common_nodes_and_builtins
+_init_standard_includes
+_update_path
+_cpp_read_main_file
+_merge_include_chains
+_remove_dup_dirs
+_remove_dup_dir
+__cpp_read_file
+_open_file
+_find_or_create_entry
+_splay_tree_lookup
+_splay_tree_splay
+_splay_tree_insert
+_splay_tree_foreach
+_splay_tree_foreach_helper
+_inode_finder
+_stack_include_file
+_read_include_file
+_cpp_push_buffer
+__cpp_do_file_change
+_add_line_map
+_cb_file_change
+_update_header_times
+_extract_interface_info
+_get_fileinfo
+_splay_tree_splay_helper
+_c_common_init
+_init_pragma
+_cpp_register_pragma
+_cpp_lookup
+_lookup_pragma_entry
+_insert_pragma_entry
+__cpp_aligned_alloc
+_cxx_init
+_init_cp_pragma
+_init_repo
+_objc_init
+_add_objc_tree_codes
+_set_dump_tree_p
+_init_objc
+_hash_init
+_synth_module_prologue
+_push_lang_context
+_objcp_xref_tag
+_xref_tag
+_tree_low_cst
+_host_integerp
+_identifier_type_value
+_lookup_tag
+_binding_for_name
+_lookup_name
+_lookup_name_real
+_lookup_flags
+_unqualified_namespace_lookup
+_current_decl_namespace
+_find_binding
+_lookup_using_namespace
+_select_decl
+_make_aggr_type
+_cp_make_lang_type
+_default_set_default_type_attributes
+_build_pointer_type
+_layout_type
+_size_int_wide
+_size_int_type_wide
+_force_fit_type
+_htab_find_slot
+_size_htab_hash
+_size_htab_eq
+_finalize_type_size
+_get_mode_alignment
+_round_type_align
+_round_up
+_size_binop
+_int_const_binop
+_integer_onep
+_make_binfo
+_make_tree_vec
+_pushtag
+_current_scope
+_create_implicit_typedef
+_set_identifier_type_value_with_scope
+_maybe_process_template_type_declaration
+_maybe_check_template_type
+_pushdecl_with_scope
+_objc_declare_class
+_is_class_name
+_lookup_interface
+_objcp_lookup_name
+_follow_tag_typedef
+_original_type
+_build_function_type
+_type_hash_list
+_type_hash_canon
+_type_hash_lookup
+_htab_find_with_hash
+_type_hash_add
+_objcp_builtin_function
+_type_hash_eq
+_attribute_list_equal
+_attribute_list_contained
+_type_list_equal
+_generate_forward_declaration_to_string_table
+_build_nt
+_define_decl
+_objcp_start_decl
+_start_decl
+_chainon
+_grokdeclarator
+_toplevel_bindings_p
+_cp_type_quals
+_strip_array_types
+_cp_build_qualified_type_real
+_create_array_type_for_decl
+_build_cplus_array_type
+_build_cplus_array_type_1
+_uses_template_parms
+_is_id
+_for_each_template_parm
+_walk_tree
+_for_each_template_parm_r
+_cp_walk_subtrees
+_build_array_type
+_grokvardecl
+_layout_decl
+_set_decl_namespace
+_is_namespace_ancestor
+_no_linkage_check
+_walk_tree_without_duplicates
+_htab_find
+_hash_pointer
+_no_linkage_helper
+_htab_delete
+_bad_specifiers
+_c_apply_type_quals_to_decl
+_cplus_decl_attributes
+_maybe_apply_pragma_weak
+_maybe_push_decl
+_maybe_register_incomplete_var
+_start_decl_1
+_maybe_push_cleanup_level
+_objcp_finish_decl
+_cp_finish_decl
+_maybe_apply_renaming_pragma
+_cp_has_mutable_p
+_target_type
+_check_initializer
+_maybe_deduce_size_from_array_init
+_complete_array_type
+_current_stmt_tree
+_layout_var_decl
+_maybe_commonize_var
+_make_rtl_for_nonlocal_decl
+_rest_of_decl_compilation
+_timevar_push
+_assemble_variable
+_timevar_pop
+_abstract_virtuals_error
+_pop_lang_context
+_objc_act_parse_init
+_lang_dependent_init
+_init_asm_output
+_strip_off_ending
+_init_eh
+_init_optabs
+_c_lex
+_read_token
+_read_process_identifier
+_altivec_treat_as_keyword
+_yylex
+_yyparse_1
+_do_pending_lang_change
+_cpp_get_token
+__cpp_lex_token
+__cpp_lex_direct
+_skip_whitespace
+_parse_identifier
+_enter_macro_context
+_push_token_context
+_next_context
+_padding_token
+__cpp_temp_token
+_hash_tree_cons
+_list_hash_pieces
+__cpp_pop_context
+_scan_tokens
+_frob_id
+_parse_decl0
+_frob_specs
+_save_type_access_control
+_split_specs_attrs
+_parse_decl
+_build_type_copy
+_copy_node
+_parse_end_decl
+_decl_type_access_control
+_deferred_type_access_control
+_note_list_got_semicolon
+_clear_anon_tags
+_do_pending_inlines
+_ggc_collect
+_handle_newline
+_get_effective_char
+__cpp_handle_directive
+_start_directive
+_directive_diagnostics
+_do_endif
+_check_eol
+_skip_block_comment
+_end_directive
+_skip_rest_of_line
+_do_undef
+_lex_macro_node
+_adjust_column
+_do_if
+__cpp_parse_expr
+_lex
+_parse_defined
+_push_conditional
+_do_ifndef
+__obstack_newchunk
+_do_define
+__cpp_create_definition
+_alloc_expansion_token
+_pfe_is_cmd_ln_processing
+_cb_line_change
+_list_hash_eq
+_build_tree_list
+_do_ifdef
+_find_include_file
+__cpp_execute_include
+_push_srcloc
+_debug_nothing_int_charstar
+__cpp_never_reread
+_do_import
+_do_include_common
+_parse_include
+_parse_string
+_unescaped_terminator_p
+_hmap_lookup_path
+_maybe_note_name_used_in_class
+_note_got_semicolon
+_parse_params
+_save_parameter
+_lex_expansion_token
+_parse_number
+_parse_number
+___udivdi3
+___udivmoddi4
+_do_else
+_identifier_type
+_do_include
+_search_from
+_lbasename
+__cpp_pop_buffer
+__cpp_pop_file_buffer
+_purge_cache
+_pop_srcloc
+_debug_nothing_int
+_do_elif
+_comptypes
+_compparms
+_add_method
+_build_overload
+_ovl_cons
+_clone_function_decl
+_clone_constructors_and_destructors
+_check_bases_and_members
+_finish_struct_methods
+_maybe_warn_about_overly_private_class
+_method_name_cmp
+_type_requires_array_cookie
+_lookup_fnfields
+_lookup_member
+_complete_type
+_bfs_walk
+_varray_init
+_lookup_field_r
+_lookup_fnfields_1
+_lookup_field_1
+_finish_struct_1
+_layout_class_type
+_start_record_layout
+_determine_primary_base
+_create_vtable_ptr
+_build_base_fields
+_layout_nonempty_base_or_field
+_place_field
+_integer_zerop
+_default_ms_bitfield_layout_p
+_normalize_rli
+_normalize_offset
+_compare_tree_int
+_tree_int_cst_sgn
+_byte_position
+_byte_from_pos
+_convert
+_ocp_convert
+_decl_constant_value
+_convert_to_integer
+_build1
+_first_rtl_op
+_fold
+_fold_convert
+_layout_conflict_p
+_splay_tree_max
+_add_double
+_end_of_class
+_rli_size_unit_so_far
+_finish_record_layout
+_finalize_record_size
+_mul_double
+_encode
+_decode
+_rli_size_so_far
+_bit_from_pos
+_compute_record_mode
+_bit_position
+_int_bit_position
+_simple_cst_equal
+_mode_for_size_tree
+_remove_zero_width_bit_fields
+_layout_virtual_bases
+_warn_about_ambiguous_direct_bases
+_splay_tree_delete
+_splay_tree_delete_helper
+_splay_tree_xmalloc_deallocate
+_nreverse
+_modify_all_vtables
+_dfs_walk
+_dfs_walk_real
+_dfs_modify_vtables
+_dfs_unmark
+_finish_struct_bits
+_aggregate_value_p
+_count_fields
+_add_fields_to_vec
+_field_decl_cmp
+_finish_vtbls
+_accumulate_vtbl_inits
+_build_vtt
+_build_vtt_inits
+_complete_vars
+_maybe_suppress_debug_info
+_dump_class_hierarchy
+_dump_begin
+_decl_function_context
+_rest_of_type_compilation
+_finish_struct
+_popclass
+_poplevel_class
+_pop_binding
+_pop_binding_level
+_find_class_binding_level
+_pop_class_decls
+_pop_search_level
+_pop_stack_level
+_finish_class_definition
+_check_for_missing_semicolon
+_do_pending_defargs
+_done_pending_defargs
+_begin_inline_definitions
+_finish_inline_definitions
+_clear_inline_text_obstack
+_set_identifier_type_value
+_build_self_reference
+_finish_member_declaration
+_pushdecl_class_level
+_push_class_level_binding
+_push_class_binding
+_note_name_declared_in_class
+_push_binding
+_context_for_name_lookup
+_is_properly_derived_from
+_begin_class_definition
+_check_class_key
+_decl_namespace
+_parse_field0
+_parse_field
+_grokfield
+_constructor_name
+_constructor_name_full
+_objc_check_decl
+_template_class_depth
+_template_class_depth_real
+_splay_tree_compare_pointers
+_reset_type_access_control
+_unreverse_member_declarations
+_fixup_inline_methods
+_check_bases
+_check_field_decls
+_delete_duplicate_fields
+_delete_duplicate_fields_1
+_pod_type_p
+_check_field_decl
+_finish_struct_anon
+_check_methods
+_add_implicitly_declared_members
+_implicitly_declare_fn
+_synthesize_exception_spec
+_make_call_declarator
+_parmlist_is_exprlist
+_check_special_function_return_type
+_member_function_or_else
+_grokparms
+_build_cplus_method_type
+_grokfndecl
+_build_exception_variant
+_comp_except_specs
+_eq_pointer
+_get_containing_scope
+_grokclassfn
+_build_qualified_type
+_get_qualified_type
+_set_type_quals
+_build_artificial_parm
+_maybe_retrofit_in_chrg
+_statement_code_p
+_cp_statement_code_p
+_cp_is_overload_p
+_check_explicit_specialization
+_current_tmpl_spec_kind
+_grok_ctor_properties
+_copy_fn_p
+_skip_artificial_parms_for
+_grok_special_member_properties
+_sufficient_parms_p
+_defer_fn
+_build_reference_type
+_hash_tree_chain
+_type_promotes_to
+_c_promoting_integer_type_p
+_grok_op_properties
+_ambi_op_p
+_unary_op_p
+_build_clone
+_copy_decl
+_copy_lang_decl
+_copy_list
+_parse_bitfield0
+_parse_bitfield
+_grokbitfield
+_constant_expression_warning
+_lex_number
+_int_fits_type_p
+_check_bitfield_decl
+_do_aggr
+_yyungetc
+_handle_class_head
+_maybe_process_partial_specialization
+_pushclass
+_invalidate_class_lookup_cache
+_pushlevel_class
+_push_binding_level
+_push_class_decls
+_push_search_level
+_push_stack_level
+_dfs_push_type_decls
+_dfs_push_decls
+_storetags
+_reset_specialization
+_make_pointer_declarator
+_get_type_decl
+_finish_decl_parsing
+_check_for_new_type
+_finish_parmlist
+_varray_grow
+_pfe_s_realloc
+_pfe_realloc
+_do_warning
+__cpp_extend_buff
+_nothrow_libfn_p
+_libc_name_p
+_lex_string
+_build_string
+_lookup_tag_reverse
+_skip_escaped_newlines
+_begin_function_definition
+_start_function
+_lookup_attribute
+_check_function_type
+_require_complete_types_for_parms
+_complete_type_or_else
+_init_function_start
+_prepare_function_start
+_init_stmt_for_function
+_init_eh_for_function
+_init_emit
+_clear_emit_caches
+_init_virtual_regs
+_init_expr
+_init_varasm_status
+_init_temp_slots
+_init_pending_stack_adjust
+_push_cp_function_context
+_rs6000_init_machine_status
+_objc_printable_name
+_objc_demangle
+_emit_line_note
+_set_file_and_line_for_stmt
+_emit_note
+_hard_function_value
+_begin_stmt_tree
+_announce_function
+_pushlevel
+_start_fname_decls
+_store_parm_decls
+_storedecls
+_push_local_binding
+_getdecls
+_gettags
+_begin_function_body
+_keep_next_level
+_begin_compound_stmt
+_build_stmt
+_add_stmt
+_stmts_are_full_exprs_p
+_do_pushlevel
+_make_binding_level
+_add_scope_stmt
+_current_scope_stmt_stack
+_at_function_scope_p
+_compute_array_index_type
+_cp_convert
+_build_binary_op
+_really_overloaded_fn
+_default_conversion
+_decay_conversion
+_type_unknown_p
+_is_overloaded_fn
+_common_type
+_type_after_usual_arithmetic_conversions
+_merge_type_attributes
+_merge_attributes
+_build_type_attribute_variant
+_build
+_operand_equal_p
+_tree_int_cst_equal
+_const_binop
+_neg_double
+_build_index_type
+_non_lvalue
+_place_union_field
+_qualify_lookup
+_finish_id_expr
+_do_identifier
+_objcp_lookup_identifier
+_lookup_objc_ivar
+_hack_identifier
+_mark_used
+_assemble_external
+_convert_from_reference
+_build_x_unary_op
+_build_new_op
+_build_unary_op
+_lvalue_type
+_unary_complex_lvalue
+_lvalue_or_else
+_lvalue_p
+_lvalue_p_1
+_mark_addressable
+_staticp
+_reparse_absdcl_as_casts
+_altivec_is_vector_constant_element
+_groktypename
+_build_c_cast
+_convert_force
+_convert_to_pointer_force
+_cp_convert_to_pointer
+_build_x_modify_expr
+_build_modify_expr
+_require_complete_type
+_convert_for_assignment
+_dubious_conversion_warnings
+_overflow_warning
+_can_convert_arg_bad
+_implicit_conversion
+_standard_conversion
+_strip_top_quals
+_perform_implicit_conversion
+_convert_like_real
+_finish_expr_stmt
+_convert_to_void
+_finish_stmt
+_dependent_base_p
+_currently_open_class
+_type_access_control
+_build_x_component_ref
+_build_component_ref
+_lookup_field
+_enforce_access
+_accessible_p
+_friend_accessible_p
+_access_in_type
+_dfs_access_in_type
+_assert_canonical_unmarked
+_dfs_assert_unmarked_p
+_dfs_accessible_p
+_grok_array_decl
+_build_expr_type_conversion
+_build_array_ref
+_build_x_arrow
+_build_indirect_ref
+_canonical_type_variant
+_build_conv
+_finish_call_expr
+_is_global
+_lookup_arg_dependent
+_arg_assoc_args
+_arg_assoc
+_arg_assoc_type
+_build_x_function_call
+_build_function_call
+_build_function_call_real
+_decl_target_overloaded_intrinsic_p
+_inline_conversion
+_convert_arguments
+_convert_for_initialization
+_build_call
+_build_addr_func
+_is_empty_class
+_finish_return_stmt
+_check_return_expr
+_maybe_warn_about_returning_address_of_local
+_finish_compound_stmt
+_finish_function_body
+_do_poplevel
+_kept_level_p
+_poplevel
+_warn_about_unused_variables
+_finish_function
+_finish_fname_decls
+_finish_stmt_tree
+_pop_labels
+_save_function_data
+_calls_setjmp_p
+_calls_setjmp_r
+_setjmp_call_p
+_special_function_p
+_free_after_parsing
+_pop_cp_function_context
+_free_stmt_status
+_free_after_compilation
+_free_eh_status
+_free_expr_status
+_free_emit_status
+_free_varasm_status
+_rs6000_free_machine_status
+_expand_body
+_simplify_aggr_init_exprs_r
+_maybe_clone_body
+_debug_nothing_tree
+_start_enum
+_build_enumerator
+_tree_int_cst_lt
+_finish_enum
+_min_precision
+_tree_floor_log2
+_fixup_unsigned_type
+_smallest_mode_for_size
+_shadow_tag
+_check_tag_decl
+_add_builtin_candidates
+_non_reference
+_type_decays_to
+_type_for_size
+_add_builtin_candidate
+_build_builtin_candidate
+_add_candidate
+_any_viable
+_splice_viable
+_tourney
+_lshift_double
+_finish_parenthesized_expr
+_build_x_binary_op
+_lookup_function_nonclass
+_lookup_name_nonclass
+_arg_assoc_namespace
+_purpose_member
+_get_narrower
+_truth_value_p
+_integer_all_onesp
+_distribute_bit_expr
+_default_comp_type_attributes
+_build_x_indirect_ref
+_build_opfncall
+_reparse_decl_as_expr
+_build_expr_from_tree
+_warn_of_redefinition
+_cpp_pedwarn_with_line
+__cpp_begin_message
+__cpp_free_definition
+_funlike_invocation_p
+_collect_args
+_replace_args
+_expand_arg
+_push_ptoken_context
+__cpp_release_buff
+_finish_sizeof
+_c_sizeof
+_extract_muldiv
+_get_inner_array_type
+_duplicate_decls
+_redeclaration_error_message
+_locate_copy
+_merge_exception_specifiers
+_add_binding
+_locate_ctor
+_make_anon_name
+_clear_identifier_class_values
+_merge_decl_attributes
+_merge_types
+_commonparms
+_list_length
+_tree_last
+_skip_line_comment
+_trigraph_p
+_see_typename
+_push_nested_class
+_set_class_shadows
+_unuse_fields
+_dfs_unuse_fields
+_maybe_begin_member_template_processing
+_inline_needs_template_parms
+_feed_defarg
+_feed_input
+_replace_defarg
+_can_convert_arg
+_finish_defarg
+_end_input
+_obstack_free
+_maybe_end_member_template_processing
+_pop_nested_class
diff --git a/order-files/cc1plus.order b/order-files/cc1plus.order
new file mode 100644
index 00000000000..39806c011ca
--- /dev/null
+++ b/order-files/cc1plus.order
@@ -0,0 +1,1356 @@
+start
+__start
+__dyld_init_check
+dyld_stub_binding_helper
+___darwin_gcc3_preregister_frame_info
+__call_mod_init_funcs
+__dyld_func_lookup
+_main
+_toplev_main
+_hex_init
+_general_init
+_xmalloc_set_program_name
+_diagnostic_initialize
+__obstack_begin
+_xmalloc
+_parse_options_and_default_flags
+_init_reg_sets
+_add_params
+_xrealloc
+_pfe_init
+_read_integral_parameter
+_override_O_option
+_extract_override_options
+_lang_init_options
+_cxx_init_options
+_c_common_init_options
+_cpp_create_reader
+_init_library
+_init_trigraph_map
+_xcalloc
+_set_lang
+_deps_init
+_init_line_maps
+__cpp_init_tokenrun
+__cpp_get_buff
+_new_buff
+_pfe_s_malloc
+_pfe_malloc
+_gcc_obstack_init
+_pfe_obstack_chuck_alloc
+__cpp_init_includes
+_splay_tree_new
+_splay_tree_new_with_allocator
+_splay_tree_xmalloc_allocate
+_set_index_lang
+_set_target_switch
+_optimization_options
+_override_option
+_cxx_decode_option
+_cpp_handle_option
+_parse_option
+_xstrdup
+_append_include_chain
+__cpp_simplify_pathname
+_independent_decode_option
+_remove_component_p
+_new_pending_directive
+_compare_options
+_dump_switch_p
+_decode_f_option
+_decode_g_option
+_set_Wunused
+_set_Wformat
+_decode_W_option
+_output_set_maximum_length
+_set_real_maximum_length
+_output_is_line_wrapping
+_add_env_options
+_cxx_post_options
+_c_common_post_options
+_cpp_post_options
+_init_dependency_output
+_do_compile
+_process_options
+_rs6000_override_options
+_rs6000_parse_abi_options
+_rs6000_add_gc_roots
+_ggc_add_rtx_root
+_ggc_add_root
+_htab_create
+_higher_prime_number
+_machopic_add_gc_roots
+_ggc_add_tree_root
+_new_alias_set
+_floor_log2_wide
+_init_timevar
+_timevar_start
+_lang_independent_init
+_init_ggc
+_exact_log2_wide
+_pfe_s_calloc
+_pfe_calloc
+_init_stringpool
+_ht_create
+_init_obstacks
+_ggc_add_deletable_htab
+_init_emit_once
+_mode_for_size
+_gen_rtx
+_rtx_alloc
+_ggc_alloc
+_alloc_page
+_pfe_free
+_set_page_table_entry
+_gen_raw_REG
+_gen_rtx_fmt_i0
+_gen_rtx_fmt_w
+_ereal_atof
+_asctoe53
+_asctoeg
+_ecleaz
+_enormlz
+_eshup6
+_toe53
+_eiisnan
+_eshift
+_eshup1
+_e53toe
+_eshdn1
+_ecleazs
+_emovo
+_emovz
+_eaddm
+_eshup8
+_emdnorm
+_gen_rtx_CONST_INT
+_gen_const_vector_0
+_rtvec_alloc
+_gen_rtx_fmt_E0
+_gen_rtx_REG
+_init_regs
+_init_reg_sets_1
+_reg_class_subset_p
+_init_reg_modes
+_choose_hard_reg_mode
+_gen_rtx_MEM
+_gen_rtx_fmt_e0
+_init_alias_once
+_init_stmt
+_init_loop
+_address_cost
+_memory_address_p
+_rs6000_legitimate_address
+_init_reload
+_gen_rtx_fmt_ee
+_gen_rtx_fmt_s
+_pfe_savestring
+_plus_constant_wide
+_find_constant_term_loc
+_init_varasm_once
+_init_EXPR_INSN_LIST_cache
+_init_dummy_function_start
+_prepare_function_start
+_ggc_alloc_cleared
+_init_stmt_for_function
+_init_eh_for_function
+_init_emit
+_clear_emit_caches
+_init_virtual_regs
+_init_expr
+_init_varasm_status
+_init_temp_slots
+_init_pending_stack_adjust
+_rs6000_init_machine_status
+_init_expmed
+_start_sequence
+_rtx_cost
+_emit_insn
+_make_insn_raw
+_add_insn
+_init_recog
+_recog
+_recog_13
+_gpc_reg_operand
+_register_operand
+_recog_4
+_reg_or_cint_operand
+_recog_5
+_nonimmediate_operand
+_general_operand
+_input_operand
+_memory_operand
+_toc_relative_expr_p
+_constant_pool_expr_1
+_reg_or_short_operand
+_short_cint_operand
+_htab_find_slot_with_hash
+_const_int_htab_eq
+_init_expr_once
+_boolean_or_operator
+_boolean_operator
+_recog_1
+_reg_or_mem_operand
+_recog_7
+_recog_10
+_recog_9
+_altivec_register_operand
+_zero_constant
+_strict_memory_address_p
+_init_caller_save
+_recog_memoized_1
+_extract_insn
+_insn_extract
+_constrain_operands
+_reg_fits_class_p
+_recog_6
+_cc_reg_operand
+_ht_lookup
+_alloc_node
+_make_node
+_tree_size
+_get_identifier
+_init_reswords
+_calc_hash
+_cxx_init
+_init_spew
+_init_tree
+_set_dump_tree_p
+_init_cplus_expand
+_init_cp_semantics
+_add_c_tree_codes
+_add_cpp_tree_codes
+_init_operators
+_init_method
+_init_mangle
+_varray_init
+_init_error
+_init_output_buffer
+_output_set_prefix
+_clear_diagnostic_info
+_build_int_2_wide
+_cxx_init_decl_processing
+_initialize_predefined_identifiers
+_cp_parse_init
+_init_decl2
+_ggc_add_tree_varray_root
+_init_pt
+_push_to_top_level
+_maybe_push_to_top_level
+_push_namespace
+_build_lang_decl
+_build_decl
+_retrofit_lang_decl
+_build_common_tree_nodes
+_initialize_sizetypes
+_default_set_default_type_attributes
+_get_mode_alignment
+_copy_node
+_make_signed_type
+_fixup_signed_type
+_layout_type
+_tree_int_cst_sgn
+_smallest_mode_for_size
+_size_int_wide
+_size_int_type_wide
+_force_fit_type
+_htab_find_slot
+_size_htab_hash
+_finalize_type_size
+_round_type_align
+_round_up
+_size_htab_eq
+_size_binop
+_int_const_binop
+_integer_onep
+_tree_cons
+_make_unsigned_type
+_fixup_unsigned_type
+_pushlevel
+_make_binding_level
+_push_binding_level
+_declare_namespace_level
+_namespace_binding
+_pushdecl
+_lookup_name_current_level
+_check_template_shadow
+_namespace_bindings_p
+_innermost_nonclass_level
+_set_namespace_binding
+_add_decl_to_level
+_pop_namespace
+_suspend_binding_level
+_find_class_binding_level
+_c_common_nodes_and_builtins
+_record_builtin_type
+_set_identifier_type_value_with_scope
+_binding_for_name
+_find_binding
+_set_identifier_type_value
+_identifier_global_value
+_signed_type
+_set_sizetype
+_build_common_tree_nodes_2
+_build_pointer_type
+_build_qualified_type
+_get_qualified_type
+_build_type_copy
+_set_type_quals
+_mul_double
+_encode
+_decode
+_rs6000_build_va_list
+_make_vector
+_finish_vector_type
+_build_index_type
+_convert
+_ocp_convert
+_complete_type
+_decl_constant_value
+_convert_to_integer
+_build1
+_first_rtl_op
+_fold
+_fold_convert
+_compare_tree_int
+_host_integerp
+_tree_low_cst
+_type_hash_canon
+_type_hash_lookup
+_htab_find_with_hash
+_type_hash_add
+_build_array_type
+_build
+_integer_zerop
+_comptypes
+_non_lvalue
+_add_double
+_simple_cst_equal
+_mode_for_size_tree
+_start_record_layout
+_place_field
+_layout_decl
+_default_ms_bitfield_layout_p
+_normalize_rli
+_normalize_offset
+_finish_record_layout
+_finalize_record_size
+_get_inner_array_type
+_rli_size_so_far
+_bit_from_pos
+_rli_size_unit_so_far
+_byte_from_pos
+_compute_record_mode
+_type_hash_eq
+_attribute_list_equal
+_attribute_list_contained
+_bit_position
+_int_bit_position
+_build_function_type
+_type_hash_list
+_type_list_equal
+_builtin_function_2
+_builtin_function
+_builtin_function_1
+_build_library_fn_1
+_push_overloaded_decl
+_decls_match
+_warn_extern_redeclared_static
+_check_default_args
+_make_decl_rtl
+_decode_reg_name
+_darwin_encode_section_info
+_ggc_alloc_string
+_update_stubs
+_decl_attributes
+_init_attributes
+_default_insert_attributes
+_insert_default_attributes
+_c_common_insert_default_attributes
+_c_init_attributes
+_builtin_function_disabled_p
+_mangle_decl
+_mangle_decl_string
+_resume_binding_level
+_strip_array_types
+_cp_type_quals
+_build_cplus_array_type
+_build_cplus_array_type_1
+_uses_template_parms
+_for_each_template_parm
+_walk_tree
+_for_each_template_parm_r
+_cp_walk_subtrees
+_statement_code_p
+_cp_statement_code_p
+_cp_is_overload_p
+_record_unknown_type
+_xref_tag
+_identifier_type_value
+_add_exception_specifier
+_build_tree_list
+_build_exception_variant
+_comp_except_specs
+_push_cp_library_fn
+_build_cp_library_fn
+_set_mangled_name_for_decl
+_write_encoding
+_write_name
+_decl_is_template_id
+_write_unscoped_name
+_write_unqualified_name
+_write_bare_function_type
+_write_method_parms
+_write_type
+_find_substitution
+_canonical_type_variant
+_cp_build_qualified_type_real
+_write_CV_qualifiers_for_type
+_write_builtin_type
+_add_substitution
+_build_library_fn_ptr
+_build_library_fn
+_init_class_processing
+_init_one_libfunc
+_init_exception_processing
+_supports_one_only
+_start_fname_decls
+_using_eh_for_cleanups
+_type_for_size
+_init_cpp_parse
+_c_common_init
+_init_c_lex
+_get_fileinfo
+_splay_tree_lookup
+_splay_tree_splay
+_splay_tree_insert
+_cpp_get_callbacks
+_cpp_read_main_file
+__cpp_init_hashtable
+__cpp_init_directives
+_cpp_lookup
+__cpp_init_internal_pragmas
+_cpp_register_pragma
+_lookup_pragma_entry
+_insert_pragma_entry
+__cpp_aligned_alloc
+_init_standard_includes
+_update_path
+_concat
+_translate_name
+_get_key_value
+_merge_include_chains
+_remove_dup_dirs
+_remove_dup_dir
+_cpp_warning
+__cpp_begin_message
+__cpp_read_file
+_open_file
+_find_or_create_entry
+_splay_tree_foreach
+_splay_tree_foreach_helper
+_inode_finder
+_stack_include_file
+_read_include_file
+_cpp_push_buffer
+__cpp_do_file_change
+_add_line_map
+_cb_file_change
+_update_header_times
+_extract_interface_info
+_splay_tree_splay_helper
+_init_pragma
+_init_cp_pragma
+_init_repo
+_lang_dependent_init
+_init_asm_output
+_init_eh
+_init_optabs
+_init_all_optabs
+_init_integral_libfuncs
+_init_libfuncs
+_init_floating_libfuncs
+__obstack_newchunk
+_dwarf2out_do_frame
+_dwarf2out_frame_init
+_dwarf2out_def_cfa
+_def_cfa_1
+_lookup_cfa
+_add_fde_cfi
+_initial_return_save
+_reg_save
+_dbxout_init
+_getdecls
+_getpwd
+_output_quoted_string
+_assemble_name
+_maybe_get_identifier
+_text_section
+_dbxout_typedefs
+_dbxout_symbol
+_timevar_pop
+_compile_file
+_init_final
+_init_branch_prob
+_timevar_push
+_yyparse
+_dbxout_start_source_file
+_cpp_finish_options
+_init_builtins
+__cpp_define_builtin
+_run_directive
+_start_directive
+_do_define
+_lex_macro_node
+__cpp_lex_token
+__cpp_lex_direct
+_parse_identifier
+__cpp_create_definition
+_skip_whitespace
+_parse_string
+_unescaped_terminator_p
+_alloc_expansion_token
+_lex_expansion_token
+_handle_newline
+_pfe_is_cmd_ln_processing
+_end_directive
+_skip_rest_of_line
+__cpp_pop_buffer
+_parse_number
+_pfe_set_cmd_ln_processing
+_cpp_define
+_warn_of_redefinition
+__cpp_equiv_tokens
+__cpp_free_definition
+_pfe_reset_cmd_ln_processing
+_free_chain
+__cpp_push_next_buffer
+_push_include
+__cpp_execute_include
+_find_include_file
+_search_from
+_push_srcloc
+_yyparse_1
+_yylex
+_read_token
+_c_lex
+_cpp_get_token
+_get_effective_char
+_skip_block_comment
+_adjust_column
+_skip_line_comment
+__cpp_handle_directive
+_directive_diagnostics
+_do_ifndef
+_check_eol
+_push_conditional
+_do_else
+_do_endif
+___udivmoddi4
+_parse_number
+_lex
+__cpp_parse_expr
+__cpp_pop_context
+_do_if
+_do_include
+_do_include_common
+_parse_include
+_find_framework_file
+_skip_escaped_newlines
+_enter_macro_context
+_push_token_context
+_next_context
+___udivdi3
+_parse_defined
+_do_elif
+__cpp_pop_file_buffer
+_purge_cache
+_pop_srcloc
+_dbxout_end_source_file
+_lbasename
+_parse_params
+_save_parameter
+_read_process_identifier
+_altivec_treat_as_keyword
+_padding_token
+__cpp_temp_token
+_hash_tree_cons
+_list_hash_pieces
+_scan_tokens
+_frob_id
+_lookup_name
+_lookup_name_real
+_lookup_flags
+_unqualified_namespace_lookup
+_current_decl_namespace
+_lookup_using_namespace
+_select_decl
+_chainon
+_parse_decl0
+_frob_specs
+_save_type_access_control
+_split_specs_attrs
+_parse_decl
+_start_decl
+_grokdeclarator
+_toplevel_bindings_p
+_bad_specifiers
+_cplus_decl_attributes
+_maybe_apply_pragma_weak
+_maybe_push_decl
+_start_decl_1
+_maybe_push_cleanup_level
+_parse_end_decl
+_decl_type_access_control
+_deferred_type_access_control
+_cp_finish_decl
+_maybe_apply_renaming_pragma
+_cp_has_mutable_p
+_rest_of_decl_compilation
+_note_list_got_semicolon
+_clear_anon_tags
+_do_pending_inlines
+_ggc_collect
+_cb_line_change
+_list_hash_eq
+_identifier_type
+_maybe_note_name_used_in_class
+_note_got_semicolon
+_do_aggr
+_yyungetc
+_handle_class_head
+_current_scope
+_lookup_tag
+_make_aggr_type
+_cp_make_lang_type
+_make_binfo
+_make_tree_vec
+_pushtag
+_create_implicit_typedef
+_maybe_process_template_type_declaration
+_maybe_check_template_type
+_pushdecl_with_scope
+_begin_class_definition
+_reset_type_access_control
+_maybe_process_partial_specialization
+_pushclass
+_pushlevel_class
+_push_class_decls
+_push_search_level
+_push_stack_level
+_dfs_walk
+_dfs_walk_real
+_dfs_push_type_decls
+_dfs_push_decls
+_storetags
+_reset_specialization
+_build_self_reference
+_constructor_name
+_constructor_name_full
+_finish_member_declaration
+_pushdecl_class_level
+_push_class_level_binding
+_push_class_binding
+_note_name_declared_in_class
+_push_binding
+_context_for_name_lookup
+_is_properly_derived_from
+_check_class_key
+_decl_namespace
+_parse_field0
+_parse_field
+_grokfield
+_c_apply_type_quals_to_decl
+_target_type
+_check_initializer
+_maybe_deduce_size_from_array_init
+_current_stmt_tree
+_template_class_depth
+_template_class_depth_real
+_splay_tree_compare_pointers
+_finish_class_definition
+_finish_struct
+_unreverse_member_declarations
+_nreverse
+_finish_struct_1
+_fixup_inline_methods
+_check_bases_and_members
+_check_bases
+_check_field_decls
+_delete_duplicate_fields
+_delete_duplicate_fields_1
+_pod_type_p
+_check_field_decl
+_finish_struct_anon
+_check_methods
+_add_implicitly_declared_members
+_implicitly_declare_fn
+_synthesize_exception_spec
+_make_call_declarator
+_build_nt
+_parmlist_is_exprlist
+_check_special_function_return_type
+_member_function_or_else
+_grokparms
+_build_cplus_method_type
+_decl_function_context
+_grokfndecl
+_no_linkage_check
+_walk_tree_without_duplicates
+_htab_find
+_hash_pointer
+_no_linkage_helper
+_eq_pointer
+_htab_delete
+_get_containing_scope
+_grokclassfn
+_build_artificial_parm
+_abstract_virtuals_error
+_defer_fn
+_build_reference_type
+_hash_tree_chain
+_type_promotes_to
+_c_promoting_integer_type_p
+_maybe_retrofit_in_chrg
+_check_explicit_specialization
+_current_tmpl_spec_kind
+_grok_ctor_properties
+_copy_fn_p
+_skip_artificial_parms_for
+_grok_special_member_properties
+_make_rtl_for_nonlocal_decl
+_assemble_variable
+_grok_op_properties
+_ambi_op_p
+_unary_op_p
+_add_method
+_build_overload
+_compparms
+_ovl_cons
+_clone_constructors_and_destructors
+_clone_function_decl
+_build_clone
+_copy_decl
+_copy_lang_decl
+_copy_list
+_finish_struct_methods
+_maybe_warn_about_overly_private_class
+_method_name_cmp
+_type_requires_array_cookie
+_lookup_fnfields
+_lookup_member
+_bfs_walk
+_lookup_field_r
+_lookup_fnfields_1
+_lookup_field_1
+_layout_class_type
+_determine_primary_base
+_create_vtable_ptr
+_build_base_fields
+_layout_nonempty_base_or_field
+_byte_position
+_layout_conflict_p
+_splay_tree_max
+_end_of_class
+_aggregate_value_p
+_finish_struct_bits
+_count_fields
+_finish_vtbls
+_accumulate_vtbl_inits
+_build_vtt
+_build_vtt_inits
+_complete_vars
+_maybe_suppress_debug_info
+_dump_class_hierarchy
+_dump_begin
+_rest_of_type_compilation
+_popclass
+_poplevel_class
+_pop_binding
+_pop_binding_level
+_pop_class_decls
+_pop_search_level
+_pop_stack_level
+_splay_tree_delete
+_splay_tree_delete_helper
+_splay_tree_xmalloc_deallocate
+_do_pending_defargs
+_done_pending_defargs
+_begin_inline_definitions
+_finish_inline_definitions
+_clear_inline_text_obstack
+_shadow_tag
+_check_tag_decl
+_follow_tag_typedef
+_original_type
+_duplicate_decls
+_redeclaration_error_message
+_invalidate_class_lookup_cache
+_sufficient_parms_p
+_make_pointer_declarator
+_create_array_type_for_decl
+_compute_array_index_type
+_constant_expression_warning
+_cp_convert
+_build_binary_op
+_really_overloaded_fn
+_default_conversion
+_decay_conversion
+_type_unknown_p
+_is_overloaded_fn
+_common_type
+_type_after_usual_arithmetic_conversions
+_merge_type_attributes
+_merge_attributes
+_build_type_attribute_variant
+_operand_equal_p
+_tree_int_cst_equal
+_const_binop
+_neg_double
+_lex_number
+_remove_zero_width_bit_fields
+_layout_virtual_bases
+_warn_about_ambiguous_direct_bases
+_modify_all_vtables
+_dfs_modify_vtables
+_dfs_unmark
+_int_fits_type_p
+_do_ifdef
+_check_for_new_type
+_finish_parmlist
+_begin_function_definition
+_start_function
+_nothrow_libfn_p
+_libc_name_p
+_lookup_attribute
+_check_function_type
+_require_complete_types_for_parms
+_complete_type_or_else
+_init_function_start
+_push_cp_function_context
+_lang_printable_name
+_lang_decl_name
+_decl_as_string
+_output_clear_message_text
+_dump_decl
+_dump_function_decl
+_dump_type_prefix
+_dump_type
+_dump_qualifiers
+_output_add_string
+_maybe_wrap_text
+_output_append
+_output_emit_prefix
+_output_append_r
+_output_add_space
+_dump_scope
+_dump_function_name
+_dump_parameters
+_output_add_character
+_dump_type_suffix
+_output_finalize_message
+_emit_line_note
+_set_file_and_line_for_stmt
+_emit_note
+_hard_function_value
+_begin_stmt_tree
+_announce_function
+_store_parm_decls
+_storedecls
+_push_local_binding
+_gettags
+_begin_function_body
+_keep_next_level
+_begin_compound_stmt
+_build_stmt
+_add_stmt
+_stmts_are_full_exprs_p
+_do_pushlevel
+_add_scope_stmt
+_current_scope_stmt_stack
+_build_expr_from_tree
+_do_identifier
+_qualify_lookup
+_objcp_lookup_identifier
+_hack_identifier
+_mark_used
+_assemble_external
+_convert_from_reference
+_build_x_indirect_ref
+_build_opfncall
+_build_new_op
+_build_indirect_ref
+_reparse_decl_as_expr
+_finish_parenthesized_expr
+_finish_return_stmt
+_check_return_expr
+_convert_for_initialization
+_convert_for_assignment
+_dubious_conversion_warnings
+_overflow_warning
+_can_convert_arg_bad
+_implicit_conversion
+_standard_conversion
+_strip_top_quals
+_lvalue_p
+_lvalue_p_1
+_build_conv
+_perform_implicit_conversion
+_convert_like_real
+_maybe_warn_about_returning_address_of_local
+_finish_stmt
+_finish_compound_stmt
+_finish_function_body
+_do_poplevel
+_kept_level_p
+_poplevel
+_warn_about_unused_variables
+_finish_function
+_finish_fname_decls
+_finish_stmt_tree
+_pop_labels
+_save_function_data
+_calls_setjmp_p
+_calls_setjmp_r
+_free_after_parsing
+_pop_cp_function_context
+_free_stmt_status
+_free_after_compilation
+_free_eh_status
+_free_expr_status
+_free_emit_status
+_free_varasm_status
+_rs6000_free_machine_status
+_expand_body
+_simplify_aggr_init_exprs_r
+_maybe_clone_body
+_debug_nothing_tree
+_lex_string
+_build_string
+_push_lang_context
+_grokvardecl
+_set_decl_namespace
+_is_namespace_ancestor
+_maybe_register_incomplete_var
+_layout_var_decl
+_maybe_commonize_var
+_make_anon_name
+_start_enum
+_finish_unary_op_expr
+_build_x_unary_op
+_build_unary_op
+_build_expr_type_conversion
+_build_enumerator
+_check_for_missing_semicolon
+_dump_aggr_type
+_class_key_or_enum
+_check_for_uninitialized_const_var
+_at_function_scope_p
+_add_decl_stmt
+_maybe_inject_for_scope_var
+_initialize_local_var
+_destroy_local_var
+_finish_id_expr
+_dependent_base_p
+_currently_open_class
+_type_access_control
+_build_x_component_ref
+_build_component_ref
+_lookup_field
+_enforce_access
+_accessible_p
+_friend_accessible_p
+_access_in_type
+_dfs_access_in_type
+_assert_canonical_unmarked
+_dfs_assert_unmarked_p
+_dfs_accessible_p
+_build_x_modify_expr
+_build_modify_expr
+_require_complete_type
+_lvalue_or_else
+_get_unwidened
+_finish_expr_stmt
+_convert_to_void
+_lookup_base
+_lookup_base_r
+_build_method_call
+_build_new_method_call
+_resolve_args
+_add_function_candidate
+_list_length
+_lvalue_type
+_reference_binding
+_real_lvalue_p
+_reference_related_p
+_reference_compatible_p
+_at_least_as_qualified_p
+_direct_reference_binding
+_add_candidate
+_any_viable
+_splice_viable
+_tourney
+_is_dummy_object
+_build_over_call
+_unary_complex_lvalue
+_mark_addressable
+_staticp
+_cp_convert_to_pointer
+_is_friend
+_build_base_path
+_resolves_to_fixed_type_p
+_fixed_type_or_null
+_check_function_format
+_build_target_expr_with_type
+_build_target_expr
+_maybe_build_cleanup
+_build_cplus_new
+_nullify_returns_r
+_htab_expand
+_list_hash
+_find_empty_slot_for_expand
+_finish_decl_parsing
+_pop_lang_context
+_lookup_tag_reverse
+_finish_enum
+_tree_int_cst_lt
+_min_precision
+_tree_floor_log2
+_do_undef
+_get_inner_reference
+_optimize_bit_field_compare
+_condition_conversion
+_has_cleanups
+_finish_if_stmt_cond
+_build_x_arrow
+_build_x_binary_op
+_split_tree
+_grok_array_decl
+_build_array_ref
+_cp_pointer_int_sum
+_pointer_int_sum
+_size_in_bytes
+_extract_muldiv
+_finish_then_clause
+_finish_if_stmt
+_begin_if_stmt
+_shorten_compare
+_get_narrower
+_invert_tree_comparison
+_fold_range_test
+_make_range
+_cp_truthvalue_conversion
+_truthvalue_conversion
+_fold_truthop
+_maybe_convert_cond
+_negate_expr
+_finish_call_expr
+_is_global
+_lookup_arg_dependent
+_arg_assoc_args
+_arg_assoc
+_arg_assoc_type
+_build_x_function_call
+_build_function_call
+_build_function_call_real
+_decl_target_overloaded_intrinsic_p
+_inline_conversion
+_convert_arguments
+_build_call
+_build_addr_func
+_is_empty_class
+_arg_assoc_class
+_purpose_member
+_arg_assoc_namespace
+_convert_class_to_reference
+_lookup_conversions
+_add_conversions
+_build_component_addr
+_decl_type_context
+_convert_force
+_convert_to_pointer_force
+_parse_bitfield0
+_parse_bitfield
+_grokbitfield
+_locate_ctor
+_merge_exception_specifiers
+_locate_copy
+_funlike_invocation_p
+_collect_args
+_replace_args
+_expand_arg
+_push_ptoken_context
+__cpp_release_buff
+_merge_decl_attributes
+_merge_types
+_type_hash_hash
+_lshift_double
+_add_fields_to_vec
+_field_decl_cmp
+__cpp_extend_buff
+_twoval_comparison_p
+_swap_tree_comparison
+_merge_ranges
+_range_binop
+_build_range_check
+_unsigned_type
+_invert_truthvalue
+_build_x_conditional_expr
+_build_conditional_expr
+_operand_equal_for_comparison_p
+_truth_value_p
+_fold_binary_op_with_conditional_arg
+_global_bindings_p
+_integer_all_onesp
+_distribute_bit_expr
+_default_comp_type_attributes
+_setjmp_call_p
+_special_function_p
+_warn_about_long_double
+_reparse_absdcl_as_casts
+_altivec_is_vector_constant_element
+_groktypename
+_build_c_cast
+_convert_to_real
+_handle_aligned_attribute
+_tree_log2
+_is_attribute_p
+_finish_sizeof
+_c_sizeof
+_place_union_field
+_complete_array_type
+_handle_format_attribute
+_decode_format_attr
+_decode_format_type
+_attribute_hash_list
+_value_member
+_commonparms
+_tree_last
+_lookup_function_nonclass
+_lookup_name_nonclass
+_add_builtin_candidates
+_non_reference
+_type_decays_to
+_add_builtin_candidate
+_build_builtin_candidate
+_store_init_value
+_digest_init
+_combine_strings
+_choose_string_type
+_finish_asm_stmt
+_parse_output_constraint
+_check_multiple_declarators
+_varray_grow
+_pfe_s_realloc
+_pfe_realloc
+_build_this
+_stabilize_reference
+_stabilize_reference_1
+_lex_charconst
+_cpp_interpret_charconst
+_do_pragma
+_darwin_pragma_options
+_pop_field_alignment
+_build_x_compound_expr
+_build_compound_expr
+_null_ptr_cst_p
+_integer_pow2p
+_tree_expr_nonnegative_p
+_push_field_alignment
+__cpp_backup_tokens
+_ht_expand
+_clear_identifier_class_values
+_expand_tree_builtin
+_fold_builtin
+_trigraph_p
+_parse_method
+_start_method
+_snarf_method
+_snarf_block
+_finish_method
+_fixup_pending_inline
+_check_for_override
+_protected_accessible_p
+_pop_nested_class
+_enter_scope_of
+_push_nested_class
+_set_class_shadows
+_unuse_fields
+_dfs_unuse_fields
+_is_aggr_type
+_check_classfn
+_finish_this_expr
+_maybe_end_member_template_processing
+_process_next_inline
+_end_input
+_obstack_free
+_begin_parsing_inclass_inline
+_feed_input
+_maybe_begin_member_template_processing
+_inline_needs_template_parms
+_dump_exception_spec
+_see_typename
+_finish_base_specifier
+_xref_basetypes
+_unshare_base_binfos
+_get_vbase_types
+_unmarkedp
+_dfs_get_vbase_types
+_markedp
+_dfs_build_inheritance_graph_order
+_unmarked_pushdecls_p
+_template_self_reference_p
+_setup_class_bindings
+_lookup_field_queue_p
+_marked_pushdecls_p
+_mark_primary_bases
+_dfs_unshared_virtual_bases
+_build_base_field
+_propagate_binfo_offsets
+_get_primary_binfo
+_record_subobject_offsets
+_walk_subobject_offsets
+_record_subobject_offset
+_dfs_set_offset_for_unshared_vbases
+_dfs_unmarked_real_bases_queue_p
+_dfs_marked_real_bases_queue_p
+_feed_defarg
+_grok_method_quals
+_cp_type_qual_from_rid
+_make_reference_declarator
+_comp_ptr_ttypes
+_comp_ptr_ttypes_real
+_string_conv_p
+_frob_opname
+_maybe_dummy_object
+_build_field_call
+_finish_object_call_expr
+_initializer_constant_valid_p
+_cplus_expand_constant
+_layout_vtable_decl
+_get_vtbl_decl_for_binfo
+_initialize_vtable
+_initialize_array
+_char_type_p
+_process_init_constructor
+_dump_vtable
+_adjust_clone_args
+_begin_eh_spec_block
+_begin_constructor_body
+_finish_mem_initializers
+_emit_base_init
+_sort_member_init
+_build_field_list
+_sort_base_init
+_initialize_vtbl_ptrs
+_dfs_initialize_vtbl_ptrs
+_expand_virtual_init
+_build_vtbl_address
+_build_vfield_ref
+_perform_member_init
+_finish_constructor_body
+_finish_eh_spec_block
+_update_cloned_parm
+_store_bindings
+_clone_body
+_copy_body
+_copy_body_r
+_cp_auto_var_in_fn_p
+_copy_tree_r
+_copy_scope_stmt
+_remap_block
+_insert_block
+_nonstatic_local_decl_p
+_local_variable_p
+_remap_decl
+_pop_from_top_level
+_pfe_varray_free
+_handle_noreturn_attribute
+_check_default_argument
+_add_defarg_fn
+_shared_unmarked_p
+_canonical_binfo
+_shared_marked_p
+_dfs_canonical_queue
+_dfs_accessible_queue_p
+_is_subobject_of_p
+_revert_static_member_fn
+_begin_template_parm_list
+_begin_scope
+_note_template_header
+_finish_template_type_parm
+_process_template_parm
+_build_template_parm_index
+_end_template_parm_list
+_push_template_decl_real
+_template_parm_scope_p
+_check_default_tmpl_args
+_current_template_args
+_build_template_decl
+_pushdecl_namespace_level
+_classtype_mangled_name
+_most_general_template
+_mangle_class_name_for_template
+_get_innermost_template_args
+_type_as_string
+_finish_template_decl
+_end_template_decl
+_finish_scope
+_write_nested_name
+_write_prefix
+_write_source_name
+_write_number
+_hwint_to_ascii
+_write_identifier
+_joust
+_compare_ics
+_maybe_handle_implicit_object
+_maybe_handle_ref_bind
+_qualified_lookup_using_namespace
+_ambiguous_decl
+_do_scoped_id
+_finish_else_clause
+_build_functional_cast
+_build_user_type_conversion_1
+_build_ptr_wrapper
+_convert_default_arg
+_break_out_target_exprs
+_bot_manip
+_bot_replace
+_write_special_name_constructor
+_build_delete
+_build_dtor_call
+_write_special_name_destructor
+_build_throw
+_is_admissible_throw_operand
+_complete_ptr_ref_or_void_ptr_p
+_doing_eh
+_decl_is_java_type
+_push_throw_library_fn
+_push_library_fn
+_pushdecl_top_level
+_push_function_context_to
+_pop_function_context_from
+_restore_emit_status
+_begin_init_stmts
+_begin_stmt_expr
+_create_temporary_var
+_obscure_complex_init
+_build_aggr_init
+_expand_aggr_init_1
+_expand_default_init
+_build_new_function_call
+_ptr_reasonably_similar
+_begin_else_clause
+_finish_init_stmts
+_finish_stmt_expr
+_build_min
+_finish_decl_cleanup
+_do_allocate_exception
+_prepare_eh_type
+_build_eh_type_type
+_get_tinfo_decl
+_mangle_typeinfo_for_type
+_mangle_special_for_type
+_write_class_enum_type
+_check_bitfield_decl
diff --git a/pbproj/gcc3.pbproj/dpatel.pbxuser b/pbproj/gcc3.pbproj/dpatel.pbxuser
new file mode 100644
index 00000000000..8ad2052ee77
--- /dev/null
+++ b/pbproj/gcc3.pbproj/dpatel.pbxuser
@@ -0,0 +1,208 @@
+// !$*UTF8*$!
+{
+ 8928587D02108C4F0CCA2CB6 = {
+ activeExec = 0;
+ };
+ 8C18C7DB00C5722F06CA2AC8 = {
+ activeBuildStyle = 8C864B2C00C575A806CA2AC8;
+ activeTarget = 8928587D02108C4F0CCA2CB6;
+ addToTargets = (
+ );
+ breakpoints = (
+ );
+ perUserDictionary = {
+ PBXWorkspaceContents = (
+ {
+ LeftSlideOut = {
+ Split0 = {
+ Split0 = {
+ NavCount = 1;
+ NavGeometry0 = {
+ Frame = "{{0, 0}, {851, 904}}";
+ NavBarVisible = YES;
+ };
+ };
+ SplitCount = 1;
+ Tab0 = {
+ Debugger = {
+ Split0 = {
+ SplitCount = 2;
+ };
+ SplitCount = 1;
+ TabCount = 2;
+ };
+ LauncherConfigVersion = 4;
+ };
+ Tab1 = {
+ LauncherConfigVersion = 3;
+ Runner = {
+ };
+ };
+ TabCount = 4;
+ };
+ SplitCount = 1;
+ Tab1 = {
+ OptionsSetName = "Hierarchy, all classes";
+ };
+ Tab3 = {
+ SplitCount = 2;
+ };
+ TabCount = 6;
+ };
+ },
+ );
+ PBXWorkspaceGeometries = (
+ {
+ ContentSize = "{1106, 927}";
+ LeftSlideOut = {
+ ActiveTab = 0;
+ Collapsed = NO;
+ Frame = "{{0, 23}, {1106, 904}}";
+ Split0 = {
+ Collapsed = NO;
+ Frame = "{{255, 0}, {851, 904}}";
+ Split0 = {
+ Frame = "{{0, 0}, {851, 904}}";
+ };
+ SplitCount = 1;
+ Tab0 = {
+ Debugger = {
+ ActiveTab = 1;
+ Collapsed = NO;
+ Frame = "{{0, 0}, {681, 289}}";
+ Split0 = {
+ Frame = "{{0, 92}, {681, 197}}";
+ Split0 = {
+ Frame = "{{0, 0}, {331, 197}}";
+ };
+ Split1 = {
+ DebugVariablesTableConfiguration = (
+ Name,
+ 114,
+ Value,
+ 206,
+ );
+ Frame = "{{340, 0}, {341, 197}}";
+ };
+ SplitCount = 2;
+ };
+ SplitCount = 1;
+ Tab0 = {
+ Frame = "{{0, 0}, {100, 50}}";
+ };
+ Tab1 = {
+ Frame = "{{0, 0}, {681, 68}}";
+ };
+ TabCount = 2;
+ TabsVisible = YES;
+ };
+ Frame = "{{0, 0}, {681, 289}}";
+ LauncherConfigVersion = 4;
+ };
+ Tab1 = {
+ Frame = "{{0, 0}, {681, 120}}";
+ LauncherConfigVersion = 3;
+ Runner = {
+ Frame = "{{0, 0}, {681, 120}}";
+ };
+ };
+ Tab2 = {
+ BuildMessageFrame = "{{0, 0}, {683, 127}}";
+ BuildTranscriptFrame = "{{0, 136}, {683, 100}}";
+ Frame = "{{0, 0}, {681, 234}}";
+ };
+ Tab3 = {
+ Frame = "{{0, 0}, {681, 238}}";
+ };
+ TabCount = 4;
+ TabsVisible = NO;
+ };
+ SplitCount = 1;
+ Tab0 = {
+ Frame = "{{0, 0}, {231, 904}}";
+ GroupTreeTableConfiguration = (
+ SCMStatusColumn,
+ 22,
+ TargetStatusColumn,
+ 18,
+ MainColumn,
+ 176,
+ );
+ };
+ Tab1 = {
+ ClassesFrame = "{{0, 0}, {233, 329}}";
+ ClassesTreeTableConfiguration = (
+ PBXBookColumnIdentifier,
+ 20,
+ PBXClassColumnIdentifier,
+ 190,
+ );
+ Frame = "{{0, 0}, {231, 548}}";
+ MembersFrame = "{{0, 338}, {233, 210}}";
+ MembersTreeTableConfiguration = (
+ PBXBookColumnIdentifier,
+ 20,
+ PBXMethodColumnIdentifier,
+ 189,
+ );
+ };
+ Tab2 = {
+ Frame = "{{0, 0}, {231, 904}}";
+ };
+ Tab3 = {
+ Frame = "{{0, 0}, {231, 548}}";
+ Split0 = {
+ Frame = "{{0, 0}, {231, 265}}";
+ TargetTreeTableConfiguration = (
+ ActiveTarget,
+ 16,
+ TargetName,
+ 199,
+ );
+ };
+ Split1 = {
+ BuildStyleTreeTableConfiguration = (
+ IsActive,
+ 16,
+ Name,
+ 200,
+ );
+ Frame = "{{0, 274}, {231, 274}}";
+ };
+ SplitCount = 2;
+ };
+ Tab4 = {
+ ExecutableTreeTableConfiguration = (
+ ActiveExecutable,
+ 16,
+ ExecutableName,
+ 198,
+ );
+ Frame = "{{0, 0}, {231, 548}}";
+ };
+ Tab5 = {
+ BreakpointsTreeTableConfiguration = (
+ breakpointColumn,
+ 178,
+ enabledColumn,
+ 31,
+ );
+ Frame = "{{0, 0}, {231, 548}}";
+ };
+ TabCount = 6;
+ TabsVisible = YES;
+ };
+ StatusViewVisible = YES;
+ Template = 64ABBB4501FA494900185B06;
+ ToolbarVisible = YES;
+ WindowLocation = "{5, 10}";
+ },
+ );
+ PBXWorkspaceStateSaveDate = 36016411;
+ };
+ projectwideBuildSettings = {
+ };
+ wantsIndex = 1;
+ wantsSCM = 0;
+ };
+}
diff --git a/pbproj/gcc3.pbproj/project.pbxproj b/pbproj/gcc3.pbproj/project.pbxproj
new file mode 100644
index 00000000000..d04c87abd7f
--- /dev/null
+++ b/pbproj/gcc3.pbproj/project.pbxproj
@@ -0,0 +1,191 @@
+// !$*UTF8*$!
+{
+ archiveVersion = 1;
+ classes = {
+ };
+ objectVersion = 39;
+ objects = {
+ 8928587D02108C4F0CCA2CB6 = {
+ buildArgumentsString = "$ACTION $ALL_SETTINGS";
+ buildPhases = (
+ );
+ buildSettings = {
+ OTHER_CFLAGS = "";
+ OTHER_LDFLAGS = "";
+ OTHER_REZFLAGS = "";
+ PRODUCT_NAME = gcc3;
+ SECTORDER_FLAGS = "";
+ WARNING_CFLAGS = "-Wmost -Wno-four-char-constants -Wno-unknown-pragmas";
+ };
+ buildToolPath = /usr/bin/gnumake;
+ dependencies = (
+ );
+ isa = PBXLegacyTarget;
+ name = "B&I build and install";
+ passBuildSettingsInEnvironment = 1;
+ productName = "Full build and install";
+ settingsToExpand = 6;
+ settingsToPassInEnvironment = 287;
+ settingsToPassOnCommandLine = 280;
+ };
+//890
+//891
+//892
+//893
+//894
+//8C0
+//8C1
+//8C2
+//8C3
+//8C4
+ 8C18C7DB00C5722F06CA2AC8 = {
+ buildSettings = {
+ };
+ buildStyles = (
+ 8C864B2C00C575A806CA2AC8,
+ 8C956F6300C57A1506CA2AC8,
+ );
+ hasScannedForEncodings = 1;
+ isa = PBXProject;
+ mainGroup = 8C18C7DC00C5722F06CA2AC8;
+ productRefGroup = 8C864B2700C575A806CA2AC8;
+ projectDirPath = "";
+ targets = (
+ 8928587D02108C4F0CCA2CB6,
+ EE598EB2051F7D4C0002A5CC,
+ EE598EFC051F8B4C0002A5CC,
+ );
+ };
+ 8C18C7DC00C5722F06CA2AC8 = {
+ children = (
+ 8C18C7DD00C5731506CA2AC8,
+ 8C864B2700C575A806CA2AC8,
+ );
+ isa = PBXGroup;
+ refType = 4;
+ sourceTree = "<group>";
+ };
+ 8C18C7DD00C5731506CA2AC8 = {
+ expectedFileType = folder;
+ fallbackIsa = PBXFileReference;
+ includeInIndex = 0;
+ isa = PBXFolderReference;
+ name = gcc3;
+ path = ..;
+ refType = 2;
+ sourceTree = SOURCE_ROOT;
+ };
+ 8C864B2700C575A806CA2AC8 = {
+ children = (
+ EE598EB3051F7D4C0002A5CC,
+ );
+ isa = PBXGroup;
+ name = Products;
+ refType = 4;
+ sourceTree = "<group>";
+ };
+ 8C864B2C00C575A806CA2AC8 = {
+ buildRules = (
+ );
+ buildSettings = {
+ COPY_PHASE_STRIP = NO;
+ GCC_DYNAMIC_NO_PIC = NO;
+ GCC_ENABLE_FIX_AND_CONTINUE = YES;
+ GCC_GENERATE_DEBUGGING_SYMBOLS = YES;
+ GCC_OPTIMIZATION_LEVEL = s;
+ OPTIMIZATION_CFLAGS = "-O0";
+ ZERO_LINK = YES;
+ };
+ isa = PBXBuildStyle;
+ name = Development;
+ };
+ 8C956F6300C57A1506CA2AC8 = {
+ buildRules = (
+ );
+ buildSettings = {
+ COPY_PHASE_STRIP = YES;
+ GCC_ENABLE_FIX_AND_CONTINUE = NO;
+ ZERO_LINK = NO;
+ };
+ isa = PBXBuildStyle;
+ name = Deployment;
+ };
+//8C0
+//8C1
+//8C2
+//8C3
+//8C4
+//EE0
+//EE1
+//EE2
+//EE3
+//EE4
+ EE598EB1051F7D4C0002A5CC = {
+ buildActionMask = 2147483647;
+ files = (
+ );
+ inputPaths = (
+ );
+ isa = PBXShellScriptBuildPhase;
+ outputPaths = (
+ );
+ runOnlyForDeploymentPostprocessing = 0;
+ shellPath = /bin/sh;
+ shellScript = "# shell script goes here\ncd $BUILD_DIR\n$SRCROOT/../configure --enable-threads --enable-languages=c,c++,objc,objc++ --prefix=$DSTROOT\n\n";
+ };
+ EE598EB2051F7D4C0002A5CC = {
+ buildPhases = (
+ EE598EB1051F7D4C0002A5CC,
+ );
+ buildSettings = {
+ OTHER_CFLAGS = "";
+ OTHER_LDFLAGS = "";
+ OTHER_REZFLAGS = "";
+ PRODUCT_NAME = "Configuration Target";
+ REZ_EXECUTABLE = YES;
+ SECTORDER_FLAGS = "";
+ WARNING_CFLAGS = "-Wmost -Wno-four-char-constants -Wno-unknown-pragmas";
+ };
+ dependencies = (
+ );
+ isa = PBXToolTarget;
+ name = "Configuration Target";
+ productInstallPath = /usr/local/bin;
+ productName = "Configuration Target";
+ productReference = EE598EB3051F7D4C0002A5CC;
+ };
+ EE598EB3051F7D4C0002A5CC = {
+ expectedFileType = "compiled.mach-o.executable";
+ includeInIndex = 0;
+ isa = PBXFileReference;
+ path = "Configuration Target";
+ refType = 3;
+ sourceTree = BUILT_PRODUCTS_DIR;
+ };
+ EE598EFC051F8B4C0002A5CC = {
+ buildArgumentsString = "$(ACTION) -j2";
+ buildPhases = (
+ );
+ buildSettings = {
+ OTHER_CFLAGS = "";
+ OTHER_LDFLAGS = "";
+ OTHER_REZFLAGS = "";
+ PRODUCT_NAME = "Simple compiler build";
+ SECTORDER_FLAGS = "";
+ WARNING_CFLAGS = "-Wmost -Wno-four-char-constants -Wno-unknown-pragmas";
+ };
+ buildToolPath = /usr/bin/make;
+ buildWorkingDirectory = $BUILD_DIR;
+ dependencies = (
+ );
+ isa = PBXLegacyTarget;
+ name = "Simple compiler build";
+ passBuildSettingsInEnvironment = 1;
+ productName = "Simple compiler build";
+ settingsToExpand = 6;
+ settingsToPassInEnvironment = 287;
+ settingsToPassOnCommandLine = 280;
+ };
+ };
+ rootObject = 8C18C7DB00C5722F06CA2AC8;
+}
diff --git a/pbproj/gcc3.pbproj/spolk.pbxuser b/pbproj/gcc3.pbproj/spolk.pbxuser
new file mode 100644
index 00000000000..95cd3dafd2f
--- /dev/null
+++ b/pbproj/gcc3.pbproj/spolk.pbxuser
@@ -0,0 +1,370 @@
+// !$*UTF8*$!
+{
+ 8928587D02108C4F0CCA2CB6 = {
+ activeExec = 0;
+ };
+ 8C18C7DB00C5722F06CA2AC8 = {
+ activeBuildStyle = 8C864B2C00C575A806CA2AC8;
+ activeExecutable = EEB483E5051FA9DE00C73F14;
+ activeTarget = EE598EFC051F8B4C0002A5CC;
+ addToTargets = (
+ );
+ breakpoints = (
+ EEB483C7051F96E200C73F14,
+ );
+ codeSenseManager = EE598EAA051F7C710002A5CC;
+ executables = (
+ EE598EB4051F7D4C0002A5CC,
+ EE598EFF051F92590002A5CC,
+ EEB483E5051FA9DE00C73F14,
+ );
+ perUserDictionary = {
+ PBXConfiguration.PBXFileTableDataSource3.PBXExecutablesDataSource = {
+ PBXFileTableDataSourceColumnSortingDirectionKey = "-1";
+ PBXFileTableDataSourceColumnSortingKey = PBXExecutablesDataSource_NameID;
+ PBXFileTableDataSourceColumnWidthsKey = (
+ 22,
+ 761.7974,
+ );
+ PBXFileTableDataSourceColumnsKey = (
+ PBXExecutablesDataSource_ActiveFlagID,
+ PBXExecutablesDataSource_NameID,
+ );
+ };
+ PBXConfiguration.PBXFileTableDataSource3.PBXFileTableDataSource = {
+ PBXFileTableDataSourceColumnSortingDirectionKey = -1;
+ PBXFileTableDataSourceColumnSortingKey = PBXFileDataSource_Filename_ColumnID;
+ PBXFileTableDataSourceColumnWidthsKey = (
+ 20,
+ 523,
+ 20,
+ 95,
+ 43,
+ 43,
+ 20,
+ );
+ PBXFileTableDataSourceColumnsKey = (
+ PBXFileDataSource_FiletypeID,
+ PBXFileDataSource_Filename_ColumnID,
+ PBXFileDataSource_Built_ColumnID,
+ PBXFileDataSource_ObjectSize_ColumnID,
+ PBXFileDataSource_Errors_ColumnID,
+ PBXFileDataSource_Warnings_ColumnID,
+ PBXFileDataSource_Target_ColumnID,
+ );
+ };
+ PBXConfiguration.PBXFileTableDataSource3.PBXFindDataSource = {
+ PBXFileTableDataSourceColumnSortingDirectionKey = "-1";
+ PBXFileTableDataSourceColumnSortingKey = PBXFindDataSource_LocationID;
+ PBXFileTableDataSourceColumnWidthsKey = (
+ 390.2974,
+ 393.2085,
+ );
+ PBXFileTableDataSourceColumnsKey = (
+ PBXFindDataSource_MessageID,
+ PBXFindDataSource_LocationID,
+ );
+ };
+ PBXConfiguration.PBXTargetDataSource.PBXTargetDataSource = {
+ PBXFileTableDataSourceColumnSortingDirectionKey = "-1";
+ PBXFileTableDataSourceColumnSortingKey = PBXFileDataSource_Filename_ColumnID;
+ PBXFileTableDataSourceColumnWidthsKey = (
+ 20,
+ 446,
+ 96,
+ 20,
+ 96,
+ 43,
+ 43,
+ );
+ PBXFileTableDataSourceColumnsKey = (
+ PBXFileDataSource_FiletypeID,
+ PBXFileDataSource_Filename_ColumnID,
+ PBXTargetDataSource_PrimaryAttribute,
+ PBXFileDataSource_Built_ColumnID,
+ PBXFileDataSource_ObjectSize_ColumnID,
+ PBXFileDataSource_Errors_ColumnID,
+ PBXFileDataSource_Warnings_ColumnID,
+ );
+ };
+ PBXPerProjectTemplateStateSaveDate = 87524715;
+ PBXWorkspaceContents = (
+ {
+ PBXProjectWorkspaceModule_StateKey_Rev36 = {
+ PBXProjectWorkspaceModule_EditorOpen = false;
+ PBXProjectWorkspaceModule_EmbeddedNavigatorGroup = {
+ SplitCount = 1;
+ };
+ PBXProjectWorkspaceModule_OldDetailFrame = "{{0, 0}, {807, 634}}";
+ PBXProjectWorkspaceModule_OldEditorFrame = "{{0, 0}, {750, 480}}";
+ PBXProjectWorkspaceModule_OldSuperviewFrame = "{{182, 0}, {807, 634}}";
+ PBXProjectWorkspaceModule_RunWindowVisible = true;
+ PBXProjectWorkspaceModule_SCMWindowVisible = true;
+ PBXProjectWorkspaceModule_SGTM = {
+ PBXBottomSmartGroupGIDs = (
+ 1C37FBAC04509CD000000102,
+ 1C37FAAC04509CD000000102,
+ 1C08E77C0454961000C914BD,
+ 1CC0EA4004350EF90044410B,
+ 1CC0EA4004350EF90041110B,
+ 1C37FABC05509CD000000102,
+ 1C37FABC05539CD112110102,
+ 1C37FABC04509CD000100104,
+ );
+ PBXTopSmartGroupGIDs = (
+ );
+ };
+ };
+ },
+ );
+ "PBXWorkspaceContents:PBXConfiguration.PBXModule.PBXBatchFindModule" = {
+ };
+ "PBXWorkspaceContents:PBXConfiguration.PBXModule.PBXBuildResultsModule" = {
+ };
+ "PBXWorkspaceContents:PBXConfiguration.PBXModule.PBXDebugCLIModule" = {
+ };
+ "PBXWorkspaceContents:PBXConfiguration.PBXModule.PBXDebugSessionModule" = {
+ };
+ "PBXWorkspaceContents:PBXConfiguration.PBXModule.PBXNavigatorGroup" = {
+ Split0 = {
+ bookmark = EE7F9785053785D1001B8D1B;
+ history = (
+ EE7F978005378595001B8D1B,
+ );
+ };
+ SplitCount = 1;
+ };
+ "PBXWorkspaceContents:PBXConfiguration.PBXModule.PBXProjectWorkspaceModule" = {
+ PBXProjectWorkspaceModule_StateKey_Rev36 = {
+ PBXProjectWorkspaceModule_EditorOpen = true;
+ PBXProjectWorkspaceModule_EmbeddedNavigatorGroup = {
+ SplitCount = 1;
+ };
+ PBXProjectWorkspaceModule_OldDetailFrame = "{{0, 0}, {600, 115}}";
+ PBXProjectWorkspaceModule_OldEditorFrame = "{{0, 115}, {600, 186}}";
+ PBXProjectWorkspaceModule_OldSuperviewFrame = "{{0, 0}, {600, 301}}";
+ PBXProjectWorkspaceModule_SGTM = {
+ PBXBottomSmartGroupGIDs = (
+ );
+ PBXTopSmartGroupGIDs = (
+ );
+ };
+ };
+ };
+ PBXWorkspaceGeometries = (
+ {
+ Frame = "{{0, 0}, {989, 654}}";
+ PBXProjectWorkspaceModule_GeometryKey_Rev11 = {
+ PBXProjectWorkspaceModule_SGTM_Geometry = {
+ _collapsingFrameDimension = 0;
+ _indexOfCollapsedView = 0;
+ _percentageOfCollapsedView = 0;
+ sizes = (
+ "{{0, 0}, {182, 634}}",
+ "{{182, 0}, {807, 634}}",
+ );
+ };
+ };
+ WindowFrame = "{{50, 286}, {989, 716}}";
+ },
+ );
+ "PBXWorkspaceGeometries:PBXConfiguration.PBXModule.PBXBatchFindModule" = {
+ Frame = "{{0, 0}, {543, 158}}";
+ WindowFrame = "{{273, 822}, {543, 158}}";
+ };
+ "PBXWorkspaceGeometries:PBXConfiguration.PBXModule.PBXBuildResultsModule" = {
+ Frame = "{{0, 0}, {750, 526}}";
+ WindowFrame = "{{418, 196}, {750, 604}}";
+ };
+ "PBXWorkspaceGeometries:PBXConfiguration.PBXModule.PBXDebugCLIModule" = {
+ Frame = "{{0, 0}, {400, 200}}";
+ WindowFrame = "{{50, 974}, {400, 222}}";
+ };
+ "PBXWorkspaceGeometries:PBXConfiguration.PBXModule.PBXDebugSessionModule" = {
+ DebugConsoleDrawerSize = "{100, 120}";
+ DebugConsoleVisible = Drawer;
+ DebugConsoleWindowFrame = "{{200, 200}, {500, 300}}";
+ DebugSTDIOWindowFrame = "{{61, 120}, {500, 300}}";
+ Frame = "{{0, 0}, {1195, 638}}";
+ WindowFrame = "{{21, 247}, {1195, 716}}";
+ };
+ "PBXWorkspaceGeometries:PBXConfiguration.PBXModule.PBXNavigatorGroup" = {
+ Frame = "{{0, 0}, {750, 480}}";
+ WindowFrame = "{{511, 375}, {750, 558}}";
+ };
+ "PBXWorkspaceGeometries:PBXConfiguration.PBXModule.PBXProjectWorkspaceModule" = {
+ Frame = "{{0, 0}, {600, 321}}";
+ PBXProjectWorkspaceModule_GeometryKey_Rev11 = {
+ GroupTreeCollapsed = yes;
+ PBXProjectWorkspaceModule_SGTM_Geometry = {
+ _collapsingFrameDimension = 182;
+ _indexOfCollapsedView = 0;
+ _percentageOfCollapsedView = 0.3033333;
+ sizes = (
+ "{{0, 0}, {600, 301}}",
+ );
+ };
+ };
+ WindowFrame = "{{485, 144}, {600, 383}}";
+ };
+ PBXWorkspaceStateSaveDate = 87524715;
+ };
+ sourceControlManager = EE598EA9051F7C710002A5CC;
+ userBuildSettings = {
+ };
+ };
+ EE02018005211E0D00ABC2E7 = {
+ expectedFileType = "compiled.mach-o.executable";
+ isa = PBXFileReference;
+ name = cc1;
+ path = "/Volumes/SandBox/spolk/Source/gcc/src.apple.com/pre-import/gcc3/pbproj/build/gcc/cc1";
+ refType = 0;
+ sourceTree = "<absolute>";
+ };
+ EE598EA9051F7C710002A5CC = {
+ isa = PBXSourceControlManager;
+ scmConfiguration = {
+ };
+ scmType = scm.cvs;
+ };
+ EE598EAA051F7C710002A5CC = {
+ indexTemplatePath = "";
+ isa = PBXCodeSenseManager;
+ usesDefaults = 0;
+ wantsCodeCompletion = 1;
+ wantsCodeCompletionAutoPopup = 0;
+ wantsCodeCompletionAutoSuggestions = 0;
+ wantsCodeCompletionCaseSensitivity = 1;
+ wantsCodeCompletionOnlyMatchingItems = 1;
+ wantsCodeCompletionParametersIncluded = 1;
+ wantsCodeCompletionPlaceholdersInserted = 1;
+ wantsCodeCompletionTabCompletes = 1;
+ wantsIndex = 1;
+ };
+ EE598EB2051F7D4C0002A5CC = {
+ activeExec = 0;
+ executables = (
+ EE598EB4051F7D4C0002A5CC,
+ );
+ };
+ EE598EB4051F7D4C0002A5CC = {
+ activeArgIndex = 2147483647;
+ activeArgIndices = (
+ );
+ argumentStrings = (
+ );
+ configStateDict = {
+ };
+ debuggerPlugin = GDBDebugging;
+ enableDebugStr = 1;
+ environmentEntries = (
+ );
+ isa = PBXExecutable;
+ name = "Configuration Target";
+ shlibInfoDictList = (
+ );
+ sourceDirectories = (
+ );
+ };
+ EE598EFC051F8B4C0002A5CC = {
+ activeExec = 0;
+ };
+ EE598EFF051F92590002A5CC = {
+ activeArgIndex = 0;
+ activeArgIndices = (
+ YES,
+ YES,
+ YES,
+ YES,
+ );
+ argumentStrings = (
+ "-B",
+ gcc,
+ ../hello.c,
+ "-v",
+ );
+ configStateDict = {
+ };
+ debuggerPlugin = GDBDebugging;
+ dylibVariantSuffix = "";
+ enableDebugStr = 1;
+ environmentEntries = (
+ );
+ isa = PBXExecutable;
+ launchableReference = EEB483D6051F97ED00C73F14;
+ name = Driver;
+ shlibInfoDictList = (
+ );
+ sourceDirectories = (
+ );
+ startupPath = "<<ProductDirectory>>";
+ };
+ EEB483C7051F96E200C73F14 = {
+ isa = PBXSymbolicBreakpoint;
+ state = 1;
+ symbolName = main;
+ };
+ EEB483D6051F97ED00C73F14 = {
+ expectedFileType = "compiled.mach-o.executable";
+ isa = PBXFileReference;
+ name = xgcc;
+ path = "/Volumes/SandBox/spolk/Source/gcc/src.apple.com/pre-import/gcc3/pbproj/build/gcc/xgcc";
+ refType = 0;
+ sourceTree = "<absolute>";
+ };
+ EEB483E5051FA9DE00C73F14 = {
+ activeArgIndex = 0;
+ activeArgIndices = (
+ YES,
+ YES,
+ YES,
+ YES,
+ YES,
+ YES,
+ YES,
+ YES,
+ YES,
+ YES,
+ YES,
+ YES,
+ YES,
+ YES,
+ YES,
+ YES,
+ YES,
+ );
+ argumentStrings = (
+ "-iprefix",
+ "gcc/../lib/gcc/ppc-apple-darwin7.0.0/3.3/",
+ "-isystem",
+ gcc/include,
+ "-D__GNUC__=3",
+ "-D__GNUC_MINOR__=3",
+ "-D__GNUC_PATHLEVEL__=0",
+ "-D__APPLE_CC__=9999",
+ "-D__DYNAMIC__",
+ ../hello.c,
+ "-fPIC",
+ "-dumpbase",
+ hello.c,
+ "-auxbase",
+ hello,
+ "-version",
+ "-o /var/tmp/foo.s",
+ );
+ configStateDict = {
+ };
+ debuggerPlugin = GDBDebugging;
+ dylibVariantSuffix = "";
+ enableDebugStr = 1;
+ environmentEntries = (
+ );
+ isa = PBXExecutable;
+ launchableReference = EE02018005211E0D00ABC2E7;
+ name = cc1;
+ shlibInfoDictList = (
+ );
+ sourceDirectories = (
+ );
+ };
+}
diff --git a/pbproj/gcc3.pbproj/zlaski.pbxuser b/pbproj/gcc3.pbproj/zlaski.pbxuser
new file mode 100644
index 00000000000..1ec0bc8873d
--- /dev/null
+++ b/pbproj/gcc3.pbproj/zlaski.pbxuser
@@ -0,0 +1,225 @@
+// !$*UTF8*$!
+{
+ 8928587D02108C4F0CCA2CB6 = {
+ activeExec = 0;
+ };
+ 8C18C7DB00C5722F06CA2AC8 = {
+ activeBuildStyle = 8C864B2C00C575A806CA2AC8;
+ activeTarget = 8928587D02108C4F0CCA2CB6;
+ breakpoints = (
+ C1BF887A0327FA7100C91839,
+ C15C8F870337D2B300C91839,
+ C14FA71B04201ADF00C91541,
+ C10B6401044B5EF200C91839,
+ C1D92266044DE56B00C91839,
+ C1351C4C0460A0F900C91839,
+ C144BAF204699A3100C91839,
+ C1DE69FD048698B600C91839,
+ C185E70C04D5C6D200C91839,
+ );
+ codeSenseManager = C12B2B0A049FDBCB00C91839;
+ perUserDictionary = {
+ PBXPerProjectTemplateStateSaveDate = 81722981;
+ PBXWorkspaceContents = (
+ {
+ },
+ );
+ "PBXWorkspaceContents:PBXConfiguration.PBXModule.PBXBuildResultsModule" = {
+ };
+ "PBXWorkspaceContents:PBXConfiguration.PBXModule.PBXCVSModule" = {
+ };
+ "PBXWorkspaceContents:PBXConfiguration.PBXModule.PBXDebugSessionModule" = {
+ };
+ "PBXWorkspaceContents:PBXConfiguration.PBXModule.PBXNavigatorGroup" = {
+ NavContent0 = {
+ bookmark = C12B2B12049FE27600C91839;
+ history = (
+ C12B2B0D049FDC0000C91839,
+ );
+ };
+ NavCount = 1;
+ NavGeometry0 = {
+ Frame = "{{0, 0}, {750, 460}}";
+ NavBarVisible = YES;
+ WindowFrame = "{{339, 87}, {750, 558}}";
+ };
+ NavSplitVertical = NO;
+ };
+ "PBXWorkspaceContents:PBXConfiguration.PBXModule.PBXProjectWorkspaceModule" = {
+ };
+ "PBXWorkspaceContents:PBXConfiguration.PBXModule.PBXRunSessionModule" = {
+ };
+ PBXWorkspaceGeometries = (
+ {
+ Frame = "{{0, 0}, {959, 800}}";
+ WindowFrame = "{{322, 111}, {959, 878}}";
+ },
+ );
+ "PBXWorkspaceGeometries:PBXConfiguration.PBXModule.PBXBuildResultsModule" = {
+ Frame = "{{0, 0}, {480, 216}}";
+ WindowFrame = "{{402, 521}, {480, 294}}";
+ };
+ "PBXWorkspaceGeometries:PBXConfiguration.PBXModule.PBXCVSModule" = {
+ Frame = "{{0, 0}, {480, 192}}";
+ WindowFrame = "{{402, 561}, {480, 214}}";
+ };
+ "PBXWorkspaceGeometries:PBXConfiguration.PBXModule.PBXDebugSessionModule" = {
+ DebugConsoleDrawerSize = "{100, 120}";
+ DebugConsoleVisible = None;
+ DebugConsoleWindowFrame = "{{200, 200}, {500, 300}}";
+ DebugSTDIOWindowFrame = "{{200, 200}, {500, 300}}";
+ Frame = "{{0, 0}, {745, 442}}";
+ WindowFrame = "{{269, 408}, {745, 520}}";
+ };
+ "PBXWorkspaceGeometries:PBXConfiguration.PBXModule.PBXNavigatorGroup" = {
+ Frame = "{{0, 0}, {750, 480}}";
+ WindowFrame = "{{339, 87}, {750, 558}}";
+ };
+ "PBXWorkspaceGeometries:PBXConfiguration.PBXModule.PBXProjectWorkspaceModule" = {
+ Frame = "{{0, 0}, {959, 800}}";
+ WindowFrame = "{{444, -403}, {959, 878}}";
+ };
+ "PBXWorkspaceGeometries:PBXConfiguration.PBXModule.PBXRunSessionModule" = {
+ Frame = "{{0, 0}, {745, 442}}";
+ WindowFrame = "{{269, 436}, {745, 464}}";
+ };
+ PBXWorkspaceStateSaveDate = 81722981;
+ };
+ projectwideBuildSettings = {
+ };
+ sourceControlManager = C1351A7F045F217400C91839;
+ wantsSCM = -1;
+ };
+ C10B6401044B5EF200C91839 = {
+ fileReference = C10B6402044B5F1000C91839;
+ isa = PBXFileBreakpoint;
+ lineNumber = 234;
+ state = 1;
+ };
+ C10B6402044B5F1000C91839 = {
+ isa = PBXFileReference;
+ name = "objcp-decl.c";
+ path = "/Volumes/DATA2/Dev/WC/apple/pre-import-2003-02-13/gcc3/gcc/objcp/objcp-decl.c";
+ refType = 0;
+ sourceTree = "<absolute>";
+ };
+ C12B2B0A049FDBCB00C91839 = {
+ indexTemplatePath = "";
+ isa = PBXCodeSenseManager;
+ usesDefaults = 1;
+ wantsCodeCompletion = 1;
+ wantsCodeCompletionAutoPopup = 0;
+ wantsCodeCompletionAutoSuggestions = 0;
+ wantsCodeCompletionCaseSensitivity = 1;
+ wantsCodeCompletionOnlyMatchingItems = 1;
+ wantsCodeCompletionParametersIncluded = 1;
+ wantsCodeCompletionPlaceholdersInserted = 1;
+ wantsCodeCompletionTabCompletes = 1;
+ wantsIndex = 1;
+ };
+ C1351A7F045F217400C91839 = {
+ isa = PBXSourceControlManager;
+ scmConfiguration = {
+ };
+ scmType = "";
+ };
+ C1351C4C0460A0F900C91839 = {
+ fileReference = C14FA7A60421803700C91541;
+ isa = PBXFileBreakpoint;
+ lineNumber = 6020;
+ state = 1;
+ };
+ C144BAF204699A3100C91839 = {
+ fileReference = C14FA7A60421803700C91541;
+ isa = PBXFileBreakpoint;
+ lineNumber = 3306;
+ state = 1;
+ };
+ C14FA71B04201ADF00C91541 = {
+ fileReference = C14FA71C04201AED00C91541;
+ isa = PBXFileBreakpoint;
+ lineNumber = 1269;
+ state = 1;
+ };
+ C14FA71C04201AED00C91541 = {
+ expectedFileType = sourcecode.c.c;
+ isa = PBXFileReference;
+ name = spew.c;
+ path = "/Volumes/DATA2/Dev/WC/apple/pre-import-2003-02-13/gcc3/gcc/cp/spew.c";
+ refType = 0;
+ sourceTree = "<absolute>";
+ };
+ C14FA7A60421803700C91541 = {
+ expectedFileType = sourcecode.c.c;
+ isa = PBXFileReference;
+ name = "objc-act.c";
+ path = "/Volumes/DATA2/Dev/WC/apple/pre-import-2003-02-13/gcc3/gcc/objc/objc-act.c";
+ refType = 0;
+ sourceTree = "<absolute>";
+ };
+ C15C8F870337D2B300C91839 = {
+ fileReference = C15C8F880337D2C100C91839;
+ isa = PBXFileBreakpoint;
+ lineNumber = 230;
+ state = 2;
+ };
+ C15C8F880337D2C100C91839 = {
+ isa = PBXFileReference;
+ name = "objcp-decl.c";
+ path = "/Volumes/DATA2/Dev/WC/darwin/HEAD/gcc3/gcc/objcp/objcp-decl.c";
+ refType = 0;
+ sourceTree = "<absolute>";
+ };
+ C185E70C04D5C6D200C91839 = {
+ fileReference = C185E70D04D5C6F000C91839;
+ isa = PBXFileBreakpoint;
+ lineNumber = 504;
+ state = 1;
+ };
+ C185E70D04D5C6F000C91839 = {
+ isa = PBXFileReference;
+ name = next_mapping.h;
+ path = "/Volumes/DATA2/Dev/WC/apple/pre-import-2003-02-13/gcc3/gcc/testsuite/objc/execute/next_mapping.h";
+ refType = 0;
+ sourceTree = "<absolute>";
+ };
+ C1BF887A0327FA7100C91839 = {
+ fileReference = C1BF887B0327FA9100C91839;
+ isa = PBXFileBreakpoint;
+ lineNumber = 1626;
+ state = 2;
+ };
+ C1BF887B0327FA9100C91839 = {
+ isa = PBXFileReference;
+ name = darwin.c;
+ path = /Volumes/DATA2/Dev/WC/darwin/HEAD/gcc3/gcc/config/darwin.c;
+ refType = 0;
+ sourceTree = "<absolute>";
+ };
+ C1D92266044DE56B00C91839 = {
+ fileReference = C1D92267044DE58900C91839;
+ isa = PBXFileBreakpoint;
+ lineNumber = 745;
+ state = 1;
+ };
+ C1D92267044DE58900C91839 = {
+ isa = PBXFileReference;
+ name = dbxout.c;
+ path = "/Volumes/DATA2/Dev/WC/apple/pre-import-2003-02-13/gcc3/gcc/dbxout.c";
+ refType = 0;
+ sourceTree = "<absolute>";
+ };
+ C1DE69FD048698B600C91839 = {
+ fileReference = C1DE69FE048698D400C91839;
+ isa = PBXFileBreakpoint;
+ lineNumber = 47;
+ state = 1;
+ };
+ C1DE69FE048698D400C91839 = {
+ isa = PBXFileReference;
+ name = "encode-3.m";
+ path = "/Volumes/DATA2/Dev/WC/apple/pre-import-2003-02-13/gcc3/gcc/testsuite/objc.dg/encode-3.m";
+ refType = 0;
+ sourceTree = "<absolute>";
+ };
+}